# Loading libraries
if(!require("randomForest")) install.packages("randomForest")
if(!require("caTools")) install.packages("caTools")
if(!require("rpart")) install.packages("rpart")
if(!require("caret")) install.packages("caret",dependencies = T)
if(!require("rpart.plot")) install.packages("rpart.plot")
if(!require("ggplot2")) install.packages("ggplot2")
if(!require("gridExtra")) install.packages("gridExtra")
if(!require("mice")) install.packages("mice")
if(!require("quantreg")) install.packages("quantreg")
if(!require("pbkrtest")) install.packages("pbkrtest")
if(!require("VIM")) install.packages("VIM")
if(!require("corrplot")) install.packages("corrplot")
if (!require("RColorBrewer")) install.packages("RColorBrewer")
if (!require("ROCR")) install.packages("ROCR")
if(!require("party")) install.packages("party")

set.seed(108)
work_path = "D:/vaibhav/trend nxt/topgear/R Community/Predictive Model Based Logistic Regression-DrugData"
setwd(work_path)

# Loading & cleaning the dataset
data <- read.csv("Drug_data.csv", header=T, na.strings=c(""," ","NA"))
data$X=NULL
data<-data[!(is.na(data$ID)),] #  Last row is empty
original_data=data
head(data)
data$X=NULL
summary(data)
str(data)
nrow(data)
ncol(data)
any(is.na(data))
sum(is.na(data))

# HAving a look at missing data
md.pattern(data)
aggr_plot <- aggr(data, col=c('LightBlue','LightYellow'), numbers=TRUE, sortVars=TRUE, labels=names(data), cex.axis=.5,cex.numbers=.9, gap=1, ylab=c("Histogram of missing data","Pattern"))

# Replacing the NAs
hist(data$AGE)
boxplot(data$AGE)
Age =subset(data, is.na(data$AGE)== F,select=c(AGE))$AGE
range(Age)
mean(Age)
m=median(Age)
data$AGE[is.na(data$AGE)] = m

# cleaning further
data$ID= NULL
data$RACE= as.factor(data$RACE)
data$DFREE=as.factor(data$DFREE)

# Exploratory Analysis

plottable1=table(data$DFREE,data$IVHX)
barplot(plottable1, main="Drug Free vs IV Drug use History", xlab="Drug Use History",col=c("LightGreen","Grey"),legend=rownames(plottable1),beside = TRUE)
plottable2=table(data$DFREE,data$RACE)
barplot(plottable2, main="Drug Free vs Race", xlab="Race",col=c("LightGreen","Grey"),legend=rownames(plottable2),beside = TRUE)
plottable3=table(data$DFREE,data$Sex)
barplot(plottable3, main="Drug Free vs SEX", xlab="SEX",col=c("LightGreen","Grey"),legend=rownames(plottable3),beside = TRUE)
plottable4=table(data$DFREE,data$SITE)
barplot(plottable4, main="Drug Free vs Treatment Site", xlab="Treatment Site",col=c("LightGreen","Grey"),legend=rownames(plottable4),beside = TRUE)

# Correlation Analysis
numeric_features= data[c("AGE","BECK","NDRUGTX")]
corTable=cor(numeric_features)
corTable
corrplot( cor(as.matrix(numeric_features), method = "pearson", use = "complete.obs") ,is.corr = FALSE, type = "lower", order = "hclust", tl.col = "black", tl.srt = 360)

# Splitting the Data
set.seed(108)
split=sample.split(data$DFREE,SplitRatio = .7)
train=subset(data,split==T)
test=subset(data,split==F)

## Model Building & CV

# Before selecting attributes, we try to check the attributes significance
cf1 <- cforest(DFREE ~. , data=train, control=cforest_unbiased(mtry=2,ntree=50))
varimp(cf1) # get variable importance, based on mean decrease in accuracy

# GLM
model1=glm(DFREE~.-SITE-Sex-RACE,data=train,family = binomial)
predGlm=predict(model1,type="response",newdata=test)
summary(model1)
# Computing accuracy
table(test$DFREE,predGlm>.5)
(127+0)/(127+0+1+44)

# Decision Tree Model
set.seed(108)
numFolds = trainControl( method = "cv", number = 10 )
cpGrid = expand.grid( .cp = seq(0.01,0.5,0.01))
train(DFREE~AGE,data=train,method="rpart",trControl=numFolds,tuneGrid=cpGrid)
decisionTreeModel=rpart(DFREE~AGE,data=train,method="class",cp=.01)
rpart.plot(decisionTreeModel,extra=104, box.palette="GnBu",branch.lty=3, shadow.col="gray", nn=TRUE)
# Accuracy of Decision Tree
predDT=predict(decisionTreeModel,newdata = test,type = "class")
table(test$DFREE,predDT)
# Accuracy
(127+1)/(127+1+1+43)

# Random Forest
set.seed(108)
randomForestModel=randomForest(DFREE~.-SITE-Sex-RACE,data=train,ntree=100,nodesize=18)
predictRF=predict(randomForestModel,newdata=test)
table(test$DFREE,predictRF)
# Accuracy of RF
(126+3)/(126+3+2+41)

# AUC Calculation
glm_ROC=predict(model1,test,type="response")
pred_glm=prediction(glm_ROC,test$DFREE)
perf_glm=performance(pred_glm,"tpr","fpr")

dt_ROC=predict(decisionTreeModel,test)
pred_dt=prediction(dt_ROC[,2],test$DFREE)
perf_dt=performance(pred_dt,"tpr","fpr")

RF_ROC=predict(randomForestModel,test,type="prob")
pred_RF=prediction(RF_ROC[,2],test$DFREE)
perf_RF=performance(pred_RF,"tpr","fpr")

auc_glm <- performance(pred_glm,"auc")
auc_glm <- round(as.numeric(auc_glm@y.values),3)
print(paste('AUC of Logistic Regression:',auc_glm))

auc_dt <- performance(pred_dt,"auc")
auc_dt <- round(as.numeric(auc_dt@y.values),3)
print(paste('AUC of Decision Tree:',auc_dt))

auc_RF <- performance(pred_RF,"auc")
auc_RF <- round(as.numeric(auc_RF@y.values),3)
print(paste('AUC of Random Forest:',auc_RF))

# ROC Curves
plot(perf_glm, main = "ROC curves for the models", col='blue')
plot(perf_dt,add=TRUE, col='red')
plot(perf_RF, add=TRUE, col='green3')
legend('bottom', c("Logistic Regression", "Decision Tree", "Random Forest"), fill = c('blue','red','green3'), bty='n')

R Community/Predictive Model Based Logistic Regression-DrugData/code.r


library(readr)
library(plyr)

duracao <- read_csv("X:/Development/github.com/r_study/Alura/Analise de dados - Introducao com R/data/duracao.csv")
View(duracao)
duracao <- rename(duracao, replace = c("user_id"="aluno","course_id"="curso","timeToFinish"="dias"))

popularidade <- read_csv("X:/Development/github.com/r_study/Alura/Analise de dados - Introducao com R/data/popularidade.csv")
View(popularidade)
popularidade <- rename(popularidade, replace = c("course_id"="curso"))

plot(duracao$dias)

jpeg("X:/Development/github.com/r_study/Alura/Analise de dados - Introducao com R/output/histograma.jpg")
hist(duracao$dias, breaks = 20,main="Histograma do tempo", ylab = "Quantidade", xlab = "Tempo", ylim = c(0,2000),col="Blue")
dev.off()

mean(duracao$dias,na.rm = TRUE)
median(duracao$dias,na.rm = TRUE)

summary(duracao)
summary(duracao$dias)

#Faltantes %
faltantes <- sum(is.na(duracao$dias))/dim(duracao)[1]

cat(format(faltantes*100, nsmall = 2), "% dos dados não tem a duração de dias")

length(unique(duracao$curso))
length(unique(duracao$aluno))

sumario_estatistico <- setNames(aggregate(duracao$dias,list(duracao$curso),mean,na.rm=T),c("curso","duracao_mean"))
popularidade_e_duracao <- merge(sumario_estatistico,popularidade,by="curso")

plot(popularidade_e_duracao$duracao_mean,popularidade_e_duracao$freq)

modelo.linear <- lm(popularidade_e_duracao$freq~popularidade_e_duracao$duracao_mean)

abline(lm(popularidade_e_duracao$freq~popularidade_e_duracao$duracao_mean))

