# R script to perform statistical analysis of depression versus control data
# Author: Deepak Sharma
# Date: 13 September 2016

# Import libraries --------------------------------------------------------

# Import data -------------------------------------------------------------

depression_vs_control <- read.csv("depression_vs_control.csv")
dvc <- depression_vs_control
attach(dvc)

# Student's t-test --------------------------------------------------------

# 1:48 is Control data
# 49:96 is Depression data
t.test(Negatives[1:48],Negatives[49:96])
t.test(Fluctuations[1:48],Fluctuations[49:96])
t.test(Positives[1:48],Positives[49:96])

# One way ANOVA -----------------------------------------------------------

d_v_c = depression_vs_control

summary(aov(Negatives[1:48] ~ Negatives[49:96]))
summary(aov(Positives[1:48] ~ Positives[49:96]))
summary(aov(Fluctuations[1:48] ~ Fluctuations[49:96]))

boxplot(Positives[1:48], Positives[49:96], ylab="No. of positives",names=c("Control","Depressed"), main="Positives difference between control and depression")
boxplot(Negatives[1:48], Negatives[49:96], ylab="No. of negatives",names=c("Control","Depressed"), main="Negatives difference between control and depression")
boxplot(Fluctuations[1:48], Fluctuations[49:96], ylab="No. of fluctuations",names=c("Control","Depressed"), main="Fluctuation difference between control and depression")


#R version 3.3.2

firstFibonacci <- 1

secondFibonacci <- 1

sum_of_even_fibonacci <- 0

helper <- 0

# O(n) solution
while (secondFibonacci <= 4000000) {
    helper <- firstFibonacci
    firstFibonacci <- secondFibonacci
    secondFibonacci <- firstFibonacci + helper

    if (secondFibonacci %% 2 == 0) {
        sum_of_even_fibonacci <- sum_of_even_fibonacci + secondFibonacci
    }
}

print(sum_of_even_fibonacci)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

alpha <- 0.05  # probability mass in the loss tail
t.df <- 5      # degrees of freedom for the t-distribution

# Calculate VaR (inverse CDF) and expected shortfall (numeric integration)
value.at.risk <- qt(alpha, df=t.df)
t5.mean.integrand <- function(x) { x*dt(x,t.df)}
ex.shortfall <- 1/alpha*integrate(t5.mean.integrand, lower=-Inf,
                                  upper=value.at.risk)[["value"]]

curve(dt(x, t.df), xlim=c(-4,4), lwd=2)  # plot the t-distribution

# Setup for drawing a filled-in area under the curve
x.seq <- seq(-5, value.at.risk, 0.01)
y.seq <- dt(x.seq, t.df)
cord.x <- c(-5, x.seq, value.at.risk)
cord.y <- c(0, y.seq, 0)
polygon(cord.x, cord.y, col="plum1")  # and draw the filled-in area

abline(v=value.at.risk, lty=2, lwd=2, col="red")  # add a vertical line at the VaR
abline(v=ex.shortfall, lty=4, lwd=2, col="deepskyblue")   # add a vertical line at the ES
abline(h=0)
text(x=-2.015, y=0.05, "5%-VaR", pos=4)  # Add text notes near...
text(x=-2.890, y=0.01, "5%-ES", pos=4)   # ...the vertical lines


#' Calculate settling velocity for a particle.
#'
#' \code{settle} calculates the settling velocity for a particle, given some parameters.
#' @param ws_mode Denotes whether to use a 'simple' equation, neglecting the shape and roundness of particles, or to use the more 'complex' formulation
#' @param D The grain size you wish to calculate settling velocity for.
#' @param constants A list of constants for calculation, need in order (g) gravitational constant, (rhos) sediment density, (rhof) fluid density, (nuu) kinematic viscosity, (csf) corey shape factor, and (PI) Powers roundness index. For the simple formulation, neglect the last two. Defaults to constants = list(g = 9.8, rhos = 2650, rhof = 1000, nuu  = 1.004e-6, csf = 0.7, PI = 3.5)
#' @return Returns a list with two values \code{$ws} and \code{$wstar} which are the settling velocity and dimensionless settling velocity, respectively.
#' @export
#' @examples
#' settle('simple', 120e-6)
#' settle('complex', 120e-6, list(g = 9.8, rhos = 2650, rhof = 1000, nuu  = 1.004e-6, csf = 0.7, PI = 3.5)

#	function to replicate two implementations of Dietrich 1982 settling velocity measurement for a given grain size and density.
#	Eric Barefoot
#	Nov 2017

#	takes constants as a list with names g, rhos, rhof, nuu, csf, PI with an option to leave off csf and PI for a simpler case

settle = function(ws_mode, D, constants) {

	if(missing(constants)) {
		g = 9.8			# m/s^2
		rhos = 2650		# assuming ~quartz sand.
		rhof = 1000		# assuming water
		nuu  = 1.004e-6	# kinematic viscocity of water at 20C in Pa s
		csf = 0.7		# given csf for grains
		PI = 3.5		# average for natural grains. Varies from 0-6.
	}
	else if (ws_mode == 'simple' & length(constants) != 4) {
		warning('incorrect number of constants; using defaults for the simple method')
		g = 9.8			# *m/s^2
		rhos = 2650		# *assuming ~quartz sand.
		rhof = 1000		# *assuming water
		nuu  = 1.004e-6}# *kinematic viscocity of water at 20C in Pa s}
	else if (ws_mode == 'complex' & length(constants) != 6) {
		warning('incorrect number of constants; using defaults for the complex method')
		g = 9.8			# m/s^2
		rhos = 2650		# assuming ~quartz sand.
		rhof = 1000		# assuming water
		nuu  = 1.004e-6	# kinematic viscocity of water at 20C in Pa s
		csf = 0.7		# given csf for grains
		PI = 3.5}		# average for natural grains. Varies from 0-6.
	else if (ws_mode == 'simple') {
		g = constants$g			# m/s^2
		rhos = constants$rhos	# assuming ~quartz sand.
		rhof = constants$rhof	# assuming water
		nuu  = constants$nuu	# kinematic viscocity of water at 20C in Pa s
	}
	else if (ws_mode == 'complex') {
		g = constants$g			# m/s^2
		rhos = constants$rhos	# assuming ~quartz sand.
		rhof = constants$rhof	# assuming water
		nuu  = constants$nuu	# kinematic viscocity of water at 20C in Pa s
		csf = constants$csf		# given csf for grains
		PI = constants$PI		# average for natural grains. Varies from 0-6.
	}

	#	calculate dimensionless grain size

	Dstar = (rhos - rhof) * ((g * D^3) / (rhof * nuu^2))

	#	simple case

	if (ws_mode == 'simple') {

		Dsl = log10(Dstar)

		R1 = -3.76715 + 1.92944*Dsl - 0.09815*Dsl^2 - 0.00575*Dsl^3 + 0.00056*Dsl^4

		wstar = 10^(R1)

	}

	if (ws_mode == 'complex') {
	#	some simplifying common terms

		Dsl = log10(Dstar)
		tantan = tanh(Dsl - 4.6)
		csf_t = 1 - csf

		#	now the other parameters for settling velocity
		#	NOTE: lynds et al neglect the other terms, so theres a switch, one with the shape factor and powers index, and one without. default is simple

		R1 = -3.76715 + 1.92944*Dsl - 0.09815*Dsl^2 - 0.00575*Dsl^3 + 0.00056*Dsl^4

		R2 = (log10(1 - (csf_t/0.85)) - csf_t^2.3*tantan + 0.3*(0.5 - csf)*csf_t^2*(Dsl - 4.6))

		R3 = (0.65 - ((csf/2.83)*tantan))^(1+(3.5-PI)/2.5)

		wstar = R3 * 10^(R1 + R2)
	}

	#	conversion back to dimensional settling velocity

	ws = (wstar * (rhos - rhof) * g * nuu / rhof)^(1/3)

	return(list(ws = ws, wstar = wstar))

}


log_loss <- function(actual, predicted, eps=0.00001) {
  predicted <- pmin(pmax(predicted, eps), 1-eps)
  -1/length(actual)*(sum(actual*log(predicted)+(1-actual)*log(1-predicted)))
}


##### Chapter 5: Classification using Decision Trees and Rules -------------------

# 트리에 다수의 명목 특징이 여러 레벨로 이루어져 있거나, 다수의 수치 특성이 있는 경우 tree overfit
# 매개 변수(parameter) 조정으로 이러한 단점을 극복할 수 있다.
# 트리 생성을 일찍 중단하거나(사전 가지치기 pre-prunning)
# 트리를 만든 후 데이터 포인터가 적은 노드를 삭제하거나 병합하는 것(사후 가지치기 post-prunning)

# 랜덤 포레스트와, 그래디언트 부스팅으로도 이러한 단점을 극복할 수 있다.

# 트리의 C5.0 알고리즘은 트리 식별 방법으로 엔트로피를 이용한다.
# 클래스가 n개인 경우 엔트로피의 범위는 0에서 log2(밑이 2)n이다.(클래스 값의 집합 내의 무작위성 또는 무질서를 정량화)

#### Part 1: Decision Trees -------------------

## Understanding Decision Trees ----
# calculate entropy of a two-class segment
-0.60 * log2(0.60) - 0.40 * log2(0.40) # 하나는 확률 0.6, 나머진 0.4인 경우

curve(-x * log2(x) - (1 - x) * log2(1 - x), # 클래스 2개일 때 모든 가능한 엔트로피 배열
      col = "red", xlab = "x", ylab = "Entropy", lwd = 4)
# 분할을 하기 위한 최적의 특징을 결정하기 위해 엔트로피를 사용하려면
# 알고리즘은, 각 특징별로, 분할로 인해 생기는 동질성의 변화를 계산한다.
# 이것이 정보 획득량이라고 하는 척도이다.
## 어떠한 특징 F의 정보 획득량은 분할 전 세그먼트 S1과 분할로 생성된 파티션들 S2의 엔트로피 차로 계산된다.
# 그런데 문제는 분할 후에 데이터가 하나 이상의 파티션으로 나뉜다
# -> S2 계산하는 함수는 모든 파티션의 전체 엔트로피 고려
# -> n개 파티션에 대해, 각 파티션의 엔트로피에 파티션이 속하는 예시 비율로 가중치 부여하여 합산.

# 정보 획득량 높음 -> 이 특징에 분할한 후 동질적 그룹을 생성하기 더 좋은 특징.
# 수치 특성에 대해 분할할 때에도 정보 획득량 사용 -> 어떠한 임계값보다 큰지 작은지로 나눈다. 그 임계값은 다양하게 테스트한다.
# 이러한 방식으로 수치적 특성을 2레벨 범주형 특성으로 나눈다.
# 그리고 분할 시 최대 정보 획득량을 산출하는 수치 절단점을 선택한다.

# 사전 가지치기를 하면, 감지하기는 힘들지만 트리가 크게 자랐다면 학습할 수도 있는 중요한 패턴을 놓칠 수도 있다.
# 그 대안으로 사후 가지치기를 한다.
# -> 먼저 overfit되는 큰 트리로 자라게 한 후, 나중에 분류 오류에 영향이 거의 없는 노드와 분기는 제거한다.
# -> 어떤 때에는 전체 분기가 위쪽으로 옮겨지거나, 좀 더 간단한 의사결정으로 대체된다.

# overfit과 underfit의 균형을 맞추는 것은 다소 기술적.
# 하지만 모델의 정확도가 필수적이라면 다양한 가지치기 옵션으로 테스트 데이터에 대해 성능 향상이 되는지 투자해야!

## Example: Identifying Risky Bank Loans ----
## Step 2: Exploring and preparing the data ----
getwd()
setwd('D:/R_LAB/MLwR/Chapter 05')

credit <- read.csv("credit.csv")
str(credit)

# look at two characteristics of the applicant
table(credit$checking_balance)
table(credit$savings_balance)

# look at two characteristics of the loan
summary(credit$months_loan_duration)
summary(credit$amount)

# look at the class variable
table(credit$default)

# create a random sample for training and test data
# use set.seed to use the same random number sequence as the tutorial
# 훈련에 데이터 90% 사용, 테스트에 10% 사용
# 임의로 정렬되어 있지 않은 데이터를 다루는 방법 -> 랜덤 샘플
set.seed(123) # 랜덤 샘플 수행하기 전에 시드값 설정
train_sample <- sample(1000, 900)

str(train_sample)

# split the data frames
credit_train <- credit[train_sample, ]
credit_test  <- credit[-train_sample, ]

# check the proportion of class variable
# 잘 나뉘었다면 각 데이터셋은 약 30%의 채무불이행 대출을 갖는다.
prop.table(table(credit_train$default)) # 잘 나뉘었다
prop.table(table(credit_test$default)) # 잘 나뉘었다

## Step 3: Training a model on the data ----
# build the simplest decision tree
if(!require(C50)) {
  install.packages("C50")
  require(C50)
}
# ?C5.0Control 명령으로 알고리즘을 정교하게 조정하는 방법에 대한 더 자세한 사항을 확인할 것

# credit_train의 17번째 열은 default 클래스 변수이므로 제외한다.
# 그리고 분류를 하기 위한 목표 팩터 벡터로 제공해야 한다.
credit_model <- C5.0(credit_train[-17], credit_train$default)

# display simple facts about the tree
credit_model # 트리 크기 57 -> 트리가 57개의 결정으로 이뤄진 깊이라는 뜻.

# display detailed information about the tree
summary(credit_model)
# 가끔 트리는 논리적으로 이해가 안 되는 결정을 만든다.
# ex) 왜 대출 이력이 좋은 신청자가 채무불이행 가능성 있지? 왜 수표 계좌 잔고를 모르면 채무불이행 가능성 없지?
# 그런 규칙들은 데이터의 실제 패턴을 반영한 결과일 수도 있고
# 단지 통계적 이상치일 수도 있다.
# 두 경우 모두, 트리의 논리가 비즈니스 용도로 합당한지 확인하기 위해
# 이런 이상한 결정을 조사해보는 것이 중요하다.

# 트리를 출력한 후 혼동 행렬을 보여준다.
# 혼동 행렬은 모델이 훈련 데이터에서 부정확하게 분류한 레코드를 보여주는 교차표다.

## Step 4: Evaluating model performance ----
# create a factor vector of predictions on test data
credit_pred <- predict(credit_model, credit_test)

