# compute fluxes for radiation model.
# relax radiation model by adding noise to distance with sd 10km, and bootstrapping

compute_radiation_fluxes = function(numrep, radiation_length_scale, population, geodist) {
  flux <- array(0, dim=c(N, N))
  flux_var <-  array(0, dim=c(N, N))
  for (r in 1:numrep) {
    ff <- matrix(0, N, N)
    for (i in 1:N) {
      mi = population[i]
      if (i==1) {
        jj <- 2:N
      } else if (i==N) {
        jj <- 1:(N-1)
      } else {
        jj = c(1:(i-1),(i+1):N)
      }
      js = jj[order(geodist[i,jj]+rnorm(N-1,sd=radiation_length_scale))]
      nj = population[js]
      sij = cumsum(c(0.0,nj))[1:(N-1)]
      ff[i,js] = mi*nj/((mi+sij)*(mi+nj+sij))
      ff[i,i] = 1.0 - sum(ff[i,js]) # this statement weird, as fluxes don't sum to 1, unlike as claimed in Simini paper
    }
    flux = flux + ff
    flux_var = flux_var + ff^2
  }
  flux = flux / numrep
  flux_sd = (flux_var - numrep*(flux^2))/(numrep-1)
  flux_sd[flux_sd<0]=0
  flux_sd = sqrt(flux_sd)/sqrt(numrep)

  list("flux"=flux, "flux_sd"=flux_sd)
}


rm(list=ls())

library('radolc')

#--- testing ADOLC in the bi-variate case

fr <- function(x) {   ## Rosenbrock Banana function
  x1 <- x[[1]]
  x2 <- x[[2]]
  y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y }

trace_on(1)
x <- c(adouble(1.0),adouble(2.0))
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

grrADOLC <- function(x) { ## Gradient of 'fr'
  xx <- x
  yy <- c(0.0,0.0)
  gradient(1,2,xx,yy);
  yy     }

res6 <- optim(c(1.2,1), fr, grrADOLC, method = "L-BFGS-B", control = list(type = 3, trace = 2))

#Always detach the package
detach(package:radolc, unload=TRUE)


## 8장 그래프 만들기
#### 08-2 산점도 - 수치변수 간 관계 ####
rm(list=ls())
## -------------------------------------------------------------------- ##
library(ggplot2)
mpg <- ggplot2::mpg

# x축 displ, y축 hwy로 지정해 배경 생성
ggplot(data = mpg, aes(x = displ, y = hwy))

# 배경에 산점도 추가
ggplot(data = mpg, aes(x = displ, y = hwy)) + geom_point()
ggplot(mpg, aes(displ, hwy)) + geom_point()

# x축 범위 3~6으로 지정
ggplot(data = mpg, aes(x = displ, y = hwy)) +
  geom_point() +
  xlim(3, 6) #범위지정

# x축 범위 3~6, y축 범위 10~30으로 지정
ggplot(data = mpg, aes(x = displ, y = hwy)) +
  geom_point() +
  xlim(3, 6) +
  ylim(10, 30)

### Quiz 실습하기 ###

ggplot(data = mpg, aes(x=cty, y=hwy)) +
  geom_point()

midwest <- as.data.frame(ggplot2::midwest)

ggplot(data=midwest, aes(x=poptotal, y=popasian))+
  geom_point() +
  xlim(0,3e+06)+
  ylim (0,40000)

ggplot(data=midwest, aes(x=log10(poptotal), y=log10(popasian)))+
  geom_point()

#### 08-3 막대 그래프 - 집단 간 차이 표현 ####

## -------------------------------------------------------------------- ##
library(dplyr)

df_mpg <- mpg %>%
  group_by(drv) %>%
  summarise(mean_hwy = mean(hwy))

df_mpg
# 데이터를 요약한 평균표를 그대로 이용할 때 geom_col()
ggplot(data = df_mpg, aes(x = drv, y = mean_hwy)) + geom_col() #빈도수가 이미 정해져있을때

# - reorder(category, freq): freq 값에 따라 category를 재배열.
#-mean_hwy : 내림차순으로 정렬
ggplot(data = df_mpg, aes(x = reorder(drv, -mean_hwy),
                          y = mean_hwy)) + geom_col()

# 요약표를 이용하지 않고 원자료를 그대로 빈도체크해서 그릴 때 geom_bar()
table(mpg$drv)
ggplot(data = mpg, aes(x = drv)) + geom_bar()

ggplot(data = mpg, aes(x = hwy)) + geom_bar(width=1) #빈도수를 컴퓨터가 알아서 세줘야할 때
ggplot(data = mpg, aes(x = hwy)) + geom_histogram(bins=30)

### Quiz 실습하기 ###
head(mpg)
suvs<-mpg%>%
  (class=="suv") %>%
  group_by(manufacturer) %>%
  summarise(cty = mean(cty, na.rm=T)) %>%
  arrange(desc(cty)) %>%
  head(5)

suvs

ggplot(data=suvs, aes(x = reorder(manufacturer,-cty), y= cty, fill=manufacturer))+
  geom_col() +
  scale_x_discrete(limits = suvs$manufacturer)

head(mpg)

ggplot(data=mpg, aes(x = mpg$class))+
  geom_bar()

#### 08-4 선 그래프 - 시계열 데이터 표현 ####

## ---- line graph를 위해서는 x, y가 모두 필요 ------- ##
ggplot(data = economics, aes(x = date, y = unemploy)) +
  geom_line()

### Quiz 실습하기 ###
economics

ggplot(data = economics, aes(x=date, y=psavert))+
  geom_line()

#### 08-5 상자 그림 - 집단 간 분포 차이 표현 ####

## ------------ boxplot은 y를 필요로한다. ------------ ##
ggplot(data = mpg, aes(y = hwy)) + geom_boxplot()
boxplot(mpg$hwy)
ggplot(data = mpg, aes(x = drv, y = hwy)) + geom_boxplot()
boxplot(mpg$hwy ~ mpg$drv)

### Quiz 실습하기 ###

mpg2 <- mpg%>% filter(class %in% c("compact","subcompact","suv"))
ggplot(data = mpg2, aes(x=class, y=cty)) +geom_boxplot()
boxplot(mpg2$cty ~ mpg2$class)

## ---- 8장 summary -------------------------- ##
## 1.산점도
ggplot(data = mpg, aes(x = displ, y = hwy)) + geom_point()

# 축 설정 추가
ggplot(data = mpg, aes(x = displ, y = hwy)) +
  geom_point() +
  xlim(3, 6) +
  ylim(10, 30)

## 2.평균 막대 그래프

# 1단계.평균표 만들기
df_mpg <- mpg %>%
  group_by(drv) %>%
  summarise(mean_hwy = mean(hwy))

# 2단계.그래프 생성하기, 크기순 정렬하기
ggplot(data = df_mpg, aes(x = reorder(drv, -mean_hwy), y = mean_hwy)) + geom_col()

## 3.빈도 막대 그래프
ggplot(data = mpg, aes(x = drv)) + geom_bar()

## 4.선 그래프
ggplot(data = economics, aes(x = date, y = unemploy)) + geom_line()

## 5.상자 그림
ggplot(data = mpg, aes(x = drv, y = hwy)) + geom_boxplot()


setwd("C://Users//nan66//Google Drive//stt864//LAB3")
set.seed(52871775)
library(MASS)
#Q1
#reading data
polls2008<-read.csv(file="2008-polls.csv",header=TRUE)
polls2012<-read.csv(file="2012-polls.csv",header=TRUE)
results2008<-read.csv(file="2008-results.csv",header=TRUE)
results2012<-read.csv(file="2012-results.csv",header=TRUE)
#select pollsters that conducted polls >5 states.
atleast5<-table(polls2008[,5])[table(polls2008[,5])>=5]
atleast5
pollers<-c("ARG", "EPICMRA", "InsiderAdvantage",
		   "MaristColl", "MasonDixon", "MuhlenbergColl",
           "QuinnipiacU", "Rasmussen", "SienaColl",
           "SuffolkU","SurveyUSA", "UofCincinnati",
           "UofNewHampshire","Zogby")
po08sub<-polls2008[polls2008[,5]%in%pollers,]
po12sub<-polls2012[polls2012[,5]%in%pollers,]
#Q2
#reformatting the poll and true results dataset as desired
#Dem win=1 Rep win=0
winers2008<-(results2008[,2]-results2008[,3]>0)+0
#name of 51 states
StateID2008<-results2008[,1]
Allresp<-NULL
for (sid in 1:51){
  ##operate on state=sid
	po08subID<-po08sub$State==StateID2008[sid]
	#polls (at least5),
	PoWin08SubSta<-po08sub[po08subID,]
	#Dem win=1 Rep win=0
	PoWin08Sta<-(PoWin08SubSta[,2]-PoWin08SubSta[,3]>0)+0
	#whether the polls is correct
	pollwinersIND<-(PoWin08Sta==winers2008[sid])+0
	#conbine it to "Allresp"
	Allresp<-c(Allresp,pollwinersIND)
}
#absolute difference between Supp rates of Dem and Rep.
margins2008<-abs(po08sub[,2]-po08sub[,3])
lagtime2008<-rep(0,dim(po08sub)[1])
electiondate2008<-c("Nov 04 2008")
EdDa08<-as.Date(electiondate2008, format="%b %d %Y")
for (i in 1:dim(po08sub)[1]){
	StDa08<-as.Date(as.character(po08sub[i,4]),
		format="%b %d %Y")
	lagtime2008[i]<-EdDa08-StDa08
}
data08<-cbind(Allresp,as.character(po08sub[,1]),
	margins2008,lagtime2008,as.character(po08sub[,5]))
#Q3
# select the states with at least one failure prediction
# aka data08$Allresp=0
stateslist<-unique(data08[which(data08[,1]=="0"),2])
subdata08<-data08[data08[,2]%in%stateslist,]
#Q4 need the significance.!!!
# define new variables and fit a logistic regression model
resp<-as.integer(subdata08[,1])
statesFAC<-as.factor(subdata08[,2])
margins<-as.double(subdata08[,3])
lagtime<-as.double(subdata08[,4])
pollersFAC<-as.factor(subdata08[,5])
logitreg<-glm(resp~statesFAC+margins+lagtime+pollersFAC,
	family="binomial")
summary(logitreg)
#Q5
#Fit a simple logistic regression model without states
logitreg1<-glm(resp~margins+lagtime+pollersFAC,
	family="binomial")
summary(logitreg1)
anova(logitreg1,logitreg)
anova(logitreg1,logitreg,test="Chisq")
# reformating the 2012 poll data for prediction purpose
pollwiners2012<-(po12sub[,2]-po12sub[,3]>0)+0
margins2012<-abs(po12sub[,2]-po12sub[,3])
lagtime2012<-rep(0,dim(po12sub)[1])
electiondate2012<-c("Nov 06 2012")
EdDa12<-as.Date(electiondate2012, format="%b %d %Y")
for (i in 1:dim(po12sub)[1]){
	StDa12<-as.Date(as.character(po12sub[i,4]),
		format="%b %d %Y")
 lagtime2012[i]<-EdDa12-StDa12
}
data12<-cbind(pollwiners2012,as.character(po12sub[,1]),
	margins2012,lagtime2012,as.character(po12sub[,5]))