scatter.smooth(popularidade_e_duracao$duracao_mean,popularidade_e_duracao$freq,pch=21,col='blue')

library(ggplot2)

grafico <-ggplot(popularidade_e_duracao,aes(duracao_mean,freq))
grafico <- grafico + geom_point()
grafico <- grafico + geom_smooth()
grafico

Alura/Analise de dados - Introducao com R/analise_02.r


#https://github.com/binder-examples/r

library(dplyr)
library(stringr)
library(magrittr)

df = data.frame(x = rnorm(100), y = rbinom(100,1,0.2))
df %>% group_by(y) %>% summarise(n = n())

s = "hello darkness my old friend"
stringr::str_count(s,"e")


library(kernlab)
data(cars)
plot(cars$speed,cars$dist)
model<- rvm(cars$speed,cars$dist)
ytest<- predict(model,cars$speed)
lines(cars$speed,ytest,col="red")
models2<-rvm(cars$speed,cars$dist,cross=6,fit=T,interactions=1,tol=0.01)
ytest <- predict(models2,cars$speed)
lines(cars$speed,ytest,col="yellow")


#install.packages("ggplot2")
#install.packages("RColorBrewer")
#install.packages("zoo")

library("RColorBrewer")
require("ggplot2")
library(zoo)

par(mfrow=c(1,1))

setwd("C:/Code/climData/glaser2010")

t0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2010/master/csv/t_1500_2006.csv", sep=",", na = "NA")
p0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/p_1500_1995.csv", sep=",", na = "NA")

spifull <- read.csv("https://raw.githubusercontent.com/climdata/dwdSPI/master/csv/spi_de.csv", sep=",", na = "NA")
baurfull <- read.csv("https://raw.githubusercontent.com/climdata/baur/master/csv/baur_yearly.csv", sep=",")

avg <- rollapply(baurfull, width=30, by=1, FUN=mean)
std <- rollapply(baurfull, width=30, by=1, FUN=sd)

last <-tail(baurfull, n=-30)

norm <- (last-avg)/std
norm$year <- last$year
norm <-tail(norm, n=-30)
norm$win <- NULL
norm$spr <- NULL
norm$sum <- NULL
norm$aut <- NULL
norm$avg <- NULL

normnew <- subset(norm, norm$year>max(t0$year))
t0 <- rbind(t0, normnew)

t1 <- data.frame()
p1 <- data.frame()
monthNames = c("jan","feb","mar","apr","mai","jun","jul","aug","sep","oct","nov","dec")
for(i in 1:length(monthNames)) {
  tnew <- data.frame(year = t0$year, month = i)
  tnew$temp0 <-  t0[,monthNames[i]]
  t1 <- rbind(t1, tnew)
  pnew <- data.frame(year = p0$year, month = i)
  pnew$prec0 <- p0[,monthNames[i]]
  p1 <- rbind(p1, pnew)
}

t1$time = t1$year + (t1$month+0.5)/12.0
t1 <- t1[order(t1$time),]
p1$time = p1$year + (p1$month+0.5)/12.0

spinew <- subset(spifull, spifull$time>max(p1$time))
spinew <- spinew[, c("year","month","time","spi1")]
names(spinew)[names(spinew) == 'spi1'] <- 'prec0'
p1 <- rbind(p1, spinew)
p1 <- p1[order(p1$time),]

frqFilter <- function(data, years=1.0) {
  pic <- data
  len <- length(pic)
  ## mirror pic
  pic <- append(pic, pic)
  for(i in 1:len) {
    pic[i+len] <- pic[1+len-i]
  }

  frq <- fft(pic, inverse = FALSE)
  frq0 <- frq
  frq1 <- frq

  start = round(len/(12*years))
  stop  = round(2*len-start)
  frq1[start:stop] <- 0.0

  pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
  pic1 <- pic1[1:len]
  return(pic1)
}

t1$temp1 <- frqFilter(t1$temp0, years=1.0)
t1$temp5 <- frqFilter(t1$temp0, years=5.0)
p1$prec1 <- frqFilter(p1$prec0, years=1.0)
p1$prec5 <- frqFilter(p1$prec0, years=5.0)

p1$time <- NULL
b1 <- merge(t1,p1, by=c("year","month"))

# xmax, xmin, xmid, ymax, ymin, ymid, x, y
# color max, mid, min
mixColor <- function(xList, yList,
                     #xmin=-1, xmid=0, xmax=1,
                     xmin=min(xList, na.rm = TRUE), xmid=mean(xList, na.rm = TRUE), xmax=max(xList, na.rm = TRUE),
                     #ymin=-1, ymid=0, ymax=1,
                     ymin=min(yList, na.rm = TRUE), ymid=mean(yList, na.rm = TRUE), ymax=max(yList, na.rm = TRUE),
                     cxmin="#FF0000", cxmid="#000000", cxmax="#0000FF",
                     cymin="#FFFF00", cymid="#000000", cymax="#00FF00"
){
  ## x and y must be same length
  colList <- c()

  for (i in 1:length(xList)) {

    cul = rgb(colorRamp(c(cxmin, cymax))( 0.5 )/255)
    cum = rgb(colorRamp(c(cxmid, cymax))( 0.5 )/255)
    cur = rgb(colorRamp(c(cxmax, cymax))( 0.5 )/255)
    cml = rgb(colorRamp(c(cxmin, cymid))( 0.5 )/255)
    cmm = rgb(colorRamp(c(cxmid, cymid))( 0.5 )/255)
    cmr = rgb(colorRamp(c(cxmax, cymid))( 0.5 )/255)
    cll = rgb(colorRamp(c(cxmin, cymin))( 0.5 )/255)
    clm = rgb(colorRamp(c(cxmid, cymin))( 0.5 )/255)
    clr = rgb(colorRamp(c(cxmax, cymin))( 0.5 )/255)

    x=xList[i]
    y=yList[i]

    if(is.na(x)) {
      x<-y
      cul = rgb(colorRamp(c(cymin, cymax))( 0.5 )/255)
      cum = rgb(colorRamp(c(cymid, cymax))( 0.5 )/255)
      cur = rgb(colorRamp(c(cymax, cymax))( 0.5 )/255)
      cml = rgb(colorRamp(c(cymin, cymid))( 0.5 )/255)
      cmm = rgb(colorRamp(c(cymid, cymid))( 0.5 )/255)
      cmr = rgb(colorRamp(c(cymax, cymid))( 0.5 )/255)
      cll = rgb(colorRamp(c(cymin, cymin))( 0.5 )/255)
      clm = rgb(colorRamp(c(cymid, cymin))( 0.5 )/255)
      clr = rgb(colorRamp(c(cymax, cymin))( 0.5 )/255)
      if(is.na(xmin)) { xmin <- ymin }
      if(is.na(xmid)) { xmid <- ymid }
      if(is.na(xmax)) { xmax <- ymax }
    }
    if(is.na(y)) {
      y<-x
      cul = rgb(colorRamp(c(cxmin, cxmax))( 0.5 )/255)
      cum = rgb(colorRamp(c(cxmid, cxmax))( 0.5 )/255)
      cur = rgb(colorRamp(c(cxmax, cxmax))( 0.5 )/255)
      cml = rgb(colorRamp(c(cxmin, cxmid))( 0.5 )/255)
      cmm = rgb(colorRamp(c(cxmid, cxmid))( 0.5 )/255)
      cmr = rgb(colorRamp(c(cxmax, cxmid))( 0.5 )/255)
      cll = rgb(colorRamp(c(cxmin, cxmin))( 0.5 )/255)
      clm = rgb(colorRamp(c(cxmid, cxmin))( 0.5 )/255)
      clr = rgb(colorRamp(c(cxmax, cxmin))( 0.5 )/255)
      if(is.na(ymin)) { ymin <- xmin }
      if(is.na(ymid)) { ymid <- xmid }
      if(is.na(ymax)) { ymax <- xmax }
    }

  if (x>xmid) {
    xn = (x-xmid)/(xmax-xmid)
    if (y>ymid) {
      yn = (y-ymid)/(ymax-ymid)
      c1 = rgb(colorRamp(c(cmm, cmr))( xn )/255)
      c2 = rgb(colorRamp(c(cum, cur))( xn )/255)
    } else {
      yn = (y-ymid)/(ymin-ymid)
      c1 = rgb(colorRamp(c(cmm, cmr))( xn )/255)
      c2 = rgb(colorRamp(c(clm, clr))( xn )/255)
    }
  } else {
    xn = (x-xmid)/(xmin-xmid)
    if (y>ymid) {
      yn = (y-ymid)/(ymax-ymid)
      c1 = rgb(colorRamp(c(cmm, cml))( xn )/255)
      c2 = rgb(colorRamp(c(cum, cul))( xn )/255)
    } else {
      yn = (y-ymid)/(ymin-ymid)
      c1 = rgb(colorRamp(c(cmm, cml))( xn )/255)
      c2 = rgb(colorRamp(c(clm, cll))( xn )/255)
    }
  }
  c3 = rgb(colorRamp(c(c1, c2))( yn )/255)
  ## add c3 to result list
  colList <- c(colList, c3)

  }
  return(colList)
}