# cross tabulation of predicted versus actual classes
library(gmodels)
# gmodels 패키지에 있는 CrossTable() 함수를 통해, 이 벡터와 실제 클래스 값을 비교할 수 있다.
CrossTable(credit_test$default, credit_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# prop.c = FALSE, prop.r = FALSE 하면 표에서 열과 행 비율을 제거한다.

# 남은 백분율 prop.t는 전체 레코드 개수에서 셀의 레코드 비율을 나타낸다.

## Step 5: Improving model performance ----
# 실제 채무불이행 중 42%만 정확히 예측했다. 이는 매우 큰 비용이 될 수 있다.

## Boosting the accuracy of decision trees
# boosted decision tree with 10 trials(부스팅 팀에 사용할 독립적 트리의 갯수를 10개로 늘림)
credit_boost10 <- C5.0(credit_train[-17], credit_train$default,
                       trials = 10)
# rules = TRUE를 명시하면 분류 규칙을 이용해 모델을 생성하게 된다.

credit_boost10 # 트리의 크기가 57에서 47로 줄어들었다.
summary(credit_boost10)
# 부스팅을 추가하기 전 오류율보다 매우 줄어들었다.

# 테스트 데이터에서도 성능 향상이 될까?
credit_boost_pred10 <- predict(credit_boost10, credit_test)
CrossTable(credit_test$default, credit_boost_pred10,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# 오류율이 27에서 18로 줄었다. 채무불이행은 여전히 예측율이 낮다.
# 더 크게 개선되지 않은 이유
  # 1. 상대적으로 작은 훈련 데이터셋과 함수 관계
  # 2. 이 문제 자체가 원래 해결하기 어려운 문제

# 부스팅을 쓰지 않는 이유 -> 계산량 증가, 훈련 데이터에 잡음이 많으면 부스팅으로 개선되지 않음.

## Making some mistakes more costly than others

# create dimensions for a cost matrix
# 트리가 좀 더 비용이 많이 드는 실수를 하지 못하도록
# 여러 오류 유형에 페널티를 줄 수 있음.
matrix_dimensions <- list(c("no", "yes"), c("no", "yes"))
names(matrix_dimensions) <- c("predicted", "actual")
matrix_dimensions

# build the matrix
# 행렬을 채울 때 열 단위로 위에서 아래로 채우기 때문에, 특정 순서대로 값을 제공해야 한다.
# pre x act x
# pre o act x
# pre x act o
error_cost <- matrix(c(0, 1, 4, 0), nrow = 2, dimnames = matrix_dimensions)
error_cost

# apply the cost matrix to the tree
credit_cost <- C5.0(credit_train[-17], credit_train$default,
                          costs = error_cost)
credit_cost_pred <- predict(credit_cost, credit_test)

CrossTable(credit_test$default, credit_cost_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))
# 거짓 긍정을 증가시킨 대가로 거짓 부정을 줄였다.
# 전체적인 실수는 증가했지만, 이렇게 하는 편이 오히려 이익이 될 수도 있다.

#### Part 2: Rule Learners -------------------

# 분류 규칙은, 클래시를 레이블이 없는 예시에 할당하는 논리적인 if-else문으로 지식을 표현한다.
# -> 이것이 발생하면, 저것이 발생한다.

# 규칙은 tree로도 생성할 수 있는데 왜 별도의 규칙 학습자 알고리즘에 신경을 쓰는가?
# -> 규칙 학습자가 규칙을 직접 찾음으로써 피할 수 있는 작업에 대해,
# 의사 결정 트리는 특정 편향을 불러오기 때문이다.

# 규칙 학습자는 일반적으로, 특징이 주로 또는 전체적으로 명목형인 문제에 적용된다.
# 희소한 사건이, 특징 값 사이에 매우 특정한 상호작용에서 발생한다 하더라도, 규칙 학습자는 희소 사건을 잘 식별함.

# 클래스 값을 식별하는 점점 더 구체적인 규칙을 생성해 데이터를 드릴 다운한다.
# 규칙이 데이터의 부분을 커버하는 것 같아 보이기 때문에, 분리 정복 알고리즘은 커버링 알고리즘이라고도 한다.

# ZeroR -> 아무 규칙도 학습하지 않는 규칙 학습자(ex. 셋 중에 하나 뽑기)
## 1R 알고리즘 -> 하나의 규칙을 선택하는 방식.
  # 각 특징에 대해 유사한 값으로 데이터를 그룹으로 분리한다.
  # 그 다음 알고리즘은 각 세그먼트에 대해 대다수 클래스를 예측한다.
  # 각 특징에 기반을 두는 규칙의 오류율을 계산하고, 최소 오류를 갖는 규칙을 단일 규칙으로 선정한다.
# 1R 알고리즘은 너무 느리고, 잡음이 섞이면 쉽게 부정확해진다.

# RIPPER 알고리즘으로 규칙 학습자를 만들자.
# RIPPER 알고리즘의 3단계
  # 1. 기르기
    # 규칙에 조건을 탐욕스럽게 추가하기 위해 분할 정복 기법 사용
    # 데이터의 부분집합을 완벽하게 분류하거나, 분할을 위한 속성이 없어질 때까지 진행
    # 정보 획득량 기준 사용 -> 규칙이 더 정교햐져도 엔트로피가 줄지 않으면, 그 규칙은 가지치기된다.
  #
# 탐욕스러운 학습자 -> 선입 선처리 기반으로 데이터 사용
  # -> 한 번에 하나의 파티션을 만들고자 함. 먼저 가장 동질적인 파티션을 찾고 난 후에 차선을 찾고
    # -> 모든 예시가 다 분류될 때까지 계속해서 찾는다.
  # 단점 : 특정 데이터셋에 최적이고, 가장 정확하고, 최소 개수로 된 규칙을 생성한다는 보장이 없음
    # -> 데이터의 한 부분집합에 대해 정확한 한 개의 규칙은 계속해서 찾아낼 수 있지만
    # -> 전체 데이터셋에 대해 더 나은 전반적인 정확도를 갖는 좀 더 섬세한 규칙들을 개발할 기회 잃게 됨.

# 트리와 규칙 모두 탐욕 학습 휴리스틱 사용. 차이는
  # 트리는 이전 결정의 이력에 의해 영원히 제한된다.
  # 규칙은 규칙의 모든 조건으로 커버되지 않는 어떤 예시든 다음 규칙에 의해 재정복 가능.

## Example: Identifying Poisonous Mushrooms ----
## Step 2: Exploring and preparing the data ----
mushrooms <- read.csv("mushrooms.csv", stringsAsFactors = TRUE)

# examine the structure of the data frame
str(mushrooms)

# drop the veil_type feature(범주인데 하나밖에 없음 ->쓸모도없다)
mushrooms$veil_type <- NULL

# examine the class distribution
table(mushrooms$type)

## Step 3: Training a model on the data ----
library(RWeka) # JAVA 설치 필요

# train OneR() on the data
mushroom_1R <- OneR(type ~ ., data = mushrooms) # 1R 만들어내는 함ㅅ
# 규칙 학습자가 type ~. 을 통해 모든 특징을 고려하도록 만듦

## Step 4: Evaluating model performance ----
mushroom_1R
summary(mushroom_1R)

## Step 5: Improving model performance ---- # RIPPER 규칙 사용
mushroom_JRip <- JRip(type ~ ., data = mushrooms)
mushroom_JRip # 전체 9개의 규칙(if-else문)을 학습함.
summary(mushroom_JRip)

# Rule Learner Using C5.0 Decision Trees (not in text)
library(C50)
mushroom_c5rules <- C5.0(type ~ odor + gill_size, data = mushrooms, rules = TRUE)
summary(mushroom_c5rules)


#' winddir
#'
#' @description Calculate meteorological wind direction from cartesian components u and v.
#'
#' @param u numeric U zonal component
#' @param v numeric V meridian component
#'
#' @references
#' Istituto di Biometeorologia Firenze Italy
#' @author  Alfonso crisci \email{a.crisci@@ibimet.cnr.it} Marco Morabito \email{m.morabito@@unifi.it}
#' @keywords Meteorological Wind direction
#'
#'
#' @export

winddir <- function(u, v) {
                    (180 / pi) * atan(u/v) + ifelse(v>0,180,ifelse(u>0,360,0))
}


library("magrittr")
a <- 0.88
b <- 1.55

costA <- function(lambda){
	return(160 + (40 * (lambda + lambda^2)))
}

costB <- function(lambda){
	return(128 + (40 * (lambda + lambda^2)))
}

ansa <- costA(a) #226.176
ansb <- costB(b) #286.1
cat(sprintf("%.3f\n", ansa))
cat(sprintf("%.3f\n", ansb))

cat(round(ansa,3),'\n')
cat(round(ansb,3))

#simulation:
n <- 10^8
asim <- rpois(n = n, lambda = a)
bsim <- rpois(n = n, lambda = b)

amax <- asim %>% max
bmax <- bsim %>% max

calc <- function(v, max){
	zeroToN = c()
	for(i in 0:max)
	{
		bool <- ifelse(v == i, 1, 0)
		proportionI <- sum(bool)/n
		zeroToN = c(zeroToN, proportionI)
	}
	return(zeroToN)
}

costa <- function(X){
	return(160 + (40 * X^2))
}
costb <- function(Y){
	return(128 + (40 * Y^2))
}

#apply cost functions to random variables x and y

acost <- sapply(X = asim, FUN = costa)
bcost <- sapply(X = bsim, FUN = costb)

sum(acost)/n
sum(bcost)/n

aans <- acost %>% sum()/n
bans <- bcost %>% sum()/n
cat(aans, "\n")
cat(bans)


require(Rdonlp2)

factors <- c(
  0.02040000,-0.08672903,0.06208421,0.08537144,
  0.08530000,0.01567469,0.08519883,0.13293438,
  0.02570000,-0.03997748,0.04657237,0.04977169,
  0.00760000,0.04163002,-0.00568537,-0.02547824,
  0.04540000,0.11255746,0.05319682,0.04129890,
  -0.01830000,0.00805313,-0.00421743,-0.05443995,
  -0.03520000,-0.08656963,-0.05054419,-0.01769600,
  0.07920000,0.16539408,0.05479713,0.06737632,
  0.03190000,0.02451794,0.02632593,0.01820807,
  0.07870000,0.05045111,0.07801389,0.09820405,
  0.02140000,0.02911620,0.00553052,0.03437993,
  0.08920000,0.16132008,0.09959438,0.09472788,
  -0.02850000,-0.02864671,-0.03634867,-0.04231819,
  0.02810000,0.02976673,0.03965725,0.04903749,
  0.08810000,0.07181523,0.07879099,0.06418204,
  0.09070000,0.11896197,0.07516213,0.11833781,
  -0.02310000,-0.07499952,-0.00807299,-0.02992491,
  0.06940000,0.09002753,0.09137129,0.09216098,
  0.02640000,0.08124712,0.02024337,0.02541702,
  -0.04460000,0.01855777,-0.04992867,-0.04843952,
  0.01530000,0.10141779,0.02720172,0.05258464,
  -0.00860000,-0.04908988,-0.00546264,-0.03273162,
  0.05120000,0.05606888,0.08323532,0.08211691,
  0.02090000,0.00249315,0.02060449,-0.00069403,
  0.05400000,0.03418127,0.05196274,0.04239199
)

factors <- matrix(data=factors, nrow=25, ncol=4, byrow=TRUE)

fund_returns <- c(
  0.07950000,
  0.11440000,
  0.04550000,
  0.01010000,
  0.03350000,
  -0.01470000,
  -0.02160000,
  0.07120000,
  0.02200000,
  0.08970000,
  0.02530000,
  0.04560000,
  -0.01980000,
  0.03100000,
  0.06020000,
  0.08530000,
  0.00640000,
  0.05500000,
  0.02920000,
  -0.02150000,
  0.00160000,
  0.00830000,
  0.04780000,
  0.02280000,
  0.04110000
)

objective <- function(weights) {

  # ASSERT: ncol(factors) == length(weights)

  # calculate the sum product of factors and weights
  sum_product <- factors %*% matrix(weights, ncol=1)
  sum_product_return <- cbind(sum_product, fund_returns)
  residuals <- sum_product_return[, 2] - sum_product_return[, 1]

  # ASSERT: nrow(factors) == length(residuals)

  # calculate (and return) the stdev of the residuals
  sd(residuals)
}

weights <- c(0.25, 0.25, 0.25, 0.25)   # start weights

# weight constraints
weights.lower <- c(0, 0, 0, 0)         # >= 0
weights.upper <- c(1, 1, 1, 1)         # <= 1

# equality constraints
eqFun <- list(
  function(x) sum(x)
)
eqFun.bound <- c(1)

# note: no need for inequality and non-linear constraints

x1 <- donlp2NLP(
  par = weights,
  par.lower = weights.lower,
  par.upper = weights.upper,
  fun = objective,
  eqFun = eqFun,
  eqFun.bound = eqFun.bound
)

#str(x1)

found_weights = x1$par

# sanity check
if (sum(found_weights) > 1.00000000000001 || sum(found_weights) < 1)
 cat('FAILED: Sum(W) = ', sum(found_weights), '\n')

if (sum(abs(found_weights)) > 1.00000000000001 || sum(abs(found_weights)) < 1)
 cat('FAILED: Sum(Abs(W)) = ', sum(abs(found_weights)), '\n')

if(any(found_weights < 0) || any(found_weights > 1))
  cat('FAILED: One or more factor weight <0 or >1\n')

# print out weights....
cat(found_weights[1], '\t', found_weights[2],'\t', found_weights[3],'\t', found_weights[4], '\n')


qqplot_nwj <- function(x, type='nwj', jfit='all', mainadder=NULL) {
    ## creates side by side, normal, Weibull and/or Johnson qq plots

    ## make room for 1, 2 or 3 plots depending on length of string 'type'
    nplots <- nchar(type)
    if (nplots != 1) par(mfrow=c(1, nplots))

    nparms <- NULL
    wparms <- NULL
    jparms <- NULL
    if (grepl('n', type)) {
        ## make normal QQ plot
        main <- paste('Normal QQ Plot', mainadder, sep=" ")
        nparms <- qualityTools::qqPlot(x, "normal",  col='black', main=main)
    }

    if (grepl('w', type) & min(x)>0) {
        ## make Weibull QQ plot
        main <- paste('Weibull QQ Plot', mainadder, sep=" ")
        ## tolerance package seems more robust than qualityTools
        ##     wparms <- qualityTools::qqPlot(x, "Weibull", col='black', main=main)
        ## also, tolerance packages is used in hist_nwj so more consistent
        out     <- tolerance::exttol.int(x, alpha=0.05, P=0.95, side=1, dist='Weibull')
        shape   <- out$'shape.1'
        scale   <- out$'shape.2'
        wparms  <- list(shape=shape, scale=scale)
        qualityTools::qqPlot(x, "Weibull", col='black', main=main, start=wparms)
    } else if (grepl('w', type)) {
        ## some values are negative or zero so Weibull is not appropriate
        cat('Weibull plot not made because not appropriate; some values not > 0\n')
    }

    if (grepl('j', type)) {
        ## obtain Johnson parameter estimates
        x <- sort(x, na.last=NA)
        if (jfit == 'all') {
            ## let R figure out which Johnson distribution fits best
            jparms  <- SuppDists::JohnsonFit(x)
            main <- paste('Johnson QQ Plot', mainadder, '; Type=', jparms$type, sep=" ")
        } else if (jfit == 'SU') {
            ## force the Johnson SU distribution
            jparms.out <- ExtDist::eJohnsonSU(x)
            jparms <- list(gamma   = jparms.out$gamma,
                           delta   = jparms.out$delta,
                           xi      = jparms.out$xi,
                           lambda  = jparms.out$lambda,
                           type <- 'SU')
            main <- paste('JohnsonSU QQ Plot', mainadder, sep=" ")
        } else if (jfit == 'SB') {
            ## force the Johnson SB distribution
            jparms <- ExtDist::eJohnsonSU(x)
            jparms$type <- 'SB'
            main <- paste('JohnsonSB QQ Plot', mainadder, sep=" ")
        } else {
            ## use Johnson parameters specified in jfit
            ## needs to be in same list format as created by SuppDists::JohnsonFit
            jparms <- jfit
            main <- paste('User Specified Johnson QQ Plot', mainadder, sep=" ")
        }

        ## make Johnson QQ plot
        xtheoretical <- SuppDists::qJohnson(ppoints(length(x)), jparms)
        plot(x, xtheoretical, xlab='Observed value, x', ylab='Expected Value', main=main)
        abline(0,1, col='red')

        ## quantiles_john <- qJohnson(ppoints(length(x)), jparms)
        ## stats::qqplot(
        ##     x = x,
        ##     xlab = "Data",
        ##     y = quantiles_john,
        ##     ylab = 'Quantiles from "Johnson" Distribution',
        ##     main = expression('Q-Q plot for "Johnson" Distribution'),
        ##     col='black')
        ## stats::qqline(x, distribution = function(p) qJohnson(p, jparms), col='red')
        ## abline(0,1, col='blue', lty=2)
        ## legend("bottomright",col=c('red', 'blue'), lty=c(1,2), legend=c('qqline', '45 degree line'))
    }

    if (grepl('k', type)) {
        ## alternate approach for Johnson QQ plot to get confidence intervals

        ## transpose Johnson distributed data to normal
        out <- johnson_tol(x, jfit='all', alpha=0.01, P=0.99, side=1, plots='no')
        xn <- out$xn

        ## now make normal QQ plot using
        main <- paste('Johnson Transposed to Normal QQ Plot', mainadder, sep=" ")
        nparms <- qualityTools::qqPlot(xn, "normal",  col='black', main=main)
    }

    return(list(nparms=nparms, wparms=wparms, jparms=jparms))

}

##-----------------------------------------------------------------------------
qqplot_nwj_tests <- function() {

    qqplot_nwj(mtcars$mpg)

    x <- sort(mtcars$mpg)

    ## comparisons for normal qq plot using same method as for Johnson qqplot
    par(mfrow=c(1,2))
    qualityTools::qqPlot(x, "normal",  col='black')
    xtheoretical <- qnorm(ppoints(length(x)), mean = mean(x), sd = sd(x))
    plot(x, xtheoretical, xlab='Observed value, x', ylab='Expected Value')
    abline(0,1, col='red')

    ## comparisons for Weibull qq plot using same method as for Johnson qqplot
    par(mfrow=c(1,2))
    qualityTools::qqPlot(x, "Weibull",  col='black')
    tol_out <-  exttol.int(x, alpha =0.1, P=0.99, side=1)
    shape <- tol_out$'shape.1'
    scale <- tol_out$'shape.2'
    xtheoretical <- qweibull(ppoints(length(x)), shape = shape, scale = scale)
    plot(x, xtheoretical, xlab='Observed value, x', ylab='Expected Value')
    abline(0,1, col='red')

}


#' Function to return (a - b)*(a + b) using a and b as inputs.
#' @param a numeric value
#' @param b a numeric value added after b
#' @return return The output of the function
#' @export
#' @examples
#' calculation_1(10,5)
#' calculation_1(8,3)

calculation_1 <- function(a,b) {
  output <- a^2 - b^2
  output
}


# R code for chapter 5 of Wood (2006) "GAMs: An Introduction with R"

## 5.1 Cherry trees again

library(mgcv)
data(trees)
ct1<-gam(Volume~s(Height)+s(Girth),
         family=Gamma(link=log),data=trees)
ct1
par(mfrow=c(1,2))
plot(ct1,residuals=TRUE)

## 5.1.1 Finer control of gam

ct2 <- gam(Volume~s(Height,bs="cr")+s(Girth,bs="cr"),
           family=Gamma(link=log),data=trees)
ct2
par(mfrow=c(2,2))
plot(ct1,residuals=TRUE)
plot(ct2,residuals=TRUE)

ct3 <- gam(Volume ~ s(Height)+s(Girth,bs="cr",k=20),
           family=Gamma(link=log),data=trees)
ct3

ct4 <- gam(Volume ~ s(Height) + s(Girth),
           family=Gamma(link=log),data=trees,gamma=1.4)
ct4
par(mfrow=c(2,2))
plot(ct1,residuals=TRUE)
plot(ct4,residuals=TRUE)

## 5.1.2 Smooths of several variables

ct5 <- gam(Volume ~ s(Height,Girth,k=25),
           family=Gamma(link=log),data=trees)
ct5
plot(ct5,too.far=0.15)

ct6 <- gam(Volume ~ te(Height,Girth,k=5),
           family=Gamma(link=log),data=trees)
ct6
plot(ct6,too.far=0.15)

## 5.1.3 Parametric model terms

gam(Volume~Height+s(Girth),family=Gamma(link=log),data=trees)
trees$Hclass <- factor(floor(trees$Height/10)-5,
                labels=c("small","medium","large"))

ct7 <- gam(Volume ~ Hclass+s(Girth),
           family=Gamma(link=log),data=trees)
par(mfrow=c(1,2))
plot(ct7,all.terms=T)

anova(ct7)
AIC(ct7)
summary(ct7)

## 5.2 Brain imaging example
## 5.2.1 Preliminary modeling
library(gamair)
data(brain)
brain

## Each row corresponds to one voxel

brain <- brain[brain$medFPQ>=3e-5,] # exclude 2 outliers
m0 <- gam(medFPQ~s(Y,X,k=100),data=brain)
gam.check(m0)

e <- residuals(m0); fv <- fitted(m0)
lm(log(e^2)~log(fv))

m1<-gam(medFPQ^.25~s(Y,X,k=100),data=brain)
gam.check(m1)

m2<-gam(medFPQ~s(Y,X,k=100),data=brain,family=Gamma(link=log),optimizer="perf")

mean(fitted(m1)^4);mean(fitted(m2));mean(brain$medFPQ)
m2

vis.gam(m2,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model m2 image plot and overlaid contours on scale of linear predictor")

## 5.2.2 Would an additive structure be better?
m3 <- gam(medFPQ~s(Y,k=30)+s(X,k=30),data=brain,
          family=Gamma(link=log),optimizer="perf")
m3
summary(m2)
summary(m3)
# Compare models m2 and m3
anova(m3,m2,test="F")

m4 <- gam(medFPQ~s(Y,k=30)+s(X,k=30)+s(Y,X,k=100),data=brain,
      family=Gamma(link=log),optimizer="perf")

## 5.2.3 Isotropic or tensor product smooths?

tm<-gam(medFPQ~te(Y,X,k=10),data=brain,family=Gamma(link=log),
        optimizer="perf")
tm1<-gam(medFPQ~s(Y,k=10,bs="cr")+s(X,bs="cr",k=10),
         data=brain,family=Gamma(link=log),optimizer="perf")

tm1
tm
anova(tm1,tm,test="F")

## So we plot them again
vis.gam(tm1,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model tm1 image plot and overlaid contours")

vis.gam(tm,plot.type="contour",too.far=0.03,
        color="gray",n.grid=60,zlim=c(-1,2),main="model tm image plot and overlaid contours")

## 5.3 Air pollution in Chicago example
library(mgcv)
library(gamair)
data(chicago)
ap0 <- gam(death~s(time,bs="cr",k=200)+pm10median+so2median+
           o3median+tmpd,data=chicago,family=poisson)
gam.check(ap0)

par(mfrow=c(2,1))
plot(ap0,n=1000)  # n increased to make plot smooth
plot(ap0,residuals=TRUE,n=1000)

chicago$death[3111:3123]

ap1<-gam(death~s(time,bs="cr",k=200)+s(pm10median,bs="cr")+
     s(so2median,bs="cr")+s(o3median,bs="cr")+s(tmpd,bs="cr"),
     data=chicago,family=poisson)
gam.check(ap1)

par(mfrow=c(3,2))
plot(ap1,n=1000)

lag.sum <- function(a,l0,l1)
## l0 is the smallest lag, l1 the largest
{ n<-length(a)
  b<-rep(0,n-l1)
  for (i in 0:(l1-l0)) b <- b + a[(i+1):(n-l1+i)]
  b
}
death<-chicago$death[4:5114]
time<-chicago$time[4:5114]
o3 <- lag.sum(chicago$o3median,0,3)
tmp <- lag.sum(chicago$tmpd,0,3)
pm10 <- lag.sum(log(chicago$pm10median+40),0,3)
so2 <- lag.sum(log(chicago$so2median+10),0,3)

ap2 <- gam(death ~ s(time,bs="cr",k=200) +
                   te(o3,tmp,pm10,k=c(8,8,6)),family=poisson)
gam.check(ap2)

ap3 <- gam(death ~ s(time,bs="cr",k=200) + te(o3,tmp,k=8) +
                   s(pm10,bs="cr",k=6),family=poisson)
par(mfrow=c(3,1))
plot(ap3)

## 5.6.1 Package 'gam' (note need to run chicago pre-proc first)

detach(package:mgcv)
library(gam)
install.packages("akima")
library(akima) # needed for plotting
bfm <- gam(death~s(time,df=140)+lo(o3,tmp,span=.1),
           family=poisson,control=gam.control(bf.maxit=150))
summary(bfm)

## 5.6.2 Package 'gss'
install.packages("gss")
library(gss)
ssm <- gssanova1(death~time+o3*tmp,family="poisson",nbasis=200)

summary(ssm)

tp <- seq(min(time),max(time),length=500)
fvt <- predict(ssm,newdata=data.frame(time=tp,
               o3=rep(mean(o3),500),tmp=rep(mean(tmp),500)),
               include=list("time"))
plot(tp,fvt,type="l",xlab="time",ylab="time effect")

m <- 40
o3m <- seq(min(o3),max(o3),length=m)
tmpm <- seq(min(tmp),max(tmp),length=m)
tmpp <- rep(tmpm,rep(m,m))
o3p <- rep(o3m,m)
pd <- data.frame(time=rep(0,m*m),o3=o3p,tmp=tmpp)
fv <- predict(ssm,newdata=pd,include=list("o3","tmp","o3:tmp"))
library(mgcv)
ind <- exclude.too.far(o3p,tmpp,o3,tmp,dist=0.04)
fv[ind] <- 0
persp(o3m,tmpm,matrix(fv,m,m),phi=30,theta=-30,zlab="o3*tmp",
      xlab="o3",ylab="tmp")

Linear Regression GLMs and GAMs with R/scripts/Ch-5-Day-4.r


#Tratamientos
A <- c(62,60,63,59)
B <- c(63,67,71,64,65,66)
C <- c(68,66,71,67,68,68)
D <- c(56,62,60,61,63,64,63,59)

#Tabla de resultados
resultado <- c(A,B,C,D)

dietas <- c(rep("A",length(A)),
            rep("B",length(B)),
            rep("C",length(C)),
            rep("D",length(D)))

misdatos <- data.frame(dietas,resultado)

boxplot(resultado~dietas,misdatos, main="Tiempo de coagulación de la sangre segun dieta", ylab="Tiempo (segundos)")

# ANOVA
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)

# global Effect and Treatment Effect
mu.est <- mean(misdatos$resultado)
mu.est
#aplicar media por grupos
mean_treatment <-  aggregate(resultado~dietas,misdatos,mean)
mean_treatment
#diferencia media por gruposy media global
effect_treatment <-  aggregate(resultado~dietas,misdatos,function(x){mean(x)-mu.est})
mu.est
effect_treatment

# Treatment Effect with a reference Level
round(coefficients(anova1),2)

# Changing Reference Level
misdatos$dietas <- relevel(misdatos$dietas,ref="B")
misdatos$dietas
anova1 <- aov(resultado~dietas,misdatos)
summary(anova1)
round(coefficients(anova1),2)

#================================================
# DBCA
#================================================
 res <- c(13,16,5,22,24,4,18,17,1,39,44,22)
 factor <- c(1,2,3,1,2,3,1,2,3,1,2,3)
 bloque <- c(1,1,1,2,2,2,3,3,3,4,4,4)

 midata <- data.frame(factor,bloque,res)

 length(res)
 length(factor)
 length(bloque)

 boxplot(res~factor,midata, main="Retardo en el crecimiento de bacterias",
         ylab="Tiempo (segundos)",
         xlab="Factor: Soluciones de lavado")
 boxplot(res~bloque,midata, main="Retardo en el crecimiento de bacterias",
         ylab="Tiempo (segundos)",
         xlab="Bloques: Días")

 # Interacciones
 interaction.plot(midata$factor,midata$bloque,midata$res,
                  xlab="Factor: Soluciones de lavado",
                  ylab="Tiempo (segundos)",
                  leg.legend="Bloque")

 #Opt1
 anova1 <- aov(res~as.factor(factor)+as.factor(bloque),midata)
 summary(anova1)

 #Opt2
 midata <- data.frame(factor=as.factor(factor),bloque=as.factor(bloque),res)
 anova1 <- aov(res~factor+bloque,midata)
 summary(anova1)

 # global Effect and Treatment Effect
 mu.est <- mean(midata$res)
 mean_treatment <-  aggregate(res~factor,midata,mean)
 effect_treatment <-  aggregate(res~factor,midata,function(x){mean(x)-mu.est})
 effect_block <-  aggregate(res~bloque,midata,function(x){mean(x)-mu.est})
 mu.est
 effect_treatment
 effect_block

 #Effects with control treatment
 round(coefficients(anova1),4)


# Install Package
install.packages("UsingR")
install.packages("Hmisc")

# List installed packages
installed.packages()

# List names
row.names(installed.packages())

# Load package
library(UsingR)

# R help
help(row.names)
?row.names
# Search for help in R
??lenear

# Assign Variables
x = 5
y <- 2*x + 6
"Austria" -> z

# Data structures
# 1. Vector / array
v1 = c() # Empty vector
v1 = c(1, 4, 6., 4, 7, 12., -17) # Vector with numbers
v1

# Add new elements to vector
v2 = c("a", "b", "c")
v2
v12 = c(v1, v2)

# Check types of vectors
str(v1)
str(v2)
str(v12) # Casted to string vector

str(c(1, 2, 'p'))
typeof(c(1, 2, 'p'))

# Date vector
v3 = as.Date(c("2015-01-01", "2016-07-08"))
?as.Date # Convert strings to dates

# The merge between numbers and dates converts dates to integer.
# This integer presents count of the days since 1970-01-01
v13 <- c(v1, v3)
as.numeric(v13)

# As is used for force an object to belong to a class
# Force to be casted to number - strings are replaced by NA
as.numeric(v12)

# No problem everything include numbers can be presented as string
as.character(v1)

# ERROR, start date for counting the days is not set
as.Date(v1)
# Origin is start date of countring
as.Date(v1, origin = "2011-01-01")

v1.temp = c(1, 2, 2, 4, 5, 7, 18, -19)
# Gets length of the vector
length(v1.temp)

# Gets max value
max(v1)

# Gets sum of elements
sum(v1)

# Check which element is 2
v1.temp == 2

# Count of elements equals to 2
sum(v1.temp == 2)

# Get element from vector
# Indexing starts from 1!
v1[1]

# New vector that contains first and last element from v1
v1[c(1, length(v1))]

# Vector with four times third element of v1
v1[c(3, 3, 3, 3)]

# Create a sequences
# Returns vector with elemnents 1 to 10
1:10
10:1

# Multiplies vector
temp = 1;
for (i in 1:3) {
  temp = temp * i
}
temp

# Equivalent, but with function
seq(from = 1, to = 10, by = 1)
seq(from = 10, to = 1, by = -1)

# Third, Sixth and from First to Fourth element
v1[c(3, 6, 1:4)]

# In R we can create a subvector. The values that we DON'T want!
# Не искаме елементите от 3 до 6
v1[-c(3, 6)]

# Всички елементи без първия
v1[-1]

# Всички елементи без от 3ти до 6ти
v1[-(3:6)]

#   За да не ни се налага да се чудим какви числа да измисляме всеки път, то най-добре е
#   всичко до оставим в ръцете на "съдбата". Тоест да генерираме нашите числа на случаен принцип.

#   Създаваме 3 вектора с генерирани псевдослучайни величини. За да получаваме винаги една и
#   съща редица от числа, то трябва винаги да стартираме от една и съща начална позиция. За тази
#   цел използваме командата set.seed(...).
#   Искаме числата, които се генерират в трите вектора, да се падат с равни вероятности. Тоест
#   P(1) = P(2) = ... = P(n-1) = P(n), където P(x) е вероятнсотта да се падне числото x.

#   В упражненията ще учите подробно различните вероятностни разпределения, но за момента е
#   достатъчно да знаем, че този вид разпределение се нарича "равномерно".

#   Равномерно разпределение е когато всяка една от стойностите е с равна вероятност да се падне.

# Histogram of random numbers
# Uniform Distribution
hist(
  trunc(runif(n = 10^3, min = 1, max = 5.9999)),
  col = "red",
  main = "Histogram",
  xlab = "Pseudo random numbers"
) # чертае хистограма на данните

runif(n = 10^3, min = 1, max = 5.9999) # Прави random 1000 числа със стойности от 1 до 6
trunc(runif(n = 10^3, min = 1, max = 5.9999)) # trunc маха дробната част от числата
table(trunc(runif(n = 10^3, min = 1, max = 5.9999)))
?runif
##############################

# Set Seed and Uniform Distribution
set.seed(1806)
v4 = trunc(runif(n = 20, min = 1, max = 40.99999)) # генерира равномерно разпределени числа
set.seed(2713)
v5 <- round(runif(n = length(v4), min = 1, max = 40.99999))
set.seed(189)
v6 <- round(runif(n = length(v4) - 7, min = 1, max = 40.99999))

# Генерира псевдо случайни равномерно разпределени числа.
?runif

# Operations with vectors
# Add 3 to every element
v4 + 3

# Miltiply every element from vector with 2
v4 * 2

# Complex expression
(v4/7) + 11

# Скаларно произведение
# Вектор по вектор
# Трябва да са с равни дължини двата вектора
v4 * v5

# Дава предупреждение, защото дължината на втория вектор не е кратна на първия.
v4 * v6

# Change first 4 elements
v4.prime <- v4
v4[c(1, 2, 3, 4)] = 4

# ---------
# Functions
func1 <- function(a, b, c) {
  return (a + b + c)
}

func1(1, 1, 1)

# Functions with default params
func2 <- function(a, b = 2, c = 3) {
  print(paste('A:',a))
  print(paste('B:',b))
  print(paste('C:',c))

  return (a + b + c)
}

# С paste се конкатенират string-ове

func2(3, 3, 1)
func2(b = 3, c = 3, a = 1)
func2(1, c = 3)
func2(b = 2, c = 3) # ERROR - a doesnt have default value

# Check for value in the function
#   Командата "missing" проверява дали имаме стойност за параметъра "a"!
#   С "print()" извеждаме съобщение
#   С "rnorm(n = 1)" генерираме една (n = 1) нормално разпределена случайна величина
#   с очакване 0 и стандартно отклонение 1
func3 <- function(a, b = 0, c = 0) {
  if(missing(a)) {
    print("You don't enter value for \"a\". The function generate normal distributed value")
    a <- rnorm(n = 1)
  }
  return(a + b + c)
}
rnorm(n = 1) # Генерира нормално разпределение

func3(b = 2, c = 3)

func4 <- function(a, b = 2, c = 3) {
  if(missing(a)) {
    a <- NA
  }

  Obj <- NULL
  Obj$number1 <- a
  Obj$number2 <- b
  Obj$number3 <- c

  Obj # return(Obj)
}

obj <- func4()

# ----------------
# if-else statement

# if() {
#
# } else if() {
#
# } else {
#
# }

# ----------------
# Loops
# for (...) {} - foreach iteration
v7 <- c("a", "b", "c", "d", "e")
for(i in v7) {
  print(i)
}

for(i in 1:length(v7)) {
  print(v7[i])
}

# Reverse iterating
for(i in length(v7):1) {
  print(v7[i])
}

# How to skip iteration?
for (i in 1:length(v7)) {
  if (i == 4) {
    print("----MISS")
    next # continue; skip iteration;
  }

  print(v7[i])
}

# while loop
counter <- 0
while(counter < 5) {
  counter <- counter + 1
  print(counter)
}

# Repeat loop # Only exits with break;
counter <- 0
repeat {
  counter <- counter + 1
  print(counter)

  if (counter >= 5) {
    break;
  }
}

#   Циклите в R са бавни. Ето защо е подходящо в някои случаи да използвате методите
#   apply, lapply, sapply, vapply и tapply. Тези методи ще ги представим след малко.

# ---------------------------
# 2.  Matrix
# List Of values; like array_map;
l1 <- lapply(1:12, function(x) {x})

#   С функцията "matrix" в R създаваме матрица от предварително зададено множество от
#   стойности - вектор или лист със стойности. Освен множеството с елементи, трябва да
#   посочим и формата на матрицата - брой редове и колони. Стойностите на матрицата се
#   пълнят по колони. За да напълним матрицата със стойности по редове, трябва да използваме
#   параметъра byrow = TRUE

# These two rows are equivalent:
M1 <- matrix(data = l1, nrow = 4, ncol = 3)
M1 <- matrix(data = 1:12, nrow = 4, ncol = 3)

# Fill by row
M2 <- matrix(data = 1:12, nrow = 4, ncol = 3, byrow = T)
M2[,2]
M1
M2

# Fetch element from matrix, row, col, and sub-matrix
M3 <- matrix(data = c(1:28), nrow = 7, ncol = 4, byrow = TRUE)
# Print the whole matrix
M3
# Fetch Row
M3[2,]
# Fetch Column
M3[ ,3]
# Fetch Element
M3[1, 3]
# Fetch 1st and 2nd element from 3rd col
M3[c(1, 2), 3]
# Fetch Submatrix
M3[c(1, 2), c(3, 4)]

# Operations with matrix
# Adds 4 to every element from the matrix
M3 + 4

#   Добавяме по вектор към всеки от четирите колони
M3 + 5*c(1:7)
M3
M3 + c(1:4)

#   Добавяме ред вектор всеки от седемте реда на матрицата
M3 + 5*c(1:4)

#   R автоматично удвоява вектора до дължина 4 и добавяме вектора към всеки ред
M3 + 5*c(1:2)

#   Аналогично е и при умножение на матрица с вектор
M4 <- matrix(1:8, nrow = 4, ncol = 2)
M4

#   Стандартно умножение на две матрици
#   M(7x4) * M(4x2) = M(7x2)
M34 <- M3 %*% M4
M34

# Size of matrix
dim(M34)
# Number of rows
nrow(M34)
# Number of cols
ncol(M34)

#   Функцията apply се прилага върху матрици, data.frame и други производни структури.
#   Първият параметър е множеството от данни, вторият показва по редове (1) или колони (2) искаме
#   да направим трансформациите, а третият е самата функция
?apply
apply(M3, 2, function(x, a) {
  sum(x)
}, a)

apply(M3, 1, function(x) {
  sum(x)
})


# Rate of return data

#########################################################################
# Get CSV of return data
p <- read.csv("jstdatasetr4.csv", header=TRUE)

#########################################################################
# Calculate returns
#########################################################################
p <- # create lagged CPI
  p %>%
  group_by(iso) %>%
  mutate(lag.cpi = dplyr::lag(cpi, n = 1, default = NA))
p$inf <- (p$cpi - p$lag.cpi)/p$lag.cpi # inflation
p$housing_real <- (1+p$housing_tr)/(1+p$inf) - 1 # housing return
p$eq_real <- (1+p$eq_tr)/(1+p$inf) - 1 # equities
p$safe_real <- (1+p$safe_tr)/(1+p$inf) - 1 # safe assets
p$risky_real <- (1+p$risky_tr)/(1+p$inf) - 1 # risky assets
p$capital_real <- (1+p$capital_tr)/(1+p$inf) - 1 # capital in total

# Lagged values
p <- p %>% group_by(iso) %>% mutate(lag1.capital_real = dplyr::lag(capital_real, n = 1, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag2.capital_real = dplyr::lag(capital_real, n = 2, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag3.capital_real = dplyr::lag(capital_real, n = 3, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag4.capital_real = dplyr::lag(capital_real, n = 4, default = NA))
p <- p %>% group_by(iso) %>% mutate(lag5.capital_real = dplyr::lag(capital_real, n = 5, default = NA))

# 5-year moving average
p$ma5.capital_real = round(((1+p$lag4.capital_real)*(1+p$lag3.capital_real)*(1+p$lag2.capital_real)*(1+p$lag1.capital_real)*(1+p$capital_real))^(1/5) - 1,digits=2)

# Subset of countries and time period
stable <- p[ which(p$iso %in% c("USA", "DEU", "JPN", "GBR", "AUS")),]
stable <- stable[which(p$year > 1949),]

#########################################################################
# Figure of 5-year rates of return
#########################################################################
fig <- plot_ly(stable, x = ~year, y = ~ma5.capital_real, linetype = ~country, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Return to capital over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = '5-year annualized return',range = c(-.1,.2)),
              hovermode="x unified")
api_create(fig, filename = "jst-stable-return")


x = c(-1, 0, 3, 7)
y = c(2, 0, 4, 7)

n = length(x)

num = sum(x * y) - sum(x) * sum(y) / n
den = sum(x * x) - sum(x) * sum(x) / n

B1 = num / den
B0 = (sum(y) - (B1 * sum(x))) / n

png('images/disp_diagram.png')

plot(x, y)

dev.off()

B0
B1

print('For x = 1 predicted value is')
print(B1 * 1 + B0)


#!/usr/bin/env Rscript

## 加载文件的数据
source("./factor_levels.r")
state
statef

incomes = c(60, 49, 40, 61, 64, 60, 59, 54, 62, 69, 70, 42, 56,
61, 61, 61, 58, 51, 48, 65, 49, 49, 41, 48, 52, 46,
59, 46, 58, 43)

## 应用一个函数在某个因素各水平上
incmeans = tapply(X = incomes, INDEX = statef, FUN = mean)
round(incmeans, 2)

stderr = function(x) sqrt(var(x)/length(x))

incstderr = tapply(incomes, statef, stderr)
round(incstderr, 2)


v <- c(1, 2, 100, 50, 0)
print(max(v)) # 100


# Estat�stica B�sica

# Exerc�cio

# Cuidado: A Linguagem R � case sensitive!

# Definindo a pasta de trabalho
# Substitua o caminho abaixo pela pasta no seu computador
setwd("C:/Users/dmpm/Documents/PowerBI/Cap12")
getwd()

# Carregando o dataset
notas <- read.csv("Notas.csv", fileEncoding = "windows-1252")

# Exerc�cio 1: Apresente um resumo de tipos de dados e estat�sticas do dataset.
View(notas)
str(notas)
summary(notas$TurmaA)
summary(notas$TurmaB)

# Exerc�cio 2: Qual a m�dia de cada turma?
mean(notas$TurmaA)
mean(notas$TurmaB)

# Exerc�cio 3: Qual turma apresentou maior variabilidade de notas? Justifique sua resposta.
sd(notas$TurmaA)
sd(notas$TurmaB)

# Exerc�cio 4 - Calcule o coeficiente de varia��o das 2 turmas.
media_ta <- mean(notas$TurmaA)
media_tb <- mean(notas$TurmaB)

sd_ta <- sd(notas$TurmaA)
sd_tb <- sd(notas$TurmaB)

cvA <- sd_ta / media_ta * 100
cvB <- sd_tb / media_tb * 100

cvA
cvB

# Exerc�cio 5 - Qual nota apareceu mais vezes em cada turma?
calculaModa <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]
}

calculaModa(notas$TurmaA)
calculaModa(notas$TurmaB)


 ZGELS Example Program Results

 Least squares solution
 (-0.5044,-1.2179) (-2.4281, 2.8574) ( 1.4872,-2.1955) ( 0.4537, 2.6904)

 Square root of the residual sum of squares
   6.88E-02


library(MASS)
getPriorProbabilities <- function (dset, column) {
  dsetLength <- dim(dset)[1]
  return (table(dset[, column]) / dsetLength)
}

likelihood <- function(feature, expectation, deviation) {
  return ((1 / (deviation * sqrt(2 * pi))) * exp(-((feature - expectation) ^ 2) / (2 * deviation ^ 2)))
}

# returns a probability of a given point to be in a given class
getProbability <- function(dset, classesColumn, className, point, lambda) {
  classesCount <- 0
  featuresCount <- length(point)
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]
  # lambda <- 1 # rep(1, classesCount)

  expectations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    expectations[i] <- mean(dset[which(dset[, classesColumn] == className), i])
  }

  matr <- matrix(0, featuresCount, featuresCount)
  for (i in 1:featuresCount) {
    matr[i, ] <- sum((dset[which(dset[, classesColumn] == className), i] - expectations[i]) ^ 2) / dsetLength
  }
  deviations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    deviations[i] <- matr[i, i]
  }

  # print(log(lambda * prior))
  # print(expectations)
  # print('separator')
  # print(featuresCount)
  # print(deviations)
  # print(lambda * prior)
  # print(sum(log(likelihood(point, expectations, deviations))))

  logOfLikelihood <- sum(log(likelihood(point, expectations, deviations)))

  return (log(lambda * prior) + logOfLikelihood)
}