#Q6 Q7 Q8
# Focusing on the states in the state list of 2008
# select the states with at least one failure prediction
# aka data08$Allresp=0
subdata12<-data12[data12[,2]%in%stateslist,]
# Predict with logistic and simple logistic model
margins2012<-as.double(subdata12[,3])
lagtime2012<-as.double(subdata12[,4])
pollersFAC2012<-as.factor(subdata12[,5])
StateName<-c("FL","MI","MO","CO")
n<-c(0,0,0,0)
SSE<-c(0,0,0,0)
SSE1<-c(0,0,0,0)
# Pred for Q6
Pred<-matrix(0,4,4)
rownames(Pred)<-StateName
colnames(Pred)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# Pred for Q7
Pred1<-matrix(0,4,4)
rownames(Pred1)<-StateName
colnames(Pred1)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# log regression CI for Q8
PredCI<-matrix(0,4,4)
rownames(PredCI)<-StateName
colnames(PredCI)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# sample log regression CI for Q8
PredCI1<-matrix(0,4,4)
rownames(PredCI1)<-StateName
colnames(PredCI1)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# bootstrap CI of log regression for Q8
BSCI<-matrix(0,4,4)
rownames(BSCI)<-StateName
colnames(BSCI)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# bootstrap CI of sample log regression for Q8
BSCI1<-matrix(0,4,4)
rownames(BSCI1)<-StateName
colnames(BSCI1)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# Weighted Pred of log regression for Q9
S.Pred<-matrix(0,4,4)
rownames(S.Pred)<-StateName
colnames(S.Pred)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# computation of weight of pollers for Q9
poNum<-length(pollers)
ErrRates<-rep(0,poNum)
for (poID in 1:poNum){
  PoPred08<-NULL
  PoPredRt<-NULL
  Po08Rt<-NULL
  StateID<-NULL
  PoPred08<-po08sub[po08sub[,5]==pollers[poID],]
  PoPredRt<-(PoPred08[,2]>PoPred08[,3])+0
  StateID<-PoPred08[,1]
  Po08Rt<-winers2008[StateID]
  ErrRates[poID]<-sum(1-(PoPredRt==winers2008[StateID]))/length(PoPredRt)
}
PoRank<-rank(ErrRates)
Weight<-1/(PoRank^2)
PollWeight<-data.frame(pollers,Weight)
#the loop
for (k in 1:4){
	# number of locations
	NOpolls<-sum(subdata12[,2]==StateName[k])
	locations<-which(subdata12[,2]==StateName[k])
	n[k]<-length(locations)
	# clearance of variables in the loop
    probDemwin<-NULL
	probGopwin<-NULL
	subWeight<-NULL
	X<-matrix(0,n[k],4)
	Xs<-matrix(0,n[k],3)
	X[,1]<-1
	Xs[,1]<-1
	X[,4]<-1
	Xs[,3]<-1
	# container of predictions
	LogPR<-cbind(as.double(subdata12[locations,1]),
		rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
	sLogPR<-cbind(as.double(subdata12[locations,1]),
		rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
	DeLogPR<-cbind(as.double(subdata12[locations,1]),
		rep(0,n[k]),rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
	DesLogPR<-cbind(as.double(subdata12[locations,1]),
		rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
	counts<-0
	for (i in locations){
		counts<-counts+1
 		LogDPs<-data.frame(statesFAC=StateName[k],
 			margins=margins2012[i],lagtime=lagtime2012[i],
 			pollersFAC=pollersFAC2012[i])
 		sLogDPs<-data.frame(margins=margins2012[i],
 			lagtime=lagtime2012[i],pollersFAC=pollersFAC2012[i])
 		X[counts,2:3]<-as.matrix(LogDPs[2:3])
 		Xs[counts,1:2]<-as.matrix(sLogDPs[1:2])
		LogPR[counts,2:4]<-unlist(predict(logitreg,LogDPs,
			type="response",se.fit=TRUE))
		sLogPR[counts,2:4]<-unlist(predict(logitreg1,sLogDPs,
			type="response",se.fit=TRUE))
		#derivative
		DeLogPR[counts,2:5]<-(1-LogPR[counts,2])*LogPR[counts,2]*unlist(LogDPs)
		DesLogPR[counts,2:4]<-(1-sLogPR[counts,2])*sLogPR[counts,2]*unlist(sLogDPs)
	}
	SSE<-sum(LogPR[,3]^2)
	SSE1<-sum(sLogPR[,3]^2)
	P1<-LogPR[,1]*LogPR[,2]+(1-LogPR[,1])*(1-LogPR[,2])
	P2<-sLogPR[,1]*sLogPR[,2]+(1-sLogPR[,1])*(1-sLogPR[,2])

	# Predictions for Q6
	Pred[k,1]<-mean(P1)
	Pred[k,2]<-mean(1-P1)
	Pred[k,3]<-mean(P2)
	Pred[k,4]<-mean(1-P2)
	# Predictions for Q7
	Pred1[k,1]<-mean(P1>0.5+0)
	Pred1[k,2]<-mean(P1<0.5+0)
	Pred1[k,3]<-mean(P2>0.5+0)
	Pred1[k,4]<-mean(P2<0.5+0)
	# Q8.1
	# clearance of containers
	varbeta<-NULL
	varbeta1<-NULL
	# define the function of var of two models
	VarGBeta<-function(x){
		x<-as.matrix(x[2:5])
		return(t(x)%*%ginv(t(X)%*%diag(P1*(1-P1))%*%X)%*%x)
	}
	VarGBeta1<-function(x){
		x<-as.matrix(x[2:4])
		return(t(x)%*%ginv(t(Xs)%*%diag(P2*(1-P2))%*%Xs)%*%x)
	}
	varbeta<-apply(DeLogPR,1,VarGBeta)
	varbeta1<-apply(DesLogPR,1,VarGBeta1)
	PredCI[k,1]<-mean(P1)-qnorm(0.975)*sqrt(mean(varbeta)/n[k])
	PredCI[k,2]<-mean(P1)+qnorm(0.975)*sqrt(mean(varbeta)/n[k])
	PredCI[k,3]<-1-PredCI[k,2]
	PredCI[k,4]<-1-PredCI[k,1]
	PredCI1[k,1]<-mean(P2)-qnorm(0.975)*sqrt(mean(varbeta1)/n[k])
	PredCI1[k,2]<-mean(P2)+qnorm(0.975)*sqrt(mean(varbeta1)/n[k])
	PredCI1[k,3]<-1-PredCI1[k,2]
	PredCI1[k,4]<-1-PredCI1[k,1]
	# Q8.2 Bootstrap prediction CI
	xStar<-NULL
	xStar1<-NULL
	for (boot in 1:500){
		BS.sample<-sample(P1,n[k],replace=TRUE)
		xStar[boot]<-mean(BS.sample)
		BS.sample1<-sample(P2,n[k],replace=TRUE)
		xStar1[boot]<-mean(BS.sample)
	}
	BSCI[k,1]<-mean(xStar)-qnorm(0.975)*sd(xStar)
	BSCI[k,2]<-mean(xStar)+qnorm(0.975)*sd(xStar)
	BSCI[k,3]<-mean(1-xStar)-qnorm(0.975)*sd(1-xStar)
	BSCI[k,4]<-mean(1-xStar)+qnorm(0.975)*sd(1-xStar)
	BSCI1[k,1]<-mean(xStar1)-qnorm(0.975)*sd(xStar1)
	BSCI1[k,2]<-mean(xStar1)+qnorm(0.975)*sd(xStar1)
	BSCI1[k,3]<-mean(1-xStar1)-qnorm(0.975)*sd(1-xStar1)
	BSCI1[k,4]<-mean(1-xStar1)+qnorm(0.975)*sd(1-xStar1)
	#Q9
	subPoName<-subdata12[subdata12[,2]==StateName[k],5]
	subWeight<-rep(0,NOpolls)
	for (f in 1:NOpolls){
	  subWeight[f]<-PollWeight[PollWeight[,1]==subPoName[f],2]
	}
	W.P1<-P1*subWeight/sum(subWeight)
	W.P2<-P2*subWeight/sum(subWeight)
	W.P1.C<-(1-P1)*subWeight/sum(subWeight)
	W.P2.C<-(1-P2)*subWeight/sum(subWeight)
	S.Pred[k,1]<-sum(W.P1)
	S.Pred[k,2]<-sum(W.P1.C)
	S.Pred[k,3]<-sum(W.P2)
	S.Pred[k,4]<-sum(W.P2.C)
}
#Q6
Pred
#Q7
Pred1
results2012[results2012[,1]%in%StateName,]
#Q8
PredCI
PredCI1
BSCI
BSCI1
#Q9
S.Pred


factors(c(45, 53, 64))


#
# Testing:
#
# H_0:             b_1 = b_2 = 0   <= null hyphotesis
# H_Alternative:   b_1 != 0 or b_2 != 0
#
# So:
# Unrestricted: y = b_0 + b_1*x_1 + b_2*x_2 + b_3*x_3 + b_4*x_4
# Restricted:   y = b_0 + b_3*x_3 + b_4*x_4

# We are given this data
SSR_R <- 198.3 #sum squares residual for restricted
SSR_U <- 183.2 #sum squares residual for unrestricted
alpha <- 0.05
r = 2 #restrictions (dropped coeficients)
n = 500 #observations
k = 4 #number of coeficients of regressors (b_0 or intercept is not counted here)

# This test is one-sided hypotheses, so only one tail
F_critical_value = qf(alpha, r, n-(k+1), lower.tail = FALSE)
F_statistic = ((SSR_R - SSR_U)/r)/(SSR_U/(n-(k+1)))

print(F_critical_value)
print(F_statistic)

if (F_stat > F_critical_value){
  print("Reject de null hyphotesis")
}else{
  print("No reject de null hyphotesis")
}


 pca.modified = function (b) {
    id = rownames(b)
    vars = colnames(b)
    corel = cor(b, use="pairwise.complete.obs")
    corel[is.na(corel)] = 0
    s = svd(corel)
    evec = s$v
    eval = s$d
    if (0) {
        matrix.multiply = function (x, y, nfac=2){
            ndat = dim(x)[1]
            z = matrix(0, nrow=ndat, ncol = nfac)
            for (j in 1:nfac) {
              for (i in 1:ndat) {
                z[i,j] = sum ( x[i,] * t(y[,j]), na.rm=T )
              }
            }
            return (z)
        }
        scores = matrix.multiply (b, s$v)  # i.e., b %*% s$v  .. force a multiplication ignoring NA
        scores = cbind(scores[,1]/sqrt(eval[1]), scores[,2]/sqrt(eval[2]) )
    }
    b[which(!is.finite(A))] = 0  # TODO:: prob better to try to estimate missing values from linear models ...
    scores = b %*% s$v  %*% (1/sqrt(eval)) # i.e., b %*% s$v  .. force a multiplication ignoring NA
    loadings = cbind(evec[,1]*sqrt(eval[1]) , evec[,2]*sqrt(eval[2]) )
    X11()
    biplot(scores, loadings, var.axes=T, col=c("blue", "red"), ylabs=vars)
    X11()
    plot(loadings)
    text(loadings[,1], loadings[,2], vars)
  }


local({
  library(readr)
  library(ggplot2)
  library(Cairo)

  samples <- read_csv("volume s3 samples.txt", col_names=FALSE)
  samples.density <- density(samples$X1)

  samples.density.mode   <- samples.density$x[which.max(samples.density$y)]
  samples.density.median <- samples.density$x[min(which(cumsum(samples.density$y) > sum(samples.density$y) * 0.5))]

  df <- data.frame(value=samples.density$x, density=samples.density$y)

  p <<- ggplot(df, aes(x=value, y=density)) +
    scale_x_continuous(expand=c(0,0)) +
    scale_y_continuous(expand=c(0,0)) +
    geom_line() +
    geom_vline(xintercept=samples.density.mode,   color='red') +
    geom_vline(xintercept=samples.density.median, color='blue')

  dpi <- 72 * 1.5
  ggsave(plot=p, 'volume s3 samples.png', h=1080/dpi, w=1920/dpi, type="cairo-png", dpi=dpi)

  plot(p)
  print(paste("mode:", samples.density.mode))
  print(paste("median:", samples.density.median))
})


library(shiny)
library(xlsx)
library(forecast)

cpiU <- read.xlsx("./data/SeriesReport-20160224001724_bf095b.xlsx", sheetName = "BLS Data Series", startRow = 11, header = TRUE, endRow = 51)
cpiU <- cpiU[-1,] #Remove 1977 row to align with 1978
cpiUts <- ts(cpiU$Annual, start = c(1978), end = c(2014), frequency = 1) #Time series obj of yearly average
cpiUper <- cpiUts/lag(cpiUts,-1) - 1    #Annual inflation based on CPI-U

shinyServer(
  function(input, output) {

    cpiUperm <- meanf(cpiUper, h=86, level = c(80,99), fan = FALSE, lambda = NULL) #86 yr Forecast from mean
    cpiUpern <- naive(cpiUper, h=86, level = c(80,99), fan = FALSE, lambda = NULL) #86 yr Forecast Naive method
    cpiUperd <- rwf(cpiUper, h=86, drift = TRUE, level = c(80,99), fan = FALSE, lambda = NULL)#86 yr Forecast from Random Walk with drift

    output$od2 <- renderPrint({input$id2})
    output$od3 <- renderPrint({
      as.numeric(input$id3) - 2014 #Calculate number of years
      })
    output$od4 <- renderPrint({
        p<-input$id1 #Principal
        y<-as.numeric(input$id3) - 2014 #Calculate number of years

      if (input$id2 == "Mean")
        for(i in 1:y) {  p <- as.numeric(p*cpiUperm$upper[i,2]) + p } #Mean Upper 99% compound interest
      if (input$id2 == "Naive")
         for(i in 1:y) {  p <- as.numeric(p*cpiUpern$upper[i,2]) + p } #Naive Upper 99% compound interest
      if (input$id2 == "Random Walk with Drift")
         for(i in 1:y) {  p <- as.numeric(p*cpiUperd$upper[i,2]) + p } #Random Upper 99% compound interest

      paste0("$", round(p, digits=2)) #Return inflated result
      })

    output$newPlot <- renderPlot({
        Y<-as.numeric(input$id3) - 2014 #Calculate number of years
        #Recalculate forecast for specific year input
        cpiUm <- meanf(cpiUper, h=Y, level = c(80,99), fan = FALSE, lambda = NULL)
        cpiUn <- naive(cpiUper, h=Y, level = c(80,99), fan = FALSE, lambda = NULL)
        cpiUd <- rwf(cpiUper, h=Y, drift = TRUE, level = c(80,99), fan = FALSE, lambda = NULL)
        #Return custom plot
      if (input$id2 == "Mean")
         plot(cpiUm, xlab="Years", ylab="Delta", main = "Inflation Rate Forecast with Mean")
         legend("bottomleft",c("80 confidence level","99 confidence level","mean"),lwd=c(3,3,3), col=c("gray","gray60","blue"))

      if (input$id2 == "Naive")
         plot(cpiUn, xlab="Years", ylab="Delta", main = "Inflation Rate Forecast with Naive")
         legend("bottomleft",c("80 confidence level","99 confidence level","mean"),lwd=c(3,3,3), col=c("gray","gray60","blue"))

      if (input$id2 == "Random Walk with Drift")
         plot(cpiUd, xlab="Years", ylab="Delta", main = "Inflation Rate Forecast with RWF Drift")
         legend("bottomleft",c("80 confidence level","99 confidence level","mean"),lwd=c(3,3,3), col=c("gray","gray60","blue"))
    })
  } )


# compute the expected vaccine efficacy against breakthrough infections that is
# due to a reduction in the case attributable fraction

# do this so that we can compare it against the estimated overall vaccine
# efficacy against breakthrough infections

# then compute correction factors to the infectiousness for vaccinated cases in
# each of the 4 combinations of vaccine type and  number of doses

# p_s = proportion symptomatic among unvaccinated infections

# p_s_star = proportion symptomatic among vaccinated infections

# VE_s = vaccine efficacy (% reduction) against symptomatic disease

# VE_o = vaccine efficacy (% reduction) against onward infectiousness of
# breakthrough infections

# VE_o(s) = vaccine efficacy (% reduction) against onward infectiousness of
# breakthrough infections, that is mediated by reductions in the fraction
# symptomatic

# absolute infectiousness (z is a transmission probability) of all unvaccinated
# people (symptomatic or asymptomatic)
# z * (p_s + (1 - p_s) / 2)

# absolute infectiousness (z is a transmission probability) of all vaccinated
# people (symptomatic or asymptomatic)
# z * (p_s_star + (1 - p_s_star) / 2)

# relative infectiousness of vaccinated versus unvaccinated (breakthrough)
# infections
#  (z * (p_s_star + (1 - p_s_star) / 2)) / (z * (p_s + (1 - p_s) / 2))
#   = (p_s_star + (1 - p_s_star) / 2) / (p_s + (1 - p_s) / 2)
#   = (1 + p_s_star) / (1 + p_s)

# proportion symptomatic among vaccinated infections
# p_s_star = p_s * (1 - VE_s)

# correction is the multiplier for reduction in onward transmission we want,
# divided by the one expected via reduction in symptomatics
# correction = ((1 - VE_o) / (1 - VE_o_s))

# this ^ can be multiplied by the probability of infection (by age bin, vaccine
# type, vaccine doses) to adjust it ot the correct value

library(tidyverse)

efficacies <- tibble::tribble(
  ~vaccine, ~dose, ~ve_infection, ~ve_symptom, ~ve_onward,
  "pfizer",     1,            30,          33,         46,
  "pfizer",     2,            79,          83,         65,
      "AZ",     1,            18,          33,         48,
      "AZ",     2,            60,          61,         65
) %>%
  mutate(
    across(
      starts_with("ve"),
      ~./100
    )
  )

clinical_fractions <- structure(
  list(
    age_group_5y = c("0-4", "5-9", "10-14", "15-19",
                     "20-24", "25-29", "30-34", "35-39", "40-44", "45-49", "50-54",
                     "55-59", "60-64", "65-69", "70-74", "75-79", "80+"),
    clinical_fraction_mean = c(
      0.29,
      0.29, 0.21, 0.21, 0.27, 0.27, 0.33, 0.33, 0.4, 0.4, 0.49, 0.49,
      0.63, 0.63, 0.69, 0.69, 0.69
    )
  ),
  row.names = c(NA, -17L),
  class = c("tbl_df", "tbl", "data.frame")
)

clinical_fractions %>%
  left_join(
    efficacies,
    by = character()
  ) %>%
  rename(
    clinical_fraction_unvacc = clinical_fraction_mean
  ) %>%
  mutate(
    clinical_fraction_vacc = clinical_fraction_unvacc * (1 - ve_symptom),
    ve_onward_via_symptom = 1 - ((1 + clinical_fraction_vacc) / (1 + clinical_fraction_unvacc)),
    onward_correction = ((1 - ve_onward) / (1 - ve_onward_via_symptom))
  ) %>%
  relocate(
    clinical_fraction_unvacc, .after = clinical_fraction_vacc
  ) %>%
  relocate(
    ve_onward_via_symptom, .after = ve_onward
  )

# p_s <- seq(0.1, 0.9, by = 0.1)
# VE_s <- efficacies$ve_symptom[2]
# VE_o <- efficacies$ve_onward[2]
# p_s_star = p_s * (1 - VE_s)
# VE_o_s <- 1 - ((1 + p_s_star) / (1 + p_s))
# correction <- ((1 - VE_o) / (1 - VE_o_s))


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  svd = svd(x)
  d = svd$d
  u = svd$u
  v = svd$v
} else {
  x = NULL
}

dx = expand(x)

svd_test = svd(dx)

d_test = svd_test$d
u_test = collapse(svd_test$u)
v_test = svd_test$v

comm.print(all.equal(d, d_test))

# the direction of the vectors can differ, so we have to account for sign
comm.print(all.equal(abs(u), abs(u_test)))
comm.print(all.equal(abs(v), abs(v_test)))

x = rantshaq(stats::rnorm, 3, 10)
v = svd(x)$v
vt = La.svd(x)$vt
comm.print(all.equal(abs(DATA(v)), abs(DATA(t(vt)))))

x = t(x)
v = svd(x)$v
vt = La.svd(x)$vt
comm.print(all.equal(abs(v), abs(t(vt))))

finalize()


REBOL [
    Title: {Comparing User Native vs. Rebol Fibonacci Number Calculation}
    Description: {
        @ShixinZeng created this as an initial test to compare the performance
        of a user native implementation of Fibonacci numbers, to an algorithm
        written in the exact same style using Rebol.

        It takes hundreds of CPU cycles to run a single step of Rebol, since
        it is run by an interpreter.  But a line of C generally translates
        into only a few instructions.  At time of writing, the TCC version is
        about 50x faster than an -O2 release build running the Rebol version.
    }
]

c-fib: make-native [
    "nth Fibonacci Number"
    n [integer!]
]{
    int n = rebUnboxInteger(rebArgR("n"));

    if (n < 0) { return rebInteger(-1); }
    if (n <= 1) { return rebInteger(n); }

    int i0 = 0;
    int i1 = 1;
    while (n > 1) {
        int t = i1;
        i1 = i0 + i1;
        i0 = t;
        --n;
    }
    return rebInteger(i1);
}

rebol-fib: function [
    n [integer!]
][
    if n < 0 [return -1]
    if n <= 1 [return n]
    i0: 0
    i1: 1
    loop [n > 1] [
        t: i1
        i1: i0 + i1
        i0: t
        n: n - 1
    ]
    return i1
]

compilables: [
    ;
    ; We get two tests in one here...we test the availability of the
    ; C standard library, and also handling of #define with quotes
    ; embedded in them (it's a tricky case that trips up mbedTLS if
    ; you don't support it correctly).
    ;
    {#include STDIO_INCLUDE}

    c-fib
]

opts: [
    ; This can be specified with LIBREBOL_INCLUDE_DIR as an environment
    ; variable, but you can also do it here for convenience.
    ;
    ;;librebol-path %/home/hostilefork/Projects/ren-c/build/prep/include/

    ; This can be specified with CONFIG_TCCDIR as an environment variable,
    ; but you can also do it here for convenience.  Lack of a trailing
    ; slash is tolerated as that is CONFIG_TCCDIR convention in TCC.
    ;
    ;;runtime-path %/home/hostilefork/Projects/tcc

    ; TCC expects options strings to have the backslashes in them.  This
    ; is needed because plain quotes are used for filenames that have
    ; spaces in them.  Note that the C99 command line emulation must
    ; therefore add these quotes in for #defines, since the shell will
    ; strip out any backslashes provided.
    ;
    options {-DSTDIO_INCLUDE=\"stdio.h\"}
]

compile/inspect/settings compilables opts  ; print out for verbose info
compile/settings compilables opts  ; does the actual compilation

print ["c-fib 30:" c: c-fib 30]
print ["rebol-fib 30:" r: rebol-fib 30]

assert [c = r]

if not find system/options/args "nobench" [
    n: 10000
    print ["=== Running benchmark," n "iterations ==="]
    print "(If you're using a debug build, this metric is affected)"

    c: delta-time [
        repeat n [c-fib 30]
    ]
    r: delta-time [
        repeat n [rebol-fib 30]
    ]

    print ["C time:" c]
    print ["Rebol time:" r]
    print ["Improvement:" unspaced [to integer! (r / c) "x"]]
]


# Generate and plot Brownian tree. Version #2.
# 7/27/16 aev
# gpBrownianTree2(m, n, clr, fn, ttl, dflg, psz)
# Where: m - defines matrix m x m; n - limit of the number of moves;
#   fn - file name (.ext will be added); ttl - plot title; dflg - 0-no dump,
#   1-dump; psz - picture size.
gpBrownianTree2 <- function(m, n, clr, fn, ttl, dflg=0, psz=600)
{
  cat(" *** START:", date(), "m=",m, "n=",n, "clr=",clr, "psz=", psz, "\n");
  M <- matrix(c(0), ncol=m, nrow=m, byrow=TRUE);
  # Random seed always
  x <- sample(1:m, 1, replace=FALSE); y <- sample(1:m, 1, replace=FALSE);
  M[x,y]=1;
  pf=paste0(fn,".png");
  cat(" *** Plot file -",pf,"Seed:",x,"/",y,"\n");
  # Main loops
  for (i in 1:n) {
    if(i>1) {
      x <- sample(1:m, 1, replace=FALSE)
      y <- sample(1:m, 1, replace=FALSE)}
    while(1) {
      dx <- sample(-1:1, 1, replace=FALSE);
      dy <- sample(-1:1, 1, replace=FALSE);
      nx=x+dx; ny=y+dy;
      if(!(nx<=m && ny<=m && nx>0 && ny>0)) {
        x <- sample(1:m, 1, replace=FALSE); y <- sample(1:m, 1, replace=FALSE)}
      else {if(M[nx,ny]) {M[x,y]=1; break}
        else{x=nx; y=ny;}}
    }
  }
  plotmat(M, fn, clr, ttl, dflg, psz);
  cat(" *** END:",date(),"\n");
}
gpBrownianTree2(400,5000,"brown", "BT2R", "Brownian Tree v.2", 1);

## Rename BT2R.dmp to BT2aR.dmp
plotv2("BT2aR", "orange", "Brownian Tree v.2a", 640)


setwd ("c://R")
PetrolData=read.csv ("EscapingHydrocarbons.csv", header=TRUE,sep=";")
str(PetrolData)

n<-names(PetrolData)
form1 = as.formula(paste("AmountEscapingHydrocarbons ~", paste(n[!n %in% "AmountEscapingHydrocarbons"], collapse = " + ")))

MLModel = lm(form1,data =PetrolData)
MLModel

summary(MLModel)

Pred <- predict(MLModel)

plot(PetrolData[,5],Pred,
     xlab="Actual",ylab="Predicted",cex = 1.3,lwd = 10)
abline(a=0,b=1,lwd = 5)

par(mfrow=c(2,2))
plot(MLModel)


merge<-function(a,b) {
    r<-numeric(length(a)+length(b))
    ai<-1; bi<-1; j<-1;
    for(j in 1:length(r)) {
        if((ai<=length(a) && a[ai]<b[bi]) || bi>length(b)) {
            r[j] <- a[ai]
            ai <- ai+1
        } else {
            r[j] <- b[bi]
            bi <- bi+1
        }
    }
    r
}
msort<-function(A) {
    if(length(A)>1) {
        q <- ceiling(length(A)/2)
        a <- msort(A[1:q])
        b <- msort(A[(q+1):length(A)])
        merge(a,b)
    } else {
        A
    }
}

res<-c(5,9,1,3,4,6,6,3,2)
msort(res)


# Script R for Visualization

# Load cluster_career data and class
data = read.csv("../Datasets/classification_career.csv")
data = data[-1]

# Calcuate summary of cluster_career
summary(data)

# Draw Correlation Matrix
library(seriation)
data_matrix <- as.matrix(data[-7])
pearson_corr <- cor(data[-7], method="pearson")
pearson_corr
write.csv(pearson_corr, "Tables/pearson_corr_career.csv")
pimage(pearson_corr, main="Correlation Matrix", col = bluered(100))

# Draw scatter plots without class
plot(data[-7])

# Draw half scatter plots without class
pairs(data[-7], upper.panel=NULL)

# Draw hs_diploma_grade vs grade_weighted_avg plot without class
plot(data[,2], data[,3], xlab="hs_diploma_grade", ylab="grade_weighted_avg", pch=19)

# Draw scatter plots with class
class <- data[,7]
colors <- c("red", "blue")
class_column <- colors[as.numeric(class)]
plot(data, col=class_column)

# Draw half scatter plots with class
test=as.character(levels(class))
pairs(data[-7], col=class_column, upper.panel=NULL)
par(xpd=TRUE)
legend(x=0.65, y=0.9, cex=2, legend=rev(as.character(levels(class))), fill=unique(class_column))
par(xpd=NA)

# Draw hs_diploma_grade vs grade_weighted_avg plot with class
plot(data[,2], data[,3], xlab="hs_diploma_grade", ylab="grade_weighted_avg", pch=19, col=class_column)

# Draw Summary Plot without class
library("GGally")
ggpairs(data[-7])

# Draw Summary Plot with class
library("GGally")
ggpairs(data, ggplot2::aes(colour=class))

# Parallel Coordinates
par(las = 1, mar = c(4.5, 3, 3, 2) + 0.1, cex = .8)
MASS::parcoord(data[-7], col = class_column, var.label = TRUE, lwd = 2)
legend(x = 4, y = 0.18, cex = 1.2, legend = as.character(levels(class)), fill = unique(class_column), horiz = TRUE)

par(las = 1, mar = c(4.5, 3, 3, 2) + 0.1, cex = .8)
MASS::parcoord(data[-7], col = class_column, var.label = TRUE, lwd = 2)

# Load cluster_exams data
data = read.csv("../Datasets/cluster_exams.csv")
data = data[-1]

# Calcuate summary of cluster_career
summary(data)

# Draw Correlation Matrix
library(seriation)
data_matrix <- as.matrix(data)
pearson_corr <- cor(data, method="pearson")
pearson_corr
write.csv(pearson_corr, "Tables/pearson_corr_exams.csv")
pimage(pearson_corr, main="Correlation Matrix", col = bluered(100))

# Draw ASD vs CPS plot
plot(data[,1], data[,13], xlab="ASD", ylab="CPS", pch=19)

# Draw BDSI vs CPS plot
plot(data[,8], data[,13], xlab="BDSI", ylab="CPS", pch=19)

# Draw MDL vs SO plot
plot(data[,4], data[,9], xlab="MDL", ylab="SO", pch=19)

# Draw Summary Plot
library("GGally")
ggpairs(data)


#ganancias
#lazo abierto, sistema planta 1
To<-1.080
Kp<-25.51
Tp<-15.0423
#Ganancia proporcional
GanP<-function(Tp,Kp,To){
  return(Tp/(Kp*To))
}
GanPr<-GanP(Tp,Kp,To)
GanPr
#Kp en ganancia integral
GanI<-function(Tp,Kp,To){
  return((0.9*Tp)/(Kp*To))
}
#PI
GanIn<-GanI(Tp,Kp,To)
GanIn
#tiempo de la integral
Tin<-3.33*To
Tin
#Kp en ganancia derivativa
GanD<-function(Tp,Kp,To){
  return((0.9*Tp)/(Kp*To))
}
#PID
GanPID<-GanD(Tp,Kp,To)
GanPID
#Tiempo integral en derivaticva
Tip<-2*To
Tip
#Tiempo derivativo
Td<-0.5*To
Td

KI<-GanIn/Tin
KI

K<-GanPID/Tip
K
KD<-GanPID*Td
KD

#para un sistema planta 2 en lazo cerrado
Ku<-1.749
Tu<-1.2
GaP<-0.5*Ku
GaP

Gi<-0.45*Ku
Gi

Gd<-0.6*Ku
Gd

#Tiempo integral
#Para un PI
tpi<-Tu/1.2
tpi

#Para la acción derivadiva
tid<-Tu/2
tid
#Tiempo derivativo
tpid<-Tu/8
tpid

Kp<-GaP
Kp

Ki<-Gi/tpi
Ki

kid<-Gd/tid
kid

Kd<-Gd*tpid
Kd

Practica 1 y 2/Parte 2 practica/2.2.2/LazoCerradoYAbierto.r


#' @aliases getDistance,numeric,numeric-method
#' @rdname getDistance
#' @export
#' @examples
#' # getDistance(c(1,1),c(4,5),costfactor=1) # should result 5.
#' # getDistance(c(1,1),c(4,5),costfactor=2) # should result 10.
setMethod( "getDistance", signature =c("numeric", "numeric"),
  function(n0=c(0,0),n1,...){
    li<- list(...)

    if(is.null(li$costfactor)) li$costfactor <-1
    dist <- sqrt( (n1[1] - n0[1])^2 + (n1[2] - n0[2])^2 )

    if(!is.null(li$digits)){
      if(class(li$digits) != "numeric"){
        warning(paste("Parameter digits is ignored, as the wrong class is provided. Expected is numeric, provided:", class(li$digits)))
      }else{
        if(li$digits<0){
          warning(paste("Parameter digits is ignored. Only non-negative values are accepted. Provided value:", li$digits))
        }else{
          dist <- round(dist, digits = li$digits)
        }
      }
    }
    dist <- dist * li$costfactor
    return(dist)
  }
)


#!/usr/bin/env Rscript

# NOTE: fOptions uses non-standard definition of cost of carry: b = interestrate - carryrate, i.e. the adjusted drift κ in the geometric Brownian motion:
#   dS_t = (κ - σ^2/2) S_t dt + σ S_t dW_t

library(fOptions)

df = Reduce(function(x,y) merge(x,y,all=TRUE),
             list(data.frame(startprice=c(80,100,120)),
                  data.frame(strikeprice=c(80,100,120)),
                  data.frame(days=c(50,120)),
                  data.frame(interestrate=c(0.05,0.07)),
                  data.frame(carryrate=c(0.0,0.025)),
                  data.frame(sigma=c(0.05,0.1,0.5))
                  ))

bs = df

for (type in c("c","p")) {
    bs[type] = with(bs,
                    GBSOption(TypeFlag = type, S = startprice, X = strikeprice, Time = days/365,
                              r = interestrate, b = interestrate - carryrate, sigma = sigma)@price)
}

write.csv(bs,"bs.csv",row.names=FALSE)

crr = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    crr[otype] = with(crr,
                     sapply(mapply(CRRBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}

write.csv(crr,"crr.csv",row.names=FALSE)

tian = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    tian[otype] = with(tian,
                     sapply(mapply(TIANBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}
write.csv(tian,"tian.csv",row.names=FALSE)

jr = merge(df,data.frame(nsteps=c(20,100)),all=TRUE)
for (otype in c("ce","pe","ca","pa")) {
    tian[otype] = with(jr,
                     sapply(mapply(JRBinomialTreeOption,TypeFlag = otype, S = startprice, X = strikeprice, Time = days/365,
                                   r = interestrate, b = interestrate - carryrate, sigma = sigma, n=nsteps),
                            function(x) x@price))
}
write.csv(tian,"jr.csv",row.names=FALSE)


=begin
[((<README|URL:README.html>))] [((<Japanese|URL:../doc-ja/index-ja.html>))]
= Algebra
  Version: 0.72 (2006.09.14)
  Author: Shin-ichiro HARA (sinara@blade.nagaokaut.ac.jp)

This is a library of one-variate and multi-variate polynomials.

== 0. First Step

Begin with 'require "algebra"'.

  require "algebra"
  x = Polynomial(Integer, "x").var
  puts( (x+1)**7 )
    #=> x^7 + 7x^6 + 21x^5 + 35x^4 + 35x^3 + 21x^2 + 7x + 1
  puts( (x**7 + 7*x**6 + 21*x**5 + 35*x**4 + 35*x**3 + 21*x**2 + 7*x + 1).factorize )
    #=> (x + 1)^7

== 1. Samples

* ((<Samples|URL:samples.html>))

== 2. Class and Module

 * ((<Algebra|URL:algebra.html>)) (Module of Algebra)
   * ((<Algebra::Polynomial|URL:polynomial.html>)) (Class of Polynomial Ring)
   * ((<Algebra::EuclidianRing|URL:euclidian-ring.html>)) (Eulcidian Ring Module)
   * ((<Algebra::MPolynomial|URL:m-polynomial.html>)) (Multi-variate Polynomial Ring Class)
   * ((<Algebra::ResidueClassRing|URL:residue-class-ring.html>)) (Residue Class Ring Class)
   * ((<Algebra::AlgebraicExtensionField|URL:algebraic-extension-field.html>)) (Algebraic Extension Class)
   * ((<Algebra::LocalizedRing|URL:localized-ring.html>)) (Localized Ring Class)
   * ((<Algebra::MatrixAlgebra|URL:matrix-algebra.html>)) (Matrix Algebra Class)
   * ((<Algebra::AlgebraicParser|URL:algebraic-parser.html>)) (evaluation of algebraic strings)
   * ((<Algebra::Set|URL:finite-set.html>)) (Sets)
   * ((<Algebra::Map|URL:finite-map.html>)) (Maps)
   * ((<Algebra::Group|URL:finite-group.html>)) (Groups)
   * ((<Algebra::PermutationGroup|URL:permutation-group.html>)) (PermutationGroups)

== 3. Other

 * ((<Algebra::ElementaryDivisor|URL:elementary-divisor.html>)) (Elementary Divisor Module)
 * ((<Algebra::JordanForm|URL:jordan-form.html>)) (Jordan Matrix Class)
 * ((<Algebra::MatrixAlgebraTriplet|URL:matrix-algebra-triplet.html>)) (Triplete of Matrices Class)
 * ((<Algebraic Equations|URL:algebraic-equation.html>))
 * ((<Conversions of Polynomial Classes|URL:polynomial-converter.html>))

== 4. Contents of package

=== General
  algebra.rb               File for using Algebra libraries

=== One variate polynomial
  polynomial.rb            Class of one variate polynomial
  euclidian-ring.rb        Module of Euclidian domain
  polynomial-factor.rb     Factorization:
    polynomial-factor-int.rb   Integer version
    polynomial-factor-zp.rb    Zp version
    polynomial-factor-alg.rb   Algebraic number version

=== Multi variate polynomial
  m-polynomial.rb         Class of multi-variate polynomial
    m-index.rb            Class of indices of degrees
  m-polynomial-factor.rb     Factorization:
    m-polynomial-factor-int.rb   Integer version
    m-polynomial-factor-zp.rb    Zp version
  groebner-basis.rb       Module of Groebner basis
  groebner-basis-coeff.rb Module of division by Groebner basis

=== Foundation
  finite-set.rb           Sets
    finite-map.rb         Maps
    finite-group.rb       Groups
      permutation-group.rb  Permutation Groups

=== Common part
  numeric-supplement.rb   Supplement of Numeric
  prime-gen.rb            Class of prime numbers
  polynomial-converter.rb Conversions between polynomial classes
  algebraic-parser.rb     Evaluation of strings
  algebra-system.rb       Common specification of algebras

=== General algebra
  localized-ring.rb       Quotient fields
  matrix-algebra.rb       Matrix
    elementary-divisor.rb Elementary Divisor Class
    matrix-algebra-triplet.rb  Triplet of Matrices Class
    jordan-form.rb        Jordan Block Class
  residue-class-ring.rb   Residue class ring
  algebraic-extention-field.rb Algebraic Extention Field of Polynomial
  splitting-field.rb      Minimal Splitting Field of Polynomial
  galois-group.rb         Galois Group of Polynomial
  linear-algebra.rb       library for linear algebra
  algebraic-equation.rb   library for algebraic equation

=== Others
  array-supplement.rb    Supplement of Array
  doc/                   English Manuals(RD, HTML, TXT)
  doc-ja/                Japanese Manuals(RD, HTML, TXT)
  sample/                Sample Codes
  work/                  (working directory for the developer)

== 5. ToDo
#<<< todo.rd
* ((<todo.html|URL:todo.html>))

== 6. Changes
#<<< changes.rd
* ((<changes.html|URL:changes.html>))

=end


library(shiny)

paramNames <- c("start_capital", "annual_mean_return", "annual_ret_std_dev",
	"annual_inflation", "annual_inf_std_dev", "monthly_withdrawals", "n_obs",
	"n_sim")

# Define server logic required to generate and plot a random distribution
#
# Idea and original code by Pierre Chretien
# Small updates by Michael Kapler
#
shinyServer(function(input, output, session) {

	getParams <- function(prefix) {
		input[[paste0(prefix, "_recalc")]]

		params <- lapply(paramNames, function(p) {
			input[[paste0(prefix, "_", p)]]
		})
		names(params) <- paramNames
		params
	}

  # Function that generates scenarios and computes NAV. The expression
  # is wrapped in a call to reactive to indicate that:
  #
  #  1) It is "reactive" and therefore should be automatically
  #     re-executed when inputs change
  #
  navA <- reactive(do.call(simulate_nav, getParams("a")))
  navB <- reactive(do.call(simulate_nav, getParams("b")))

  # Expression that plot NAV paths. The expression
  # is wrapped in a call to renderPlot to indicate that:
  #
  #  1) It is "reactive" and therefore should be automatically
  #     re-executed when inputs change
  #  2) Its output type is a plot
  #
  output$a_distPlot <- renderPlot({
  	plot_nav(navA())
  })
  output$b_distPlot <- renderPlot({
  	plot_nav(navB())
  })

})

simulate_nav <- function(start_capital = 2000000, annual_mean_return = 5.0,
                         annual_ret_std_dev = 7.0, annual_inflation = 2.5,
                         annual_inf_std_dev = 1.5, monthly_withdrawals = 1000,
                         n_obs = 20, n_sim = 200) {
  #-------------------------------------
  # Inputs
  #-------------------------------------

  # Initial capital
  start.capital = start_capital

  # Investment
  annual.mean.return = annual_mean_return / 100
  annual.ret.std.dev = annual_ret_std_dev / 100

  # Inflation
  annual.inflation = annual_inflation / 100
  annual.inf.std.dev = annual_inf_std_dev / 100

  # Withdrawals
  monthly.withdrawals = monthly_withdrawals

  # Number of observations (in Years)
  n.obs = n_obs

  # Number of simulations
  n.sim = n_sim

  #-------------------------------------
  # Simulation
  #-------------------------------------

  # number of months to simulate
  n.obs = 12 * n.obs

  # monthly Investment and Inflation assumptions
  monthly.mean.return = annual.mean.return / 12
  monthly.ret.std.dev = annual.ret.std.dev / sqrt(12)

  monthly.inflation = annual.inflation / 12
  monthly.inf.std.dev = annual.inf.std.dev / sqrt(12)

  # simulate Returns
  monthly.invest.returns = matrix(0, n.obs, n.sim)
  monthly.inflation.returns = matrix(0, n.obs, n.sim)

  monthly.invest.returns[] = rnorm(n.obs * n.sim, mean = monthly.mean.return, sd = monthly.ret.std.dev)
  monthly.inflation.returns[] = rnorm(n.obs * n.sim, mean = monthly.inflation, sd = monthly.inf.std.dev)

  # simulate Withdrawals
  nav = matrix(start.capital, n.obs + 1, n.sim)
  for (j in 1:n.obs) {
    nav[j + 1, ] = nav[j, ] * (1 + monthly.invest.returns[j, ] - monthly.inflation.returns[j, ]) - monthly.withdrawals
  }

  # once nav is below 0 => run out of money
  nav[ nav < 0 ] = NA

  # convert to millions
  nav = nav / 1000000

  return(nav)
}

plot_nav <- function(nav) {

  layout(matrix(c(1,2,1,3),2,2))

  palette(c("black", "grey50", "grey30", "grey70", "#d9230f"))

  # plot all scenarios
  matplot(nav,
    type = 'l', lwd = 0.5, lty = 1, col = 1:5,
    xlab = 'Months', ylab = 'Millions',
    main = 'Projected Value of Initial Capital')

  # plot % of scenarios that are still paying
  p.alive = 1 - rowSums(is.na(nav)) / ncol(nav)

  plot(100 * p.alive, las = 1, xlab = 'Months', ylab = 'Percentage Paying',
    main = 'Percentage of Paying Scenarios', ylim=c(0,100))
  grid()

  last.period = nrow(nav)

  # plot distribution of final wealth
  final.nav = nav[last.period, ]
  final.nav = final.nav[!is.na(final.nav)]

  if(length(final.nav) ==  0) return()

  plot(density(final.nav, from=0, to=max(final.nav)), las = 1, xlab = 'Final Capital',
    main = paste0('Distribution of Final Capital\n', 100 * p.alive[last.period], '% are still paying'))
  grid()
}


df <- data.frame(x=1:10, y=(1:10)+rnorm(n=10))
print(df)
print(lm(y ~ x, df))


source('positiveNumberValidator.r')

rent = setRefClass("rent",
  contains = "positiveNumberValidator",
  fields = list(
    monthlyCost = 'numeric',
    yearlyIncrease = 'numeric',
    numberYears = 'numeric',
    totalSpent = 'numeric'
  ),
  methods = list(
    initialize = function(mC, yI, nY){
      validateInputs(mC, yI, nY)

      monthlyCost <<- mC
      yearlyIncrease <<- yI
      numberYears <<- nY

      calculateTotalRentSpent(monthlyCost, yearlyIncrease, numberYears)
    },
    calculateTotalRentSpent = function(mC, yI, nY){
      total = 0
      currentMonthlyCost = mC
      for (year in 1:nY) {
         total = total + currentMonthlyCost * 12
         currentMonthlyCost = currentMonthlyCost * (1 + yI / 100)
      }
      totalSpent <<- total
    },
    validateInputs = function(mC, yI, nY){
      validateNumber(mC)
      validateNumber(yI)
      validateNumber(nY)
    }
  )
)

renderRentInput = function(title, mcId, yiId, nId){
  fluidRow(
    column(12,
      h4(title, style = "margin-top: 0px; border-bottom: 1px solid #e3e3e3;"),
      numericInput(mcId, "Monthly Costs ($)", 3000, min = 0),
      numericInput(yiId, "Yearly Increase (%)", 0, min = 0),
      sliderInput(nId, label = "Number of years", min = 1,
        max = 50, value = 25, width = "100%")
    )
  )
}


# Analysis: Hospitals service areas vs google's fastest route

library(Epi)
library(lmtest)
library(ggplot2)
library(tidyverse)

# The effect of the method chosen on ambulance time to arrival

model_one = glm(time ~ strategy + distance,
                family = gaussian(),
                data = time_by_strategy)

summary(model_one)
round(ci.lin(model_one),4)

# Interpretation:
# Overall, after adjusting for the distance, using google's fastest route
# takes out 17 seconds on the average trip duration

# ---------------------------------------------------------------------------------

# Analysis stratified by distance between each place to the hospital of its service
# area

for (i in 0:11) {
  model_i = glm(time ~ strategy,
                subset = time_by_method$group == i,
                family=gaussian(),
                data=time_by_strategy)
  print(round(ci.lin(model_i),2))
}

#   Strata               Estimate  p-val  lowerCI  upperCI Samples
# group 0:  methodfastest   00.00      1    -8.64     8.64     562
# group 1:  methodfastest  -00.85    0.8    -7.35     5.66    2094
# group 2:  methodfastest  -15.80      0   -22.72    -8.88    2446
# group 3:  methodfastest  -81.21      0   -93.64   -68.77    1258
# group 4:  methodfastest  -98.39      0  -122.27   -74.51     502
# group 5:  methodfastest -100.26      0  -155.90   -44.63     106
# group 6:  methodfastest  -72.00   0.34  -219.94    75.94      22
# group 7:  methodfastest   -51.3   0.28  -145.07    42.47      40
# group 8:  methodfastest  -62.64   0.02  -117.23    -8.05      22
# group 9:  methodfastest -130.86      0  -168.47   -93.24      42
# group 10: methodfastest -132.33      0  -178.19   -86.48       6
# group 11: methodfastest  -770.0      0  -779.70  -760.30       4

# Interpretetion
# For each strata of data according to the distance to the referenc hospital, the
# effect of the method is significant and grater in those farthest.

# ---------------------------------------------------------------------------------

# Change in the number of people that are under 10 minutes away from a hospital

model_two = glm(under ~ strategy + distance,
                family = quasipoisson(),
                data = time_by_strategy)

summary(model_two)
round(ci.lin(model_two, Exp=T),4)

# Interpretation
# Using gmaps strategy, people that are under 10 minutes away from a hospital grow
# by 7% (202.211 persons)

# ---------------------------------------------------------------------------------

# Time save for those city blocks that changed their target hospital

model_thr = glm(time ~ strategy + distance,
                family=gaussian(),
                data=filter(time_by_strategy, change == 1))

summary(model_thr)
round(ci.lin(model_thr, Exp=F),4)

# Interpretation
# For those places where google maps routing service found a faster hospital other
# than the hospitla from the referral area, the time saved was 109 seconds (CI95:
# -119 - -99 seconds).

# ---------------------------------------------------------------------------------

# Model with the best fit

best_fit = lm(time ~ strategy * poly(distance, 2),
              data=time_by_strategy)

# Adjusted Rsqr = 0.845
summary(best_fit)
time_by_method$predict = predict(best_fit)

# ---------------------------------------------------------------------------------

# Visualizations

# time by distance with results from predictions drawn with best_fit model
ggplot(time_by_strategy) +
  geom_point(aes(distance, time, color=strategy), alpha=1, size=0.01) +
  geom_line(aes(distance, predict, group=strategy))


#' sunposition
#'
#' @description Function to assess sun azimuth and elevation given the time in GMT format.
#'
#' @param timenow time indicat in time format equivalent to "POSIXct" or "POSIXt" object.
#' @param  lat numeric latitude in decimal degrees
#' @param lon numeric  longitude in decimal degrees
#' @references
#' Istituto di Biometeorologia Firenze Italy
#' Centro Interdipartimentale di Bioloclimatologia University of Florence
#' \url{http://stackoverflow.com/questions/8708048/position-of-the-sun-given-time-of-day-latitude-and-longitude}
#' @author  Alfonso crisci \email{a.crisci@@ibimet.cnr.it} Marco Morabito \email{m.morabito@@unifi.it}
#'
#'
#' @export

sunposition <- function(timenow,lat, long) {

    time=as.POSIXlt(timenow, "GMT")
    year=as.numeric(format(time,"%Y"))
    hour=as.numeric(format(time,"%H"))
    day=as.numeric(format(time,"%d"))
    month=as.numeric(format(time,"%m"))
    min=as.numeric(format(time,"%M"))
    sec=as.numeric(format(time,"%S"))

    twopi <- 2 * pi
    deg2rad <- pi / 180

    # Get day of the year, e.g. Feb 1 = 32, Mar 1 = 61 on leap years

    month.days <- c(0,31,28,31,30,31,30,31,31,30,31,30)
    day <- day + cumsum(month.days)[month]
    leapdays <- year %% 4 == 0 & (year %% 400 == 0 | year %% 100 != 0) &
                day >= 60 & !(month==2 & day==60)
    day[leapdays] <- day[leapdays] + 1

    # Get Julian date - 2400000
    hour <- hour + min / 60 + sec / 3600 # hour plus fraction
    delta <- year - 1949
    leap <- trunc(delta / 4) # former leapyears
    jd <- 32916.5 + delta * 365 + leap + day + hour / 24

    # The input to the Atronomer's almanach is the difference between
    # the Julian date and JD 2451545.0 (noon, 1 January 2000)
    time <- jd - 51545.

    # Ecliptic coordinates

    # Mean longitude
    mnlong <- 280.460 + .9856474 * time
    mnlong <- mnlong %% 360
    mnlong[mnlong < 0] <- mnlong[mnlong < 0] + 360

    # Mean anomaly
    mnanom <- 357.528 + .9856003 * time
    mnanom <- mnanom %% 360
    mnanom[mnanom < 0] <- mnanom[mnanom < 0] + 360
    mnanom <- mnanom * deg2rad

    # Ecliptic longitude and obliquity of ecliptic
    eclong <- mnlong + 1.915 * sin(mnanom) + 0.020 * sin(2 * mnanom)
    eclong <- eclong %% 360
    eclong[eclong < 0] <- eclong[eclong < 0] + 360
    oblqec <- 23.439 - 0.0000004 * time
    eclong <- eclong * deg2rad
    oblqec <- oblqec * deg2rad

    # Celestial coordinates
    # Right ascension and declination
    num <- cos(oblqec) * sin(eclong)
    den <- cos(eclong)
    ra <- atan(num / den)
    ra[den < 0] <- ra[den < 0] + pi
    ra[den >= 0 & num < 0] <- ra[den >= 0 & num < 0] + twopi
    dec <- asin(sin(oblqec) * sin(eclong))

    # Local coordinates
    # Greenwich mean sidereal time
    gmst <- 6.697375 + .0657098242 * time + hour
    gmst <- gmst %% 24
    gmst[gmst < 0] <- gmst[gmst < 0] + 24.

    # Local mean sidereal time
    lmst <- gmst + long / 15.
    lmst <- lmst %% 24.
    lmst[lmst < 0] <- lmst[lmst < 0] + 24.
    lmst <- lmst * 15. * deg2rad

    # Hour angle
    ha <- lmst - ra
    ha[ha < -pi] <- ha[ha < -pi] + twopi
    ha[ha > pi] <- ha[ha > pi] - twopi

    # Latitude to radians
    lat <- lat * deg2rad

    # Azimuth and elevation
    el <- asin(sin(dec) * sin(lat) + cos(dec) * cos(lat) * cos(ha))
    az <- asin(-cos(dec) * sin(ha) / cos(el))

    # For logic and names, see Spencer, J.W. 1989. Solar Energy. 42(4):353

    cosAzPos <- (0 <= sin(dec) - sin(el) * sin(lat))
    sinAzNeg <- (sin(az) < 0)
    az[cosAzPos & sinAzNeg] <- az[cosAzPos & sinAzNeg] + twopi
    az[!cosAzPos] <- pi - az[!cosAzPos]

    el <- el / deg2rad
    az <- az / deg2rad
    lat <- lat / deg2rad

    return(list(elevation=el, azimuth=az))
}


 E04TCJ Example Program Results

 First solve the problem with the outliers

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             1.05037E+00
 Norm of gradient                   8.78014E-06
 Norm of scaled gradient            6.05781E-06
 Norm of step                       1.47886E-01

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1       -inf        3.61301E-01        inf
     2       -inf        9.10227E-01        inf
     3       -inf        3.42138E-03        inf
     4       -inf       -6.08965E+00        inf
     5       -inf        6.24881E-04        inf
 --------------------------------------------------------

 Now remove the outlier residuals from the problem handle

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             5.96811E-02
 Norm of gradient                   1.19914E-06
 Norm of scaled gradient            3.47087E-06
 Norm of step                       3.49256E-06

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1       -inf        3.53888E-01        inf
     2       -inf        1.06575E+00        inf
     3       -inf        1.91383E-03        inf
     4       -inf        2.17299E-01        inf
     5       -inf        5.17660E+00        inf
 --------------------------------------------------------

 Assuming the outliers points are measured again
 we can enable the residuals and adjust the values

 --------------------------------------------------------
 E04GG, Nonlinear least squares method for bound-constrained problems
 Status: converged, an optimal solution was found
 Value of the objective             6.51802E-02
 Norm of gradient                   2.57338E-07
 Norm of scaled gradient            7.12740E-07
 Norm of step                       1.56251E-05

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   3.00000E-01    3.00000E-01    3.00000E-01
     2       -inf       1.06039E+00         inf
     3       -inf       2.11765E-02         inf
     4       -inf       2.11749E-01         inf
     5       -inf       5.16415E+00         inf


R version 3.3.0 (2016-05-03) -- "Supposedly Educational"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 install.packages("quantmod")
 library(quantmod)
 install.packages("lubridate")
 library(lubridate)
 install.packages("e1071")
 library(e1071)

 startDate = as.Date("2012-01-01")

 endDate = as.Date("2014-01-01")

 getSymbols("AAPL", env = .GlobalEnv, src = "yahoo", from = startDate, to = endDate)

 weekDays <- wday(AAPL, label=TRUE)

 head(weekDays)

 changeInPrices <- Cl(AAPL) - Op(AAPL)

 head(changeInPrices)

 summary(changeInPrices)

 dim(changeInPrices)

 binaryClassification <- ifelse(changeInPrices>0,"UP","DOWN")

 binaryClassification

 summary(binaryClassification)

 AAPLDataSet <- data.frame(weekDays,binaryClassification)

 AAPLDataSet

 head(AAPLDataSet)

 dim(AAPLDataSet)

 NaiveBayesclassifier <- naiveBayes(AAPLDataSet[,1], AAPLDataSet[,2])

 NaiveBayesclassifier

 exponentialMovingAverage5 <- EMA(Op(AAPL),n = 5)

 exponentialMovingAverage5

 summary(exponentialMovingAverage5)

 exponentialMovingAverage10 <-EMA(Op(AAPL),n = 10)

 exponentialMovingAverage10

 summary(exponentialMovingAverage10)

 dim(exponentialMovingAverage10)

 exponentialMovingAverageDiff <- exponentialMovingAverage5 - exponentialMovingAverage10

 exponentialMovingAverageDiff

 summary(exponentialMovingAverageDiff)

 exponentialMovingAverageDiffRound <- round(exponentialMovingAverageDiff, 2)

 summary(exponentialMovingAverageDiffRound)

 AAPLDataSetNew <- data.frame(weekDays,exponentialMovingAverageDiffRound, binaryClassification)

 AAPLDataSetNew

 summary(AAPLDataSetNew)

 AAPLDataSetNew <- AAPLDataSetNew[-c(1:10),]

 AAPLDataSetNew

 summary(AAPLDataSetNew)

 dim(AAPLDataSetNew)

 trainingDataSet <- AAPLDataSetNew[1:328,]

 dim(trainingDataSet)

 summary(trainingDataSet)

 TestDataSet <- AAPLDataSetNew[329:492,]

 dim(TestDataSet)

 summary(TestDataSet)

 exponentialMovingAverageDiffRoundModel <- naiveBayes(trainingDataSet[,1:2],trainingDataSet[,3])

 exponentialMovingAverageDiffRoundModel

 table(predict(exponentialMovingAverageDiffRoundModel,TestDataSet),TestDataSet[,3],dnn=list('Predicted','Actual'))

Chapter 06/4Naive Bayes - Predicting the Direction of Stock Movement.r


#' Linear Model Coefficients
#'
#' Coefficients of the linear model.
#'
#' @details
#' The model is fit using a QR factorization of the input \code{x}. At this
#' time, that means
#'
#' Both of \code{x} and \code{y} must be distributed in an identical fashion.
#' This means that the number of rows owned by each MPI rank should match, and
#' the data rows \code{x} and labels \code{y} should be aligned.  Additionally,
#' each MPI rank should own at least one row.  Ideally they should be load
#' balanced, so that each MPI rank owns roughly the same amount of data.
#'
#' @section Communication:
#' The operation has the same communication as
#'
#' @param x,y
#' The input data \code{x} and response \code{y}.  Each must be a shaq, and
#' each must be distributed in an identical fashion.  See the details section
#' for more information.
#' @param tol
#' Numerical tolerance for deciding rank.
#'
#' @return
#' A regular vector.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' comm.set.seed(1234, diff=TRUE)
#'
#' x = ranshaq(rnorm, 10, 3)
#' y = ranshaq(runif, 10)
#'
#' fit = lm_coefs(x, y)
#' comm.print(fit)
#'
#' finalize()
#' }
#'
#' @seealso \code{\link{glms}}
#' @name lm_coefs
#' @export
lm_coefs = function(x, y, tol=1e-7)
{
  check.is.shaq(x)
  check.is.shaq(y)

  R = qr_R(x)
  Q = qr_Q(x, R)

  ### NOTE here we assume that x (and hence Q) and y are distributed in identical fashion!
  qty = allreduce(crossprod(Data(Q), Data(y)))
  rank = max(which(abs(diag(R)) > tol))

  if (rank < ncol(x))
  {
    ind = 1:rank
    coefs = solve(R[ind, ind], qty[ind])
    coefs = c(coefs, rep(NA_real_, ncol(x)-rank))
  }
  else
    coefs = solve(R, qty)

  if (ncol(y) == 1)
  {
    dim(coefs) = NULL
    names(coefs) = paste0("x", 1:ncol(x))
  }
  else
    rownames(coefs) = paste0("x", 1:ncol(x))

  coefs
}


# Eric Anderson
#
# Spline interpolate rain gauge data to 0.1
# degree grids and save to .csv
#
# Version 1.0
# 8 April 2015
#
# The purpose of this program is to ingest .csv
# rainfall data for one day, interpolate them to
# 0.1 degree grid spacing, and save them to
# another .csv.

# load libraries
library(maptools) # autoloads sp
library(raster)
library(rgeos)
library(rgdal)
library(akima)
library(fields)

# set workspace
setwd("C:/Users/Eric/Dropbox/ESS508_Python/r_assign")

# Create area of interest for masking final interpolation (and
# extrapolation if necessary)
# This file should stay the same
aoi <- readShapePoly("aoi_sv_buff10_gcs.shp")

# Create vectors for x and y grid spacing. This will only need to # be created once per area to interpolate.
ygrids <- seq(13,14.5,0.1) # ~10km
xgrids <- seq(-90.2,-87, 0.1) # ~10km

# Load station data points (this file will be different every day)
# Note that this may include missing gauge data, but it must be stored as "NaN"
pluv_raw <- read.csv(file="daily_rain.csv")

# Remove rows with missing rain data
pluv <- pluv_raw[complete.cases(pluv_raw),]

print("Rain gauge data read and missing data removed.",quote=0)

# Load coordinates to be interpolated
# This file will only need to be created once per area to interpolate
pt <- read.csv(file="coords.csv")
coordinates(pt)= ~ longitude+ latitude

# Interpolate the pluviometer data to surface rasters
    ## Pick ONE of the following interpolation techniques by setting extLogical to TRUE or FALSE
   extLogical <- TRUE  # if extLogical is true, spline is used (linLogical is false)
   #extLogical <- FALSE  # if extLogical is false, linear is used (see akima documentation).
    # set linLogical to true or false based on extrapolation choice
    if (extLogical == TRUE) linLogical <- FALSE
    if (extLogical == FALSE) linLogical <- TRUE

# Define x, y (same for every day) and interpolated z values (different for every day)
x<- pluv[,4]; y<- pluv[,3]; z<- pluv[,5]
interpex <- mask(raster(interp(x,y,z, linear=linLogical, extrap=extLogical, xo=xgrids, yo=ygrids)),aoi)

# Tell me I'm finished and how to plot an image
print("Interpolation complete. Use plot(interpex) command to see results in R console.",quote=0)

# Stack interpolated rasters... (only needed if many days are to be prepared at the same time)
rStack = stack(interpex)

# Perform the value extraction on the raster stack
# (extracts interpolated rain values from raster to the 0.1 degree-spaced points)
rVal = extract(rStack,pt)
rVal[rVal<0] <- 0		#replace all negative values to 0 (artifact of extrapolating to edge)

# Combine these extracted results with the lat/lon of 0.1 degree-spaced csv points
write.table(cbind(pt,data.frame(rVal)),file="pluv_daily_spline.csv", append=FALSE, sep= ",", row.names=FALSE, col.names=TRUE)

print("Program complete. Output saved to pluv_daily_spline.csv.",quote=0)
# Program complete.


uid<-c(1,2,3,4)
marks<-c(40,30,50,45)
op<-lm(marks ~ uid)
print(op)
print(summary(op))
x<-data.frame(uid=6)
y<- predict(op,x)
print(y)
p<-lm(uid ~ marks)
print(p)
q<-data.frame(marks=50)
r<-predict(p,q)
print(r)
plot(uid,marks)
plot(uid,marks,col='blue')
plot(uid,marks,col='blue',main = 'uid&marks')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks',type = 'l')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks',type='h')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks',type='s')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks',type='c')
plot(uid,marks,col='blue',main = 'uid&marks',xlab = 'uid',ylab = 'marks',type='n')
age<-c(21,20,25,23)
height<-c(5.5,3.4,6,4.3)
x<-lm(age ~ height)
print(x)
plot(age,height)


#   Copyright (C) 2019  Dr. Norbert Bátfai, nbatfai@gmail.com
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>
#
# https://youtu.be/Koyw6IH5ScQ

library(neuralnet)

a1    <- c(0,1,0,1)
a2    <- c(0,0,1,1)
OR    <- c(0,1,1,1)

or.data <- data.frame(a1, a2, OR)

nn.or <- neuralnet(OR~a1+a2, or.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.or)

compute(nn.or, or.data[,1:2])

a1    <- c(0,1,0,1)
a2    <- c(0,0,1,1)
OR    <- c(0,1,1,1)
AND   <- c(0,0,0,1)

orand.data <- data.frame(a1, a2, OR, AND)

nn.orand <- neuralnet(OR+AND~a1+a2, orand.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.orand)

compute(nn.orand, orand.data[,1:2])

a1      <- c(0,1,0,1)
a2      <- c(0,0,1,1)
EXOR    <- c(0,1,1,0)

exor.data <- data.frame(a1, a2, EXOR)

nn.exor <- neuralnet(EXOR~a1+a2, exor.data, hidden=0, linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.exor)

compute(nn.exor, exor.data[,1:2])

a1      <- c(0,1,0,1)
a2      <- c(0,0,1,1)
EXOR    <- c(0,1,1,0)

exor.data <- data.frame(a1, a2, EXOR)

nn.exor <- neuralnet(EXOR~a1+a2, exor.data, hidden=c(6, 4, 6), linear.output=FALSE, stepmax = 1e+07, threshold = 0.000001)

plot(nn.exor)

compute(nn.exor, exor.data[,1:2])


partition<-function(low,high){
  pivot<-arr[high]
  i=low-1
  for(j in low:(high-1)){
    if(arr[j]<=pivot){
      i=i+1
      temp<-arr[i]
      arr[i]<<-arr[j]
      arr[j]<<-temp
    }
  }
  temp<-arr[i+1]
  arr[i+1]<<-arr[high]
  arr[high]<<-temp
  return(i+1)
}
sort<-function(low,high){
  if(low<high){
  pi<-partition(low,high)
  sort(low,pi-1)
  sort(pi+1,high)
}
}
arr<-c(10,80,30,90,40,50,70)
sort(1,length(arr))
print(arr)


# Day 13: Transparent Origami

get_day13_input_path <- function() {
    paste(getwd(), "/2021/Day 13/Day13_input.txt", sep = "")
}

highest_x <- 0
highest_y <- 0

part1 <- function(num_folds = 1) {
    readings <- readLines(get_day13_input_path())

    dots <- readings[1:799]
    directions <- strsplit(readings[801:length(readings)], " ")
    set_dimensions(dots)

    grid <- matrix(".", ncol = highest_x, nrow = highest_y)

    for (d in seq_len(length(dots))) {
        dot <- strtoi(unlist(strsplit(dots[d], ","))) + 1
        grid[dot[2], dot[1]] <- "#"
    }

    for (f in seq_len(length(directions))) {
        grid <- fold_grid(grid, directions[f])

        if (f == num_folds) {
            break
        }
    }

    print(sum(grid == "#"))

    if (num_folds > 1) {
        print(grid)
        # EFJKZLBL
    }
}

part2 <- function() {
    part1(100)
}

set_dimensions <- function(dots) {
    for (i in seq_len(length(dots))) {
        dot <- strtoi(unlist(strsplit(dots[i], ","))) + 1
        if (highest_x < dot[1]) {
            highest_x <<- dot[1]
        }
        if (highest_y < dot[2]) {
            highest_y <<- dot[2]
        }
    }
}

fold_grid <- function(grid, direction) {
    parsed_dir <- unlist(strsplit(unlist(direction)[3], "="))

    if (parsed_dir[1] == "x") {
        grid <- x_fold(grid, strtoi(parsed_dir[2]) + 1)
    } else {
        grid <- y_fold(grid, strtoi(parsed_dir[2]) + 1)
    }

    grid
}

x_fold <- function(grid, fold_line) {
    right_fold <- grid[, (fold_line + 1):highest_x]
    right_fold_bound <- highest_x - fold_line
    right_fold_mirror <- right_fold[, c(right_fold_bound:1)]

    left_fold <- grid[, 1:(fold_line - 1)]

    for (i in seq_len(nrow(left_fold))) {
        for (j in seq_len(ncol(left_fold))) {
            if (left_fold[i, j] == "#") {
                next
            } else {
                left_fold[i, j] <- right_fold_mirror[i, j]
            }
        }
    }

    highest_x <<- ncol(left_fold)
    left_fold
}

y_fold <- function(grid, fold_line) {
    down_fold <- grid[(fold_line + 1):highest_y, ]
    down_fold_bound <- highest_y - fold_line
    down_fold_mirror <- down_fold[c(down_fold_bound:1), ]

    up_fold <- grid[1:(fold_line - 1), ]

    for (i in seq_len(nrow(up_fold))) {
        for (j in seq_len(ncol(up_fold))) {
            if (up_fold[i, j] == "#") {
                next
            } else {
                up_fold[i, j] <- down_fold_mirror[i, j]
            }
        }
    }

    highest_y <<- nrow(up_fold)
    up_fold
}

part1()
part2()


library(dplyr)
library(ggplot2)

data(package='plyr', 'baseball')

# First need to create new variables that capture the number of years
# a player has played, and for each year, how far through their career
# they are.

# This is straightforward using the techniques we just learned
b2 <- tbl_df(baseball) %>%
  group_by(id) %>%
  mutate(cyear = year - min(year) + 1,
         career = (cyear - 1) / max(cyear))
b2

# Now what sort of model should we use?
bruth <- subset(b2, id == "ruthba01")
qplot(career, g, data = bruth, geom = "line")
qplot(career, g, data = b2, geom="boxplot", group = plyr::round_any(career, 0.05))

# Could we model that as two straight lines?
bruth$p <- (bruth$career - 0.5) * 100
mod <- lm(g ~ p + p:I(p > 0), data = bruth)
bruth$ghat <- predict(mod)
qplot(career, g, data = bruth, geom = "line") +
  geom_line(aes(y = ghat), colour = "red")

# It doesn't look great, but it's a start
# Let's fit that model to every player
b2$p <- (b2$career - 0.5) * 100

models <- b2 %>% do(model=lm(data=., formula = g ~ p + p:I(p > 0)))
# Or a bit more explicitly
models <- b2 %>% do(model=(function(df) lm(data=df, g ~ p + p:I(p > 0)))(.))

nrow(models)
onem <- models[[1, 'model']]
onem
summary(onem)

coefs <- as.list(coef(onem))
names(coefs) <- c("mid", "inc", "dec")
rsq <- summary(onem)$r.squared

get_coefs <- function(model) {
  coefs <- as.list(coef(model))
  names(coefs) <- c("mid", "inc", "dec")
  data.frame(coefs, rsq = summary(model)$r.squared)
}

coefs <- models %>% do(get_coefs(.$model))

qplot(rsq, data = coefs, geom = "histogram", binwidth = 0.02)
qplot(mid, data = coefs, geom = "histogram", binwidth = 5)
qplot(inc, data = coefs, geom = "histogram", binwidth = 0.2)
qplot(dec, data = coefs, geom = "histogram", binwidth = 0.2)

qplot(rsq, inc, data=coefs)
qplot(dec, inc, data=coefs, colour=rsq)


library(Sleuth3)
library(ggplot2)

head(case0501)
summary(case0501$Diet)
qplot(Diet,Lifetime,data=case0501,geom="boxplot")
case0501.aov<-aov(Lifetime~Diet,data=case0501)
case0501.aov
anova(case0501.aov)

t.test(Depth~Year,data=case0201,var.equal=TRUE)
case0201.aov<-aov(Depth~Year,data=case0201)
anova(case0201.aov)
(-4.5833)^2
0.97304^2
166.638/176

nrow(case0501) # Find total sample size
length(unique(case0501$Diet)) # How many different groups?

2546.8/44.6


#!/usr/bin/Rscript

library(testthat, quietly=T)
library(bestSubsetGA, quietly=T)
library(doMC, quietly=T)
registerDoMC(cores=2)

modelSigma <- function(fitted_model) {
  summary(fitted_model)$sigma
}

generateIVs <- function(n) {
  data.frame( A=seq(1, n)
            , B=runif(n, 0, 10)
            , C=runif(n, 0, 10)
            , D=runif(n, -100, 100)
            , E=runif(n, 0, 10)
            , F=rnorm(n, 0, 1000)
            , H=runif(n, 0, 10)
            , I=runif(n, -10, 10)
            , J=rnorm(n, 0, 10)
            , K=runif(n, 0, 10)
            )
}

generateDV <- function(ivs) {
  29 + (3 * ivs$A) - (2 * ivs$C) + (3.5 * ivs$D) + rnorm(nrow(ivs), 0, 1)
}

set.seed(1)

ivs <- generateIVs(1000)
dv <- generateDV(ivs)

test_that("Minimizes linear model's random error", {
  min_subset <- bestSubset(dv, ivs, buildModel=lm, fitnessMetric=modelSigma,
                           likelihoodFn=invLog, n_generations=250, n_genes=50,
                           mutation_rate=0.005)
  expect_equal(min_subset, c(1, 2, 3, 4, 5, 8, 9))
})

test_that("Maximizes linear model's random error", {
  max_subset <- bestSubset(dv, ivs, buildModel=lm, fitnessMetric=modelSigma,
                           likelihoodFn=squared, minimize_fitness_metric=FALSE,
                           n_generations=250, n_genes=50, mutation_rate=0.005)
  expect_equal(max_subset, c(2, 3, 5, 6, 7, 8, 9, 10))
})

print("All tests passed.")


# Method
pow <- function(x, y)
{
   x <- as.numeric(x)
   y <- as.integer(y)
   prod(rep(x, y))
}
#Operator
"%pow%" <- function(x,y) pow(x,y)

pow(3, 4)    # 81
2.5 %pow% 2  # 6.25


#set working directory that consists distance matrix files in phylip format
library(phangorn)
library(dendextend)

dm_dn <- readDist(file="nd5_dn.txt", format = "phylip")
dm_in <- readDist(file="nd5_in.txt", format = "phylip")
dm_co <- readDist(file="nd5_clustal.mat", format = "phylip")

#par(mar=c(2.1, 4.1, 4.1, 2.1))

hc_dn <- hclust(as.dist(dm_dn), method = "average")
hcd_dn <- as.dendrogram(hc_dn)
#plot(hcd_dn, horiz=TRUE, main = "R/P-F DN", edge.root = TRUE)

hc_in <- hclust(as.dist(dm_in), method = "average")
hcd_in <- as.dendrogram(hc_in)
#plot(hcd_in, horiz=TRUE, main = "R/P-F IN", edge.root = TRUE)

hc_co <- hclust(as.dist(dm_co), method = "average")
hcd_co <- as.dendrogram(hc_co)
#plot(hcd_co, horiz=TRUE, main = "CLUSTAL O", edge.root = TRUE)

#--------------------------------------------------
cor_cophenetic(hcd_dn, hcd_co)
cor_cophenetic(hcd_in, hcd_co)

#Robinson-foulds
t_dn <- as.phylo(hcd_dn)
t_in <- as.phylo(hcd_in)
t_co <- as.phylo(hcd_co)
treedist(t_dn,t_co)
treedist(t_in,t_co)


fptcdf=function(z,x0max,chi,driftrate,sddrift) {
  if (x0max<1e-10) return(pnorm(chi/z,mean=driftrate,sd=sddrift,lower.tail=F))
  zs=z*sddrift ; zu=z*driftrate ; chiminuszu=chi-zu ; xx=chiminuszu-x0max
  chizu=chiminuszu/zs ; chizumax=xx/zs
  tmp1=zs*(dnorm(chizumax)-dnorm(chizu))
  tmp2=xx*pnorm(chizumax)-chiminuszu*pnorm(chizu)
  1+(tmp1+tmp2)/x0max
}

fptpdf=function(z,x0max,chi,driftrate,sddrift) {
  if (x0max<1e-10) return( (chi/z^2)*dnorm(chi/z,mean=driftrate,sd=sddrift))
  zs=z*sddrift ; zu=z*driftrate ; chiminuszu=chi-zu
  chizu=chiminuszu/zs ; chizumax=(chiminuszu-x0max)/zs
  (driftrate*(pnorm(chizu)-pnorm(chizumax)) +
    sddrift*(dnorm(chizumax)-dnorm(chizu)))/x0max
}

rlba=function(n,b,A,vs,s,t0,st0=0,truncdrifts=TRUE){
  n.with.extras=ceiling(n*(1+3*prod(pnorm(-vs))))
  drifts=matrix(rnorm(mean=vs,sd=s,n=n.with.extras*length(vs)),ncol=length(vs),byrow=TRUE)
  if (truncdrifts) {
    repeat {
      drifts=rbind(drifts,matrix(rnorm(mean=vs,sd=s,n=n.with.extras*length(vs)),ncol=length(vs),byrow=TRUE))
      tmp=apply(drifts,1,function(x) any(x>0))
      drifts=drifts[tmp,]
      if (nrow(drifts)>=n) break
    }
  }
  drifts=drifts[1:n,]
  drifts[drifts<0]=0
  starts=matrix(runif(min=0,max=A,n=n*length(vs)),ncol=length(vs),byrow=TRUE)
  ttf=t((b-t(starts)))/drifts
  rt=apply(ttf,1,min)+t0+runif(min=-st0/2,max=+st0/2,n=n)
  resp=apply(ttf,1,which.min)
  list(rt=rt,resp=resp)
}

dlba=function(t,t0,x0max,chi,v1,v0,sdI,truncdrifts=TRUE) {
  # Generates defective PDF for responses on node #1.
  # "truncdrifts" sets whether that part of the multi-variate
  # normal distribution on drift rates which would otherwise
  # lead to non-terminating trials is truncated.
  if(t < 0){
    drift = c(v0,v1)
  }else{
    drift = c(v1,v0)
  }
  t = abs(t)
  t = t - t0
  x0max = rep(x0max,2)
  chi = rep(chi,2)

  sdI = rep(drift,2)

  N=length(drift) # Number of responses.
  if (N>2) {
    tmp=array(dim=c(length(t),N-1))
    for (i in 2:N) tmp[,i-1]=fptcdf(z=t,x0max=x0max[i],chi=chi[i],
      driftrate=drift[i],sddrift=sdI[i])
    G=apply(1-tmp,1,prod)
  } else {
    G=1-fptcdf(z=t,x0max=x0max[2],chi=chi[2],driftrate=drift[2],sddrift=sdI[2])
  }
  out=G*fptpdf(z=t,x0max=x0max[1],chi=chi[1],driftrate=drift[1],sddrift=sdI[1])
  if (truncdrifts) {
    out=out/(1-prod(pnorm(-drift/sdI)))
    out[t<=0]=0
    out = pmax(out,1e-10)
    return(out)
  } else {
    out = pmax(out,1e-10)
    return(out)
  }
}

n1PDF=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts=TRUE) {
  N=length(drift) # Number of responses
  if (length(x0max)<N) x0max=rep(x0max,length.out=N)
  if (length(chi)<N) chi=rep(chi,length.out=N)
  if (length(sdI)<N) sdI=rep(sdI,length.out=N)
  if (length(st0)>1) st0=st0[1] # Only ONE non-decision time.
  if (st0==0) return(n1PDFfixedt0(t,x0max,chi,drift,sdI,truncdrifts=truncdrifts))
  tmpf=function(t,x0max,chi,drift,sdI,st0,truncdrifts)
    n1PDFfixedt0(t,x0max,chi,drift,sdI,truncdrifts=truncdrifts)/st0
  outs=numeric(length(t))
  for (i in 1:length(outs)) outs[i]=integrate(f=tmpf,lower=t[i]-st0/2,upper=t[i]+st0/2,
    x0max=x0max,chi=chi,drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value
  outs
}

n1CDF=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts=TRUE) {
  # Generates defective CDF for responses on node #1.
  N=length(drift) # Number of responses
  if (length(x0max)<N) x0max=rep(x0max,length.out=N)
  if (length(chi)<N) chi=rep(chi,length.out=N)
  if (length(sdI)<N) sdI=rep(sdI,length.out=N)
  if (length(st0)>1) stop("Only one value of st0 allowed.")
  if (st0<1e-6) st0=0 # Integral can fail for small st0.
  outs=numeric(length(t)) ; bounds=c(-st0/2,t)
  for (i in 1:length(t)) {
    tmp="error"
    repeat {
      if (bounds[i]>=bounds[i+1]) {outs[i]=0;break}
      tmp=try(integrate(f=n1PDF,lower=bounds[i],upper=bounds[i+1],subdivisions=1000,
        x0max=x0max,chi=chi,drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value,silent=T)
      if (is.numeric(tmp)) {outs[i]=tmp;break}
      # Try smart lower bound.
      if (bounds[i]<=0) {
	bounds[i]=max(c((chi-0.98*x0max)/(max(mean(drift),drift[1])+2*sdI)[1],0))
	next
      }
      # Try smart upper bound.
      if (bounds[i+1]==Inf) {
	bounds[i+1]=0.02*max(chi)/(mean(drift)-2*mean(sdI))
	next
      }
      stop("Error in n1CDF that I could not catch.")
    }
  }
  cumsum(outs)
}

n1mean=function(x0max,chi,drift,sdI,truncdrifts=TRUE) {
  # Generates mean RT for responses on node #1.
   pc=n1CDF(Inf,x0max,chi,drift,sdI,truncdrifts=truncdrifts)
   fn=function(t,x0max,chi,drift,sdI,st0=0,truncdrifts,pc)
     t*n1PDF(t,x0max,chi,drift,sdI,st0,truncdrifts=truncdrifts)/pc
   tmp=integrate(f=fn,lower=0,upper=100*chi,x0max=x0max,chi=chi,pc=pc,
     drift=drift,sdI=sdI,st0=st0,truncdrifts=truncdrifts)$value
   list(mean=tmp,p=pc)
}


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 2.6B   Chapter : 2.6   Pageno : 102
# Forward Elimination
library(pracma)
P<-matrix(c(1,1,1,1,1,2,3,4,1,3,6,10,1,4,10,20),ncol=4)
b<-c(1,0,0,0)
L<-lu(P)$L
U<-lu(P)$U
c<-solve(L,b)
x<-solve(U,c)
print("The solution is ")
print(x)


# Importamos librerías
rm(list=ls())
install.packages("FuzzyR")
library(FuzzyR)

# Iniciamos un nuevo objeto FIS (Fuzzy inference system)
etapa <- newfis("Variables")

# Creamos variables de ingreso con sus rangos
etapa <- addvar(etapa, "input", "edad", c(0,60))
etapa <- addvar(etapa, "input", "salario", c(0,1000))
etapa <- addvar(etapa, "input", "ingreso", c(2000,2021))
etapa <- addvar(etapa, "output", "apellidos", c(0,3))

# Creamos funciones de pertenencia trapezoidales y triangulares (inputs)
# Funciones "edad"
etapa <- addmf(etapa,"input", 1, "Joven", "trapmf", c(0,0,25,35) )
etapa <- addmf(etapa,"input", 1, "Adulto", "trimf", c(25,35,45))
etapa <- addmf(etapa,"input", 1, "Viejo", "trapmf", c(35,45,100,100) )

# Funciones "salario"
etapa <- addmf(etapa,"input", 2, "Bajo", "trapmf", c(0,0,400,650) )
etapa <- addmf(etapa,"input", 2, "Medio", "trimf", c(400,650,700))
etapa <- addmf(etapa,"input", 2, "Alto", "trapmf", c(650,700,1000,1000) )

# Funciones "ingreso"
etapa <- addmf(etapa,"input", 3, "Antiguo", "trapmf", c(0,0,2005,2011) )
etapa <- addmf(etapa,"input", 3, "Medio", "trimf", c(2005,2011,2014))
etapa <- addmf(etapa,"input", 3, "Reciente", "trapmf", c(2011,2014,2021,2021) )

# Funciones "cumple requisitos" (output)
etapa <- addmf(etapa,"output", 1, "no cumple requisitos", "trapmf", c(0,0,1,2) )
etapa <- addmf(etapa,"output", 1, "cumple requisitos", "trapmf", c(1,2,3,3))

# Dibujamos las funciones
plotmf(etapa,"input",1,xlab="Edad",ylab="Pertenencia",main="Edad")
plotmf(etapa,"input",2,xlab="Salario",ylab="Pertenencia",main="Dinero")
plotmf(etapa,"input",3,xlab="Antigüedad",ylab="Pertenencia",main="Ingreso")
plotmf(etapa,"output",1)

# Creamos las reglas que indican qué valor resulta para valores que se encuentren
# en cierto punto de las funciones de pertenencia, respondiendo a la pregunta
# “Cuáles son los apellidos de las personas jóvenes o recientemente empleadas,
# pero con sueldo alto”.
rulelist <- rbind(c(1,3,3,3,1,1),
                  c(1,3,2,2,1,1),
                  c(1,3,1,2,1,1),

                  c(2,3,3,2,1,1),
                  c(2,3,2,1,1,1),
                  c(2,3,1,1,1,1),

                  c(3,3,3,2,1,1),
                  c(3,3,2,1,1,1),
                  c(3,3,1,1,1,1)
        )

# Agregamos reglas al sistema difuso
etapa <- addrule(etapa, rulelist)

# Ingresamos valores a evaluar, que son los incluídos en la tabla del enunciado
matrixInput <- matrix(c(30,800,2010,
                        30,600,2010,
                        25,900,2004,
                        55,700,2016,
                        25,750,2015),ncol=3, byrow=TRUE)

# Realizamos la evaluación de los inputs usando el sistema difuso y sus resultados
# son entregados en la consola de R.
evalfis(matrixInput,etapa)


rm(list = ls())

library(tidyverse)
library(tidyquant)
library(timetk)
library(tibbletime)

symbols <-  c(
    "000001.SS",
    "600606.SS", # * Green Land Coporation Ltd
    "002499.SZ", # * Kelin Environmental Protection Equipment, Inc
    "000571.SZ", # * Sundiro Holding Co., Ltd.
    "002259.SZ", # * Sichuan Shengda Forestry Industry Co., Ltd
    "600666.SS", # * Aurora Optoelectronics Co.,Ltd
    "002356.SZ", # * Shenzhen Hemei Group Co.,LTD
    "600289.SS", # * Bright Oceans Inter-Telecom Corporation
    "002418.SZ", # * Zhe Jiang Kangsheng Co.,Ltd.
    "002766.SZ", # * Shenzhen Soling Industrial Co.,Ltd
    "000677.SZ"  # * CHTC Helon Co., Ltd
  )

prices <- getSymbols(symbols,
                     src = 'yahoo',
                     from = "2012-12-31",
                     to = "2020-04-16",
                     auto.assign = TRUE,
                     warnings = FALSE) %>%
  map(~Ad(get(.))) %>%
  reduce(merge) %>%
  `colnames<-`(symbols)

prices_weekly <- to.weekly(prices, indexAt = "last", OHLC = FALSE)

asset_returns_dplyr_byhand <- prices %>%
  to.monthly(indexAt = "last", OHLC = FALSE) %>%
  tk_tbl(preserve_index = TRUE, rename_index = "date") %>%
  gather(asset, returns, -date) %>%
  group_by(asset) %>%
  mutate(returns = (log(returns) - log(lag(returns)))) %>%
  spread(asset, returns) %>%
  select(date, symbols)

colnames(asset_returns_dplyr_byhand) <- c(
  "date",
  "Ind.Stock",
  "Comp1",
  "Comp2",
  "Comp3",
  "Comp4",
  "Comp5",
  "Comp6",
  "Comp7",
  "Comp8",
  "Comp9",
  "Comp10"
)

asset_returns_long_format <-
  asset_returns_dplyr_byhand %>%
  gather(asset, returns, -date)

plot <- asset_returns_long_format

ggplot(data = plot,
       aes(x = plot$date, y = plot$returns, color = asset)) + geom_line() +
  geom_point() +
  scale_x_date(date_labels="%b %y",date_breaks  ="3 month") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1), legend.position='none',
        axis.title.x = element_blank()) +
  geom_vline(xintercept = as.Date("2019-1-1", "%Y-%m-%d"), color = "red") +
  facet_grid(vars(asset),  scales = "free") + labs(y = "Return(log)")


R version 3.2.2 (2015-08-14) -- "Fire Safety"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
[Workspace loaded from ~/.RData]

 install.packages("markovchain")
 library(markovchain)

 RentalStates <- c("Downtown", "East", "West")

 RentalStates

 RentalTransitionMatrix <- matrix(c(0.3, 0.3, 0.4,
                                     0.4, 0.4, 0.2,
                                     0.5, 0.3, 0.2),
                                   byrow = T, nrow = 3, dimnames = list(RentalStates, RentalStates))

 RentalTransitionMatrix

 mcRental <- new("markovchain", states = RentalStates, byrow = T, transitionMatrix = RentalTransitionMatrix, name = "Rental Cars")

 mcRental

 mcRental[2]

 plot(mcRental)

 transitionProbability(mcRental, "East", "West")

 x <- 0.3 * 0.3
 y <- 0.3 * 0.4
 z <- 0.4 * 0.5
 x + y + z

 mcRental ^ 2

 mcRental^20

 mcRental ^ 30

 70 * steadyStates(mcRental)

 summary(mcRental)

 conditionalDistribution(mcRental, "Downtown")

 conditionalDistribution(mcRental, "West")

 conditionalDistribution(mcRental, "East")

Chapter 08/3Markov Chains - Car Rental Agency Service.r


#clear environment, load runjags.
rm(list = ls())
library(runjags)

#### Generate pseudo data ####
#10 sites, 9 plots per site, 10 observations per plot.
n.site <- 10
n.plot <- 9
n.core <- 10
siteID <- sort(rep(LETTERS[1:n.site],n.plot*n.core))
plotID <- rep(1:n.plot,n.site*n.core)
plotID <-paste(siteID,plotID,sep = '_')
site.means <- runif(n.site,10,25)
plot.means <- list()
for(i in 1:length(site.means)){
  plot.means[[i]] <- rnorm(n.plot,site.means[i],2)
}
plot.means <- unlist(plot.means)

#get observations for each plot, based on a mean, and a sd of 2
obs <- list()
for(i in 1:length(plot.means)){
  obs[[i]] <- rnorm(n.core, mean = plot.means[i], sd = 2)
}
x <- unlist(obs)

#create true data frame.
dat <- data.frame(siteID,plotID)
dat <- dat[order(plotID),]
dat$x <- x

#indexing.
plotindex <- as.factor(dat$plotID)
siteindex <- list()
for(i in 1:n.site){
  siteindex[[i]] <- rep(LETTERS[i],n.plot)
}
siteindex <- as.factor(unlist(siteindex))

#### Specify hierarchical JAGS model ####
jags.model = "
model {
#priors
global ~ dnorm(0,1.0E-4) #global level parameter prior.
site.tau ~ dgamma(0.1,0.1)
plot.tau ~ dgamma(0.1,0.1)
core.tau ~ dgamma(0.1,0.1)

for(i in 1:N.site){ site[i] ~ dnorm(global, site.tau)}            ## estimate global mean
for(j in 1:N.plot){ plot[j] ~ dnorm(site[siteindex[j]],plot.tau)} ## estimate site means
for(k in 1:N.core){ core[k] ~ dnorm(plot[plotindex[k]],core.tau)} ## estimate plot means

} #end model
"
##### specify JAGS data object. ####
jags.data <- list(core = dat$x,
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

#### Fit JAGS model ####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('plot','site'))
out <- summary(jags.out)

##### compare estimate plot/site means to true values. All w/in 95% credible interval. ####
par(mfrow = c(1,2))
fit.plot.means <- out[grep('plot',rownames(out)),][,4]
fit.site.means <- out[grep('site',rownames(out)),][,4]
plot(plot.means ~ fit.plot.means, main = 'plot-level fit'); abline(0,1,lwd=2, lty=2)
plot(site.means ~ fit.site.means, main = 'site-level fit'); abline(0,1,lwd=2, lty=2)

##### check uncertainty values #####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core.tau','plot.tau','site.tau','global'))
summary(jags.out)

##### create data with missing observations. #####
missing <- dat
#remove 3 observations within a plot in site A.
missing[2:4,3] <- NA
#remove an entire plot in site B.
missing[missing$plotID == 'B_1',3] <- NA
#remove all observations in site C.
missing[missing$siteID == 'C'  ,3] <- NA

##### create new jags data object for fitting missing data model. ####
jags.data <- list(core = missing$x,
                  N.site = length(unique(dat$siteID)),
                  N.plot = length(unique(dat$plotID)),
                  N.core = nrow(dat),
                  plotindex = plotindex, siteindex=siteindex)

##### Fit missing data model. ####
jags.out <- runjags::run.jags(jags.model,
                              data = jags.data,
                              n.chains = 3,
                              monitor = c('core','plot','site'))

out <- summary(jags.out)
comp <- dat
comp$pred <- out[grep('core',rownames(out)),4]
comp$removed <- missing$x
z <- comp[is.na(comp$removed),]

##### how are the core level predcitions compared to true values? in range. #####
cbind(out[2:4,],dat$x[2:4])

##### how about the missing plot? ####
zz <- cbind(out[grep('core',rownames(out)),],missing,dat$x)
zz[zz$plotID == 'B_1',]

##### how about the missing site? ####
zz[zz$siteID == 'C',]


library(nloptr)

get_expected = function(beta, tau1, tau2, N0, A0, observed_I=NULL) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  N0 : numeric
    Initial number of contagious patients.
  A0 : numeric
    Initial number of asymptomatic patients.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  tau1 : numeric
    Probability that an asymptomatic patient will turn contagious in the next
    time step.
  tau : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected : list
    Daily expected number of infectious (N), new asymptomatic (A), and new
    infectious (I) patients.
  "
  steps = length(beta)
  expected_I = rep(0, steps)
  expected_N = rep(0, steps)
  expected_A = rep(0, steps)
  N_previous = N0
  A_previous = A0
  for(t in 1:steps) {
    expected_I[t] = (1 - exp(-tau1)) * A_previous
    expected_A[t] = (exp(-tau1) * A_previous) + (beta[t] * N_previous)
    expected_N[t] = (exp(-tau2) * N_previous) + expected_I[t]
    if (is.null(observed_I)) { # history not available
      N_previous = expected_N[t]
    } else { # history available; use it
      N_previous = sum(c(N0, observed_I[1:t]) * rev(pexp(0:t, rate=tau2, lower.tail=FALSE)))
    }
    A_previous = expected_A[t]
  }
  return(list("N"=c(N0, expected_N), "A"=c(A0, expected_A), "I"=expected_I))
}

fit = function(observed_I, beta0, beta_min, beta_max, tau10, tau1_min,
               tau1_max, tau20, tau2_min, tau2_max, N00, N0_min, N0_max, A00,
               A0_min, A0_max, lambda, ignore_beta_diff, use_history, n_nloptr_iter=100000) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, tau10, tau20, N00, A00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), tau1_min, tau2_min, N0_min, A0_min)
  ub = c(rep(beta_max, steps), tau1_max, tau2_max, N0_max, A0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7, "maxeval" = n_nloptr_iter)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    tau1 = x[steps + 1]
    tau2 = x[steps + 2]
    N0 = x[steps + 3]
    A0 = x[steps + 4]
    # calculate loss
    if (use_history) {
      expected = get_expected(beta, tau1, tau2, N0, A0, observed_I)
    } else {
      expected = get_expected(beta, tau1, tau2, N0, A0)
    }

    regularization =  (diff(beta) / beta[1:(steps - 1)]) ^ 2
    regularization = regularization[!1:length(regularization) %in% ignore_beta_diff]
    observed_I = round(observed_I, 0)
    factSum = function(x) {
      return(sum(log(1:round(x, 0))))
    }
    loglikelihood = observed_I*log(expected$I)-expected$I-sapply(as.matrix(observed_I), FUN=factSum)
    loglikelihood[observed_I==0] = -expected$I[observed_I==0]
    return(-mean(loglikelihood) + lambda*mean(regularization))
  }
  result = nloptr(x0=x0, eval_f=loss, lb=lb, ub=ub, opts=opts)
  model = list(
    "R" = result$solution[1:steps] / result$solution[steps + 2],
    "beta" = result$solution[1:steps],
    "tau1" = result$solution[steps + 1],
    "tau2" = result$solution[steps + 2],
    "N0" = result$solution[steps + 3],
    "A0" = result$solution[steps + 4],
    "loss" = result$objective,
    "lambda" = lambda,
    "ignore_beta_diff" = ignore_beta_diff,
    "use_history" = use_history
  )
  regularization =  (diff(model$beta) / model$beta[1:(steps - 1)]) ^ 2
  regularization = regularization[!1:(steps - 1) %in% ignore_beta_diff]
  model$likelihood = (model$loss - lambda * mean(regularization)) * steps
  return(model)
}

fit_robust = function(observed_I, beta_min, beta_max, tau1_min, tau1_max,
                      tau2_min, tau2_max, N0_min, N0_max, A0_min, A0_max, lambda,
                      ignore_beta_diff, use_history, n_robust_iter, n_nloptr_iter) {
  best_loss = Inf
  best_model = NULL
  for (i in 1:n_robust_iter) {
    beta0 = runif(length(observed_I), beta_min, beta_max)
    tau10 = runif(1, tau1_min, tau1_max)
    tau20 = runif(1, tau2_min, tau2_max)
    N00 = runif(1, N0_min, N0_max)
    A00 = runif(1, A0_min, A0_max)
    model = fit(observed_I, beta0=beta0, beta_min=beta_min, beta_max=beta_max,
                tau10=tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=tau20,
                tau2_min=tau2_min, tau2_max=tau2_max, N00=N00, N0_min=N0_min,
                N0_max=N0_max, A00=A00, A0_min=A0_min, A0_max=A0_max,
                lambda=lambda, ignore_beta_diff=ignore_beta_diff,
                use_history=use_history, n_nloptr_iter=n_nloptr_iter)
    if (model$loss < best_loss) {
      best_model = model
      best_loss = model$loss
    }
  }
  best_model[["n_robust_iter"]] = n_robust_iter
  return(best_model)
}

search_best_model = function(observed_I, beta_min, beta_max, tau1_min, tau1_max,
                      tau2_min, tau2_max, N0_min, N0_max, A0_min, A0_max,
                      ignore_beta_diff, n_iter,search=FALSE) {
    best_loss = Inf
    best_model = NULL
    for (i in 1:n_iter) {
      beta0 = runif(length(observed_I), beta_min, beta_max)
      tau10 = runif(1, tau1_min, tau1_max)
      tau20 = runif(1, tau2_min, tau2_max)
      N00 = runif(1, N0_min, N0_max)
      A00 = runif(1, A0_min, A0_max)
      model = fit(observed_I, beta0=beta0, beta_min=beta_min, beta_max=beta_max,
                  tau10=tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=tau20,
                  tau2_min=tau2_min, tau2_max=tau2_max, N00=N00, N0_min=N0_min,
                  N0_max=N0_max, A00=A00, A0_min=A0_min, A0_max=A0_max,
                  lambda=0, ignore_beta_diff=ignore_beta_diff,n_iter=10000000)
      if (model$loss < best_loss) {
        best_model = model
        best_loss = model$loss
        best_param=list(
          "beta0"=beta0,
          "tau10"=tau10,
          "tau20"=tau20,
          "N00"=N00,
          "A00"=A00
        )
      }
    }
    if(search){
    p_value = 0
    c_left = 0
    c_right = 1e20
    p_values = 0
    cs = c_left
    while( 0.93 > p_value | 0.96 < p_value)
    {
      c = (c_left + c_right)/2
      model = fit(observed_I, beta0=best_model$beta, beta_min=beta_min, beta_max=max(beta_max,best_model$beta),
                  tau10=best_param$tau10, tau1_min=tau1_min, tau1_max=tau1_max, tau20=best_param$tau20,
                  tau2_min=tau2_min, tau2_max=tau2_max, N00=best_param$N00, N0_min=N0_min,
                  N0_max=N0_max, A00=best_param$A00, A0_min=A0_min, A0_max=A0_max,
                  lambda=c, ignore_beta_diff=ignore_beta_diff,n_iter=10)
      LRTest=2*(model$loss-best_loss)
      p_value=pchisq(LRTest,length(best_model$beta), lower.tail=TRUE)
      p_values = c(p_values,p_value)
      cs = c(cs,c)
      if(p_value < 0.95)
      {
       c_left = c
      }
      if(p_value > 0.96)
      {
        c_right = c
      }
    }
      return(model)
    }
    return(best_model)
    }


function(y,yfit,family=binomial(),variance=NULL)
{
  # Calculate the residual for given observed y and its fitted value yfit:
  # the length between y and yfit along the quardratic variance function:
  #           V(mu) = v2*mu^2+v1*mu+v0
  qvresidual<-function(y,yfit,v2,v1)
  {
    vpa <- 2*v2*yfit+v1
    svpa2 <- sqrt(1+vpa*vpa)

    vpb <- 2*v2*y+v1
    svpb2 <- sqrt(1+vpb*vpb)

    vr <- (log((vpb+svpb2)/(vpa+svpa2))+vpb*svpb2-vpa*svpa2)/(4*v2)
    vr
  }

  if( is.character(family) ) {
    cf <- family
    family <- get(family, mode="function", envir=parent.frame())
  } else
    cf <- family$family

  if( pmatch("Negative Binomial",cf,nomatch=F) )
  {
    theta <- as.numeric(gsub("(?<=\\()[^()]*(?=\\))(*SKIP)(*F)|.","", cf, perl=T))
    cf <- "negative.binomial"
  } else if( pmatch("Tweedie",cf,nomatch=F) )
  {
    dv <- Deriv(family$variance,"mu")
    theta <- dv(1)
  }

  if( is.null(variance) )
  {
    switch(cf,
      binomial={DFUN<-function(x) qvresidual(x[1],x[2],-1,1)}, # Need modify for Y~Bin(n,p)
      gaussian={DFUN<-function(x) x[1]-x[2]},
      Gamma={DFUN<-function(x) qvresidual(x[1],x[2],1,0)},
      negative.binomial={DFUN<-function(x) qvresidual(x[1],x[2],1/theta,1)},
      poisson={DFUN<-function(x) x[1]-x[2]},
      quasibinomial={DFUN<-function(x) qvresidual(x[1],x[2],-1,1)},
      quasipoisson={DFUN<-function(x) x[1]-x[2]},
      inverse.gaussian={
        DFUN<-function(x) integrate(function(mu){sqrt(1+9*mu^4)},x[1],x[2])$value},
      Tweedie={ # var.power: 0, 1, (1,2), 2, >2
        if( (theta==0)|(theta==1) )
          DFUN<-function(x) x[1]-x[2]
        else if( theta==2 )
          DFUN<-function(x) qvresidual(x[1],x[2],1,0)
        else
          DFUN<-function(x) integrate(function(mu){sqrt(1+theta^2*mu^(2*theta-2))},x[1],x[2])$value},
      quasi={  # variance for quasi: "constant","mu(1-mu)","mu","mu^2","mu^3", or other
        if( (family$varfun=="constant")|(family$varfun=="mu") )
          DFUN <- function(x) x[1]-x[2]
        else if( family$varfun=="mu(1-mu)" )
          DFUN<-function(x) qvresidual(x[1],x[2],-1,1)
        else if( family$varfun=="mu^2" )
          DFUN<-function(x) qvresidual(x[1],x[2],1,0)
        else
          DFUN<-function(x) integrate(function(mu){sqrt(1+Deriv(family$variance,"mu")^2)},x[1],x[2])$value})
  }
  else
    DFUN<-function(x) integrate(function(mu){sqrt(1+Deriv(variance,"mu")^2)},x[1],x[2])$value

  vresidual <- apply(cbind(y,yfit),1,DFUN)
}