mixTColor <- function(t,p) {
  c <- mixColor(t,t,
                cxmin="#0505b3", cxmid="#F7F7F7", cxmax="#c90b04",
                cymin="#0505b3", cymid="#F7F7F7", cymax="#c90b04"
  )
}
mixPColor <- function(t,p) {
  c <- mixColor(p,p,
                cxmin="#AA6010", cxmid="#FCF0C2", cxmax="#23AB30",
                cymin="#AA6010", cymid="#FCF0C2", cymax="#23AB30"
  )
}

mixTPColor <- function(t,p) {
  c <- mixColor(t,p,
                cxmin="#0505b3", cxmid="#F7F7F7", cxmax="#c90b04",
                cymin="#AA6010", cymid="#FCF0C2", cymax="#23AB30"
  )
  return(c)
}

mp <- ggplot(b1, aes())
mp + geom_raster(aes(year,month), fill=mixTPColor(b1$temp0, b1$prec0))+
  #geom_raster(aes(year,-1, fill=3*temp5))+
  #geom_raster(aes(year,-2, fill=1*temp1))+
  geom_raster(aes(year, 15), fill=mixTColor(3*b1$temp5, 3*b1$temp5))+
  geom_raster(aes(year, 14), fill=mixPColor(3*b1$prec5, 3*b1$prec5))+
  geom_raster(aes(year,-1), fill=mixTPColor(3*b1$temp5, 3*b1$prec5))+
  geom_raster(aes(year,-2), fill=mixTPColor(1*b1$temp1, 1*b1$prec1))+
  #theme_classic() +
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(-2,-1,1,6,12,14,15), lab=c("1y","5y","1","6","12","P","T"))+
  scale_x_continuous(limits=c(1500,2020)) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="TI/PI", reverse = TRUE)) +
  geom_hline(aes(yintercept = 9+0)) +
  geom_line(aes(y=9+2*b1$temp5, x=b1$time, color="Filtered"), size=2) +
  geom_hline(aes(yintercept = 3+0)) +
  geom_line(aes(y=3+2*b1$prec5, x=b1$time, color="Filtered"), size=2) +
  scale_color_manual("Filtered", values=c("#000000"), labels=c("5y"))
  #geom_line(aes(y=10+0.5*pt1$hhim, x=pt1$time))

## Legende
dl = data.frame()
for (i in 1:7) {
  for (j in 1:7) {
     nl = data.frame(i=i,j=j, t=i-4, p=j-4)
     dl <- rbind(dl, nl)
  }
}
for (i in 1:7) {
  nl = data.frame(i=i,j=9, t=i-4, p=NA)
  dl <- rbind(dl, nl)
  }
for (j in 1:7) {
  nl = data.frame(i=-1,j=j, t=NA, p=j-4)
  dl <- rbind(dl, nl)
}

mp <- ggplot(dl ,aes()) +
   theme_classic(base_size=80) +
   geom_raster(aes(i, j), fill=mixTPColor( dl$t, dl$p )) +
   scale_y_continuous(breaks=c(1,2,3,4,5,6,7,9), lab=c("-3","-2","-1","0","+1","+2","+3", "T")) +
   scale_x_continuous(breaks=c(-1,1,2,3,4,5,6,7), lab=c("P","-3","-2","-1","0","+1","+2","+3")) +
   xlab("Temperature") + ylab("Precipitation")
mp

###

b1$temp2 <- frqFilter(b1$temp0, years=2.0)
b1$temp3 <- frqFilter(b1$temp0, years=3.0)
b1$temp4 <- frqFilter(b1$temp0, years=4.0)
b1$prec2 <- frqFilter(b1$prec0, years=2.0)
b1$prec3 <- frqFilter(b1$prec0, years=3.0)
b1$prec4 <- frqFilter(b1$prec0, years=4.0)

mp <- ggplot(b1, aes())
mp +

  geom_raster(aes(year, 5), fill=mixTColor(1*b1$temp1, 1*b1$temp1))+
  geom_raster(aes(year, 4), fill=mixTColor(1.5*b1$temp2, 1.5*b1$temp2))+
  geom_raster(aes(year, 3), fill=mixTColor(2*b1$temp3, 2*b1$temp3))+
  geom_raster(aes(year, 2), fill=mixTColor(2.5*b1$temp4, 2.5*b1$temp4))+
  geom_raster(aes(year, 1), fill=mixTColor(3*b1$temp5, 3*b1$temp5))+
  geom_raster(aes(year, 0), fill=mixTPColor(3*b1$temp5, 3*b1$prec5))+
  geom_raster(aes(year,-1), fill=mixPColor(3*b1$prec5, 3*b1$prec5))+
  geom_raster(aes(year,-2), fill=mixPColor(2.5*b1$prec4, 2.5*b1$prec4))+
  geom_raster(aes(year,-3), fill=mixPColor(2*b1$prec3, 2*b1$prec3))+
  geom_raster(aes(year,-4), fill=mixPColor(1.5*b1$prec2, 1.5*b1$prec2))+
  geom_raster(aes(year,-5), fill=mixPColor(1*b1$prec1, 1*b1$prec1))+

  #theme_classic() +
  theme_classic(base_size=80) +
  scale_y_continuous(breaks=c(-5,-4,-3,-2,-1,0,1,2,3,4,5), lab=c("1y P","2y P","3y P","4y P","5y P","5y T&P","5y T", "4y T", "3y T", "2y T", "1y T"))+
  scale_x_continuous(limits=c(1500,2020)) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="TI/PI", reverse = TRUE)) +
  geom_hline(aes(yintercept = 3+0)) +
  geom_line(aes(y=3+2*b1$temp5, x=b1$time, color="Filtered"), size=2) +
  geom_hline(aes(yintercept = -3+0)) +
  geom_line(aes(y=-3+2*b1$prec5, x=b1$time, color="Filtered"), size=2) +
  scale_color_manual("Filtered", values=c("#000000"), labels=c("5y"))
#geom_line(aes(y=10+0.5*pt1$hhim, x=pt1$time))


# Parameters
## SAD
S_POOL <- c(20L, 200L)
N_SIM <- c(2000L, 20000L)
SAD_COEF = c(list(cv_abund = 0.1), list(cv_abund = 0.5), list(cv_abund = 1))

## Dispersion
SIGMA <- c(0.05, 0.2, 0.8)

## sampling
QUADRAT_WIDTH <- sqrt(c(0.01, 0.1))

parameter_table <- expand.grid(S_POOL = S_POOL, N_SIM = N_SIM, SAD_COEF = SAD_COEF, SIGMA = SIGMA, QUADRAT_WIDTH = QUADRAT_WIDTH)


library(pacman)
library(tidyverse)
p_load(ggbeeswarm)
p_load(gridExtra)

df <- read.csv("../PsychoPy/logfiles/readingP2_2_Bonyby.csv")

wordlen = vector()

for (i in df$Word){
  wordlen <- c(wordlen, nchar(i))
}

df <- df %>% mutate(Word_Length = wordlen)
View(df)

ggplot(df, aes(x = df$Reaction.time, y = df$Word_Length)) +
  geom_point(alpha = 0.05, color = "#eba487") +
  stat_summary(fun.y = "median", geom = "point", size = 2, color = "#abdcf1") +
  stat_summary(fun.y = "median", geom = "line", aes(group = 1),
               size = 1.1, color = "#abdcf1") +
  labs(
    title = "How word length affects reading times",
    subtitle = paste0("Most professional athletes take part in competitions",
                      " when they are between 20 and 34.\nThe ",
                      "highest weights are achieved by professional ",
                      "athletes between the ages of 20\nand 34. After ",
                      "that the weight decreases steadily."),
    x = "Seconds",
    y = "Word Length",
    caption = "Esben Kran Christensen"
  )