classify <- function(point, lambdas) {
  classes <- unique(dset[, 3])
  classesCount <- length(classes)
  scores <- array(dim = classesCount)
  for (i in 1:classesCount) {
    scores[i] <- getProbability(dset, 3, classes[i], point, lambdas[i])
  }
  return(classes[which.max(scores)])
}

mu1 <- c(0, 0)
mu2 <- c(4, 4)
sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
dset1 <- mvrnorm(250, mu1, sig1)
dset2 <- mvrnorm(250, mu2, sig2)
dset <- rbind(cbind(dset1, 1),cbind(dset2, 2))
plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# generating map
colors <- c("1" = "green", "2" = "blue")
xs <- seq(from = -5, to = 6.2, by = 0.1)
ys <- seq(from = -4.2, to = 8, by = 0.1)
lambdas <- runif(2, min=1, max=100)
print(lambdas)

all <- length(xs) * length(ys)
progress = 1
for (i in xs) {
  for (j in ys) {
    cat("\rProcessing point", progress, "of", all)
    progress <- progress + 1
    result <- classify(c(i, j), lambdas)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")

6 - Naive Bayes Classifier/naive-bayes.r


#' Numeric correlation
#'
#' @description Compute pearson, kendall and spearman correlation coefficient
#'
#' @param x numeric vector
#' @param y numeric vector
#'
#'
#' @return Numeric vector
#' @export
#'
#' @examples
#'
#' x <- rnorm(100)
#'
#' y <- rnorm(100)
#'
#' plot(x,y)
#'
#' num_corr(x,y)
#'
#'

num_corr <- function(x,y){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(y) == F){
    stop("y must be numeric")
  }

  out <-
  dplyr::tibble(
    pearson  =  cor.test(x,y,method = "pearson",na.rm = T)$estimate,
    kendall  =  cor.test(x,y,method = "kendall",na.rm = T)$estimate,
    spearman =  cor.test(x,y,method = "spearman",na.rm = T)$estimate
  )

  return(out)

}


##### 医学統計勉強会18　第4回　回帰分析　R code #####

install.packages("ISｗR")	# ISwRパッケージのインストール。最初の一回のみ実行
library(ISwR)

# 散布図 #
thuesen <- na.omit(thuesen)	# 欠測値を除く #
attach(thuesen)

plot(blood.glucose, short.velocity)
plot(thuesen)			# 上と同じ

# 数量的データの要約（二変量） #
cov(blood.glucose, short.velocity)		# 共分散
cov(thuesen)				# 分散共分散行列
cor(blood.glucose, short.velocity)		# 相関係数
cor(thuesen)				# 相関行列

# 単回帰分析 #
fit <- lm(short.velocity ~ blood.glucose, data=thuesen)
summary(fit)		# 回帰分析の結果表示
plot(thuesen)		# 散布図
abline(fit)			# 推定された回帰直線の描画
confint(fit)		# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))
plot(fit)
par(mfrow=c(1,1))

# 重回帰 (CPUデータ) #
library(MASS)
head(cpus, n=2)
dim(cpus)			# cpusの行と列の数を確認
?cpus				# cpusのオンラインヘルプ起動

cpus2 <- cpus[, c(8, 2:7)]
head(cpus2, n=2)

pairs(cpus2)		# cpus2の散布図行列

cpus2.lm <- lm(perf ~ syct + mmin + mmax + cach + chmin + chmax, data=cpus2)				# 回帰モデルの当てはめ
cpus2.lm <- lm(perf ~ ., data=cpus2)	# 上と同じ

summary(cpus2.lm)	# 回帰分析の結果表示
confint(cpus2.lm)	# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))	# グラフィックスウィンドウを2行2列の4つの領域に分割する
plot(cpus2.lm)
par(mfrow=c(1,1))	# グラフィックスウィンドウを元に戻す

# Box-Cox変換 #
library(MASS)
bxcx <- boxcox(perf ~ ., data=cpus2, lambda=seq(0, 0.5, .01))
lambda <- bxcx$x[which.max(bxcx$y)]
lambda

perf.new <- (cpus2$perf^lambda -1)/lambda
cpus3 <- cpus2[, -1]
cpus3 <- cbind.data.frame(perf.new, cpus3)

cpus2.bxcx.lm <- lm(perf.new ~ ., data=cpus3)
summary(cpus2.bxcx.lm)	# 回帰分析の結果表示
confint(cpus2.bxcx.lm)	# 回帰パラメターの信頼区間

# 回帰診断 #
par(mfrow=c(2,2))	# グラフィックスウィンドウを2行2列の4つの領域に分割する
plot(cpus2.bxcx.lm)
par(mfrow=c(1,1))	# グラフィックスウィンドウを元に戻す


library(rgl)

euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

w1 <- function(k, dist) {
  return (1 ^ k)
}

kwNN <- function(dataset, points, k, dist = euclidean, weight = w1) {
  answer <- array(dim = c(length(points[,1])))
  classes = unique(iris$Species)

  for (i in 1:length(points[,1])) {
    distance <- array(dim = c(length(dataset[,1])))
    for (j in 1:length(dataset[,1])) {
      distance[j] = dist(points[i, ], dataset[j, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    scores <- rep(x = 0, times = length(classes))
    names(scores) = classes
    for (j in 1:k) {
      scores[sortedDataset$Species[j]] = scores[sortedDataset$Species[j]] + weight(j, distance[j])
    }

    answer[i] = names(which.max(scores))[1]
  }

  return (answer)
}

kwNN_point <- function(dataset, point, k, dist = euclidean, weight = w1) {
  distances <- array(dim = c(length(dataset[,1])))
  for (i in 1:length(distances)) {
    distances[i] <- dist(point[,3:4], dataset[i,3:4])
  }

  sortedDataset <- dataset[order(distances),]
  distances <- sort(distances)
  scores <- array(0L, length(unique(dataset$Species)))
  names(scores) = unique(dataset$Species)
  for (i in 1:k) {
    scores[sortedDataset$Species[i]] = scores[sortedDataset$Species[i]] + weight(i, distances[i])
  }

  return (names(which.max(scores)))
}

# print(kwNN_point(iris[-1,], iris[1,], 6, euclidean, (function(k, dist) {return (0.5 ^ k)})))

# stats <- cvloo_kwnn()
# plot(stats[,1], stats[,2], type = "l", xlab="q", ylab="Accuracy")

fast_cvloo_kwnn <- function() {
  # qPointsCount <- 10
  # maxK <- length(iris[,1]) - 1
  maxK <- 149
  classes = unique(iris$Species)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)

  ans <- array(0L, dim = c(maxK, length(qs))) #rep(x = 0, times = maxK * qPointsCount)
  for (i in 1:length(iris[,1])) { # samples
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    classesCount <- array(0L, dim = c(length(classes), length(qs)))
    dimnames(classesCount) = list(classes)
    for (j in 1:maxK) { # k's
      index <- 1
      for (q in qs) {
        classesCount[sortedDataset$Species[j],index] <- classesCount[sortedDataset$Species[j],index] + (q ^ j)
        classForCurrentK = names(which.max(classesCount[,index]))[1]

        if (classForCurrentK == paste(iris$Species[i])) {
          ans[j,index] = ans[j,index] + 1
        }
        index <- index + 1
      }
    }
    index <- index + 1
  }
  cat("\n")

  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / (length(iris[,1]) - 1)
  # }

  return (ans)
}

kwnn_loo <- function(k) {
  classes = unique(iris$Species)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)
  result <- array(0L, dim = c(length(qs)))
  for (i in 1:length(iris[,1])) {
    cat("\rProcessing sample", i, "of", length(iris[,1]))
    dataset <- iris[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    classesCount <- array(0L, dim = c(length(classes)))
    dimnames(classesCount) = list(classes)

    classesCount <- array(0L, dim = c(length(classes), length(qs)))
    dimnames(classesCount) = list(classes)
    for (j in 1:k) { # k's
      index <- 1
      for (q in qs) {
        classesCount[sortedDataset$Species[j],index] <- classesCount[sortedDataset$Species[j],index] + (q ^ j)
        classForCurrentK = names(which.max(classesCount[,index]))[1]

        index <- index + 1
      }
    }
    for (j in 1:length(qs)) {
      ans = names(which.max(classesCount[,j]))[1]

      if (ans == paste(iris$Species[i])) {
        result[j] <- result[j] + 1
      }
    }
  }
  cat("\n")

  for (i in 1:length(result)) {
    result[i] <- result[i] / length(iris[,1])
  }

  return (result)
}

# m <- fast_cvloo_kwnn()
k <- 6

qs <- (seq(from = 0.0, to = 1.0, by = 0.05))
acc = kwnn_loo(6)

par(mfrow=c(1,1), pty="s")

plot(qs, acc, type = "l", xlab = "q", ylab="Accuracy")
points(qs[which.max(acc)], max(acc), pch = 19, col = "red")

cat("Best accuracy:", max(acc), "for q =", which.max(acc) / 21)

1 - Nearest neighbors algorithm/kwnn-fixed-k-loocv.r


#' Compute the amplitude spectrum of a timeseries.
#'
#' @param t Sampling times of timeseries.
#' @param x Value of timeseries at each sample time.
#' @param omega Angular frequencies to evaluate periodogram at.
#' @param demeaned Whether timeseries has already been de-meaned.
#' @param standardized Whether timeseries has already been standardized.
#'
#' @return Values of amplitude spectrum at angular frequencies specified.
#'
#' @examples
#' amplitude.spectrum(1:10, sin(1:10), 2*pi/1:10, FALSE, FALSE)
#'
#' @export
amplitude.spectrum <- function(t, x, omega,
                               demeaned = FALSE, standardized = FALSE) {

    ## De-mean and standardize, if not already done. ##
    if (!demeaned) {
        x <- x - mean(x)
    }
    if (!standardized) {
        x <- x / sd(x)
    }

    tau <- tau(t, omega)

    a <- periodogram.component(t, x, omega, tau, "cos")
    b <- periodogram.component(t, x, omega, tau, "sin")

    0.5 * (a^2 + b^2)

}


# Assignment: ASSIGNMENT 1.1
# Name:Mangat,Harsimar
# Date: 2020-06-06

#1.What are the observational units in the study?
#1.Answer:Each row is the grade/total points per the respective section (sports/regular)
scores_df <- read.csv("scores.csv")
head(scores_df)

#2.Identify the variables mentioned in the narrative paragraph and determine which ones are categorical & quantitive?"
#2.Answer: Using str(score_df), we have three variables, Count (which is int or quantitative), Score (INT/Quantitative)
# and Section (CHR/Categorical)
str(scores_df)

#3. Create one variable to hold a subset of your data set that contains only
#the Regular Section and one variable for the Sports Section.
scores_reg <-scores_df[scores_df$Section == "Regular",]
scores_sport <-scores_df[scores_df$Section == "Sports",]
reg_mean<-colMeans(scores_reg['Score'])
sport_mean<-colMeans(scores_sport['Score'])
reg_median<-median(scores_reg[,'Score'])
sport_median<-median(scores_sport[,'Score'])
sum_sport<-sum(scores_sport['Score'] > 300)
sum_reg<-sum(scores_reg['Score'] > 300)

#4.Use the Plot function to plot each Sections scores and the number of students achieving that score.
#Use additional Plot Arguments to label the graph and give each axis an appropriate label.
#Once you have produced your Plots answer the following questions:

plot(scores_reg[,'Score'],main=" Regular vs Sport Section Scores",col="red",xlab = "# of Students",ylab="Scores",xlim=c(0,25),ylim=c(200,400))
par(new=TRUE)

plot(scores_sport[,'Score'],col="blue",xlab = "# of Students",ylab="Scores",xlim=c(0,25),ylim=c(200,400))
legend(x=20,y=300,legend=c('Regular','Sport'),col=c('red','blue'),pch=c(8,16))

#a.Comparing and contrasting the point distributions between the two section,
#looking at both tendency and consistency: Can you say that one section tended to
#score more points than the other? Justify and explain your answer.
reg_mean
sport_mean
sum_sport
sum_reg
reg_median
sport_median
regsum=summary(scores_reg['Score'])
sportsum=summary(scores_reg['Score'])
#a.Answer: The regular session had a higher minimum score and higher 1st and 3rd quartile.
#In addition, the regular session had a higher Median & Average - therefore indicating a stronger central tendency than the sports section

#b.Did every student in one section score more points than every student in the other section?
#If not, explain what a statistical tendency means in this context.
#b.Answer: If we look at the median and mean, then we will see that the regular section performed generally higher than the sports section

#c.What could be one additional variable that was not mentioned in the narrative that
#could be influencing the point distributions between the two sections?
#c.Answer: Although not a quantitative variable, there could be a chance that not every student enjoys sports, whereas the regular session
#had data-sets across a spectrum, therefore allowing students to be experience various data-sets across multiple categories.
# This could have an effect.


# A function to create the exact variance
# this function will not work for files that don't
# fit in memory.
# This function was only for testing with small datasets
#
# file - name of a pipe-delimited file with 3 columns
calcVar_Swanstrom1 <- function(file) {
  # read in the file
  data <- read.csv(file,sep='|')
  mn = mean(data$Amount)
  sq = (data$Amount - mn)^2
  return(sum(sq)/length(sq))
}

# A function to calculate the variance
# of the 3rd column of a | delimited file.
# It calculates the exact variance, not the sample variance.
#
# This function uses the Welford method as described
# by Knuth in the Art of Programming.
# See vol. 2 of the books or John D. Cook's blog post
# on the topic.
# http://www.johndcook.com/blog/standard_deviation/
#
# Usage:
#    calcVar_Swanstrom('yourdatafile.txt')
#
# file - name of a pipe-delimited file with 3 columns
# Returns a number indicating the variance
calcVar_Swanstrom <- function(file) {

  # read in the file
  conn=file(file,open="r")

  # read the header row
  readLines(conn, n=1)

  # the kth number being read in
  k = 1
  # mean of the first k numbers
  # it gets initialized to the first value
  mk = as.numeric(unlist(strsplit(readLines(conn, n=1),'[|]'))[3])
  # running calculation for variance
  vk = 0
  line = readLines(conn, n=1)
  while (length(line) >0){
    # split the string on | and select the 3rd column
    # set an a number
    ln = unlist(strsplit(line,'[|]'))
    amt = as.numeric(ln[3])
    k = k+1
    mkprev = mk
    mk = mk + (amt - mk)/k
    vk = vk + (amt-mkprev)*(amt-mk)
    line = readLines(conn, n=1)
  }
  close(conn)
  return(vk/(k))
}

calcVar_Swanstrom1('data.csv')
calcVar_Swanstrom('data.csv')


# Dexter Barrows
#
# run: Rscript sc2-multi.r > sc2-multi.log 2>&1

library(reshape2)
library(foreach)
library(parallel)
library(doParallel)
library(rstan)

## Stochastic SIR functions
##############################################################################################

source(paste(getwd(),"../../sir-functions", "StocSIR.r", sep = "/"))
source(paste(getwd(),"../../sir-functions", "StocSIRstan.r", sep = "/"))

## Setup
##############################################################################################

set.seed(1004)

T       <- 60
i_infec <- 5
steps   <- 7
N       <- 500
sigma   <- 10
Tlim    <- T

## Generate true trajecory and synthetic data
##

pars_true <- c(R0 = 3.0,    # new infected people per infected person
          r = 0.1,      # recovery rate
          N = 500,      # population size
          eta = 0.5,    # geometric random walk
          berr = 0.5)   # Beta geometric walk noise

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

nTrials <- 10
maxTrunc <- 40
nTraj <- 200

numCores <- detectCores()
cl <- makeCluster(numCores)
registerDoParallel(cl)

## external files

# R source files
stoc_sir_file 		<- paste(getwd(),"../../sir-functions", "StocSIR.r", sep = "/")
if2_paraboot_file 	<- paste(getwd(), "if2-paraboot.r", sep = "/")
source(stoc_sir_file)
source(if2_paraboot_file)

# C++ source files
if2file 	<- paste(getwd(), "../../if2", "if2.cpp", sep="/")
if2_s_file 	<- paste(getwd(), "../../if2", "if2-s.cpp", sep="/")
hmcfile 	<- paste(getwd(), "../../hmc", "sirode_euler.stan", sep="/")

## IF2 settings

NP          <- 2500
nPasses     <- 50
coolrate    <- 0.975

## fit once to compile
##

# get raw data
sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

# conform data to stan's required format
datlen <- T*7 + 1

data <- matrix(data = -1, nrow = T+1, ncol = steps)
data[,1] <- infec_counts
standata <- as.vector(t(data))[1:datlen]

#options
rstan_options(auto_write = TRUE)

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1)   		# thinning number

# data
sir_data <- list( T = datlen,       # simulation time
                  y = standata,     # infection count data
                  N = 500,          # population size
                  h = 1/steps )     # step size per day

# fit!
initialfit <- with(stan_options,
                stan(file   = hmcfile,
                    data    = sir_data,
                    chains  = chains,
                    iter    = iter,
                    warmup  = warmup,
                    thin    = thin)
                )

## Run multiple trajectories
#########################################################################################################

SSEmat <- foreach ( trunc = seq(4,maxTrunc,4), .combine = rbind, .packages = c("Rcpp","rstan","reshape2","foreach") ) %dopar% {

	Tlim <- T - trunc

	if2SSEs <- numeric(nTrials)
	hmcSSEs <- numeric(nTrials)

	for(trial in 1:nTrials) {

		# get true trajectory
	    sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
	    colnames(sdeout_true) <- c('S','I','R','B')

	    # get full data
	    infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
	    infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

	    # truncate data
	    datapart <- c(infec_counts[1:(Tlim+1)],rep(NA,T-Tlim))

	    ## IF2
	    ##

	    # initial fit
	    sourceCpp(if2file)
	    if2time <- system.time( if2data <- if2(datapart, Tlim+1, N, NP, nPasses, coolrate) )

	    # IF2 parametric bootstrap
	    if2_paraboot_data <- if2_paraboot(if2data,
                                  T, Tlim, steps, N, nTraj,
                                  if2file, if2_s_file, stoc_sir_file,
                                  NP, nPasses, coolrate)

	    # get mean of trajectories
		parabootdata <- data.frame(if2_paraboot_data)
		countnames <- paste("counts",1:(dim(parabootdata)[2]-9), sep = "")
		countdata <- parabootdata[,countnames]
		countmeans <- colMeans(countdata)

		# get SSE, save
		truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
    	estfuture   <- countmeans[-1]
    	err <- estfuture - truefuture
    	sse <- sum(err^2)
    	if2SSEs[trial] <- sse

	    ## HMC fitting with stan
	    ##

	    datlen <- Tlim*7 + 1

	    data <- matrix(data = -1, nrow = T+1, ncol = steps)
	    data[,1] <- datapart
	    standata <- as.vector(t(data))[1:datlen]

	    sir_data <- list( T = datlen,       # simulation time
	                      y = standata,     # infection count data
	                      N = 500,          # population size
	                      h = 1/steps )     # step size per day

	    hmctime <- system.time(fit <- with(stan_options,
	                            stan( fit = initialfit,
	                                  data    = sir_data,
	                                  chains  = chains,
	                                  iter    = iter,
	                                  warmup  = warmup,
	                                  thin    = thin)
	                            )
	                )

	    exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)

	    paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
	                            r = melt(exfit[,,'r'])$value,
	                            sigma = melt(exfit[,,'sigma'])$value,
	                            eta = melt(exfit[,,'eta'])$value,
	                            berr = melt(exfit[,,'berr'])$value,
	                            Sinit = melt(exfit[,,'y0[1]'])$value,
	                            Iinit = melt(exfit[,,'y0[2]'])$value,
	                            Rinit = melt(exfit[,,'y0[3]'])$value )

	    for (j in 1:datlen) {
			varname <- paste('Bnoise[', j, ']', sep = '')
			paramdata[[varname]] <- melt( exfit[,,varname] )$value
		}

	    parnames <- c("R0","r","sigma","eta","berr","Iinit")
	    parvars <- var(paramdata[parnames])
	    hmcparmeans <- colMeans(paramdata[parnames])
	    names(hmcparmeans) <- c("hmc.R0","hmc.r","hmc.sigma","hmc.eta","hmc.berr","hmc.Iinit")

	    bootstrapdata <- matrix(NA, nrow = nTraj, ncol = (T+1) )

    	pardatlen 	<- dim(paramdata)[1]
    	inds 	    <- sample.int(pardatlen,nTraj,replace = TRUE)
    	params 	    <- paramdata[inds,]

    	for (i in 1:nTraj) {

    		paramset <- params[i,]

        	init_cond <- c(S = paramset$Sinit,
        	               I = paramset$Iinit,
        	               R = paramset$Rinit)
        	pars <- c(R0 = paramset$R0,
        	          r = paramset$r,
        	          N = 500.0,
        	          eta = paramset$eta,
        	          berr = paramset$berr)

        	berrvec <- numeric(datlen)
        	for (j in 1:datlen) {
        		varname <- paste("Bnoise[", j, "]", sep = "")
        		berrvec[j] <- paramset[[varname]]
        	}

        	sdeout <- StocSIRstan(init_cond, pars, T, steps, berrvec, datlen)
        	colnames(sdeout) <- c('S','I','R','B')

        	bootstrapdata[i,] <- sdeout[,'I']

    	}

    	# in case of explosion
    	bootstrapdata <- bootstrapdata[complete.cases(bootstrapdata),]
    	goodbootsize <- dim(bootstrapdata)[1]

    	meanTraj 	<- colMeans(bootstrapdata)

    	truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
		estfuture   <- meanTraj[(Tlim+2):(T+1)]
    	err <- estfuture - truefuture
    	sse <- sum(err^2)
    	hmcSSEs[trial] <- sse

	}

	return( c(if2SSEs, hmcSSEs) )

}