plot1 <- ggplot(df, aes(x = df$Reaction.time)) +
  geom_histogram(aes(y = ..density.., fill = ..count.. ), binwidth = 0.01) +
  stat_function(
    fun = dnorm,
    color = "orangered2",
    size = 1,
    args = list(mean = mean(df$Reaction.time),
                sd = sd(df$Reaction.time))) +
  theme_minimal() +
  theme(text = element_text(),
    plot.subtitle = element_text(size = 14,
                                 lineheight = 1.1,
                                 margin = margin(b = 45)),
    panel.grid.minor.x = element_blank(),
    panel.grid.minor.y = element_blank(),
    axis.text = element_text(size = 10),
    axis.text.x = element_text(margin = margin(t = 5)),
    axis.text.y = element_text(margin = margin(r = 5)),
    axis.title = element_text(size = 14),
    axis.title.y = element_text(margin = margin(r = 20),
                                hjust = 1),
    axis.ticks = element_line(),
    axis.title.x = element_text(margin = margin(t = 15),
                                hjust = 1),
    axis.line = element_line()) +
  labs(x = "Reading time", y = "Density", title = "Distribution of reading times: Nete", subtitle = "Reading times of random sequences of words")

plot2 <- ggplot(df, aes(x = df$Reaction.time, y = df$Word)) +
  geom_point()

grid.arrange(plot1, plot2, nrow = 2)


printAnalysis <- function(ldata, variance, amplitude, peak) {
  print("Amplitude:")
  print(amplitude)
  print("Variance:")
  print(amplitude * variance / simu[length(data)])
  print(variance)
  print("Peak in days:")
  print(peak-ldata)
}

plotResults <- function(data, vOrig, aApprox, mApprox, sdApprox) {
  simu = pnorm(10:60, mean = mApprox, sd = sdApprox) * aApprox
  plot(simu*(1 + vOrig/simu[length(data)]), pch = "+", type = "l")
  points(simu, pch = "o")
  points(data, pch = "*")
  points(simu*(1 - vOrig/simu[length(data)]), pch = "-", type = "l")
  simu
}


# Prepare for model building.
form = formula(paste(target, "~ ."))
seed = 328058
train = sample(nobs, 0.7*nobs)
test = setdiff(seq_len(nobs), train)
actual = dat[test, target]
risks = dat[test, risk]

# Box-cox transformation
require(caret)
lambdas = apply(sg, 2, function(x){ return(BoxCoxTrans(x)$lambda) })

# PCA
pr = princomp(dat, center=TRUE, scale=TRUE)
loadings(pr)
plot(pr)
pr$sdev^2/sum(pr$sdev^2)*100

# Do multiple preprocessing
require(caret)
preProcess(dat, method = c("BoxCox", "center", "scale", "pca"))

# Plot correlations and filter highly correlated variables
require(corrplot)
corrplot(cor(dat), order="hclust")
filtered = dat[,-(findCorrelation(cor(dat), cutoff = .75))]

# Data splitting
require(caret)
createDataPartition
createFolds
createResamples
createMultiFolds

# Periodogram from fft
f = fft(t)
require(TSA)
periodogram(f, method="ar")


#delury estimate
delury.leslie <-	function(x,estimate=c('delury','leslie'),day.or.week='week') {
dl = list(coef=1234)
if(nrow(x)>10) {
	#x$lncpue <- log(x$cpue)

		#if sum across week before average cpue

			if(day.or.week=='day')  y <- aggregate(cbind(landings,effort)~date.fished,data=x,FUN=sum)
			if(day.or.week=='week') y <- aggregate(cbind(landings,effort)~weekno,data=x,FUN=sum)
			y$cpue <- y$landings/y$effort
			y$lncpue <- log(y$cpue)
			y$sumef <- cumsum(y$effort)
			y$sumlan <- cumsum(y$landings)
			y$yr = unique(x$yr)
			y$area = unique(x$area)

		#yi <- max(x[which(x$date_fished<as.Date(paste(unique(x$yr),06,30,sep="-"))),'weekno'])

		if(estimate=='delury') {
		y$sumef <- cumsum(y$effort)
		delu <- summary(lm(lncpue~sumef,data=y))$coefficients
		with(y,plot(sumef,lncpue,xlab='Effort',ylab='ln(CPUE)'))#,main=paste('Delury',unique(x$yr),sep="-")
		abline(a=delu[1,1],b=delu[2,1],col='red')
		#abline(v=y[which(y$weekno==yi),'sumef'],col='red')
		delu <- round(delu, 5) # extract coefficients

	mtext(bquote(lncpue == .(delu[2,1])*sumU + .(delu[1,1])-- pslope*.(delu[2,4])), side=1,line=4,cex=0.7) # display equation

		return(list(coef = delu, data = y))
		}
		if(estimate=='leslie') {
		y$sumlan <- cumsum(y$landings)
		lesl <- summary(lm(lncpue~sumlan,data=y))$coefficients
		with(y,plot(sumlan,lncpue,xlab='Landings',ylab='ln(CPUE)'))#main=paste('Leslie',unique(x$yr),sep="-")
		abline(a=lesl[1,1],b=lesl[2,1],col='red')
		#abline(v=y[which(y$weekno==yi),'sumlan'],col='red')
		return(list(coef = lesl, data = y))
		}
	}
	return(dl)
	}


library(shiny)
library(dplyr)
library(readxl)
library(ggplot2)
library(lubridate)

### title: GetExponentialModel
### content:
GetExponentialModel <- function(data, alpha, beta, phi) {
          alpha0 <- as.numeric(data[1,2])
          beta0 <- 0 # Estimate of Trend

          alphaList <- c()
          betaList <- c()
          for (i in seq(1, nrow(data))) {
                    if (i == 1) {
                              alphaElement <- alpha*alpha0 + (1-alpha)*(alpha0+phi*beta0)
                              betaElement <- beta*(alphaElement-alpha0) + (1-beta)*beta0
                              alphaList <- c(alphaList, alphaElement)
                              betaList <- c(betaList, betaElement)
                    } else {
                              alphaElement <- alpha*data[i, 2] + (1-alpha)*(alphaElement+phi*betaElement)
                              alphaList <- c(alphaList, alphaElement)

                              betaElement <- beta*(alphaList[i]- alphaList[i-1]) + (1-beta)*phi*betaList[i-1] #i=2
                              betaList <- c(betaList, betaElement)
                    }
          }

          data$Alpha <- alphaList
          data$Beta <- betaList
          data$Prediction <- alphaList + betaList
          data$Error <- data$Demand - data$Prediction
          data$MSE <- data$Error^2

          data
}

### title: GetEOQ
### content: it is a function that returns the economic order quantity.
GetEOQ <- function(Demand,PurchaseCost, MOQ = 100, CarryingCost=0.2, fixedCost = 2000) {
          EOQ = sqrt(2*fixedCost*Demand/PurchaseCost*CarryingCost)
          EOQ = MOQ*ceiling(EOQ/MOQ)
          EOQ
}

shinyServer(func = function(input, output, session) {

          ### title: GetMainData
          ### content: it is a function that returns the dataset by extracting the information to display, apart from the monthly sales values.
          GetMainData <- reactive({
                    # Load Inventory Data File
                    tryCatch(
                              {
                                        df = read_excel(input$file$datapath, sheet = 1, skip = 4)
                              },
                              error = function(e) {
                                        # return a safeError if a parsing error occurs
                                        stop(safeError(e))
                              }
                    )

                    mainData = data.frame(df[, c(2, 3, 6, 8, 9, 10)])
                    mainData[is.na(mainData)] = 0
                    colnames(mainData) = c("Code", "Description", "Available", "BackOrder", "Ordered", "MinQty")
                    mainData$currentQty = mainData$Available+mainData$Ordered-mainData$BackOrder

                    mainData
          })

          ### title:
          ### content:
          GetTimeSeriesData <- reactive({
                    # Load Inventory Data File
                    tryCatch(
                              {
                                        df = read_excel(input$file$datapath, sheet = 1, skip = 4)
                              },
                              error = function(e) {
                                        # return a safeError if a parsing error occurs
                                        stop(safeError(e))
                              }
                    )

                    # Cleaning Data
                    TimeSeriesData = data.frame(df[,17:(ncol(df)-1)])
                    TimeSeriesData = t(TimeSeriesData)
                    TimeSeriesData[is.na(TimeSeriesData)] = 0
                    colnames(TimeSeriesData) = df[,2]$Code

                    # Creating Month Data
                    months = c("jan", "feb", "mar", "apr", "may", "jun", "jul", "aug", "sep", "oct", "nov", "dec")
                    month.num = c("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
                    MonthTable1 = data.frame(months, month.num)

                    months = tolower(substr(row.names(TimeSeriesData), 1, 3))
                    years = tolower(substr(row.names(TimeSeriesData), 5, 8))
                    MonthTable2 = data.frame(months, years)

                    MonthTable = merge(MonthTable1, MonthTable2, by="months")
                    MonthTable$date = paste(MonthTable$years, MonthTable$month.num, sep='/')

                    MonthTable$date = as.Date(paste(MonthTable$date, '01', sep = '/'), '%Y/%m/%d')
                    MonthTable = arrange(MonthTable, desc(date))

                    rownames(TimeSeriesData) = as.character(MonthTable$date)

                    TimeSeriesData
          })

          loadData <- reactive({
                    mainData <- GetMainData()
                    TimeSeriesData <- GetTimeSeriesData()

                    # input
                    LEADTIME = input$leadtme
                    CSL = input$servicelevel/100

                    # regression table
                    products = mainData$Code
                    regressions = c()
                    stds = c()
                    for (product in products) {
                              demands = rev(TimeSeriesData[, product])
                              periods = seq(1, nrow(TimeSeriesData), 1)
                              regression = summary(lm(demands~periods))$coeff[2,1]
                              regressions = c(regressions, round(regression,3))
                              std = sd(demands, na.rm = F)
                              stds = c(stds, round(std,3))
                    }
                    regressionTable = data.frame(Code=products, Regression=regressions, SD = stds)

                    # combin with regression table and main Table
                    MainTable = merge(mainData, regressionTable, by = "Code")

                    # safe stock level calculation
                    MonthDemand = colSums(TimeSeriesData, na.rm = T)/colSums(!is.na(TimeSeriesData))
                    YearlyDemand = colSums(TimeSeriesData, na.rm = T)
                    QuarterlyDemand = colSums(tail(TimeSeriesData, 4), na.rm = T)

                    ReviewTime = 12/(LEADTIME+1)

                    DmdOverLeadtime = QuarterlyDemand*3/ReviewTime
                    StdOverLeadtime = MainTable$SD/sqrt(ReviewTime)

                        SafetyStock = DmdOverLeadtime + StdOverLeadtime*qnorm(CSL)

                    TopupStock = SafetyStock - mainData$currentQty

                    OrderQty = TopupStock - MainTable$currentQty
                    OrderQty = ifelse(OrderQty > 0, round(OrderQty, 0), NA)

                    MainTable$SafetyStock = round(SafetyStock)
                    MainTable$OrderQty = OrderQty
                    MainTable$YearlyDemand = YearlyDemand
                    MainTable$DmdOverLeadtime = DmdOverLeadtime
                    MainTable$ID = as.numeric(seq(1, nrow(MainTable)))

                    MainTable = MainTable %>% select("ID", everything())

                    PurchasePrice = as.data.frame(read.csv("./supplier_cost_report.csv"))
                    PurchasePrice = select(PurchasePrice, Product.Code, Supplier.Cost)
                    PurchasePrice$Supplier.Cost = as.numeric(gsub("[\\$,]", "", PurchasePrice$Supplier.Cost))
                    colnames(PurchasePrice) = c("Code", "Cost")
                    PurchasePrice = PurchasePrice[!duplicated(PurchasePrice$Code), ]
                    MainTable = merge(MainTable, PurchasePrice, by = "Code")

                    MainTable$EOQ = GetEOQ(MainTable$YearlyDemand, MainTable$Cost, input$MOQ, input$carryingcost/100, input$fixedcost)

                    MainTable
          })

          ### title: GetModelTest
          ### content: it is a function that returns the series of data from the simulation from TimeSeriesData dataset in order to find the best fit on each alpah, beta and phi value.
          GetModelTest <- reactive({
                    TimeSeriesData <- GetTimeSeriesData()

                    product = colnames(TimeSeriesData)[input$index]

                    ProductDemandData = TimeSeriesData[, product]
                    ProductDemandData = data.frame(Date=rownames(TimeSeriesData), Demand=as.numeric(ProductDemandData))
                    ProductDemandData = arrange(ProductDemandData, Date)

                    # Simulation Input
                    alphaInput = seq(0.1, 0.3, 0.1)
                    betaInput = seq(0, 0.3, 0.1)
                    phiInput = seq(0.8,1, 0.1)

                    SimulationData = data.frame()
                    for (alpha in alphaInput) {
                              for (beta in betaInput) {
                                        for (phi in phiInput) {
                                                  DemandData = GetExponentialModel(ProductDemandData, alpha, beta, phi)
                                                  mse = sum(DemandData$MSE)/(nrow(DemandData)-1)
                                                  error = abs(sum(DemandData$Error))
                                                  newData = data.frame(alpha=alpha, beta=beta, phi=phi, mse=mse, error=error)
                                                  SimulationData = rbind(SimulationData, newData)
                                        }
                              }
                    }
                    BestModel <- SimulationData[which(SimulationData$mse == min(SimulationData$mse)), ]
                    BestModel
          })

          ### title: GetStockData
          ### content:
          GetStockData <- reactive({
                    mainData <- GetMainData()
                    TimeSeriesData <- GetTimeSeriesData()

                    time0 = mainData[input$index, 3]
                    demand = TimeSeriesData[ , input$index]

                    StockLevelData = time0 + cumsum(demand)
                    StockLevelData = c(time0, StockLevelData)
                    date0 = as.Date(names(StockLevelData)[2])
                    month(date0) = month(as.Date(names(StockLevelData)[2]))+1
                    names(StockLevelData)[1] = format(date0, "%Y-%m-%d")
                    StockLevelData = data.frame(Date=names(StockLevelData), Demand=StockLevelData)

                    StockLevelData
          })

          ### title: GetPredictionData
          ### content: it is a function that returns
          GetPredictionData <- reactive({
                    TimeSeriesData <- GetTimeSeriesData()
                    product = colnames(TimeSeriesData)[input$index]

                    ProductDemandData = TimeSeriesData[, product]
                    ProductDemandData = data.frame(Date=rownames(TimeSeriesData), Demand=as.numeric(ProductDemandData))
                    ProductDemandData = arrange(ProductDemandData, Date)

                    BestModel = GetModelTest()
                    alpha = BestModel[1,1]
                    beta = BestModel[1,2]
                    phi = BestModel[1,3]

                    PredictionModel = GetExponentialModel(ProductDemandData, alpha, beta, phi)
                    PredictionModel[,-1] = round(PredictionModel[,-1], 2)
                    PredictionModel$Date = format(as.Date(PredictionModel$Date, "%Y-%m-%d"), "%b")
                    PredictionModel
          })

          ### title: table
          ### content: table is the main table shows the basic information from the excel spreadsheet.
          output$table <- renderDataTable({
                    if(is.null(input$file)){
                              return(NULL)
                    }
                    loadData()
          })

          ### title: table1
          ### content: table1 shows the prediction model of the demand over the next period, using the exponential smoothing model.
          output$table1 <- renderTable({
                    if(is.null(input$file)){
                              return(NULL)
                    }
                    GetPredictionData()
          })

          ### title: plot1
          ### content: plot1 shows monthly demand and the trend on the product.
          output$plot1 <- renderPlot({
                    if(is.null(input$file)){
                              return(NULL)
                    }
                    TimeSeriesData <- GetTimeSeriesData()

                    # Input Control
                    product = colnames(TimeSeriesData)[input$index]

                    PlotTable = TimeSeriesData[, product]

                    PlotTable = data.frame(Date=rownames(TimeSeriesData), Demand=as.numeric(PlotTable))

                    # product = "OPM29-01"
                    ggplot(data=PlotTable,
                           aes(x=as.Date(Date), y=Demand, group=1)) +
                              geom_point(size = 2) +
                              geom_text(aes(label=Demand), hjust=1, vjust=1) +
                              geom_line() +
                              geom_smooth(method = "glm", formula = y ~ x, se = T, na.rm = T, level=0.8) +
                              labs(x = "Month", title = paste(product, "Monthly Demand"))
          })

          ### title: plot2
          ### content: the plot2 shows the current stock level and highlights the safety stock level and current stock level. If the current stock level is lower than the safety stock level. The line is hightlighted so that the purchase officer can know the product is likely to be stock-out within the set leadtime.
          output$plot2 <- renderPlot({
                    if(is.null(input$file)){
                              return(NULL)
                    }

                    StockLevelData <- GetStockData()
                    MainTable <- loadData()
                    product = MainTable$Code[input$index]
                    # product = MainTable$Code[34]
                    ProductInfo <- MainTable[which(MainTable$Code==product), ]

                    ggplot(data=StockLevelData,
                           aes(x=as.Date(Date), y=Demand, group=1)) +
                              geom_point(size = 2) +
                              geom_text(aes(label=Demand), hjust=1, vjust=1) +
                              geom_hline(aes(yintercept = ProductInfo$currentQty), linetype="dashed", color = "red", alpha = ifelse(ProductInfo$Ordered > 0, 1, 1/10)) +
                              geom_hline(aes(yintercept = ProductInfo$SafetyStock), linetype="dashed", color = "blue", alpha = ifelse(ProductInfo$currentQty < ProductInfo$SafetyStock, 1, 1/10)) +
                              geom_line() +
                              labs(x = "Month", title = paste(product, "Monthly Stock Level"))
          })

          ### title: download
          ### content: download is a button that enable the user to download the csv. file. The file contains the data from the function, loadData().
          output$download <- downloadHandler(
                    # This function returns a string which tells the client browser what name to use when saving the file.
                    filename = paste(Sys.Date(), "csv", sep = "."),

                    # This function should write data to a file given to it by the argument 'file'.
                    content = function(file) {
                              sep <- ","

                              # Write to a file specified by the 'file' argument
                              write.csv(loadData(), file, sep = sep, row.names = FALSE)
                    }
          )

})

### Required variables for testing are recorded as following.

# setwd("/media/taepark/Tae Park External Hard Drive/Projects/Projects/ReorderReport")
# df = read_excel("Example_file.xlsx", sheet = 1, skip = 4, skipEmptyCols = F)
# LEADTIME = 8
# CSL = 0.95
# time0 = mainData[1, 3]
# demand = TimeSeriesData[ , 1]


require(Hmisc)
source('~/R/Hmisc/R/gbayes.s')
d <- 1:3
x <- c(-.5, 0, .5)
v <- c(1, .5, .25)
for(w in c('cdf', 'postmean')) {
  f <- gbayesMixPost(d0=1.2, v0=5, what=w)
  print(f(d, x[1], v[1]))
  print(f(d[1], x, v))
  f <- gbayesMixPost(d0=1.2, d1=1.2, v0=5, v1=5, mix=.5, what=w)
  print(f(d, x[1], v[1]))
  print(f(d[1], x, v))
}


#source("constraint.sets.r")
#source("mvo.constrained.r")
#source("efront.constrained.r")
#source("barplot.wts.r")
#library(xts)
#library(corpcor)
#load("crsp.short.Rdata")
## number of stocks
#n.stocks <- 5
#names(midcap.ts)
#names(smallcap.ts)
#names(largecap.ts)
#returns.ts = midcap.ts[,1:n.stocks]
#returns = coredata(midcap.ts[,1:n.stocks])
#sum=1
#
#
#
#
#mu.target=NULL
#w.initial=rep(1/n.stocks,n.stocks)
#toc=0.3
#upper=rep(0.5,n.stocks)
#lower=rep(-0.5,n.stocks)
#group=c(sample(1:2,n.stocks,replace=T))
#upper.group=c(0.5,0.5)
#lower.group=c(-0.5,-0.5)
#ptc=0.01
#digits=4
#wts.only=T
#mu.min = NULL
#mu.max = NULL
#rf = .003
#npoints = 20
#wts.plot = T
#printout = F
#bar.ylim = c(-1,4)
#
## constraint list
#"sum"
#"lo"
#"box"
#"groups"
#"mu.target"
#"turnover"
#"turnover"
#"propcost"
#
#
####################################################################################################
## scenario 10
#clist <- c("box","propcost")
#list.arg <- list(upper=upper,
#                 lower=lower,
#                 ptc=ptc,
#                 w.initial=w.initial)
#print(list.arg)
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
##wt plot using MU on horizontal
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg, wts.xlab="MU")
##wt plot using VOL on horizontal
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg, wts.xlab="VOL")
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## sum constraint are not combinable with propcost constraint
#clist <- c("sum","box","propcost")
#list.arg <- list( sum=sum,
#                  upper=upper,
#                  lower=lower,
#                  ptc=ptc,
#                  w.initial=w.initial)
#print(list.arg)
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
## Expected error msg: Error in propcost.modify(cset.i) : sum constraint are not combinable with propcost constraint
#
## scenario 11
#clist <- c("sum","box","turnover")
#list.arg <- list(sum=sum,
#                 upper=upper,
#                 lower=lower,
#                 toc=toc,
#                 w.initial=w.initial)
#print(list.arg)
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
#
#clist <- c("sum","box","turnover")
#list.arg <- list(sum=sum,
#		upper=upper,
#		lower=lower,
#		toc=toc,
#		w.initial=w.initial)
#print(list.arg)
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
#
#####################################################################################################
#
#
#list.arg <- list(sum=sum,
#                 mu.target=mu.target,
#                 group=group,
#                 upper.group=upper.group,
#                 lower.group=lower.group,
#                 upper=upper,
#                 lower=lower,
#                 toc=toc,
#                 w.initial=w.initial,
#                 ptc=ptc)
#
## semario 0
#cset=NULL # gmv
#efrontPlot(returns, cset=cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## scenario 1
#clist <- c("sum")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## scenario 2
#clist <- c("sum","lo")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
#
## scenario 3
#clist <- c("sum","lo","box")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## scenario 4
#clist <- c("sum","lo","groups")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## scenario 5
#clist <- c("sum","lo","mu.target")
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#
#
## scenario 6
#clist <- c("sum","lo","box","groups")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
#
## list.arg$toc <- 0.2
#
## scenario 7
#clist <- c("sum","lo","turnover")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg=list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
## 1+4+1+4+4+2+2+1+4+4+4  sum+lo+mu.target+box+box+group+group+turnover+w.sell+w.buy+w.initial
#
## scenario 8
#clist <- c("lo","box","groups")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
## scenario 9
#clist <- c("lo","box","groups","propcost")
#cset <- NULL
#cset <-combine.cset(clist=clist,returns=returns,list.arg)
#gmv(returns, cset=cset, wts.only=T,digits=4)
#
#efrontPlot(returns, cset, rf = .003, npoints = 20,wts.plot = T,bar.ylim = c(-1,4),list.arg=list.arg)
#mtext(paste(clist,collapse="_"),side=1,line=3)
#
#
#
#