stopCluster(cl)

save.image(file = "sc2-multi.RData")


# Calc connectivity clustering coeficient and path length
#
#
calc_topological_indices <- function(red.e)
{
  size.e <- vcount(red.e)
  links.e <- ecount(red.e)
  link.den <- links.e/size.e
  conn.e <- links.e/size.e^2
  cha.path.e <- average.path.length(red.e)
  clus.coef.e <- transitivity(red.e, type = "global")
  #degree.e <- degree(red.e)
  return(data.frame(Size=size.e,Links=links.e, LD=link.den,Connectance=conn.e,PathLength=cha.path.e,Clustering=clus.coef.e))
}

# Calculation of the clustering coefficients and average path for random network simulations
#
#
calc_cpl_cc <- function(size,links,CPL,CC, nsim=1000){
  redes.r <- lapply(1:nsim, function (x) erdos.renyi.game(size, links, type="gnm"))

  cha.path.r <- c()
  for (i in 1:nsim){
    cha.path.r <- c(cha.path.r,average.path.length(redes.r[[i]]))
  }

  clus.coef.r <- c()
  for (i in 1:nsim){
    clus.coef.r <- c(clus.coef.r,transitivity(redes.r[[i]], type="Global"))
  }
  qcc <- quantile(clus.coef.r,c(0.005,0.995))
  qcp <- quantile(cha.path.r,c(0.005,0.995))
  mcc <- mean(clus.coef.r)
  mcp <- mean(cha.path.r)
  gamma <- CC/clus.coef.r
  lambda <- CPL/cha.path.r
  SWness <- gamma/lambda
  qSW <- quantile(SWness,c(0.005,0.995))
  mCI <- 1+(qSW[2]-qSW[1])/2
  mSW <- CC/mcc*mcp/CPL

  return(data_frame(cha.pathMean= mcp,clus.coefMean=mcc,cha.pathLow=qcp[1],cha.pathUp=qcp[2], clus.coefLow=qcc[1],clus.coefHigh=qcc[2],SWness=mSW,SWnessCI=mCI))
}