# Color transparency function written by Sacha Epskamp
# Retrieved from http://stackoverflow.com/questions/12995683/any-way-to-make-plot-points-in-scatterplot-more-transparent-in-r

# usage: col = addTrans("col", 255) where 0 is fully transparent and 255 non-transparent.

addTrans <- function(color,trans)
{
  # This function adds transparancy to a color.
  # Define transparancy with an integer between 0 and 255
  # 0 being fully transparant and 255 being fully visable
  # Works with either color and trans a vector of equal length,
  # or one of the two of length 1.

  if (length(color)!=length(trans)&!any(c(length(color),length(trans))==1)) stop("Vector lengths not correct")
  if (length(color)==1 & length(trans)>1) color <- rep(color,length(trans))
  if (length(trans)==1 & length(color)>1) trans <- rep(trans,length(color))

  num2hex <- function(x)
  {
    hex <- unlist(strsplit("0123456789ABCDEF",split=""))
    return(paste(hex[(x-x%%16)/16+1],hex[x%%16+1],sep=""))
  }
  rgb <- rbind(col2rgb(color),trans)
  res <- paste("#",apply(apply(rgb,2,num2hex),2,paste,collapse=""),sep="")
  return(res)
}

###
# Effect size computation
# Written by CHJ Hartgerink
esComp <- function(
  x,
  df1,
  df2,
  N,
  esType){
  esComp <- ifelse(esType=="t",
                   sqrt((x^2*(1 / df2)) / (((x^2*1) / df2) + 1)),
                   ifelse(
                     esType=="F",
                     sqrt((x*(df1 / df2)) / (((x*df1) / df2) + 1))*sqrt(1/df1),
                     ifelse(
                       esType=="r",
                       x,
                       ifelse(
                         esType=="Chi2",
                         sqrt(x/N),
                         ifelse(
                           esType == "z",
                           tanh(x * sqrt(1/(N-3))),
                           NA
                         )
                       )
                     )
                   ))

  return(esComp)
}