# Generate a data.frame with all simulations
#
genrnd_cpl_cc <- function(size,links, nsim=1000){
  redes.r <- lapply(1:nsim, function (x) erdos.renyi.game(size, links, type="gnm"))

  cha.path.r <- c()
  for (i in 1:nsim){
    cha.path.r <- c(cha.path.r,average.path.length(redes.r[[i]]))
  }

  clus.coef.r <- c()
  for (i in 1:nsim){
    clus.coef.r <- c(clus.coef.r,transitivity(redes.r[[i]], type="Global"))
  }
  return(data_frame(cha.path=cha.path.r, clus.coef=clus.coef.r))
}

# Test SW in Watts Strogatz model against random
#
genWattsStrogatz_cpl_cc <- function(size,links, ratio=1.1,nsim=100){

  redes.r <- lapply(1:nsim, function (x) {
                  sw <- sample_smallworld(1,size, links/(size*runif(1,0.8,1.2)), 0.5)
                  sw <- simplify(sw,remove.loops = FALSE)})

  swr <- data_frame()

  for (i in 1:nsim){
    sw1 <- redes.r[[i]]
    swr <- bind_rows(swr, calc_cpl_cc(gorder(sw1),gsize(sw1)) %>%
      mutate(Size=gorder(sw1),Links=gsize(sw1),CPL=average.path.length(sw1),CC=transitivity(sw1,type="global")) %>%
      mutate(isInsideCPL = (CPL >= cha.pathLow*(1/ratio) & CPL<=cha.pathUp*ratio), isGreaterCC =( CC>clus.coefHigh)))
  }

  return(swr)

}


# Takes one dimensional time series, performs delay embedding
one_d <-function(data, embed_dim = 4)
{
  edata <- embed(data, embed_dim)
  return(edata)
}

#Takes time series and scales, either using max values or taking log
pre_process <- function(data, scaling_method)
{
  tmp <- data
  if (scaling_method == "max") {
    for (i in 1: ncol(tmp)) {
      tmp[,i] <- tmp[,i]/max(abs(tmp[,i]))
    }
  }
  return(tmp)
}

log_r <- function(tmp)
{
  for(i in 1:ncol(tmp)) {
    #replace each column in the data set with the log return
    #replace corresponding column in dat with new log return value
    tmp[,i] <- Delt(tmp[,i])
  }
  #Since first vale will always be N/A, remove it
  tmp <- tmp[-1,]
  return(tmp)
}

#Finds upper bound of diameter of the data
#to use for max_scale
find_diam <- function(time)
{
  dim <- ncol(time)
  diam_list = vector(length = dim)
  for (i in 1:dim) {
    high <- max(time[,i])
    low <- min(time[,i])
    diam_list[i] <- (high-low)
  }
  diam <- norm(diam_list, type = "2")
  return(diam)
}

#Takes time series and finds persistence diagrams
nd_diag <- function(time, max_scale = 0.1, K_max = 10, window = 100)
{
  tmp <- time

  #TDA
  maxdimension =1
  Diags1.rips.ls = list()
  total <- dim(tmp)[1]
  step <- 1
  spot <- seq(from=1, to=(total-window+1), by=step)

  #Persistence diagrams
  print("Computing persistence diagrams...")
  pb <- txtProgressBar(min = 0, max = length(spot), style = 3)
  for(i in 1:length(spot)){
    Diags1.rips.ls[[i]] =
      ripsDiag(tmp[spot[i]:(spot[i]+window-1), ], maxdimension=1, max_scale, library = "Dionysus")

    # update progress bar
    setTxtProgressBar(pb,i)
  }
  plot(Diags1.rips.ls[[2]]$diagram)
  return(Diags1.rips.ls)
}