###
# Written by CHJ Hartgerink
# The Fisher method applied to test for deviation from uniformity
# In NONSIGNIFICANT P-values

FisherMethod <- function(# Compute Fisher's exact test for non-significant p-values.
  ### This function computes paper level Fisher test statistics, testing whether the distribution of non-significant p-values is uniform. Significant values indicate deviation from uniformity.
  ### Returns both the normal Fisher test, as well as the complement test.
  ### Computations are done for p*=log(p), where p is all non-significant p-values for each identifier.
  x,
  ### Vector of p-values.
  id,
  ### Vector giving paper identifiers.
  alpha = .05
  ### Indicate what alpha level is being maintained for the study results, which serves as a cut-off for selecting the non-significant p-values.
){
  Res <- NULL
  for(i in 1:length(unique(id)))
  {
    selP <- x[id==unique(id)[i]]
    nSigP <- (na.omit(selP[selP>alpha])-alpha)/(1-alpha)
    SigP <- na.omit(selP[selP<=alpha])
    if(!length(nSigP)==0){
      # Compute the Fisher test statistic
      FMeth <- -2*sum(log(nSigP))
      pFMeth <- pchisq(q=FMeth, df=2*length(nSigP), lower.tail=F)
    } else {
      FMeth <- NA
      pFMeth <- NA
    }
    Res <- rbind(Res, data.frame(
      Fish = FMeth,
      PFish = pFMeth,
      CountNSig = length(nSigP),
      CountSig = length(SigP),
      PercentNonSig = length(nSigP)/length(selP)))
  }
  return(Res)
}

###
# Recalculating p-values
# Written by CHJ Hartgerink and RCM van Aert

pvalr <- function(x, N) {
  fis.r <- 0.5*log((1 + x) / (1 - x))
  se.fis.r <- sqrt(1/(N-3))
  pnorm(fis.r, mean = 0, sd = se.fis.r, lower.tail = FALSE)
}

# Computes two-tailed p-value
pvalComp <- function(
  x,
  df1,
  df2,
  N,
  esType){
  pvalComp <- ifelse(esType=="t",
                     pt(abs(x), df = df2, lower.tail = FALSE) * 2,
                     ifelse(
                       esType=="F",
                       pf(x, df1 = df1, df2 = df2, lower.tail = FALSE),
                       ifelse(
                         esType=="r",
                         pvalr(abs(x), N) * 2,
                         ifelse(
                           esType=="Chi2",
                           pchisq(x, df = df1, lower.tail = FALSE),
                           ifelse(
                             esType == "z",
                             pnorm(abs(x), lower.tail = FALSE) * 2,
                             NA
                           )
                         )
                       )
                     ))

  return(pvalComp)
}


## Load some packages that will be useful
install.packages("mgcv") # load the MGCV package with Simon Wood's gam() functions
install.packages("readr") # Hadley Wickham's package for reading in data easily
install.packages("ggplot2") # for plotting with ggplot
install.packages("ggfortify")
library(mgcv) # load the MGCV package with Simon Wood's gam() functions
library(readr) # Hadley Wickham's package for reading in data easily
library(ggplot2) # for plotting with ggplot
library(ggfortify) # for autoplot

##################################################################################################
## We'll first examine the bias-variance tradeoff in a simplified form with a small exercise.
## If you remember, this tradeoff is one of the concepts behind finding the optimal amount of smoothing.
## We'll fit linear regressions to parts of the data, increasing the number of parts from 1 to 10.
##################################################################################################

# First, read in the bioluminescence data.
# Sources is the number of bioluminescent plankton seen in each water sample
# SampleDepth is the depth of the water sample, in m
# Station is the ID of the location at which multiple water samples were taken
ISIT <- read_tsv(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/ISIT.txt')) # tsv for tab-separated values

# Subset it to one station. This is what we'll work with for now.
ISITsub <- subset(ISIT, Station == 8)

# Plot the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point()

# Now you can fit a linear regression to the ISITsub dataset, with Sources as the response and SampleDepth as the explanatory variable
# Please call the output "mod1", as I've started to fill in for you
mod1 <- lm (ISITsub$Sources ~ ISITsub$SampleDepth, data = ISITsub)

# Q1: What was your code for fitting a linear regression of Sources vs. SampleDepth?
#see above

# We'll predict the mean response and confidence intervals from this model and save the output
ISITsub$mod1 <- predict(mod1)
ISITsub$mod1lwr <- predict(mod1, interval='confidence', level=0.95)[,'lwr']
ISITsub$mod1upr <- predict(mod1, interval='confidence', level=0.95)[,'upr']

# Now plot the linear model fit to the full dataset on top of the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3)

# Q2: Use your skills from earlier in this course and evaluate this linear model (autoplot may be useful here). How does this fit look to you? Does a linear regression look reasonable? Any well-justified answer is appropriate.
autoplot(mod1)
#we want residuals around 0, so the residuals are not very normal; therefore a linear regression is not reasonable.

# For comparison, let's fit linear models to two halves of the data. This involves a fair bit of coding in R, so please ask for help understanding the code where things are confusing.
# First, we have to find the halves of the data
quants2 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.5)) # define the ends and the half-way point in the data with the quantile function
ISITsub$split2 <- cut(ISITsub$SampleDepth, breaks=quants2, include.lowest=TRUE, labels=1:2)

# Q3: In your own words, what does the cut() function do? How are we using it here?
#The cut function allows us to split up data into two lables
#here we are using it to split the data along the x axis into two subsets (labeled 1 and 2) based on where they fall (first half or second)