#Takes the diagrams from nd_diag and calculates the norm
nd_norm <- function(diag, max_scale, K_max = 10, scaling_method = "log"){
  step <- 1
  spot <- seq(from =1, to = length(diag), by = step)

  Lands1.ls = list() # collects landscapes (in 2D) at particular date i per k
  AUC_Land.m = matrix(0,length(spot),K_max) #collects values of lambda_k at particular date i per k
  AUC_Land.v = vector(length=length(spot)) #collects values of L^1 at particular date
  #Compute L^1
  print("Computing the L1 norm of persistence landscapes...")
  pb <- txtProgressBar(min = 0, max = length(spot), style = 3)
  for (i in 1:length(spot)){
    diagram <- diag[[i]]$diagram

    # print(diagram)
    # Look at persistence diagrams on a logarithmic scale
    if(scaling_method=="log") {
      # Only take logarithm of nonzero entries
      for(j in 1:nrow(diagram)) {
        if(diagram[j,1]==1) {
          diagram[j,2] = log(diagram[j,2])
          diagram[j,3] = log(diagram[j,3])
        }
      }
    }

    minim=Inf
    maxim=-Inf
    for(j in 1:nrow(diagram)) {
      # print(diagram[j,1])
      if(diagram[j,1]==1) {
        minim = min(minim,diagram[j,2])
        maxim = max(maxim,diagram[j,3])
      }
    }
    #print(minim)
    #print(maxim)

    if(minim==Inf)  # There is no 1-dimensional homology feature in this window
    {
      AUC_Land.v[i]=0
    }
    else
    {
      tseq <- seq(minim, maxim, length=500)

      for (KK in 1:K_max){
        Lands1.ls[[i]]=landscape(diagram, dimension=1, KK, tseq)
        AUC_Land.m[i,KK]=  pk.calc.auc.all(Lands1.ls[[i]],tseq, interval=c(minim,maxim))
        AUC_Land.v[i]= AUC_Land.v[i]+AUC_Land.m[i,KK]
      }
      plot(Lands1.ls[[2]])
    }
    # update progress bar
    setTxtProgressBar(pb,i)
  }
  return(AUC_Land.v)
}

#End line method - takes multi-D time series, processes,
#and finds the norm
#Default max_scale of 0 leads to find_diam being called
analyze_nd <- function(time, scaling_method = "log", returns = FALSE,
                       max_scale = 0, K_max = 10, window = 50) {
  dates <- index(time)
  if (returns) {
    #Taking log-returns of the log of the data can lead to errors,
    #so if returns are desired, we deactivate the log scaling
    if (scaling_method =="log") {
      scaling_method <- "none"
    }
    time <- log_r(time)
  }

  data <- pre_process(time, scaling_method)
  if(max_scale == 0) {
    max_scale <- find_diam(data)
  }
  diag <- nd_diag(data, max_scale, K_max, window)
  norm <- nd_norm(diag, max_scale, K_max, scaling_method)
  new_dates <- tail(dates, length(norm))
  norm.xts <- xts(norm, order.by = new_dates)

  return(norm.xts)
}

#End line method - takes one-D time series
#finds delay embedding, calls analyze_nd
analyze_1d <- function(time, dim = 4, scaling_method = "log", max_scale = 0, K_max = 10, window = 50, returns = FALSE) {
  if (returns) {
    #Taking log-returns of the log of the data can lead to errors,
    #so if returns are desired, we deactivate the log scaling
    if (scaling_method == "log") {
      scaling_method <- "none"
    }

    time <- log_r(time)
  }
  dates <- index(time)

  delay_data <- one_d(time, dim)
  delay_data.xts <- xts(delay_data, order.by = tail(dates, length(delay_data[,1])))
  analyze_nd(delay_data.xts, scaling_method, returns = FALSE,  max_scale, K_max, window)
}

output <- function(tmp, filename , plot = "FALSE")
{
  write.zoo(tmp, file = filename)
  if (plot == "TRUE") {
    plot(tmp, type = 'l')
  }
}

get_impact_window <- function(data, index, window_length)
{
  data[index:(index+window_length-1)]
}


#####################################################
#######			          	Practise			    	#########
#####################################################
## basic attributes in R
help(rank)
help.search("correlation")
library(alr3)
heights
head(heights)
dim(heights)
names(heights)
summary(heights)
heights$Mheight
## Graphical capabilities
hist(heights$Mheight, main="Histogram of Mother's height", xlab="Mother's height")
##
plot(heights$Dheight, heights$Mheight, main="Scatterplot of Mother/Daughter Height", ylab="Mother's Height", xlab="Daughter's height")
## subset the data by requesting certain rows or columns
## 10th row
heights[10, ]
## 2nd column
heights[,2]
## 2nd and 4th rows
heights[c(2,4), ]
## first 10 rows
heights[1:10, ]
## rows where Daughter's height is greater than 63
heights[heights$Dheight>63, ]

########################################################
#######			           		Questions		      		########
########################################################

### install and load the packages "alr3"
install.packages("alr3")
library("alr3")

### 1, how many observations and variables in the heights data
dim(heights)

### 2, the mean of the mother's height and maximum of daughter's height
summary(heights)

### 3, the correlation between mother's height and daughter's height
x <- heights$Mheight
y <- heights$Dheight
cor(x, y) ## in packages "stats"

### 4, the mean mothers's height for observations where daughter's height
###   greater than 63
yy <- heights[heights$Dheight>63, ]
yyM <- yy$Mheight
MyyM <- mean(yyM)
MyyM  ### the mean of the target vector


# Data Preprocessing Template

# Importing the dataset
dataset = read.csv('Simple_Linear_Regression/Salary_Data.csv')

# Splitting the dataset into the Training set and Test set
# install.packages('caTools')
library(caTools)
set.seed(123)
split = sample.split(dataset$Salary, SplitRatio = 2/3)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fitting SLR in the training set
regressor = lm(formula = Salary ~ YearsExperience,
                data = training_set)

# summary(regressor)

# Predict the test set results
y_pred = predict(regressor, newdata = test_set)

# Visualize the training set results
# install.packages('ggplot2')
library(ggplot2)

ggplot() +
    geom_point(aes(x = training_set$YearsExperience,
        y = training_set$Salary),
        color = 'red') +
    geom_line(aes(x = training_set$YearsExperience,
        y = predict(regressor, newdata = training_set)),
        color = 'blue') +
    ggtitle('Salary vs Experience (Training set)') +
    xlab('Years of Experience') +
    ylab('Salary')

ggplot() +
    geom_point(aes(x = test_set$YearsExperience,
        y = test_set$Salary),
        color = 'red') +
    geom_line(aes(x = test_set$YearsExperience,
        y = predict(regressor, newdata = test_set)),
        color = 'blue') +
    ggtitle('Salary vs Experience (Testing set)') +
    xlab('Years of Experience') +
    ylab('Salary')


require(mgcv)
# first an un-penalized example - fit E(y)=a+bx subject to a>0
set.seed(0)

# Penalized example: monotonic penalized regression spline .....
n <- 100
# Generate data from a monotonic truth.
x <- runif(100) * 4 - 1
x <- sort(x)
f <- exp(4 * x) / (1 + exp(4 * x))
y <- f + rnorm(100) * 0.1
plot(x, y)
dat <- data.frame(x = x, y = y)
# Show regular spline fit (and save fitted object)
f.ug <- gam(y ~ s(x, k = 10, bs = "cr"))
lines(x, fitted(f.ug))
# Create Design matrix, constraints etc. for monotonic spline....
sm <- smoothCon(s(x, k = 10, bs = "cr"), dat, knots = NULL)[[1]]
F <- mono.con(sm$xp)
# get constraints
G <- list(X = sm$X, C = matrix(0, 0, 0), sp = f.ug$sp, p = sm$xp, y = y, w = y * 0 + 1)
G$Ain <- F$A
G$bin <- F$b
G$S <- sm$S
G$off <- 0

p <- pcls(G)
# fit spline (using s.p. from unconstrained fit)

fv <- Predict.matrix(sm, data.frame(x = x)) %*% p
lines(x, fv, col = 2)


#R version 3.3.2

p_a <- 0
p_b <- 0
p_c <- 0

rng <- 1:998

# O(n^3)
for (a in rng) {
    for (b in a+1:998) {
        for (c in b+1:998) {
            if (a*a + b*b == c*c & a+b+c == 1000) {
                p_a <- a
                p_b <- b
                p_c <- c
                break
            }
        }
    }
}

print(p_a * p_b * p_c)


ds = read.csv("50_Startups.csv")

# Splitting dataset
library(caTools)
split = sample.split(ds, SplitRatio = 0.8)
training_set = subset(ds, split == TRUE)
test_set = subset(ds, split == FALSE)

# Dealing with categorical values
ds$State = factor(ds$State,
                  levels = c("New York", "California", "Florida"),
                  labels = c(1,2,3))

# Fitting regression model and predicting
regressor = lm(formula = Profit ~.,
               data = training_set)
summary(regressor)
y_pred = predict(regressor, newdata = test_set)

# Backwards elimination
regressor_optimum = lm(formula = Profit~.,
                       data = ds)
step(regressor_optimum, direction = "backward")

summary(regressor)$r.square
summary(regressor_optimum)$r.square


# onesample.t.r
x <-c(63, 72, 73, 70, 77, 72, 74, 73, 69, 79)  # score1.r
mx <- mean(x)  # 72.2
sx <- sd(x)     # 4.391912
lbd <- mx - qt(0.975, 9)*sx/sqrt(10)
ubd <- mx + qt(0.975, 9)*sx/sqrt(10)
lbd
ubd
t0 <- (mx-70)/(sx/sqrt(10))
t0
1-pt(t0, 9)


#!/usr/bin/env Rscript

library("optparse")
library(glmnet)
library(readr)
library(caret)
seed = sample(1:100, 1, replace=T)
set.seed(seed)

option_list = list(
  make_option(c("-c", "--concept_dir"), type="character", default='',
              help="directory where concept files are saved", metavar="character"),
  make_option(c("-d", "--file_name"), type="character", default='feature_dense_4_interstitial_marking_max_',
              help="file name suffix", metavar="character"),
  make_option(c("-m", "--measure"), type="character", default='auc',
              help="type [default= %default]", metavar="character")
)

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
if (is.null(opt$concept_dir)){
  print_help(opt_parser)
  stop("concept_dir must be supplied", call.=FALSE)
}
if (is.null(opt$file_name)){
  print_help(opt_parser)
  stop("file_name must be supplied", call.=FALSE)
}
if (is.null(opt$measure)){
  print_help(opt_parser)
  stop("measure must be supplied", call.=FALSE)
}

concept_dir = opt$concept_dir
file_name = opt$file_name
measure = opt$measure
print(paste("file_name: ", file_name, "measure: ", measure))

output_file_name = paste(concept_dir, '/',file_name,'_output_R.txt',sep='')

if (file.exists(output_file_name)){
stop("Already completed", call.=FALSE)
}

data_present = read_csv(paste(concept_dir, '/', file_name,'_positive.csv',sep=''), col_names=FALSE)
data_absent = read_csv(paste(concept_dir, '/',  file_name,'_negative.csv',sep=''), col_names=FALSE)
data_present$label = rep(1, dim(data_present)[1])
data_absent$label = rep(0, dim(data_absent)[1])
dim(data_present)
dim(data_absent)
data = rbind(data_present, data_absent)
dim(data)

# Now Selecting 75% of data as sample from total 'n' rows of the data
sample <- sample.int(n = nrow(data), size = floor(.75*nrow(data)), replace = F)
train <- data[sample, ]
test  <- data[-sample, ]
dim(train)
dim(test)
column_names = names(train)[1:ncol(train)-1]

best_alpha = 1
sink(output_file_name)
print(seed)

#Repeat lasso regression 10 times
features = list()
features_count = rep(0, 10)
for (i in 1:10){
    print(i)

    fit =  cv.glmnet(as.matrix(train[column_names]), train$label, type.measure="auc", alpha=1,family="binomial", nfolds=5)
    imp_features_cv_1se_current = rownames(coef(fit, s = 'lambda.1se'))[coef(fit, s = 'lambda.1se')[,1]!= 0]
    features$i = imp_features_cv_1se_current
    features_count[i] = length(imp_features_cv_1se_current)

    print(fit)

    pre = predict(fit, newx = as.matrix(test[column_names]), s = c(fit$lambda.min, fit$lambda.1se))
    print(assess.glmnet(pre, newy = test$label, family = "binomial"))
    print(confusion.glmnet(fit, newx = as.matrix(test[column_names]), test$label, family = "binomial"))

    pre = predict(fit, newx = as.matrix(data[column_names]), s = c(fit$lambda.min, fit$lambda.1se))
    print(assess.glmnet(pre, newy = data$label, family = "binomial"))
    print(confusion.glmnet(fit, newx = as.matrix(data[column_names]), data$label, family = "binomial"))

    print("Important Features Coeff - Min Lambda")
    imp_features_cv_min =coef(fit, s = 'lambda.min')[coef(fit, s = 'lambda.min')[,1]!= 0] ### returns nonzero coefs
    print(imp_features_cv_min)

    print("Important Features Coeff - 1se Lambda")
    imp_features_cv_1se =coef(fit, s = 'lambda.1se')[coef(fit, s = 'lambda.1se')[,1]!= 0]
    print(imp_features_cv_1se)

    print("Important Features - Min Lambda")
    imp_features_cv_min = rownames(coef(fit, s = 'lambda.min'))[coef(fit, s = 'lambda.min')[,1]!= 0] ### returns nonzero coefs
    print(imp_features_cv_min)

    print("Important Features - 1se Lambda")
    imp_features_cv_1se = rownames(coef(fit, s = 'lambda.1se'))[coef(fit, s = 'lambda.1se')[,1]!= 0]
    print(imp_features_cv_1se)
}

#Run a stable feature selection as well
library('stabs')
stab.glmnet <- stabsel(x = as.matrix(train[column_names]), y = train$label, fitfun = glmnet.lasso, args.fitfun = list(type.measure="auc", alpha=1,family="binomial"), cutoff = 0.75,PFER = 1)

print(stab.glmnet)

#After fitting lasso for 10 times:
print("feature counts in 10 runs of lasso: ")
print(features_count)
mean_num_features = mean(features_count)
std_num_features = sd(features_count)
flag = 0
for (i in 1:10){
    if (features_count[i] >  mean_num_features - (std_num_features/2)){
        if (features_count[i] <  mean_num_features + (std_num_features/2)){
            print(i)
            if (flag ==0){
            common_feature = features$i
            }
            else{
            common_feature = union(common_feature, features$i)
            }
        }
    }
}

print("Final Features:")
print(common_feature)
sink()


# Mean and Standard Deviation of the Binomial Probability Distribution
#number of trials
n<-20
#  the probability of success of single event  is
z<-0.85
Mean<-n*z
print(Mean)
standard_deviation=sqrt(n*z*(1-z))
print(standard_deviation)


# from http://ditraglia.com/Econ103Public/Rtutorials/Rtutorial4.html
# experimentA is the same as demere, but done differently
experimentA <- function(){
  rolls <- sample(1:6, size = 4, replace = TRUE)
  condition <- sum(rolls == 6) > 0
  return(condition)
}
# experimentB is a single run of Demere2 experiment
experimentB <- function(){
  first.die <- sample(1:6, size = 24, replace = TRUE)
  second.die <- sample(1:6, size = 24, replace = TRUE)
  condition <- sum((first.die == second.die) & (first.die == 6)) > 0
  return(condition)
}

# NOTE: summing the simulation
simsA <- replicate(100000, experimentA())
sum(simsA)/length(simsA)
#
simsB <- replicate(1000000, experimentB())
sum(simsB)/length(simsB)


# Date: 2022-01-21
# Author: Gustav Collin Rasmussen
# Purpose: Definition and exploration of popular 1-repetition-maximum formulas

library(tidyverse)
library(cowplot)

epley <- function(w, r) {
    stopifnot(r > 1)
    return (w * (1 + r / 30))
}

brzycki <- function(w, r) {
    return (w * 36 / (37 - r))
}

epley_inverted <- function(one_rm, r, progression) {
    stopifnot(r > 1)
    return (log10(progression) * one_rm / (1 + r / 30))
}

brzycki_inverted <- function(one_rm, r, progression) {
    return (log10(progression) * one_rm * (37 - r) / 36)
}

###### evaluate 1rm formulas at 5 reps for varying weights ######
weight = seq(10, 60, by=10)

one_rm_constant_reps_df <- data.frame(weight = weight,
                        epley_1rm = epley(weight, 5),
                        brzycki_1rm = brzycki(weight, 5)
                        )

df1 <- one_rm_constant_reps_df %>%
  select(weight, epley_1rm, brzycki_1rm) %>%
  gather(key = "variable", value = "one_rep_max", -weight)

###### evaluate 1rm formulas at weight: 70 kg for varying reps ######
reps = 2:10
one_rm_constant_weight_df <- data.frame(reps = reps,
                                      epley_1rm = epley(70, reps),
                                      brzycki_1rm = brzycki(70, reps)
)

df2 <- one_rm_constant_weight_df %>%
  select(reps, epley_1rm, brzycki_1rm) %>%
  gather(key = "variable", value = "one_rep_max", -reps)

###### evaluate inverse 1rm formulas at 5 reps for varying weights ######
inverse_one_rm_constant_reps_df <- data.frame(weight = weight,
                        epley_inverted = epley_inverted(weight, 5, 10),
                        brzycki_inverted = brzycki_inverted(weight, 5, 10)
                        )

df3 <- inverse_one_rm_constant_reps_df %>%
  select(weight, epley_inverted, brzycki_inverted) %>%
  gather(key = "variable", value = "inverse_one_rep_max", -weight)

###### evaluate inverse 1rm formulas at weight: 70 kg for varying reps ######
inverse_one_rm_constant_weight_df <- data.frame(reps = reps,
                                      epley_inverted = epley_inverted(70, reps, 10),
                                      brzycki_inverted = brzycki_inverted(70, reps, 10)
)

df4 <- inverse_one_rm_constant_weight_df %>%
  select(reps, epley_inverted, brzycki_inverted) %>%
  gather(key = "variable", value = "inverse_one_rep_max", -reps)

################## prepare plots ##################
sp1 <- ggplot(df1, aes(weight, one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp2 <- ggplot(df2, aes(reps, one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp3 <- ggplot(df3, aes(weight, inverse_one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

sp4 <- ggplot(df4, aes(reps, inverse_one_rep_max)) +
  geom_point(aes(color = variable)) +
  scale_color_manual(values = c("darkred", "steelblue"))

################## show figure ##################
plot_grid(sp1, sp2, sp3, sp4,
          labels = rep(c("constant reps (5)", "constant weight (70 kg)"), times=2),
          ncol = 2, nrow = 2)


library(lpSolve)

# Matrix
matrix <- rbind(
    as.numeric(df_pred_r2$Posicao == "ata"), # Num strikers
    as.numeric(df_pred_r2$Posicao == "ata"), # Num strikers
    as.numeric(df_pred_r2$Posicao == "mei"), # Num Mid
    as.numeric(df_pred_r2$Posicao == "mei"), # Num Mid
    as.numeric(df_pred_r2$Posicao == "zag"), # Num Defenders
    as.numeric(df_pred_r2$Posicao == "zag"), # Num Defenders
    as.numeric(df_pred_r2$Posicao == "lat"), # Num Right or left back
    as.numeric(df_pred_r2$Posicao == "lat"), # Num Right or left back
    as.numeric(df_pred_r2$Posicao == "gol"), # Num goalkeeper
    as.numeric(df_pred_r2$Posicao == "tec"),  # Num head coach
    diag(df_pred_r2$risk_points),
    df_pred_r2$Preco
  )

# Prepare input for LP solver
objective.in <- df_pred_r2$next_round
const.dir <- c( "<=", ">=",
                "<=", ">=",
                "<=", ">=",
                "<=", ">=",
                "==",
                "==",
                rep("<=", length(df_pred_r2$next_round)),
                "<="
)
const.rhs <- c(3, 1,
               5, 3,
               3, 2,
               2, 0,
               1, 1,
               rep(5, length(df_pred_r2$next_round)),
               97.11)

sol <- lp(direction = "max", objective.in, # maximize objective function
          matrix, const.dir, const.rhs,   # constraints
          all.bin = TRUE)
inds <- which(sol$solution == 1)
df_pred_r2[inds, c("Apelido", "Posicao", "next_round", "Preco", "risk_points", "variable", "pred.home.score",
                   "pred.away.score"), ]


#Generate a diagram of discrete phytoplankton size classes
PMU <- 10
SD  <- 5

x <- c(2, 5, 10, 15, 18)
y <- dnorm(x, mean = PMU, sd = SD)
X <- seq(0,20,0.01)
Y <- dnorm(X, mean = PMU, sd = SD)
pdf('discrete_example.pdf', width=3,height=3)
op <- par( font.lab  = 1,
             family  ="serif",
             mar     = c(4,4,0.5,.2),
             mgp     = c(2.3,1,0),
             cex.lab = 1.2,
             mfcol   = c(1,1),
             cex.axis=1)

plot(X, Y, type = 'n',
     xlab = bquote('Ln Volume ('~µm^3 ~ ')'),
     ylab = 'Biomass')
rect(x, 0, x+.3, y)
dev.off()


library(dslabs)
data('murders')

# 1. We made a plot of total murders versus population and noted a strong relationship. Not surprisingly, states with larger populations had more murders. Transform the variables using the log10 transformation and then plot them.

pop_in_millions <- murders$population / 10^6
total <- murders$total
plot(log10(pop_in_millions), log10(total))

# 2. Create a histogram of the state populations.

x <- with(murders, total / population * 10^6)
hist(x)

# 3. Generate boxplots of the state populations by region.

murders$rate <- with(murders, total / population * 100000)
boxplot(rate~region, data = murders)


for (n in c(3030, 1000, 500, 200, 100, 50, 10)) {
  p = dbinom(n/2, n, 0.5)
  cat(n, " : ", round(100*p, 2), " %\n")
}


#' Set outlier critical value
#'
#' Set outlier critical value using the Ljung algorithm as given in
#' Ljung, G. M. (1993). On outlier detection in time series.
#' Journal of Royal Statistical Society B 55, 559-567.
#'
#'
#' @param number_observations number of observations tested for outliers
#' @param cv_alpha alpha for critical value
#' @return outlier critical value generated by the algorithm given in Ljung (1993).
#'         The critical value in X-13 is different as it is adjusted to allow for smaller values
#'         to approximate the normal distribution.
#' @examples
#' this_critical_value <- set_critical_value(12, 0.025)
#' @export
set_critical_value <- function(number_observations, cv_alpha = 0.01) {
    # Brian Monsell Version 1.4 3/29/2021
    pmod <- 2 - sqrt(1 + cv_alpha)
    acv <- sqrt(2 * log(number_observations))
    bcv <- acv - (log(log(number_observations)) + log(2 * 2 * pi))/(2 * acv)
    xcv <- -log(-0.5 * log(pmod))
    setcvl <- (xcv/acv) + bcv
    return(setcvl)
}


# Jose.M.Pavia@uv.es
require(Hmisc)
PerCapita <- c(10, 20, 30, 20, 20, 40)
Group <- c( "A", "B", "B", "A", "A", "B")
W <- c(1.5, 2.3, 4.5, 2.6, 1.7, 3.9)

## Works
wtd.mean(PerCapita, weights=W)
wtd.quantile(PerCapita, weights=W)
wtd.mean(PerCapita[Group=="A"], weights=W[Group=="A"])
wtd.mean(PerCapita[Group=="B"], weights=W[Group=="B"])

g <- function(y) wtd.mean(y[,1],y[,2])
summarize(cbind(PerCapita, W), llist(Group), g, stat.name='y')

## davharris https://github.com/harrelfe/Hmisc/issues/69

x <- c(3.7,3.3,3.5,2.8)
wt <- c(5,  5,  4,  1)/15
wtd.mean(x, wt)
wtd.var(x, wt)


#Copyright (c) 2016 Riccardo Francescato
a <- c(108,124,124,106,115,138,163,159,134,139)
#confidency level
alpha = .01
#type of test: 0 left tail 1 double tail 2 right tail
type = 1
#calculations....
n0 = length(a)		# number of reps for sample 0
xbar0 = mean(a)		# sample 0 mean
Sigma0 = 2			# given  variance
s0 = sd(a)			# sample 0 standard deviation
X0 = ((n0-1)*s0^2)/Sigma0
if(type == 0){
	x.alpha = qchisq(1−alpha, df=n0−1)
	cat("Results of lower tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha: ",x.alpha))
	if(X0<x.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	x.top.alpha = qchisq(alpha/2, df=n0−1)
	x.bottom.alpha = qchisq(1-alpha/2, df=n0−1)
	cat("Results of 2-tail tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha +: ",x.top.alpha))
	cat(paste("\nxalpha -: ",x.bottom.alpha))
	if(X0<x.bottom.alpha || X0>x.top.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	x.alpha = qchisq(alpha, df=n0−1)
	cat("Results of upper tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nx0: ",X0))
	cat(paste("\nxalpha: ",x.alpha))
	if(X0>x.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


### functions for QR or sparseQR class
qrrank<-function(QR, tol=1e-8){
  if(class(QR)=="sparseQR")
    return(sum(abs(diag(QR@R))>tol))
  else
    return(QR$rank)
}
qrRM<-function(QR){
  if(class(QR)=="sparseQR")
    return(qrR(QR))
  else
    return(qr.R(QR))
}

# invTwobyTwoSymMatrix: inverts two-by-two symmetric matrices
# M: symmetric matrix
# OUTPUT: a two-by-two symmetric matrix
invTwobyTwoSymMatrix <- function(M) {
  if(missing(M)) stop("invTwobyTwoSymMatrix: Supply M!")
  if(nrow(M) != 2 || ncol(M) != 2) stop("invTwobyTwoSymMatrix: The matrix is not 2 by 2")
  if(M[1,2] != M[2,1]) stop("invTwobyTwoSymMatrix: The matrix is not symmetric!")
  detM = M[1,1] * M[2,2] - M[1,2]^2
  Minverse = M
  Minverse[2,2] = M[1,1]
  Minverse[1,1] = M[2,2]
  Minverse[1,2] = Minverse[2,1] = -1 * M[1,2]
  return(1/detM * Minverse)
}

# quadSolver: solves the quadratic equation ax^2 + bx + c = 0
#             Can also be used to solve eigenvalues of two-by-two matrices
#             E.x. if [d,e; f,g] is the two-by-two matrix
#                  eigenvalues are defined as the solution to det( [d,e; f,g] - lambda * I) = 0
#                  Or det([d - lambda, e; f, g - lambda]) = 0
#                  Or (d-lambda) * (g -lambda) - e*f = 0
#                  Or lambda^2 - (d +g) *lambda + d*g - e*f = 0
quadSolver = function(a,b,c) {
  if(missing(a) || missing(b) || missing(c)) stop("Supply the coefficients!")
  if(length(a) != 1 || length(b) != 1 || length(c) != 1) stop("Supply only scalar values to a,b, and c")
  if(a == 0) stop("Something is wrong! Leading coefficient is zero")

  discriminant = b^2 - 4 * a * c
  if(discriminant < 0) return(c(NA,NA))
  if(discriminant == 0) return( rep(-b/(2*a),2))
  if(discriminant > 0) {
    if(a > 0) {
	  lowerRoot = -b / (2*a) - sqrt(discriminant) / (2*a)
	  upperRoot = -b / (2*a) + sqrt(discriminant) / (2*a)
	  return(c(lowerRoot,upperRoot))
	} else {
	  lowerRoot = -b / (2*a) + sqrt(discriminant) / (2*a)
	  upperRoot = -b / (2*a) - sqrt(discriminant) /(2*a)
	  return(c(lowerRoot,upperRoot))
	}
  }
}