# Next, let's fit a linear model to each subset (half) of the data. We do this in a loop to make it easier.
mod2s <- vector('list', length=2) # A list to hold each of our models in a single, convenient object
ISITsub$mod2 <- ISITsub$mod2lwr <- ISITsub$mod2upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod2s)){ # Loop through each model
	mod2s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split2==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
	ISITsub$mod2[ISITsub$split2==i] <- predict(mod2s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
	ISITsub$mod2lwr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
	ISITsub$mod2upr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Plot the data, the 1-model fit, and the 2-model fit
# There will be an odd 3rd line segment connecting the end of the first model fit to the beginning of the second model fit. Just pretend it's not there.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
	geom_line(aes(y=mod2, color='red')) +
	geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')

# Q4: Has the fit between the model and the data improved? What's the downside of continuing the split the data into finer and finer chunks and fitting more models?
#Yes, the fit has improved! However, the downside of continuing to split the data/fit more models is the trap of overfitting
#you're not modelling the general trend, you'll eventually just show the exact data set

# Now, it's your turn. Please fit 10 linear regression models. I'd recommend using the 2-model code above as a guide and tweaking it.

quants10 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.1)) # define the ends and the 10 points
ISITsub$split10 <- cut(ISITsub$SampleDepth, breaks=quants10, include.lowest=TRUE, labels=1:10)
mod10 <- vector('list', length=10) # A list to hold each of our models in a single, convenient object
ISITsub$mod10 <- ISITsub$mod10lwr <- ISITsub$mod10upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod10)){ # Loop through each model
    mod10[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split10==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
    ISITsub$mod10[ISITsub$split10==i] <- predict(mod10[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
    ISITsub$mod10lwr[ISITsub$split10==i] <- predict(mod10[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
    ISITsub$mod10upr[ISITsub$split10==i] <- predict(mod10[[i]], interval='confidence', level=0.95)[,'upr']
}

# Now plot the 10 models on top of the data and on top of the 1- and 2-model fits. The plot with the data, 1-model, and 2-model fit is probably a useful guide here.

ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
    geom_point() +
    geom_line(aes(y=mod10)) +
    geom_ribbon(aes(ymin=mod10lwr, ymax=mod10upr), alpha=0.3) +
    geom_line(aes(y=mod10, color='red')) +
    geom_ribbon(aes(ymin=mod10lwr, ymax=mod10upr), alpha=0.3, fill='red')

# Q5: Compare your 10-model fit to the 1-model fit. Which model's predictions are furthest from the observed data? Which model has the widest confidence bounds? How does this (or does this not) illustrate the bias-variance tradeoff?
#Model 1 was the furthest from observed data, but Model 10 had the widest confidence bounds
#bias-variance tradeoff = increasing bias to reduce variance
#mod1 is biased because we assume a linear fit; mod10 has high variance, but it fits so well

####################################################
## Now you'll fit some GAMs and evaluate your models
####################################################
#install.packages("maps") # if needed
library(maps) # has map data in it

# load the data
spdata <- readRDS(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/gadusmorhua.rds')) # load the spdata data.frame with abundance and environmental data from cod surveys
spdata$presfit01 <- as.numeric(spdata$presfit) # make a vector that's nice for plotting
spdata <- spdata[order(spdata$presfit01),] # order the data from absent to present for ease of plotting

# examine the data
head(spdata) # look at the dataset
summary(spdata)

# make a map of the data
world <- map_data('world')

ggplot() +
	geom_polygon(data=world, aes(x=long, y=lat, group=group), color='black', fill=NA) + # the map
	xlim(-100, -45) +
	ylim(23, 62) +
	geom_point(data=spdata, aes(x=lon, y=lat, color=presfit, alpha=0.1), size=0.01) # the data points. note that because the dataframe is sorted from absent to present, the presences are plotted on top of the absences

# Q6: Based on the map, do you think cod prefer warmer or cooler waters? Why do you think that?
#Cod like cooler water. I think that because all of the blue points are in the nothern area = colder water

# Q7: Plot cod presence/absence (the presfit vector) vs. the bottom temperature (SBT.actual). At what range of temperatures have cod been observed?

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
    geom_point()
#cod can be found in the range ~0 - 20 Celsius

# Q8: Fit a GAM for presfit against SBT.actual. Check the model. Does it look like the assumptions have been met? Why or why not?

gam1 <- gam(presfit01 ~ s(SBT.actual, k=8), data=spdata)
gam.check(gam1)

#does not meet assumptions, using plots we can see that it is violating normality

# Q9: Fit a new GAM with a more appropriate error structure and save it as "mod2". The gam() function takes the same family= argument as does glm(). Which error structure and link function did you choose?
mod2 <- gam(presfit01 ~ s(SBT.actual, k=8), data=spdata, family=binomial)
gam.check(mod2)

# Q10: Check your mod2 GAM. Does it look like the assumptions have been met? Make sure to read the text output as well as look at the graphs. If something doesn't look right, what would you do to fix it?

#yes, the deviance residuals vs. theoretical quantiles plot follows the 1:1 ratio
#I changed the k value because the output showed a low p-value, indicating that the edf and k value were too close

# Q11: Interpret your mod2 GAM (summary function). How much deviance is explained? Is the SBT.actual term significant at alpha=0.05? How wiggly do you expect the smooth fit to be?
#deviance = 25.4%
#significance = yes, the SBT.actual is significant
#line = pretty curvy, since edf is a 9
summary(mod2)

# Now let's make predictions from our last model (mod2) and plot them.
nd <- data.frame(SBT.actual = seq(-5,30, by=0.5)) # make a data.frame of new explanatory variables
nd$mod2 <- predict(mod2, newdata=nd, type='response') # predict on the scale of the response
nd$mod2se <- predict(mod2, newdata=nd, type='response', se.fit=TRUE)$se.fit # get the standard errors of the fit

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
	geom_point() +
	geom_line(data=nd, aes(x=SBT.actual, y=mod2, color='red')) +
	geom_ribbon(data=nd, aes(x=SBT.actual, ymin=mod2-mod2se, ymax=mod2+mod2se), alpha=0.3, fill='red', inherit.aes=FALSE)

# Q12: Does the fit look realistic? Why or why not? Does it look overfit? Why or why not?
#I feel like the fit is not realistc because it has many curves; it looks overfit
#it captures too many of the ups and downs to be realistic

# Q13: This dataset is actually a concatenation of seven different surveys which each have slightly different abilities to catch cod. Fit a new GAM that includes a categorical predictor for survey (the region vector). Based on AIC, which model would you choose? How confident would you be?
mod3 <- gam(presfit01 ~ s(SBT.actual, k=6) + region, data=spdata, family=binomial)
library(MuMIn) # for model selection
model.sel(mod3, mod2)

#AIC shows that model 3, which incorporates region, is the better model. Pretty confident because it is quite a big difference between models.


forloop{
    for(*A = *B; *A < 1020; *A = *A+2){
        writeLine("stdout", *A)
    }
}

input *B=500*2+1
output ruleExecOut, *A, *B


context("Morans I")

test_that("Get the same result as in ape", {
  set.seed(123)
  graph <- rgraph_ba(t = 199)
  w <- approx_geodesic(graph)
  x <- rnorm(200)

  # Computing Moran's I
  ans0 <- moran(x, w)

  # Comparing with the ape's package version
  ans1 <- ape::Moran.I(x, as.matrix(w))

  expect_equivalent(unclass(ans0), unclass(ans1))
})
#
# graphm <- as.matrix(graph)
# microbenchmark::microbenchmark(
#   netdiffuseR::moran(x,graph),
#   ape::Moran.I(x, graphm), times = 100,
#   unit="relative"
# )


#generate lineplots of counts of variables
#monthly counts by year
#total counts over whole study period

#plot groups of variables on one plot
# can't use count list because doesn't have variable names

count_names<-list.files(diag_pop, pattern="count")

count_files<-lapply(paste0(diag_pop, count_names), readRDS)

par(mfrow=c(length(count_list),1))
#why stopping at 2019-01 (should be 2019-12)

for(i in 1:length(count_list)){
  # par(mfrow=c(length(count_list),1))
  main_name<-substr(count_names[[i]], 1,nchar(count_names[[i]])-11)
  var_counts<-count_files[[i]]$N
  mask_counts<-var_counts[varcounts<=5]<-5
  mycounts<-ts(mask_counts, frequency = 12, start = 2009,end = 2020)
  mydates<-paste0(15,"-",count_list[[i]]$month, "-", count_list[[i]]$year)
  count_list[[i]]$date<-as.Date(mydates, "%d-%m-%y")
  # plot(count_list[[i]]$date, count_list[[i]]$N, xaxt="n", yaxt="n")
  plot(mycounts, xaxt="n", yaxt="n", xlab="", ylab="counts", main=main_name, lwd=2, cex.main=1.5)
  tsp = attributes(mycounts)$tsp
  dates = seq(as.Date("2009-01-01"), by = "month", along = mycounts)
  axis(1, at = seq(tsp[1], tsp[2], along = mycounts),las=2, labels = format(dates, "%Y-%m"))
  axis(2, seq(0:(max(count_files[[i]]$N)+1)))

}

#maksing values <=5 (with legend note)

# layering plots from same group

for(i in 1:length(count_list)){
  main_name<-substr(count_names[[i]], 1,nchar(count_names[[i]])-11)
  mycounts<-ts(count_files[[i]]$N, frequency = 12, start = 2009)
  mydates<-paste0(15,"-",count_list[[i]]$month, "-", count_list[[i]]$year)
  count_list[[i]]$date<-as.Date(mydates, "%d-%m-%y")
  # plot(count_list[[i]]$date, count_list[[i]]$N, xaxt="n", yaxt="n")
  plot(mycounts, xaxt="n", yaxt="n", xlab="", ylab="", main=main_name )
  tsp = attributes(mycounts)$tsp
  dates = seq(as.Date("2009-01-01"), by = "month", along = mycounts)
  axis(1, at = seq(tsp[1], tsp[2], along = mycounts),las=2, labels = format(dates, "%Y-%m"))
  axis(2, seq(0:(max(count_files[[i]]$N)+1)))

}


'Аналогично примеру, разобранному выше, создать функцию, в к
оторой переданный параметр х возводится в степень y, а затем делится на параметр z.
Результат выводится на экран. В случае деления на ноль функция должна
выводить сообщение об ошибке в параметре z.
'

#Функция
calc <- function(x, y, z) {
  if ((typeof(x) != "double") ||
      (typeof(y) != "double") || (typeof(z) != "double"))  {
    print(
      "Предупреждение о несоответствии типов! Возможно вы передаете переменные некорректного типа!"
    )
  }

  if (y == 0) {
    z <- "Ошибка, деление на 0"
  } else{
    z <- (x ^ y) / z
  }
  return(z)
}

#Основная программа
{
  #Запускаем функцию нормально
  result <- calc(4, 6, 7)
  print(result)

  #Запускаем функцию с делением на 0
  result <- calc(4, 0, 7)
  print(result)

}