############################################################
# For owl monkey project, last revised 04.18
# Plots and statistical tests for Figure 3, Figure S3, and
# Figure S4 in owl monkey paper.
#
# Gregg Thomas
############################################################

library(ggplot2)
library(akima)
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)
cat("----------\n")

figs2_opt = F
# CHANGE TO TRUE TO GENERATE FIG. S2

figs3_opt = T
# CHANGE TO TRUE TO GENERATE FIG. S3

####################
## Estimating model parameters using Kong (2012) data
human_dm0 = 34; human_df = 31; human_num_f = 14.2; human_haploid = 2630000000; human_diploid = human_haploid * 2;
# Parameters observed from Drost & Lee (1995) and Kong (2012)

human_mu_c = (human_num_f / human_df)
cat("mu_c estimated from Kong params: ", human_mu_c, "\n")
human_mu_c = human_mu_c / human_haploid
cat("mu_c per site estimated from Kong params: ", human_mu_c, "\n")
# Estimating mu_c

# Calculate spermatogenic proportion and expected number of spermatogenic divisions
# per year using human (Kong) observations.
human_sc = 16
human_dy1 = ((2.01 / human_haploid) / human_mu_c)
human_sp = human_dy1 / (365/16)
cat("Human expected # of spermatogenic cycles/year: ", human_dy1, "\n")
cat("Human spermatogenic cell proportion given a cycle length of 16 days: ", human_sp, "\n")
cat("----------\n")
# Estimating the expected number of spermatogenic cycles per year

# 2.01 is the slope of the Kong line -- mutations per year in males after puberty.
# We can calculate the expected number of spermatogenic cycles per year (human_dy1) based on mu_c.
# Then, we can estimate the proportion of cells undergoing spermatogenesis at any given time (human_sp)
####################

####################
## Human prediction (orange)
human_puberty = 13.4
age_range = seq(human_puberty, 50.4, by=0.1)
rep_long = age_range - human_puberty
# The human age of puberty set at 13.4 years and a range of paternal ages

human_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (human_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

human_pred = data.frame(human_mu_g, age_range)
names(human_pred) = c("Mutation.rate", "Parental.age")
human_pred_reg = lm(human_mu_g ~ age_range)
cat("Human slope (d_ym1): ", coef(human_pred_reg)[2], " -> ", coef(human_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
## Owl monkey prediction (purple)
if(figs2_opt){
  om_sc = 10.2
}else{
  om_sc = 16
}
om_dy1 = (365/om_sc) * human_sp
cat("Owl monkey expected # of spermatogenic cycles/year: ", om_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in owl monkeys using the human proportion
# of cells actively dividing (human_sp).

om_puberty = 1
age_range = seq(om_puberty, 16, by=0.1)
rep_long = age_range - om_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

om_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (om_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

om_pred = data.frame(om_mu_g, age_range)
names(om_pred) = c("Mutation.rate", "Parental.age")
om_pred_reg = lm(om_mu_g ~ age_range)
cat("Owl monkey slope (d_ym1): ", coef(om_pred_reg)[2], " -> ", coef(om_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
## Chimp prediction (red)
if(figs2_opt){
  chimp_sc = 14
}else{
  chimp_sc = 16
}
chimp_dy1 = (365/chimp_sc) * human_sp
cat("Chimpanzee expected # of spermatogenic cycles/year: ", chimp_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in chimpss using the human proportion
# of cells actively dividing (human_sp).

chimp_puberty = 7.5
age_range = seq(chimp_puberty, 35.5, by=0.1)
rep_long = age_range - chimp_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

chimp_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (chimp_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

chimp_pred = data.frame(chimp_mu_g, age_range)
names(chimp_pred) = c("Mutation.rate", "Parental.age")
chimp_pred_reg = lm(chimp_mu_g ~ age_range)
cat("Chimp slope (d_ym1): ", coef(chimp_pred_reg)[2], " -> ", coef(chimp_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
# Read the study data
study_data = read.csv("data/mutation-studies.csv", header=TRUE)
####################

####################
## The plot for Fig. 3
  if(!figs3_opt){
  fig3 = ggplot(study_data, aes(x=Paternal.age, y=Mutation.rate, color=Species)) +
    geom_line(data=human_pred, aes(x=Parental.age, y=Mutation.rate), color='#db6d00', size=1) +
    geom_segment(aes(x=human_puberty,y=human_mu_g[1]-human_mu_g[1]/10,xend=human_puberty,yend=human_mu_g[1]+human_mu_g[1]/10), linetype=1, color="#db6d00", size=0.5) +
    geom_line(data=om_pred, aes(x=Parental.age, y=Mutation.rate), color='#b66dff', size=1) +
    geom_segment(aes(x=om_puberty,y=om_mu_g[1]-om_mu_g[1]/10,xend=om_puberty,yend=om_mu_g[1]+om_mu_g[1]/10), linetype=1, color="#b66dff", size=0.5) +
    geom_line(data=chimp_pred, aes(x=Parental.age, y=Mutation.rate), color='#920000', size=1) +
    geom_segment(aes(x=chimp_puberty,y=chimp_mu_g[1]-chimp_mu_g[1]/10,xend=chimp_puberty,yend=chimp_mu_g[1]+chimp_mu_g[1]/10), linetype=1, color="#920000", size=0.5) +
    geom_point(size=3) +
    scale_x_continuous(limits=c(0,50), breaks = seq(1, 50, by=5)) +
    labs(x="Paternal age (y)",y="Mutation rate per site\nper generation") +
    theme_classic() +
    guides(colour = guide_legend(override.aes = list(size=3))) +
    theme(axis.text=element_text(size=14),
          axis.title=element_text(size=20),
          axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
          axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
          axis.line=element_line(colour='#595959',size=0.75),
          axis.ticks=element_line(colour="#595959",size = 1),
          axis.ticks.length=unit(0.2,"cm"),
          legend.title=element_blank(),
          legend.position=c(0.13,0.87),
          legend.text=element_text(size=18)
    ) +
    scale_color_manual(breaks=c("Owl monkey", "Chimpanzee", "Human"), values=c("Human"='#db6d00',"Owl monkey"='#b66dff',"Chimpanzee"='#920000'))
  print(fig3)
  if(figs2_opt) {
    ggsave(filename="figS2.pdf", fig3, width=10, height=6, units="in")
  }else{
    ggsave(filename="fig3.pdf", fig3, width=10, height=6, units="in")
  }
  ####################

  ####################
  ## The F test for Fig. 3
  human_data = data.frame(study_data$Paternal.age[study_data$Species=="Human"], study_data$Mutation.rate[study_data$Species=="Human"])
  names(human_data) = c("Age","Mu")
  human_data = na.omit(human_data)

  human_study_reg = lm(human_data$Mu ~ human_data$Age)
  cat("--Regression summary for human study data--\n")
  print(summary(human_study_reg))

  human_pred_reg = lm(human_pred$Mutation.rate ~ human_pred$Parental.age)

  pred_actual = coef(human_pred_reg)[1] + human_data$Age * coef(human_pred_reg)[2]
  pred_resids = human_data$Mu - pred_actual
  #plot(human_pred$Parental.age,human_pred$Mutation.rate, type='l',ylim=c(0.8e-8,1.8e-8), xlim=c(13.4,50))
  #points(human_data$Age, human_data$Mu)
  #segments(x0=human_data$Age,y0=human_data$Mu,x1=human_data$Age,y1=human_data$Mu-pred_resids)
  #abline(human_study_reg, lty=2)
  #segments(x0=human_data$Age,y0=human_data$Mu,x1=human_data$Age,y1=human_data$Mu-resid(human_study_reg),lty=2)
  cat("--F test for differences between residuals of the predicted and best fit lines for the human studies--")
  print(var.test(resid(human_study_reg), pred_resids, alternative="two.sided"))
}
####################

####################
## Fig. S3
if(figs3_opt){
  colfunc <- colorRampPalette(c("#009292", "#920000"))
  #colfunc <- colorRampPalette(c("#009292", "#db6d00", "#920000"))
  #colfunc <- colorRampPalette(c("#009292", "#006ddb", "#920000"))
  #colfunc <- colorRampPalette(c("#018571", "#80cdc1", "#a6611a"))
  #colfunc <- colorRampPalette(c("#eecc82", "#926544", "#000000"))
  # A nice(?) color palette

  rt = c();nrt = c();
  for(i in seq(5, 51, 1))
  {
    for(j in seq(5, 51, 1))
    {
      rt = c(rt, i)
      nrt = c(nrt, j)
    }
  }
  mu_y = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * rt * human_mu_c)) / (rt + nrt));
  # Calculate mu_y for a range of life history values

  am = 20; af = 6; p = 3; rt1 = am-p; nrt1 = af+p
  mu_y_m1 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));
  am = 35; af = 6; p = 3; rt2 = am-p; nrt2 = af+p
  mu_y_m2 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));

  am = 20; af = 27; p = 3; rt3 = am-p; nrt3 = af+p
  mu_y_m3 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));
  am = 35; af = 27; p = 3; rt4 = am-p; nrt4 = af+p
  mu_y_m4 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));

  rts = c(rt1, rt2, rt3, rt4)
  nrts = c(nrt1, nrt2, nrt3, nrt4)
  muys = c(signif(mu_y_m1, 3), signif(mu_y_m2,3), signif(mu_y_m3,3), signif(mu_y_m4,3))
  # Generate a couple points with varying male age at conception

  pdf(NULL)
  dev.control(displaylist="enable")
  # pdf seems to save with some weird grid marks.
  par(mar=c(5,5,4,2))
  pred_data = interp(rt,nrt,mu_y)
  filled.contour(pred_data, xlab='RL (years)', ylab=expression('F + M'[0]*' (years)'), cex.lab=2, col=colfunc(26),
                 key.title = {par(cex.main=2);title(main=expression(mu[y]))},
                 #key.axes = axis(4, seq(2.5e-10, 1.415e-9, by = 0.5e-10)),
                 plot.axes = { contour(pred_data, drawlabels=T, axes=F, frame.plot=F, add=T, col="#999999", lwd=1.5, lty=3, labcex=1);
                   axis(1);
                   axis(2);
                   #segments(rt1, nrt1, rt2, nrt2)
                   #segments(rt3, nrt3, rt4, nrt4)
                   #points(rts, nrts)
                   #points(rts, nrts)
                   #text(rts, nrts, labels=muys, pos=1)

                   points(16.3,43.1,pch=21,bg='#db6d00',col="white",cex=2)
                   # Kong human point
                   points(5.64,7.53,pch=21,bg='#b66dff',col="white",cex=2)
                   # Our owl monkey point
                   points(16.8,33.8,pch=21,bg='#920000',col="white",cex=2)
                   # Venn chimp point
                   #points(5.15,4.19,pch=3,col='#009292',cex=1)
                   # Pfeiffer vervet point

                   #rect(xleft=min(rt_h), ybottom=min(nrt_h), xright=max(rt_h), ytop=max(nrt_h), border="orange")
                   # Human range
                   #rect(xleft=min(rt_ch), ybottom=min(nrt_ch), xright=max(rt_ch), ytop=max(nrt_ch), border="red")
                   # Chimp range
                   #rect(xleft=min(rt_om), ybottom=min(nrt_om), xright=max(rt_om), ytop=max(nrt_om), border="purple")
                   # Owl monkey range
                   #rect(xleft=min(rt_vv), ybottom=min(nrt_vv), xright=max(rt_vv), ytop=max(nrt_vv), border="#009292")
                   # Vervet range

                   #points(rt_p,nrt_p,type='l',col="red")
                   # Varying P line
                   #points(rt_gm,nrt_gm,type='l',col="green")
                   # Varying Gm line
                   #points(rt_gf,nrt_gf,type='l',col="blue")
                   # Varying Gf line
                 })
  plot_obj = recordPlot()
  dev.off()
  # Generate the plot and save it as an object. This allows simultaneous saving and displaying.

  png(file="figS3.png", width=8, height=7, units="in", res=400)
  print(plot_obj)
  dev.off()
  # Save plot to png file. pdf saves with weird grid lines.

  print(plot_obj)
  # Display plot
}


# REML estimation of variance components
#  nested effects (farm, bales in farm)
#  using lmer

wool <- read.table('wool.txt',header=T)
#  after reshaping wool.txt into row column format

library(lme4)

# there is an outlier, remove that before continuing
#  (could also use subset=() in the lmer call

wool2 <- wool[wool$clean < 62,]

# create farm, could also use match()
# bales 1 and 2 are from farm SE, 3-5 from SW, and 6 and 7 from C

wool2$farm <- rep(c('SE','SW','C'),c(2,3,2))[wool2$bale]

# convert both bale and farm to factors so can nest

wool2$farm.f <- as.factor(wool2$farm)
wool2$bale.f <- as.factor(wool2$bale)

wool.vc <- lmer(clean~(1|farm/bale),data=wool2)
# farm/bale indicates farm , then bale nested in farm (bale:farm)

# can also specify both explicitly
wool.vcb <- lmer(clean~(1|bale) + (1|farm:bale),data=wool2)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/wool2.r


# 4. faza: Analiza podatkov

data <- bdp %>% filter(Drzave=="European Union")
data <- data[,c(1,4)]
data <- aggregate(x = data$Vrednost,
                  by = list(data$Vrednost),
                  FUN = function(a){y <- a; return(y)})
colnames(data) <-c("EU","x")
data$EU <- c(1,2,3,4,5,6,7,8,9)

glm <- glm(data = data, x ~ I(EU))
cas <- data.frame(EU = c(10,11,12))
napoved <- cas %>% mutate(x=predict(glm,.))
imena <-c("2018/Q1","2018/Q2","2018/Q3","2019/Q1","2019/Q2","2019/Q3","2020/Q1",
          "2020/Q2","2020/Q3","2021/Q1","2021/Q2","2021/Q3")

graf_napoved <- data %>% ggplot(aes(x=EU, y=x)) +
  scale_x_continuous('Leto/Kvartal', breaks = seq(1,12, 1), limits = c(1,12),labels= imena) +
  geom_smooth(method='glm', formula=y ~ poly(x,1), color='blue',fullrange=TRUE) +
  geom_point(size=2) +
  geom_point(data = napoved, aes(x = EU, y = x), color = "red", size = 3,shape=17)+
  labs(title = "Napoved BDP za Evropsko Unijo v letu 2021") +
  ylab("Vrednost BDP v mio €") +
  guides(color=FALSE)


#This script will find the yield point, Young's modulus, and
#Poisson's ratio.
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#Read in csv file
ymfile <- "your_file_name_here_sim_data_YMxData.csv"
ymfilename <- strsplit(ymfile,"\\.")[[1]]
ymdat <- read.csv(ymfile)

#create vectors for stress and strain
ymstress <- ymdat[,1]
ymaxstrain <- ymdat[,2]
ymtrstrain <- ymdat[,3]
ymtime <- ymdat[,4]

#Create new vectors containing data before chain slippage, change accordingly.

ymendpoint <- length(ymaxstrain)

ymstressnew <- ymstress[1:ymendpoint]
ymaxstrainnew <- ymaxstrain[1:ymendpoint]
ymtrstrainnew <- ymtrstrain[1:ymendpoint]

#If the beginning of Poisson's ratio plot is super weird, just do ymaxstrainnew[500:ymendpoint]
psaxstrainnew <- ymaxstrainnew
pstrstrainnew <- ymtrstrainnew
# psaxstrainnew <- ymaxstrainnew[600:1700]
# pstrstrainnew <- ymtrstrainnew[600:1700]

#fit a regular linear model to data, this is for the segmented command
lin.mod <- lm(ymstressnew ~ ymaxstrainnew)
lin2.mod <- lm(pstrstrainnew ~ psaxstrainnew)

#use segmented package to calculated breakpoint(s), for multiple use c(value,value) after psi=
#Young's modulus, value for psi is guess
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~ymaxstrainnew, psi=0.02)

#Get breakpoint x-axis value for use in the Poisson's ratio breakpoint analysis
ps_psi_guess <- segmented.mod$psi[2]

#use segmented package to calculate breakpoint for Poisson's ratio data
#Uses x-axis breakpoint value from Young's modulus analysis
segmentedps.mod <- segmented::segmented(lin2.mod, seg.Z = ~psaxstrainnew, psi=0.04)

#Extract coefficients
#Set more breaks to 1 if multiple breakpoints are needed
morebreaks <- 0

#Young's modulus average and standard error
ym_value <- summary(segmented.mod)$coefficients[2,1]
ym_stderror <- summary(segmented.mod)$coefficients[2,2]
if (morebreaks == 1) {
  ym_strainvalue1 <- segmented.mod$psi[3]
  ym_strainvalue2 <- segmented.mod$psi[4]
} else {
  ym_strainvalue <- segmented.mod$psi[2]
}

#This is used in the Young's modulus plot
modulus_value <- round(ym_value/1000,digits=1)  # To get it into GPa

#Intercept of line
ym_intercept <- summary(segmented.mod)$coefficients[1,1]
ym_intstderror <- summary(segmented.mod)$coefficients[1,2]

#Extract Poisson's ratio coefficients

#Poisson's ratio and standard error
ps_value <- summary(segmentedps.mod)$coefficients[2,1]
ps_stderror <- summary(segmentedps.mod)$coefficients[2,2]

#Poisson intercept
ps_intercept <- summary(segmentedps.mod)$coefficients[1,1]
ps_intstderror <- summary(segmentedps.mod)$coefficients[1,2]

#Write matrix
if (morebreaks == 1) {
  df_ymps <- data.frame(ym_value,ym_stderror,ym_strainvalue1,ym_strainvalue2,ym_intercept,ym_intstderror,ps_value,ps_stderror,ps_intercept,ps_intstderror)

} else {
  df_ymps <- data.frame(ym_value,ym_stderror,ym_strainvalue,ym_intercept,ym_intstderror,ps_value,ps_stderror,ps_intercept,ps_intstderror)
}
#Write coefficients to file
write.table(df_ymps,file=paste(ymfilename[1],"txt",sep="."),sep="\t")

# Get point at YM_value
ym_value <- segmented.mod$psi[2]
ym_value_stderror <- segmented.mod$psi[3]
ym_y_value <- segmented.mod$coefficients[2]*ym_value+segmented.mod$coefficients[1]

#Get point at Poisson value
ps_ax_value <- segmentedps.mod$psi[2] # x-axis value of breakpoint
ps_tr_value <- segmentedps.mod$coefficients[2]*ps_ax_value+ps_intercept

# Create moving average for journal article
ma <- function(x,n=5){filter(x,rep(1/n,n),sides=2)}
ymstressma <- ma(ymstress)
ymaxstrainma <- ma(ymaxstrain)

# Need to plot full stress strain curve
# pdf(paste(ymfilename[1],"_PEEKpaper_fullcurve",".pdf",sep=""))
# par(cex.lab=1.5,cex.axis=1.5)
# plot(ymaxstrainma,ymstressma,col="black",cex.lab=3,xlim=c(0,0.2),ylim=c(-50,max(ymstressnew)),xlab = 'True Strain',ylab = 'True Stress (MPa)')
# dev.off()

#Plot breakpoint analysis for Young's modulus
pdf(paste(ymfilename[1],"_zoomedin",".pdf",sep=""))
par(cex.lab=1.5,cex.axis=1.5)
# The below is for normal analysis. The second plot is for journal articles.
plot(ymaxstrainnew,ymstressnew,col="black",xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),main = paste("Young's Modulus=",modulus_value,"GPa"),xlab = 'True Strain',ylab = 'True Stress (MPa)')
# plot(ymaxstrainnew,ymstressnew,col="black",xlim=c(0,max(ymaxstrainnew)),ylim=c(-50,max(ymstressnew)),xlab = 'True Strain',ylab = 'True Stress (MPa)')
#par(new = TRUE)
plot(segmented.mod,col="red",lwd=3,xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),xlab = '',ylab = '',rug=FALSE,add=TRUE)
#par(new = TRUE)
points(ym_value,ym_y_value,pch=21,cex=4,col="lightskyblue",bg="lightskyblue",xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),xlab = '',ylab = '')
dev.off()

#Plot breakpoint analysis for Poisson's ratio
ympoissonname <- paste(ymfilename[1],"_Poisson",sep="")
pdf(paste(ympoissonname,"pdf",sep="."))
plot(psaxstrainnew,pstrstrainnew,col="blue",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),main = paste("Poisson's ratio =",abs(round(ps_value,digits=4))),xlab = 'True Axial Strain',ylab = 'True Transverse Strain')
par(new = TRUE)
plot(segmentedps.mod,col="red",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(ps_ax_value,ps_tr_value,pch=24,col="black",bg="black",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),xlab = '',ylab = '')
dev.off()


library(forecast)
library(plyr)
library(zoo)

MAX_DECIMAL <- 79228162514264337593543950335

#Time series models
TIME_SERIES_MODEL_ALL = "ALL"
TIME_SERIES_MODEL_ARIMA = "ARIMA"
TIME_SERIES_MODEL_ETS = "ETS"
TIME_SERIES_MODEL_STL = "STL"
TIME_SERIES_MODEL_ETS_ARIMA = "ETS+ARIMA"
TIME_SERIES_MODEL_ETS_STL = "ETS+STL"

TIME_SERIES_MODELS = c(TIME_SERIES_MODEL_ALL, TIME_SERIES_MODEL_ARIMA, TIME_SERIES_MODEL_ETS, TIME_SERIES_MODEL_STL, TIME_SERIES_MODEL_ETS_ARIMA, TIME_SERIES_MODEL_ETS_STL)

#Missing value substitution options
MISSING_VALUE_MEAN = "MEAN"
MISSING_VALUE_PREVIOUS = "PREVIOUS"
MISSING_VALUE_INTERPOLATION_LINEAR = "INTERPOLATE LINEAR"
MISSING_VALUE_INTERPOLATION_POLYNOMIAL = "INTERPOLATE POLYNOMIAL"

MISSING_VALUE_OPTIONS = c(MISSING_VALUE_MEAN, MISSING_VALUE_PREVIOUS, MISSING_VALUE_INTERPOLATION_LINEAR, MISSING_VALUE_INTERPOLATION_POLYNOMIAL)

#Values for the FORCE_SEASONALITY
FORCE_SEASONALITY_AUTO = "AUTO"
FORCE_SEASONALITY_NONE = "NONE"
FORCE_SEASONALITY_ADDITIVE = "ADDITIVE"
FORCE_SEASONALITY_MULTIPLICATIVE = "MULTIPLICATIVE"

FORCE_SEASONALITY_OPTIONS = c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_NONE, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE)

#Values for the MISSING_VALUE_SCOPE option
MISSING_VALUE_SCOPE_GLOBAL = "GLOBAL"
MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE = "GRANULARITY_ATTRIBUTE"
MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE = "HISTORY_DATE_RANGE"

MISSING_VALUE_SCOPE_OPTIONS = c(MISSING_VALUE_SCOPE_GLOBAL, MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE, MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE)

order_and_fill_missing_values <- function(data, missingValueSubstitution, min_datekey, max_datekey) {

    #Order data by date key
    data <- data[order(data$DATEKEY),]

    #Get minimum and maximum date keys
    if (is.na(min_datekey)) {
        min_datekey <- head(data$DATEKEY, 1)
    }
    if (is.na(max_datekey)) {
        max_datekey <- tail(data$DATEKEY, 1)
    }

    #Fill records with missing date keys with NaN
    filled_data <- merge(data.frame(list(DATEKEY = seq(min_datekey, max_datekey))), data, all = T)

    #Replace NaN with a value, so forecast models knows that there was no data.
    if (is.numeric(missingValueSubstitution)) {
        filled_data$TRANSACTIONQTY[is.na(filled_data$TRANSACTIONQTY)] <- missingValueSubstitution
    }
    else if (missingValueSubstitution == MISSING_VALUE_MEAN) {
        filled_data$TRANSACTIONQTY[is.na(filled_data$TRANSACTIONQTY)] <- mean(filled_data$TRANSACTIONQTY, na.rm = TRUE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_PREVIOUS) {
        filled_data$TRANSACTIONQTY <- na.locf(filled_data$TRANSACTIONQTY, na.rm = FALSE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_INTERPOLATION_LINEAR) {
        filled_data$TRANSACTIONQTY <- na.approx(filled_data$TRANSACTIONQTY, na.rm = FALSE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_INTERPOLATION_POLYNOMIAL) {
        filled_data$TRANSACTIONQTY <- na.spline(filled_data$TRANSACTIONQTY)
    }

    return(filled_data)
}

mape <- function(observed, predicted) {

    observedLenght <- length(observed);

    if (observedLenght == 0) {
        return(-1);
    }

    #The same number of predicted and observed elements must be used
    predicted <- head(predicted, n = observedLenght);

    ape <- (abs(observed - predicted)) / observed * 100;
    mape <- mean(ape, na.rm = TRUE)

    if (is.nan(mape)) {
        mape <- -1;
    }

    return(mape);
}

modelArima <- function(historicalData, forecastHorizon, confidenceLevel, forceSeasonality) {
    return(tryCatch({
        force_seasonality_model_map <- c(NA, 1, 1, 0)
        names(force_seasonality_model_map) <- c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE, FORCE_SEASONALITY_NONE)

        arima_model <- auto.arima(historicalData, D = force_seasonality_model_map[forceSeasonality])
        fcast <- forecast(arima_model, h = forecastHorizon, level = c(confidenceLevel))

        mean_arima <- as.numeric(fcast$mean)
        sigma_arima <- as.numeric((fcast$upper - fcast$lower) / 2)
        arima_fitted <- as.numeric(fitted(arima_model))

        return(list(mean = mean_arima, sigma = sigma_arima, fitted = arima_fitted))

    }, error = function(err) {
        print(paste("ARIMA model error:  ", err))
        return(NULL)
    }))
}

modelEts <- function(historicalData, forecastHorizon, confidenceLevel, forceSeasonality) {
    return(tryCatch({
        # model = 3 characters: Z means automatically selected
        # 1st letter is error type, 2nd letter is trend type, 3rd letter is season type.
        force_seasonality_model_map <- c("ZZZ", "ZZA", "ZZM", "ZZN")
        names(force_seasonality_model_map) <- c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE, FORCE_SEASONALITY_NONE)

        ets_model <- ets(historicalData, model = force_seasonality_model_map[forceSeasonality])
        fcast <- forecast(ets_model, h = forecastHorizon, level = c(confidenceLevel))

        mean_ets <- as.numeric(fcast$mean)
        sigma_ets <- as.numeric((fcast$upper - fcast$lower) / 2)
        ets_fitted <- as.numeric(fitted(ets_model))

        return(list(mean = mean_ets, sigma = sigma_ets, fitted = ets_fitted))
    }, error = function(err) {
        print(paste("ETS model error:  ", err))
        return(NULL)
    }))
}

modelStl <- function(historicalData, forecastHorizon, confidenceLevel, seasonality) {
    if ((seasonality > 1) && (length(historicalData) > 2 * seasonality)) {
        tryCatch({
            fcast <- stlf(historicalData, h = forecastHorizon, level = c(confidenceLevel))

            mean_stl <- as.numeric(fcast$mean)
            sigma_stl <- as.numeric((fcast$upper - fcast$lower) / 2)
            stl_fitted <- as.numeric(fitted(fcast))

            return(list(mean = mean_stl, sigma = sigma_stl, fitted = stl_fitted))
        }, error = function(err) {
            print(paste("STL model error:  ", err))
            return(NULL)
        })
    }
    else {
        return(NULL)
    }
}

modelEtsArima <- function(ets_result, arima_result) {
    if (!is.null(ets_result) && !is.null(arima_result)) {
        mean_ets_arima <- (arima_result$mean + ets_result$mean) / 2.0;
        sigma_ets_arima <- sqrt(0.25 * ets_result$sigma * ets_result$sigma + 0.25 * arima_result$sigma * arima_result$sigma)
        ets_arima_fitted <- (arima_result$fitted + ets_result$fitted) / 2.0;

        return(list(mean = mean_ets_arima, sigma = sigma_ets_arima, fitted = ets_arima_fitted))
    }
    return(NULL)
}

modelEtsStl <- function(ets_result, stl_result) {
    if (!is.null(ets_result) && !is.null(stl_result)) {
        mean_ets_stl <- (stl_result$mean + ets_result$mean) / 2.0;
        sigma_ets_stl <- sqrt(0.25 * ets_result$sigma * ets_result$sigma + 0.25 * stl_result$sigma * stl_result$sigma)

        ets_stl_fitted <- (stl_result$fitted + ets_result$fitted) / 2.0;

        return(list(mean = mean_ets_stl, sigma = sigma_ets_stl, fitted = ets_stl_fitted))
    }
    return(NULL)
}

addToOutput <- function(vars_data_frame, granularity_attribute, date_key, transaction_qty, sigma, error_percentage, forecast_model_name) {
    new_data_frame <- data.frame(GRANULARITYATTRIBUTE = granularity_attribute, DATEKEY = date_key, TRANSACTIONQTY = transaction_qty, SIGMA = sigma, ERRORPERCENTAGE = as.numeric(0), FORECASTMODELNAME = "")

    # Put model parameters only in first line for same granularity attribute
    new_data_frame$ERRORPERCENTAGE[1] = error_percentage[1]
    new_data_frame$FORECASTMODELNAME[1] = forecast_model_name[1]

    return(rbind(vars_data_frame, new_data_frame));
}

trainModels <- function(timeSeriesModel, historicalData, forecastHorizon, confidenceLevel, seasonality, forceSeasonality) {
    result = list()

    #ARIMA
    if (timeSeriesModel == TIME_SERIES_MODEL_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        arimaForecast <- modelArima(historicalData, forecastHorizon, confidenceLevel, forceSeasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_ARIMA]] <- arimaForecast
        }
    }

    #ETS
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS || timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        etsForecast <- modelEts(historicalData, forecastHorizon, confidenceLevel, forceSeasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_ETS || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_ETS]] <- etsForecast
        }
    }

    #STL
    if (timeSeriesModel == TIME_SERIES_MODEL_STL || timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        stlForecast <- modelStl(historicalData, forecastHorizon, confidenceLevel, seasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_STL]] <- stlForecast
        }
    }

    #ETS + ARIMA
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        result[[TIME_SERIES_MODEL_ETS_ARIMA]] <- modelEtsArima(etsForecast, arimaForecast)
    }

    #ETS + STL
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        result[[TIME_SERIES_MODEL_ETS_STL]] <- modelEtsStl(etsForecast, stlForecast)
    }

    return(result);
}

entry_script = new.env()

# This method will be called on init in each worker process.
entry_script$init <- function() {
}

# This method will be called on each minibatch.
entry_script$run <- function(minibatch) {

    # Map 1-based optional input ports to variables
    datasetCombined <- minibatch # class: data.frame

    ################### PARAMETERS INIT ###################

    #Convert column names to upper
    for (i in 1:length(names(datasetCombined))) {
        colnames(datasetCombined)[i] <- toupper(colnames(datasetCombined)[i])
    }

    #First row should have parameter values
    datasetParameters <- head(datasetCombined, 1)

    data <- datasetCombined

    print(paste("Generating forecast for granularity attribute: ", data$GRANULARITYATTRIBUTE[1], ", length of dataset is: ", length(data$GRANULARITYATTRIBUTE)))

    #Number of forecast predictions
    horizon <- as.numeric(datasetParameters$HORIZON)

    if (is.na(horizon) || horizon <= 0) {
        stop(paste("Parameter HORIZON must be greater than 0."))
    }

    #Seasonality of historical data
    if (is.null(datasetParameters$SEASONALITY)) {
        seasonality <- 1;
    } else {
        seasonality <- as.numeric(datasetParameters$SEASONALITY);
    }

    if (is.na(seasonality) || seasonality <= 0) {
        stop(paste("Parameter SEASONALITY must be greater than 0."))
    }

    #Start date key from which forecast should be generated
    global_max_datekey <- max(data$DATEKEY)
    if (is.null(datasetParameters$FORECAST_START_DATEKEY)) {
        forecast_start_datekey <- global_max_datekey + 1;
    } else {
        forecast_start_datekey <- as.numeric(datasetParameters$FORECAST_START_DATEKEY);

        if (forecast_start_datekey <= global_max_datekey) {
            stop(paste("Parameter FORECAST_START_DATEKEY must be greater than maximum date key of historical data (", global_max_datekey, ")"))
        }
    }

    #Time series model
    if (is.null(datasetParameters$TIME_SERIES_MODEL)) {
        timeSeriesModel <- TIME_SERIES_MODEL_ALL;
    } else {
        timeSeriesModel <- toupper(datasetParameters$TIME_SERIES_MODEL);
    }

    if (is.na(match(timeSeriesModel, TIME_SERIES_MODELS))) {
        stop(paste("Parameter value of TIME_SERIES_MODEL does not represent any known forecasting model."))
    }

    #Confidence level
    if (is.null(datasetParameters$CONFIDENCE_LEVEL)) {
        confidenceLevel <- 95;
    } else {
        confidenceLevel <- as.numeric(datasetParameters$CONFIDENCE_LEVEL);
    }

    if (is.na(confidenceLevel) || confidenceLevel <= 0 || confidenceLevel >= 100) {
        stop(paste("Parameter CONFIDENCE_LEVEL must be greater than 0 and lower than 100."))
    }

    #Size of a test set in a percent of a total historical data size
    if (is.null(datasetParameters$TEST_SET_SIZE_PERCENT)) {
        testSetSizePercent <- 20;
    } else {
        testSetSizePercent <- as.numeric(datasetParameters$TEST_SET_SIZE_PERCENT);
    }

    if (is.na(testSetSizePercent) || testSetSizePercent < 0 || testSetSizePercent >= 100) {
        stop(paste("Parameter TEST_SET_SIZE_PERCENT must be greater than or equal to 0 and lower than 100."))
    }

    #How gaps in historical data are filled
    if (is.null(datasetParameters$MISSING_VALUE_SUBSTITUTION)) {
        missingValueSubstitution <- 0;
    } else {

        if (is.numeric(datasetParameters$MISSING_VALUE_SUBSTITUTION)) {
            missingValueSubstitution <- as.numeric(datasetParameters$MISSING_VALUE_SUBSTITUTION)
        }
        else {
            missingValueSubstitution <- toupper(datasetParameters$MISSING_VALUE_SUBSTITUTION)

            if (is.na(match(missingValueSubstitution, MISSING_VALUE_OPTIONS))) {
                stop(paste("Parameter value of MISSING_VALUE_SUBSTITUTION does not represent any known substitution option."))
            }
        }
    }

    #How are the historical data gaps filled?
    if (is.null(datasetParameters$MISSING_VALUE_SCOPE)) {
        missingValueScope <- MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE;
    } else {
        missingValueScope <- toupper(datasetParameters$MISSING_VALUE_SCOPE);
    }

    if (is.na(match(missingValueScope, MISSING_VALUE_SCOPE_OPTIONS))) {
        stop(paste("Parameter value of MISSING_VALUE_SCOPE does not represent any known option."))
    }

    #History date range period
    global_min_datekey <- min(data$DATEKEY)
    historyDateRangeFrom <- historyDateRangeTo <- NA
    if (missingValueScope == MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE) {
        if (is.null(datasetParameters$HISTORY_DATE_RANGE_FROM)) {
            historyDateRangeFrom <- global_min_datekey
        } else {
            historyDateRangeFrom <- as.numeric(datasetParameters$HISTORY_DATE_RANGE_FROM)
        }
        if (is.null(datasetParameters$HISTORY_DATE_RANGE_TO)) {
            historyDateRangeTo <- global_max_datekey
        } else {
            historyDateRangeTo <- as.numeric(datasetParameters$HISTORY_DATE_RANGE_TO)
        }

        if (historyDateRangeTo < historyDateRangeFrom) {
            stop(paste("Parameter HISTORY_DATE_RANGE_TO must be greater than parameter HISTORY_DATE_RANGE_FROM"))
        }
    }

    #Seasonality
    if (is.null(datasetParameters$FORCE_SEASONALITY)) {
        forceSeasonality <- FORCE_SEASONALITY_AUTO;
    } else {
        forceSeasonality <- toupper(datasetParameters$FORCE_SEASONALITY);
    }

    if (is.na(match(forceSeasonality, FORCE_SEASONALITY_OPTIONS))) {
        stop(paste("Parameter value of FORCE_SEASONALITY does not represent any known seasonality option."))
    }

    ################### END PARAMETERS INIT ###################

    output <- data.frame(
        GRANULARITYATTRIBUTE = character(0),
        DATEKEY = numeric(0),
        TRANSACTIONQTY = numeric(0),
        SIGMA = numeric(0),
        ERRORPERCENTAGE = numeric(0),
        FORECASTMODELNAME = character(0))

    granularityAttributes <- unique(data$GRANULARITYATTRIBUTE);
    granularityAttributes_num <- length(granularityAttributes)

    min_datekey <- max_datekey <- NA
    #Get minimum and maximum date keys
    if (missingValueScope == MISSING_VALUE_SCOPE_GLOBAL) {
        max_datekey <- max(data$DATEKEY)
        min_datekey <- min(data$DATEKEY)
    } else if (missingValueScope == MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE) {
        max_datekey <- historyDateRangeFrom
        min_datekey <- historyDateRangeTo
    }

    for (i in 1:granularityAttributes_num) {

        granularityAttribute_data <- data[which(data$GRANULARITYATTRIBUTE == granularityAttributes[i]),]

        #Prepare training and test data for given granularity attribute
        granularityAttribute_data <- order_and_fill_missing_values(granularityAttribute_data, missingValueSubstitution, min_datekey, max_datekey)

        full_data <- as.numeric(granularityAttribute_data$TRANSACTIONQTY)

        full_data_ts <- ts(full_data, frequency = seasonality)
        full_data_last_datekey <- granularityAttribute_data$DATEKEY[length(granularityAttribute_data$DATEKEY)];
        full_data_horizon_offset <- forecast_start_datekey - full_data_last_datekey + horizon - 1;

        test_size <- floor(length(granularityAttribute_data$TRANSACTIONQTY) * testSetSizePercent / 100);
        resultTimeSeriesModel <- timeSeriesModel

        if (test_size > 0) {
            #When there is data in the test set then the model will be chosen based on how well it predicts the demand in the test set

            test_data <- tail(as.numeric(granularityAttribute_data$TRANSACTIONQTY), n = test_size);
            train_data <- head(granularityAttribute_data$TRANSACTIONQTY, n = -test_size)

            train_data_ts <- ts(train_data, frequency = seasonality);

            result <- trainModels(timeSeriesModel, train_data_ts, forecastHorizon = test_size, confidenceLevel = confidenceLevel, seasonality, forceSeasonality)

            #Calculate accuracy metrics

            #Mape cannot be calculated when there are zeros in the data
            test_data_na <- replace(test_data, test_data == 0, NaN)

            result_mape <- Inf

            for (name in names(result)) {
                #How big is the error between forecasted demand and actual demand
                current_mape <- mape(test_data_na, result[[name]]$mean)

                if (current_mape < result_mape) {
                    resultTimeSeriesModel <- toupper(name)
                    result_mape <- current_mape
                }
            }

            result <- trainModels(resultTimeSeriesModel, full_data_ts, full_data_horizon_offset, confidenceLevel, seasonality, forceSeasonality)
        }
        else {
            #There is no data in the test set so the model will be chosen based on how well it fits historical data
            result <- trainModels(timeSeriesModel, full_data_ts, full_data_horizon_offset, confidenceLevel, seasonality, forceSeasonality)

            #Mape cannot be calculated when there are zeros in the data
            full_data_na <- replace(full_data, full_data == 0, NaN)

            #MAPE cannot be calculated when the test set is empty
            result_mape <- -1
            min_mape_fitted <- Inf

            for (name in names(result)) {
                #How well the model fits historical data
                current_mape_fitted <- mape(full_data_na, result[[name]]$fitted)

                if (current_mape_fitted < min_mape_fitted) {
                    resultTimeSeriesModel <- toupper(name)
                    min_mape_fitted <- current_mape_fitted
                }
            }
        }

        #Save result to output
        mean_aml <- c()
        sigma_aml <- c()
        mape_aml <- c()

        if (!is.null(result[[resultTimeSeriesModel]])) {
            mean_aml <- result[[resultTimeSeriesModel]]$mean
            sigma_aml <- result[[resultTimeSeriesModel]]$sigma
            mape_aml <- result_mape
        }

        if (length(mean_aml) == 0) {
            paste("Forecast cannot be generated for ", granularityAttributes[i])

            output = addToOutput(
                output,
                granularityAttributes[i],
                -1,
                -1,
                -1,
                -1,
                "")
        }
        else {
            sigma_aml[is.infinite(sigma_aml)] <- MAX_DECIMAL

            #Forecasted values will be sent starting from forecast start date key parameter value
            output = addToOutput(
                output,
                granularityAttributes[i],
                seq(from = forecast_start_datekey, length.out = horizon),
                tail(as.numeric(mean_aml), horizon),
                tail(as.numeric(sigma_aml), horizon),
                mape_aml,
                resultTimeSeriesModel)
        }
    }

    # Each parallel run step minibatch processing returns an array of string.
    # Lines from all the minibatches are combined into 1 output file.
    result <- paste(
        paste('"', output$GRANULARITYATTRIBUTE, '"', sep = ""),
        output$DATEKEY,
        output$TRANSACTIONQTY,
        output$SIGMA,
        output$ERRORPERCENTAGE,
        output$FORECASTMODELNAME,
        sep = ",")
}


# ......................................................................................
# ................. Cvičení 13. Neparametrické testy, testy dobré shody.................
# .................. Michal Béreš, Martina Litschmannová, Adéla Vrtková.................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Testování shody rozdělení pravděpodobnosti diskrétní NV (o konečném počtu hodnot)  ####-
# test dobré shody
# - testujeme zda naměřená data (jejich relativní četnosti) souhlasí s nějakým
# konkrétním rozdělením (tedy jeho pravděpodobnostmi)
# - testujeme pomocí $\chi^2$ testu dobré shody
# - předpoklady testu: (POZOR týkají se předpokládaných četností - tedy těch které
# bychom sledovali pokud by naměřená data byla 100% dle rozdělení v hypotéze)
#     - Očekávané četnosti ≥ 2,
#     - alespoň 80% očekávaných četností > 5
# - testová statistika (ta která má $\chi^2$ rozdělení) je $G = \sum_{i = 1}^k (O_i -
# E_i)^2 / E_i$
# - rozdělení ma stupeň volnosti $df = k - 1 - h$
#     - k je počet možností
#     - h je počet odhadovaných parametrů (toto se týká neúplně specifikovaných testů)

# ukázka viz příklad 1

# * Test dobré shody pro spojitou náhodnou veličinu (případně diskrétní o nekonežném ####
# počtu hodnot)
# - musíme převést na tabulku s konečným počtem hodnot
# - u diskrétní (např. poison) shlukneme od určitého  počtu kolonek např. 4,5,6,... na
# "4 a více"
# - u spojité vyrobíme sérii intervalů a koukáme se kolik hodnot spadne do daného
# intervalu
#     - např.: (-$\infty$, 3), <3, 4), ..., <10, $\infty$)
#     - pak musíme pro očekávané rozdělení napočítat pro každý interval kolik % dat do
# nich patří, čímž získáme tabulku očekávaných pravděpodobností
# - dále pokračujeme jako u předchozího
# - pro testování normality rozdělení existuje funkce pearson.test(data) z balíčku
# nortest

# ukázka příklady 2,3,4

#  Kontingenční tabulky ####
# - tabulky obsahující data v závislosti na dvou faktorech
# - jeden z faktorů je z pravidla nezávislá proměnná u které sledujeme, zda má vliv na
# druhý faktor (závislá proměnná)
#     - nezávislá proměnná je zpravidla v řádcích
#     - závislá je zpravidla ve sloupcích
# - pozor celé testování zkoumá korelaci, nikoliv kauzalitu! Kauzalita se dá posoudit
# "expertním" zhodnocením
#     - statistický závěr: existuje statisticky významná závislost mezi nezávislou a
# závislou proměnnou (korelace)
#     - expertní posouzení: nezávislá proměnná statisticky významně ovlivňuje závislou
# proměnnou (kauzalita)

# * Vizualizace kontingenční tabulky ####
# - vizualizace např. pomocí funkce barplot
#     - pozor na to co jsou řádky a sloupce, vždy chceme aby jednotlivé dělené sloupce
# byly přes nezávislé proměnné (každý sloupec pro jednu hodnotu nezávislé proměnné)
#     - beside = T určuje zda chceme přilehlé sloupce sloučit do jednoho děleného
# sloupce, či ne
# - preferovaná vizualizace pomocí mozaikového grafu mosaicplot
#     - totéž co u barplotu, spojené sloupce musí být přes nezávislé proměnné

# ukázky v příkladech 5,6,7

# * Míry závislosti v koningenční tabulce ####
# - Koeficient korelace CC
# - Korigovaný koeficient korelace CCcor
# - Cramerův koeficient V
#     - tento budeme používat především
#     - funkce cramersV(kont.tab) z balíčku lsr

# ukázky v příkladech 5,6,7

# * Test závislosti v kontingenční tabulce ####
# - $H_0:$ neexistuje závislost mezi nezávislou (např. je kouřák) a závislou (např. trpí
# onemocněním) proměnnou
# - $H_A: \neg H_0$
# - funkce chisq.test(kont.tab)
#     - předpoklady: Očekávané četnosti ≥ 2, alespoň 80% očekávaných četností > 5
#     - očekávané četnosti se dají zjistit z chisq.test(kont.tab)\$expected

#  Asociační tabulky ####
# - jedná se o speciální případ kontingenční tabulky
# - má vždy právě 2 možnosti pro závislou a právě 2 možnosti pro nezávislou proměnnou

# * Povinný tvar asociační tabulky ####
# - řádky označují možnosti nezávislé proměnné
#     - první řádek je takzvaná exponovaná část populace (ta vystavena jevu který
# zkoumáme - např. kuřáci poku zkoumáme vliv kouření)
#     - druhý řádek je neexponovaná část populace
# - sloupce označují možnosti závislé proměnné
#     - první sloupec označuje výskyt zkoumaného jevu (např. výskyt nemoci, chyba
# výrobku, ...)
#     - druhý sloupec označuje zbytek - bez výskytu zkoumaného jevu

# * Relativní riziko a poměr šancí ####
# - Relativní riziko a poměr šancí podávají stejnou informaci, pouze v jiném formátu
# - všechny bodové IO se spočtou pomocí funkce epi.2by2(asoc.tab) z balíčku epiR
#     - funkce bere jako vstup asociační tabulku, která musí být ve správném formátu!

# ** Relativní riziko ####
# - značíme $RR$
# - jedná se o poměr rizika (pravděpodobnost výskytu zkoumaného jevu) u exponované a
# neexponované populace
#     - pokud je roven 1 tak to značí stejné pravděpodobnosti výskytu u exponované i u
# neexponované
#     - pokud je větší než 1 pak exponovaná polulace má větší pravděpodobnost výskytu
#     - pokud je menší než 1 pak exponovaná populace má menší pravděpodobnost výskytu
# - bodový odhad $\hat{RR}$ se spočte jako poměr rel. četností zkoumaného jevu u
# exponované a neexponované populace
# - funkce epi.2by2 dodá intervalové odhady
# - pokud IO neobsahuje hodnotu 1 pak existuje statisticky významná závislost mezi
# závislou a nezávislou proměnnou

# ** Poměr šancí ####
# - značíme $OR$
# - jedná se o poměr šancí (šance výskytu zkoumaného jevu) u exponované a neexponované
# populace
#     - pokud je roven 1 tak to značí stejné šance výskytu u exponované i u neexponované
#     - pokud je větší než 1 pak exponovaná polulace má větší šanci výskytu
#     - pokud je menší než 1 pak exponovaná populace má menší šanci výskytu
# - bodový odhad $\hat{OR}$ se spočte jako poměr šancí (výběrových) zkoumaného jevu u
# exponované a neexponované populace
# - funkce epi.2by2 dodá intervalové odhady
# - pokud IO neobsahuje hodnotu 1 pak existuje statisticky významná závislost mezi
# závislou a nezávislou proměnnou

# ukázka v příkladu 7

#  Příklady (testy dobré shody) ####
# * Příklad 1. ####
# Hodilo se 6 000 krát hrací kostkou a zaznamenaly se počty padlých ok.
# Je možné na základě příslušného testu na hladině významnosti 0,05 spolehlivě tvrdit,
# že kostka
# je „falešná“, tj. že pravděpodobnosti všech čísel na kostce nejsou stejné?
# Obrázek viz sbírka úloh.

#H0: Kostka je férová. (tedy všechny pravděpodobnosti jsou 1/6)
#Ha: Kostka není férová. (negace H0)

x = c(1,2,3,4,5,6)
n.obs = c(979,1002,1015,980,1040,984)
p.exp = c(1/6,1/6,1/6,1/6,1/6,1/6)
n.exp = 6000*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# Všechny očekávané četnosti jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1 - pchisq(x.obs,5)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,711,
# Chí-kvadrát test nezávislosti, df = 5).

# * Příklad 2. ####
# Výrobní firma odhaduje počet poruch určitého zařízení během 100 hodin pomocí
# Poissonova
# rozdělení s parametrem 1,2. Zaměstnanci zaznamenali pro kontrolu skutečné počty poruch
# celkem ve 150 100hodinových intervalech (výsledky jsou uvedeny v tabulce). Ověřte
# čistým testem významnosti, zda má počet poruch daného zařízení během 100 hodin
# skutečně Poissonovo
# rozdělení s parametrem λt = 1,2.
# Obrázek viz sbírka úloh.

# Úplně specifikovaný test

# H0: Počet poruch během 100 hodin provozu lze modelovat
#     Poissonovým rozdělením s parametrem 1,2.
# Ha: Počet poruch během 100 hodin provozu nelze modelovat
#     Poissonovým rozdělením s parametrem 1,2.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

p.exp = dpois(x,1.2)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# 4 z 5 očekávaných četnosti, tj. 80%, jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,4)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,590,
# Chí-kvadrát test nezávislosti, df = 4).

# * Příklad 3. ####
# Zaměstnanci zaznamenali pro kontrolu počty poruch celkem ve 150 100hodinových
# intervalech
# (výsledky jsou uvedeny v tabulce). Ověřte čistým testem významnosti, zda má počet
# poruch
# daného zařízení během 100 hodin skutečně Poissonovo rozdělení.
# Obrázek viz sbírka úloh.

# Neúplně specifikovaný test

# H0: Počet poruch během 100 hodin provozu lze modelovat
#     Poissonovým rozdělením.
# Ha: Počet poruch během 100 hodin provozu nelze modelovat
#     Poissonovým rozdělením.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

lambda.t = weighted.mean(x,n.obs)   # odhad parametru Poissonova rozdělení
lambda.t

p.exp = dpois(x,lambda.t)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# 4 z 5 očekávaných četnosti, tj. 80%, jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,3)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,491,
# Chí-kvadrát test nezávislosti, df = 3).

# * Příklad 4.  ####
# Na dálnici byly v průběhu několika minut měřeny časové odstupy (s) mezi průjezdy
# jednotlivých vozidel. Zjištěné hodnoty těchto odstupů jsou zaznamenány v souboru
# dalnice.xlsx. Ověřte, zda se jedná o data z normálního rozdělení (použijte test dobré
# shody).

# automatický test dobré shody ze spojitých dat

dalnice = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=2)
colnames(dalnice)="hodnoty"
head(dalnice)

mu = mean(dalnice$hodnoty)
sigma = sd(dalnice$hodnoty)
mu
sigma

# generování hodnot pro osu x
xfit=seq(from = -20, to = 30, length = 100)
# generování hodnot pro osu y
yfit=dnorm(xfit, mean = mu, sd = sigma)

hist(dalnice$hodnoty, freq = FALSE, xlim = c(-20, 30))
# do posledního grafu přidání křivky na základě výše vygenerovaných hodnot
lines(xfit, yfit, col="black", lwd=2)

# install.packages("nortest")

#H0: Rozestupy mezi vozidly lze modelovat normálním rozdělením.
#Ha: Rozestupy mezi vozidly nelze modelovat normálním rozdělením.

nortest::pearson.test(dalnice$hodnoty)

# Určení počtu stupňů volbnosti
pom = nortest::pearson.test(dalnice$hodnoty, n.classes = 5)
attributes(pom)

pom$method
pom$n.classes
pom$df
pom$p.value

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody, df = 12).

# test co už znáte
shapiro.test(dalnice$hodnoty)

#  Příklady na kontingenční a asociační tabulky ####
# * Příklad 5. ####
# Rozhodněte na základě datového souboru experimentovani-s-telem.xls (Dudová, J. -
# Experimentování s tělem (výsledky průzkumu), 2013. Dostupné online na
# http://experimentovani-stelem.vyplnto.cz), zda existuje souvislost mezi pohlavím
# respondentů a tím, zda mají tetování. Pro posouzení míry kontingence použijte
# Cramerovo V.

tet = readxl::read_excel("./CV13/data/neparametricke_hypotezy.xlsx", sheet=3)
head(tet)

tet = tet[,c(6,10)]
colnames(tet) = c("pohlavi","tetovani")
head(tet)

# Preprocessing
# Varianty kat. proměnných (faktorů) je nutné uspořádat a pojmenovat tak,
# jak mají být uspořádány a pojmenovány v kont. tabulce

kont.tab = table(tet$pohlavi, tet$tetovani)
kont.tab

colnames(kont.tab) = c("má tetování","nemá tetování")
kont.tab

# Explorační analýza
prop.table(kont.tab)    # sdružené relativní četnosti
prop.table(kont.tab,1)  # řádkové relativní četnosti
prop.table(kont.tab,2)  # sloupcové relativní četnosti

# Vizualizace ve standardním R
# Shlukový sloupcový graf
# srovnejte grafy, který z grafů je pro prezentaci daných dat vhodnější

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

barplot(t(kont.tab),
        legend = colnames(kont.tab),
        beside = T)

barplot(kont.tab,
        legend = rownames(kont.tab),
        beside = T)

# Skládaný sloupcový graf

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

barplot(t(kont.tab),
        legend = colnames(kont.tab))

barplot(kont.tab,
        legend = rownames(kont.tab))

# Mozaikový graf

options(repr.plot.width = 8) # šířka grafů v Jupyteru

mosaicplot(t(kont.tab),
           las = 1, # otočení popisků osy y
           color = gray.colors(2))

# srovnejte, který z grafů je pro prezentaci daných dat vhodnější
mosaicplot(kont.tab,
           las = 1,
           color = gray.colors(2))

# install.packages("lsr")

# Výpočet Cramerova V ####
lsr::cramersV(kont.tab)

# Test nezávislosti v kontingenční tabulce

# H0: Data jsou nezávislá -> to jestli je jedinec muž nebo žena
# neovlivní jeho pravděpodobnost, že budemít tetování
# HA: negace H0 (existuje závislost)

pom = chisq.test(kont.tab)
attributes(pom)

pom$expected # Nutné pro ověření předpokladů
# Všechny očekávané četnosti jsou větší než 5.

pom

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota = 0,003,
# Chí-kvadrát test dobré shody, df = 1).
# Pozorovanou závislost lze hodnotit jako slabou (Cramerovo V = 0,121).

# * Příklad 6. ####
# Pro diferencovaný přístup v personální politice potřebuje vedení podniku vědět, zda
# spokojenost v práci závisí na tom, jedná-li se o pražský závod či závody mimopražské.
# Výsledky šetření jsou v následující tabulce. Zobrazte data pomocí mozaikového grafu a
# na základě testu nezávislosti v kombinační tabulce rozhodněte o závislosti
# spokojenosti v zaměstnání na umístnění podniku. Pro posouzení míry kontingence
# použijte Cramerovo V.
# Obrázek viz sbírka úloh.

# Nemáme k dispozici datovou matici, tj. kont. tabulku musíme zadat "ručně"
kont.tab = matrix(c(10,25,50,15,20,10,130,40),
                  nrow=2,byrow=T)
rownames(kont.tab) = c("Praha","Venkov")
colnames(kont.tab) = c("velmi nespokojen","spíše nespokojen",
                       "spíše spokojen","velmi spokojen")
kont.tab = as.table(kont.tab)
kont.tab

# Explorační analýza ####
prop.table(kont.tab)  # sdružené relativní četnosti
prop.table(kont.tab,1)  # řádkové relativní četnosti
prop.table(kont.tab,2)  # sloupcové relativní četnosti

# Vizualizace ve standardním R
# Mozaikový graf
mosaicplot(kont.tab,
           las = 1, # otočení popisků osy y o 90
           color = gray.colors(4))

# Cramerovo V
lsr::cramersV(kont.tab)

# H0: Mezi spokojenosti v práci a umístěním podniku neexistuje souvislost.
# Ha: Mezi spokojenosti v práci a umístěním podniku existuje souvislost.

# Chí-kvadrát test nezávislosti v kontingenční tabulce ####
pom = chisq.test(kont.tab)
pom$expected
# Všechny očekávané četnosti jsou větší než 5.

pom

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody, df = 3).
# Pozorovanou závislost lze hodnotit jako středně silnou (Cramerovo V = 0,296)

# * Příklad 7. (Asociační tabulka) ####
# V letech 1965 až 1968 bylo v kohortové studii kardiovaskulárních onemocnění v rámci
# „Honolulu Heart Program“ zahájeno sledování 8 006 mužů, z nichž 7 872 nemělo při
# zahájení studie v anamnéze mrtvici (apoplexii). Z tohoto počtu bylo 3 435 kuřáků a 4
# 437 nekuřáků. Při jejich sledování po dobu 12 let dostalo mrtvici 171 mužů ve skupině
# kuřáků a 117 mužů ve skupině nekuřáků.
# *** a)  ####
# Zapište zjištěné výsledky do asociační tabulky.

kont.tab = matrix(c(171,3264,117,4320),nrow=2,byrow=T)
rownames(kont.tab) = c("kuřák","nekuřák")
colnames(kont.tab) = c("ano","ne")
kont.tab

# doplnění tabulky absolutních četností
kont.tab.full = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.full) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.full) = c("ano", "ne", "sum")

kont.tab.full[1:2, 1:2] = kont.tab
kont.tab.full[1:2, 3] = rowSums(kont.tab)
kont.tab.full[3, 1:2] = colSums(kont.tab)
kont.tab.full[3, 3] = sum(kont.tab)
kont.tab.full

# doplnění tabulky relativních četností
kont.tab.rel = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.rel) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.rel) = c("ano", "ne", "sum")

kont.tab.rel[1:2, 1:2] = prop.table(kont.tab)
kont.tab.rel[1:2, 3] = rowSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 1:2] = colSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 3] = sum(kont.tab.rel[1:2, 1:2])
kont.tab.rel

# *** b) ####
# Na základě vizuálního posouzení odhadněte vliv kouření na výskyt kardiovaskulárních
# onemocnění.

# Vizualizace mozaikovým grafem v základním R
mosaicplot(kont.tab,
           color = gray.colors(2))

# Výpočet Cramerova V ####
lsr::cramersV(kont.tab)

# Dle mozaikového grafu a Cramerova V (0,061) lze souvislost mezi kuřáctvím
# a výskytem apoplexie hodnotit jako velmi slabou.

# *** c) ####
# Určete absolutní riziko vzniku kardiovaskulárních onemocnění u kuřáků a nekuřáků.

# riziko = pravděpodobnost
kont.tab.full

# Kuřáci
# Kontrola předpokladů
p = 171/3435
p

9/(p*(1-p))
# OK (3 435 > 190,3)

# Výpočet bodového a 95% Clopperova-Pearsonova intervalového odhadu
prop.test(x = 171, n = 3435)

# U kuřáku je riziko vzniku apoplexie cca 5,0 %. 95% Clopperův-Pearsonův
# intervalový odhad tohoto rizika je 4,2 % až 5,8 %.

# Nekuřáci
# Kontrola předpokladů
p = 117/4437
p

9/p/(1-p)
# OK (4 437 > 350,6)

# Výpočet bodového a 95% Clopperova-Pearsonova intervalového odhadu
prop.test(117,4437)

# U nekuřáku je riziko vzniku apoplexie cca 2,6 %. 95% Clopperův-Pearsonův
# intervalový odhad tohoto rizika je 2,1 % až 3,2 %.

# *** d) ####
# Určete relativní riziko (včetně 95% intervalového odhadu) vzniku kardiovaskulárních
# onemocnění u kuřáků a nekuřáků. Vysvětlete praktický význam zjištěných výsledků.

# install.packages("epiR")

kont.tab

epiR::epi.2by2(kont.tab)

# U kuřáků je cca 1,89 krát vyšší riziko apoplexie než u nekuřáků. 95%
# intervalový odhad tohoto relativního rizika je 1,50 až 2,38.
# Dle intervalového odhadu relativního rizika je zřejmé, že na hladině
# významnosti 0,05 je u kuřáků statisticky významně vyšší riziko vzniku
# apoplexie než u nekuřáků.

# *** e) ####
# Určete absolutní šance vzniku kardiovaskulárních onemocnění u kuřáků a nekuřáků.

# U kuřáku je šance vzniku apoplexie cca 52:1 000. Tj. u 1 052 kuřáků
# lze očekávat cca 52 výskytů apoplexie.
# U nekuřáku je šance vzniku apoplexie cca 27:1 000. Tj. u 1 027 nekuřáků
# lze očekávat cca 27 výskytů apoplexie.

#  *** f) ####
#  Určete relativní šance vzniku kardiovaskulárních onemocnění u kuřáků.

# U kuřáků je cca 1,93 (= 0,0524/0,0271) krát vyšší šance apoplexie
# než u nekuřáků. 95% intervalový odhad tohoto poměru
# šancí je 1,52 až 2,46.
# Dle intervalového odhadu poměru šancí je zřejmé, že na hladině
# významnosti 0,05 je u kuřáků
# statisticky významně vyšší šance na vznik apoplexie než u nekuřáků.

# *** g) ####
# Rozhodněte na hladině významnosti 0,05 o závislosti výskytu kardiovaskulárních chorob
# na kouření.

# Pozor! Příkaz epi.2by2 nemá jako výstup očekávané četnosti pro
# Chí-kvadrát test nezávislosti.
# Není tak možno ověřit předpoklady testu!

# H0: Mezi kouřením a výskytem apoplexie neexistuje souvislost.
# Ha: Mezi kouřením a výskytem apoplexie existuje souvislost.

pom = chisq.test(kont.tab)
pom$expected
# Všechny očekávané četnosti jsou větší než 5.

pom

lsr::cramersV(kont.tab)

#Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody,
# df = 1). Pozorovanou závislost lze hodnotit jako velmi slabou
# (Cramerovo V = 0,061).


##########################################################
# Functions to sample from the conditional distributions
##########################################################
library(MASS)
library(mvtnorm)
source('ars_alpha.r')
source('ars_beta.r')

# Chinese Restaurant Process with auxiliary tables (Neal's algorithm 8)
sample_z <- function(u, A, alpha, z, mu_ar, S_ar, mu_a0, R_a0, beta_a0, W_a0){
  m <- 3 # number of auxiliary tables to approximate the infinite number of empty tables

  n <- tabulate(z)
  K <- length(unique(z))
  D <- dim(A)[1]
  R_a0_inv <- solve(R_a0)
  W_a0_inv <- solve(W_a0)

  # Compute likelihood for every table
  logprobs <- rep(NA, K+m)
  for(k in 1:K){
    logp <- log(n[k]-as.numeric(z[u]==k))
    logp <- logp + mvtnorm::dmvnorm(A[,u], mean=mu_ar[,k,drop=FALSE], sigma=ginv(S_ar[,,k]), log=TRUE)
    logprobs[k] <- logp
  }

    # Create m auxiliary tables from the base distribution
    aux.tables.mean <- t(mvrnorm(m, mu_a0, R_a0_inv))
    aux.tables.covariance <-  rWishart(m, max(beta_a0,D), W_a0/beta_a0)

    # If last point in cluster, re-use its parameters for the auxiliary table so that
    # it has some probability of staying
    if (n[z[u]]==1){
      aux.tables.mean[,1] <- mu_ar[,z[u], drop=FALSE]
      aux.tables.covariance[,,1] <- S_ar[,,z[u]]
    }

    # Compute likelihood for auxilary table
    for(k in 1:m){
      logp <- log(alpha/m)
      logp <- logp + mvtnorm::dmvnorm(A[,u], mean=aux.tables.mean[,k], sigma=as.matrix(aux.tables.covariance[,,k]), log=TRUE)
      logprobs[K+k] <- logp
    }

  # normalize probabilities to avoid numerical underflow
  probs <- logprobs-max(logprobs)
  probs <- exp(probs)
  probs <- probs/sum(probs)

  # Choose table
  chosen <- base::sample(1:(K+m), 1, prob=probs)

  # Re-label tables
  ##########################################
  # if auxiliary table is chosen, assign label K+i-th to this new table
  if(chosen>K){
    mu_ar[,K+1] <- aux.tables.mean[, chosen - K]
    S_ar[,,K+1] <- solve(aux.tables.covariance[,, chosen - K])
    z[u] <- K+1
  }
  else{
    z[u] <- chosen
  }

  # if old cluster is empty, shift right tables to the left
  # do it only if DP is used (m>0)
  n <- tabulate(z)
  if(any(n==0)){
    empty <- which(n==0)
    right <- (empty+1):(K+1)
    mu_ar[,(empty:K)] <- mu_ar[,(empty+1):(K+1)]
    S_ar[,,(empty:K)] <- S_ar[,,(empty+1):(K+1)]
    z[z>empty] <- z[z>empty] - 1
  }

  if( max(z) != length(unique(z)) ){
    stop("Some cluster is not being used")
  }

  return(list(z=z,
              mu_ar=mu_ar,
              S_ar=S_ar))
}

########################################################
# Component parameters
########################################################
# Cluster mean
sample_mu_ar <- function(A_r, S_ar, mu_a0, R_a0){
  n <- dim(A_r)[2]

  # If nobody in the cluster sample from prior
  if (n == 0){
    return(mvrnorm(1, mu_a0, solve(R_a0)))
  }

  ar_mean <- rowMeans(A_r)
  Lambda_post <- R_a0 + n*S_ar
  Sigma_post <- solve(Lambda_post)
  mu_post <- Sigma_post %*% ((R_a0 %*% mu_a0) + n*(S_ar%*%ar_mean))
  return(mvrnorm(1, mu_post, Sigma_post))
}

# Cluster precision
sample_S_ar <- function(A_r, mu_ar_k, beta_a0, W_a0){
  #
  # Sample attributes covariance matrix of cluster r
  # from its conditional probability
  #
  n <- dim(A_r)[2]
  D <- dim(A_r)[1]

  # If nobody in the cluster sample from prior
  if (n == 0){
    # unfortunately wishart implementation does not accept dof > F-1
    # but dof >= F
    # This will only affect when the cluster is empty.
    df <- max(beta_a0, D)
    return(rWishart(1, df, solve(W_a0)/beta_a0))
  }
  # If only one point, scatter is just this product
  if(n==1){
    scatter_matrix <- (A_r-mu_ar_k)%*%t(A_r-mu_ar_k)
  }
  if(n > 1){
    scatter_matrix <- cov(t(A_r-c(mu_ar_k)))*(dim(A_r)[2]-1)
  }

  wishart_dof_post <- beta_a0 + n
  #wishart_S_post <- solve(beta_a0*W_a0 + scatter_matrix)
  wishart_S_post <- ginv(beta_a0*W_a0 + scatter_matrix)
  return(rWishart(1, wishart_dof_post, wishart_S_post)[,,1])
}

########################################################
# Hyperparameters
########################################################

# Hyper-mean of cluster means
sample_mu_a0 <- function(Lambda_a, mu_a, mu_ar, R_a0){
  #
  # Samples mean of gaussian hyperprior placed over clusters centroids
  #
  K <- dim(mu_ar)[2]
  mean_ar = rowMeans(mu_ar)
  Lambda_post = Lambda_a + K*R_a0
  Sigma_post = solve(Lambda_post)
  mu_post = Sigma_post %*% (Lambda_a %*% mu_a) + K*(R_a0 %*% mean_ar)
  return(mvrnorm(1, mu_post, Sigma_post))
}

# Hyper-precision of cluster means
sample_R_a0 <-function(Sigma_a, mu_ar, mu_a0){
  #
  # Samples precision of gaussian hyperprior placed over clusters centroids
  #
  K <- dim(mu_ar)[2]
  D <- dim(mu_ar)[1]
  # Can't use the trick cov(t(mu_ar-mu_a0))*(K-1) when there is only one cluster
  scatter_matrix <- 0
  for(i in 1:K){
    scatter_matrix <- scatter_matrix + (mu_ar[,i]-mu_a0)%*%t(mu_ar[,i]-mu_a0)
  }
  wishart_dof_post = D + K
  wishart_S_post = solve(D*Sigma_a + scatter_matrix)
  return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

# Hyper-scale of cluster covariances
sample_W_a0 <- function(Lambda_a, S_ar, beta_a0){
  #
  # Sample base covariance of attributes (hyperparameter)
  #
  K <- dim(S_ar)[3]
  D <- dim(S_ar)[1]
  # TODO: why apply does not work properly?
  #scatter_matrix <- apply(S_ar, 3, sum)
  scatter_matrix <- 0
  for (i in 1:dim(S_ar)[3]){
    scatter_matrix <- scatter_matrix + S_ar[,,i]
  }
  wishart_dof_post = D + K*beta_a0
  wishart_S_post = solve(D * Lambda_a + beta_a0*scatter_matrix)
  return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

# Hyper-dof of cluster covariances
sample_beta_a0 <- function(S, W, init=4){
  # Sample the degrees of freedom of the Wishart
  # given a scale matrix W and some observed precision matrices S
  ars.sample_beta_a0(S, W, init=init)
}


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob, real u, real b1) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200)
		   +log(1-normal_cdf(u*-0.00000005,u,0.01))*(b1<u*-0.00000005);   #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b1;
real b3;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- (mu[n-1]^2)*exp(u+b1*mu[n-1]+e[n])/(b3+mu[n-1]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.1,0.01);
b1 ~ normal(-0.0000005,0.000000001);
b3 ~ normal(0,0.000001);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob,u,b1);
}

}

"

######

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.1,b1=-0.0000005,b3=0,sig2=0.01,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=4000,iter = 40000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

Epars_m[1]=1
Epars_5[1]=1
Epars_9[1]=1

####################  trace plot

traceplot(fit, pars=c("u","b1","b3"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

traceplot(fit, pars=c("lambda","sig2","sigob"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

##################   plot 30/45/60/   length(y)

#  Germany Italy Japan Spain UK US Australia

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",lwd = 2)

#############################################################
n=length(y)

u=0.1
b1=-0.0000005
b3=0

n=length(y)

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=((x[i]^2)*exp(u+b1*x[i]))/(b3+x[i])
}
x=round(x)
x

plot(y,ylim=c(min(x),max(x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(x),max(x)))

###############################################################################
## u=0.14,b1=-0.00000009, b3=5
# u ~ normal(0,1);
# b1 ~ normal(0,0.0000001);
# b3 ~ normal(0,10);

### Germany
u=0.14
b1=-0.0000009
b2=0.4

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004


## Data analytics question and Analysis
######################################################
## A large HMO wants to know what patient and physician factors are most related to
## whether a patient’s lung cancer goes into remission after
## treatment as part of a larger study of treatment outcomes and quality of life in patients with lunger cancer.
##
## Using CancerSurvival xl (coverting it to csv) data
## Name ## Mayukh Mukhopadhyay
## Reference ## http://stats.idre.ucla.edu/other/mult-pkg/introduction-to-generalized-linear-mixed-models/
###################################################################

install.packages("ggplot2")
install.packages("GGally")
install.packages("reshape2")
install.packages("lme4")
install.packages("compiler")
install.packages("parallel")
install.packages("boot")

require(ggplot2)
require(GGally)
require(reshape2)
require(lme4)
require(compiler)
require(parallel)
require(boot)

cancerdata <- read.csv("~/CancerSurvival.csv")
cancerdata <- within(cancerdata, {
  Married <- factor(Married, levels = 0:1, labels = c("no", "yes"))
  DID <- factor(DID)
  HID <- factor(HID)
})
ggpairs(cancerdata[, c("IL6", "CRP", "LengthofStay", "Experience")])
ggplot(cancerdata, aes(x = CancerStage, y = LengthofStay)) +
  stat_sum(aes(size = ..n.., group = 1)) +
  scale_size_area(max_size=10)

 # il6 crp cancerstage plots
tmp <- melt(cancerdata[, c("CancerStage", "IL6", "CRP")], id.vars="CancerStage")
ggplot(tmp, aes(x = CancerStage, y = value)) +
  geom_jitter(alpha = .1) +
  geom_violin(alpha = .75) +
  facet_grid(variable ~ .) +
  scale_y_sqrt()

  #boxplot
tmp <- melt(cancerdata[, c("remission", "IL6", "CRP", "LengthofStay", "Experience")],
  id.vars="remission")
ggplot(tmp, aes(factor(remission), y = value, fill=factor(remission))) +
  geom_boxplot() +
  facet_wrap(~variable, scales="free_y")

# estimate the model and store results in m for nAGQ = 10
m <- glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +
    (1 | DID), data = cancerdata, family = binomial, control = glmerControl(optimizer = "bobyqa"),
    nAGQ = 10)

# BOBYQA (Bound Optimization BY Quadratic Approximation)

# print the mod results without correlations among fixed effects
print(m, corr = FALSE)

# Generalized linear mixed model fit by maximum likelihood (Adaptive Gauss-Hermite Quadrature, nAGQ
#   = 10) [glmerMod]
#  Family: binomial  ( logit )
# Formula: remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +      (1 | DID)
#    Data: cancerdata
#       AIC       BIC    logLik  deviance  df.resid
#  7397.276  7460.733 -3689.638  7379.276      8516
# Random effects:
#  Groups Name        Std.Dev.
#  DID    (Intercept) 2.015
# Number of obs: 8525, groups:  DID, 407
# Fixed Effects:
#    (Intercept)             IL6             CRP   CancerStageII  CancerStageIII   CancerStageIV
#       -2.05271        -0.05677        -0.02148        -0.41393        -1.00346        -2.33704
#   LengthofStay      Experience
#       -0.12118         0.12009

# estimate the model and store results in m for nAGQ = 50
m <- glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +
    (1 | DID), data = cancerdata, family = binomial, control = glmerControl(optimizer = "bobyqa"),
    nAGQ = 50)

# BOBYQA (Bound Optimization BY Quadratic Approximation)

# print the mod results without correlations among fixed effects
print(m, corr = FALSE)

#Generalized linear mixed model fit by maximum likelihood (Adaptive Gauss-Hermite Quadrature, nAGQ
#  = 50) [glmerMod]
# Family: binomial  ( logit )
#Formula: remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +      (1 | DID)
#   Data: cancerdata
#      AIC       BIC    logLik  deviance  df.resid
# 7397.233  7460.690 -3689.617  7379.233      8516
#Random effects:
# Groups Name        Std.Dev.
# DID    (Intercept) 2.015
#Number of obs: 8525, groups:  DID, 407
#Fixed Effects:
#   (Intercept)             IL6             CRP   CancerStageII  CancerStageIII   CancerStageIV
#      -2.05325        -0.05677        -0.02148        -0.41393        -1.00349        -2.33711
#  LengthofStay      Experience
#      -0.12118         0.12011

# getting confidence intervals (CIs)
se <- sqrt(diag(vcov(m)))
# table of estimates with 95% CI
(tab <- cbind(Est = fixef(m), LL = fixef(m) - 1.96 * se, UL = fixef(m) + 1.96 *
    se))

##                        Est          LL           UL
## (Intercept)    -2.05325039 -3.09521978 -1.011280996
## IL6            -0.05677292 -0.07934869 -0.034197141
## CRP            -0.02148286 -0.04151069 -0.001455033
## CancerStageII  -0.41393231 -0.56242696 -0.265437658
## CancerStageIII -1.00348621 -1.19612106 -0.810851355
## CancerStageIV  -2.33710519 -2.64690344 -2.027306943
## LengthofStay   -0.12118413 -0.18710508 -0.055263171
## Experience      0.12010779  0.06628398  0.173931601

# odds ratios instead of coefficients on the logit scale
exp(tab)

##                       Est         LL        UL
## (Intercept)    0.12831714 0.04526506 0.3637527
## IL6            0.94480860 0.92371778 0.9663810
## CRP            0.97874625 0.95933908 0.9985460
## CancerStageII  0.66104570 0.56982444 0.7668702
## CancerStageIII 0.36659917 0.30236479 0.4444795
## CancerStageIV  0.09660689 0.07087033 0.1316897
## LengthofStay   0.88587083 0.82935658 0.9462361
## Experience     1.12761839 1.06853011 1.1899742

##############multilevel bootstrapping with 100 replicates

sampler <- function(dat, clustervar, replace = TRUE, reps = 1) {
    cid <- unique(dat[, clustervar[1]])
    ncid <- length(cid)
    recid <- sample(cid, size = ncid * reps, replace = TRUE)
    if (replace) {
        rid <- lapply(seq_along(recid), function(i) {
            cbind(NewID = i, RowID = sample(which(dat[, clustervar] == recid[i]),
                size = length(which(dat[, clustervar] == recid[i])), replace = TRUE))
        })
    } else {
        rid <- lapply(seq_along(recid), function(i) {
            cbind(NewID = i, RowID = which(dat[, clustervar] == recid[i]))
        })
    }
    dat <- as.data.frame(do.call(rbind, rid))
    dat$Replicate <- factor(cut(dat$NewID, breaks = c(1, ncid * 1:reps), include.lowest = TRUE,
        labels = FALSE))
    dat$NewID <- factor(dat$NewID)
    return(dat)
}

set.seed(20)
tmp <- sampler(cancerdata, "DID", reps = 100)
bigdata <- cbind(tmp, cancerdata[tmp$RowID, ])

## First we store the estimates from our original model, which we will use as start values for the bootstrap models.
## Then we make a local cluster with 2 nodes (the number of processors on our machine).
## Next, we export the data and load the lme4 package on the cluster.
## Finally, we write a function to fit the model and return the estimates.
## The call to glmer() is wrapped in try because not all models may converge on the resampled data.
## This catches the error and returns it, rather than stopping processing.

f <- fixef(m)
r <- getME(m, "theta")

cl <- makeCluster(2)
clusterExport(cl, c("bigdata", "f", "r"))
clusterEvalQ(cl, require(lme4))
## [[1]]
## [1] TRUE
##
## [[2]]
## [1] TRUE

myboot <- function(i) {
    object <- try(glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay +
        Experience + (1 | NewID), data = bigdata, subset = Replicate == i, family = binomial,
        nAGQ = 1, start = list(fixef = f, theta = r)), silent = TRUE)
    if (class(object) == "try-error")
        return(object)
    c(fixef(object), getME(object, "theta"))
}

#### Execute with your own risk...My laptop with 2 cores and 4GB RAM got blackedout  5 times and returned output after 2 hours
start <- proc.time()
res <- parLapplyLB(cl, X = levels(bigdata$Replicate), fun = myboot)
end <- proc.time()

# shut down the cluster
stopCluster(cl)

# calculate proportion of models that successfully converged
success <- sapply(res, is.numeric)
mean(success)

# combine successful results
bigres <- do.call(cbind, res[success])

# calculate 2.5th and 97.5th percentiles for 95% CI
(ci <- t(apply(bigres, 1, quantile, probs = c(0.025, 0.975))))

##                       2.5%     97.5%
## (Intercept)       -3.61982 -0.985404
## IL6               -0.08812 -0.029664
## CRP               -0.04897  0.006824
## CancerStageII     -0.60754 -0.228019
## CancerStageIII    -1.30217 -0.754609
## CancerStageIV     -2.91414 -2.002643
## LengthofStay      -0.21596 -0.046420
## Experience         0.06819  0.207223
## NewID.(Intercept)  2.03868  2.476366

# All results
finaltable <- cbind(Est = c(f, r), SE = c(se, NA), BootMean = rowMeans(bigres),
    ci)
# round and print
round(finaltable, 3)

##                    Est    SE BootMean   2.5%  97.5%
## (Intercept)     -2.053 0.531   -2.205 -3.620 -0.985
## IL6             -0.057 0.012   -0.059 -0.088 -0.030
## CRP             -0.021 0.010   -0.022 -0.049  0.007
## CancerStageII   -0.414 0.076   -0.417 -0.608 -0.228
## CancerStageIII  -1.003 0.098   -1.043 -1.302 -0.755
## CancerStageIV   -2.337 0.158   -2.460 -2.914 -2.003
## LengthofStay    -0.121 0.034   -0.142 -0.216 -0.046
## Experience       0.120 0.027    0.128  0.068  0.207
## DID.(Intercept)  2.015    NA    2.263  2.039  2.476


library(tidyverse)
library(R0)
library(scales)
library(incidence)
library(EpiDynamics)
library(spatstat)

param_dat = expand.grid(
  initial_r0 = seq(2, 3, by = 0.25),
  incubation_period = seq(4, 7, by = 0.5),
  distancing_effect = seq(0.4, 0.7, by = 0.05),
  prop_susceptible = seq(0.3, 0.7, by = 0.1),
  initial_shutdown = c('2020-03-07') %>% as.Date(),
  missing_death_rate = seq(0.30, 0.60, by = 0.05)
)

setwd("~/Public_Policy/Projects/COVID-19")
italy_jh_joined = read_csv('data/jh_joined.csv') %>% filter(country_region == 'Italy') %>%
  filter(cases > 0) %>%
  mutate(
    time = as.numeric(date_upd - min(date_upd)),
    new_deaths = c(deaths[1], diff(deaths, 1)),
    days_since_first_death = as.numeric(date_upd - min(date_upd[deaths > 0])),
    weeks_since_first_death = days_since_first_death %/% 7
  )

italy_jh_joined_weekly_deaths = group_by(italy_jh_joined, weeks_since_first_death) %>%
  summarize(
    obs = n(),
    total_deaths = sum(new_deaths)
  ) %>%
  mutate(
    projected = total_deaths / (obs/7)
  )

run_sir_sim = function(the_row, return_data = F){

  # the_row = param_dat[it,]
  # the_row = these_params
  #
  # the_row = tibble(
  #   initial_r0 = 2.25,
  #   incubation_period = 5,
  #   distancing_effect = 0.6,
  #   prop_susceptible = 0.3,
  #   missing_death_rate = 0.4,
  #   initial_shutdown = as.Date('2020-03-07')
  # )
  initial_r0 = the_row$initial_r0

  distancing_effect = the_row$distancing_effect
  distancing_r0 = initial_r0 * (1- distancing_effect)

  incubation_period = the_row$incubation_period
  gamma = 1/incubation_period

  initial_beta = initial_r0 / incubation_period
  secondary_beta = distancing_r0 / incubation_period

  italy_pop = 60.36e6
  italy_susceptible = italy_pop * the_row$prop_susceptible

  missing_death_rate = the_row$missing_death_rate

  ##### pull in data ####

  initial_shutdown = the_row$initial_shutdown
  first_cases = min(italy_jh_joined$date_upd)
  initial_r0_period = as.numeric(initial_shutdown - first_cases) - 1

  secondary_period = as.numeric(max(italy_jh_joined$date_upd) - initial_shutdown)
  total_time = initial_r0_period + secondary_period - 1 + 60
  time_since_initial_case = as.numeric(max(italy_jh_joined$date_upd) - min(italy_jh_joined$date_upd))

  # covid
  initial_parameters <- c(beta = initial_beta, gamma = gamma)
  initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

  initial_covid_sir <- SIR(pars = initial_parameters, init = initials, time = 0:initial_r0_period)

  secondary_parameters <- c(beta = secondary_beta, gamma = gamma)
  secondary_initials <- c(S = tail(initial_covid_sir$results$S, 1), I = tail(initial_covid_sir$results$I, 1),
                          R = tail(initial_covid_sir$results$R, 1))

  distancing_covid_sir = SIR(pars = secondary_parameters, init = secondary_initials, time = (initial_r0_period+1):total_time)

  # combine sirs

  est_deaths = function(par, missing_death_rate, return_dat = F) {

    death_rate = par[1]

    combined_sirs =
      tibble(
        time = initial_covid_sir$time,
        S = initial_covid_sir$results$S,
        I = initial_covid_sir$results$I,
        R = initial_covid_sir$results$R,
        model = 'initial'
      ) %>%
      bind_rows(
        tibble(
          time = distancing_covid_sir$time - 1,
          S = distancing_covid_sir$results$S,
          I = distancing_covid_sir$results$I,
          R = distancing_covid_sir$results$R,
          model = 'secondary'
        ) %>%
          filter(time != min(time))
      ) %>%
      mutate(
        new_cases = round(lag(S * italy_susceptible, 1) - S*italy_susceptible),
        deaths = rbinom(length(S), new_cases, prob = death_rate),
        death_timing = rweibull(length(S), 3, 10),
        death_date =  round(time + death_timing),
        days_since_first_death = death_date - min(death_date[deaths > 0], na.rm = T),
        death_week = days_since_first_death %/% 7
      )

    # # [1] 3.005484 7.201339
    # the_weibull = rweibull(1000, the_solution$par[1], the_solution$par[2])
    # #

    sir_weekly_deaths = group_by(combined_sirs, death_week) %>%
      summarize(
        sir_total_deaths = sum(deaths, na.rm = T)
      )

    weekly_comparison = inner_join(italy_jh_joined_weekly_deaths, sir_weekly_deaths,
                                   by = c('weeks_since_first_death' = 'death_week')) %>%
      mutate(
        italy_true_death_estimate = projected / (1-missing_death_rate),
        diff_sir_total_deaths_true = sir_total_deaths - italy_true_death_estimate,
        squared_diff_sir_total_deaths_true = diff_sir_total_deaths_true^2
      )

    # use projected here
    italy_reported_deaths_to_date = sum(weekly_comparison$projected)
    italy_true_death_estimate = italy_reported_deaths_to_date / (1-missing_death_rate)
    sir_deaths_to_date = sum(weekly_comparison$sir_total_deaths)
    difference_sir_true_est = sum(weekly_comparison$squared_diff_sir_total_deaths_true)

    if (return_dat) {
      return(combined_sirs)
    } else {
      return(difference_sir_true_est)
    }
  }

  the_solution = optim(par = 0.01, fn = est_deaths, method = 'Brent', lower = 0.001, upper = 0.05, missing_death_rate = missing_death_rate)

  # > the_solution$par
  # [1] 0.003152483

  sir_dat = est_deaths(the_solution$par, return_dat = T, missing_death_rate = missing_death_rate)
  head(sir_dat)

  sir_weekly_deaths = group_by(sir_dat, death_week) %>%
    summarize(
      sir_total_deaths = sum(deaths, na.rm = T)
    )

  weekly_comparison = inner_join(italy_jh_joined_weekly_deaths, sir_weekly_deaths, by = c('weeks_since_first_death' = 'death_week')) %>%
    mutate(
      italy_true_death_estimate = projected / (1-missing_death_rate),
    )

  return_dat = tibble(
    weekly_correlation = cor(weekly_comparison$projected, weekly_comparison$sir_total_deaths),
    solution_diff = the_solution$value^(1/2),
    solved_ifr = the_solution$par,
    sir_total_deaths = sum(sir_weekly_deaths$sir_total_deaths),
    sir_total_observed_deaths = sum(sir_weekly_deaths$sir_total_deaths) * (1-missing_death_rate),
    sir_observed_to_date = sum(weekly_comparison$sir_total_deaths) * (1-missing_death_rate),
    actual_to_date = sum(weekly_comparison$total_deaths),
    projected_to_date = sum(weekly_comparison$projected),
    actual_projected_not_missing = sum(weekly_comparison$projected) / (1-missing_death_rate)
  )

  if (return_data) {
    return(
      list(
        weekly_comparison = weekly_comparison,
        sir_dat = sir_dat,
        return_dat = return_dat,
        sir_weekly_deaths = sir_weekly_deaths
      )
    )
  } else {
    return(return_dat)
  }
}

all_italy_runs = map(1:nrow(param_dat), function(it){
  print(it/nrow(param_dat))

  run_sir_sim(param_dat[it,])
}) %>%
  bind_rows()

param_dat$it = 1:nrow(param_dat)

all_italy_runs_with_params = inner_join(all_italy_runs %>% mutate(it = 1:nrow(all_italy_runs)), param_dat) %>%
  arrange(solution_diff, -weekly_correlation) %>%
  mutate(
    weekly_correlation = ifelse(weekly_correlation < 0, 0, weekly_correlation)
  )

write.csv(all_italy_runs_with_params,
          'data/all_italy_runs_with_params.csv', row.names = F)

# limit to the most plausible solutions

all_italy_runs_with_params$weekly_correlation %>% hist()
weighted.mean(all_italy_runs_with_params$solved_ifr, all_italy_runs_with_params$weekly_correlation^2)
weighted.quantile(all_italy_runs_with_params$solved_ifr, all_italy_runs_with_params$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)

ggplot(all_italy_runs_with_params, aes(distancing_effect, initial_r0 )) +
  geom_point() +
  # geom_tile(aes(fill = solution_diff, alpha = weekly_correlation^2)) +
  scale_fill_viridis_d(direction = -1)

# get top ten percent as solution set
mean(top_10$solved_ifr)
ggplot(top_10, aes(weekly_correlation, solved_ifr, colour = initial_r0)) +
  geom_point()

weighted.mean(top_10$solved_ifr, top_10$weekly_correlation^2)
weighted.quantile(top_10$solved_ifr, top_10$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)

all_italy_runs_with_params$solution_diff %>% summary()

solution_set = filter(all_italy_runs_with_params, solution_diff <= 1000) %>%
  arrange(-weekly_correlation)
solution_set$solution_diff %>%  hist()

ggplot(solution_set, aes(weekly_correlation^2, solved_ifr)) +
  geom_point(aes(colour = initial_r0))  +
  scale_colour_viridis_c(option = 'C') +
  theme_dark() +
  stat_smooth()

these_params = filter(param_dat, it %in% head(solution_set, 1)$it)
the_dat = run_sir_sim(these_params, T)
names(the_dat)
the_dat$sir_dat
ggplot(the_dat$sir_dat, aes(time, new_cases)) +
  geom_bar(stat = 'identity')
ggplot(the_dat$sir_dat, aes(time, I)) +
  geom_line()

sum(the_dat$sir_dat$new_cases, na.rm = T)
the_dat$sir_weekly_deaths

ggplot(the_dat$sir_weekly_deaths, aes(death_week , sir_total_deaths*(1-these_params$missing_death_rate))) +
  geom_bar(stat = 'identity')

ggplot(the_dat$weekly_comparison, aes(weeks_since_first_death)) +
  geom_area(aes(y = projected), alpha = 0.5) +
  geom_area(aes(y = sir_total_deaths), alpha = 0.5, fill = 'red')

the_dat$sir_weekly_deaths
sum(the_dat$sir_weekly_deaths*(1-these_params$missing_death_rate))

the_dat$weekly_comparison
ggplot(the_dat$sir_dat, aes(death_date, deaths)) +
  geom_bar(stat = 'identity')

weighted.mean(solution_set$solved_ifr, solution_set$weekly_correlation^2)
weighted.quantile(solution_set$solved_ifr, solution_set$weekly_correlation^(2), probs=seq(0,1,0.25), na.rm = TRUE)
head(solution_set, 5) %>% View()

ggplot(solution_set, aes(weekly_correlation, initial_r0, colour = solved_ifr)) +
  geom_point() +
  scale_colour_viridis_c()

head(all_italy_runs_with_params)
names(all_italy_runs_with_params)
avg_by_param

ggplot(all_italy_runs_with_params, aes(initial_r0, solved_ifr, fill = weekly_correlation, alpha = weekly_correlation)) +
  geom_point()
all_italy_runs_with_params$solved_ifr

ggplot(solution_set, aes(initial_r0, distancing_effect, fill = weekly_correlation)) +
  scale_fill_viridis_c() +
  geom_tile() +
  scale_x_continuous(breaks = seq(2, 3, by = 0.25))

filter(solution_set, distancing_effect == 0.6, initial_r0 == 2.25) %>% arrange(-weekly_correlation)
solution_set$initial_r0


# aula 6 - árvores de decisão

d <- read.csv("train.csv")
dTest <- read.csv("test.csv")

View(d)

install.packages("party")
library(party)

#Árvore com 1 variável
mod <- ctree(Survived~Sex, data=d)
plot(mod, type="simple")

# Árvore com 2 variáveis
mod <- ctree(Survived~Sex+Pclass, data=d)
plot(mod, type="simple")

#Árvore com 3 variáveis
mod <- ctree(Survived~Sex+Pclass+Age, data=d)
plot(mod, type="simple")

#ML Classificador AD
d <- read.csv("train.csv")
# Separação base treino e teste
set.seed(44)
va <-sample(nrow(d))
treino <- d[va[1:691],]
teste <- d[va[692:891],]

# Modelagem
#mod <- ctree(Survived~Sex+Pclass+Embarked, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age+Embarked, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age, data=treino)
#mod <- ctree(Survived~Sex+Pclass, data=treino)
#mod <- ctree(Survived~Sex+Pclass+Age+Fare, data=treino)
mod <- ctree(as.factor(Survived)~Sex+Pclass+Embarked+Sibsp+Parch, data=treino)
plot(mod, type="simple")
#Previsão em teste

p <- predict(mod, newdata=teste)
prev <- ifelse(p<=.407,0,1)
cbind(prev,teste$Survived)

# Matriz de confusão
# cm - A.K.A - Confusion Matrix
cm <- table(p, teste$Survived)
Precision <- cm[2,2]/ ( cm[1,2] + cm[2,2])
Recall <- cm[2,2]/ ( cm[2,1] + cm[2,2])
accuracy <- (cm[1,1] + cm[2,2] )/ nrow(teste)
cm
accuracy
Precision
Recall


library(npowerPrioR)
scenario <- 1
source(paste("data_regression_NIG_scenario_", scenario, ".r", sep = ""))
summary(lm(y_0 ~ -1 + X_0))

lm.data <- list(
  N0 = N_0,
  P = P,
  X0 = X_0,
  y0 = y_0,
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  a_0 = NULL
)

invlambda0 <- solve(lm.data$lambda_0)
###
get_mal_NIG_regression <- function(y0, X0, n0, mu0, lambda0, alpha0, beta0, a_0){
  P <- ncol(X0)
  if(length(mu0) != P) stop("mu0 is not the same dimension as X")
  Xstar <- sqrt(a_0) * X0
  ystar <- sqrt(a_0) * y0
  lambda_n <- t(Xstar)%*%Xstar + lambda0
  mu_n <- solve(lambda_n) %*% (lambda0%*%mu0 + t(Xstar)%*%ystar)
  alpha_n <-  as + (n0*a_0)/2
  beta_n <- beta0 + .5 * ( t(ystar)%*%ystar + t(mu0)%*%lambda0%*%mu0 - t(mu_n)%*%lambda_n%*%mu_n )
  det0 <- det(lambda0)
  det1 <- det(lambda_n)
  ans <- -(a_0 * n0/2) * log(2*pi) + .5 * (log(det0) - log(det1)) + (alpha0 * log(beta0) - alpha_n * log(beta_n) ) + (lgamma(alpha_n)-lgamma(alpha0))
  return(ans)
}
#
l_a0 <- function(x) {
  get_mal_NIG_regression(
    y0 = lm.data$y0,
    X0 = lm.data$X0,
    n0 = lm.data$N0,
    mu0 = lm.data$mu_beta,
    lambda0 = invlambda0,
    alpha0 = lm.data$alpha0,
    beta0 = lm.data$beta0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

#########
J <- 20

adaptive.ca0.estimates <- read.csv(paste("../data/constant_data/RegressionNIG_logCA0_adaptive_J=", J,
                                         "_scenario_", scenario, ".csv", sep = ""))
maxA <- max(adaptive.ca0.estimates$a0)
ylims <- range(c(adaptive.ca0.estimates$lc_a0, adaptive.ca0.estimates$deriv_lc))

curve(l_a0_p, 1E-4, maxA, lwd = 3, lty = 2, col = 2,
      ylab = "", xlab = expression(a[0]), cex.lab = 3, cex.axis = 2.5, ylim = ylims)
abline(h = 0, lwd = 2 , lty = 3)
curve(l_a0, 0, maxA, lwd = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0, cex = 1.5, pch = 16)
curve(l_a0_pp, 0, maxA, lwd = 3, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, cex = 1.5, col = 3, pch = 16)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc,
       pch = 16, cex = 1.5, col = 2)
legend(x = "topright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"),
       col = 1:3, lwd = 2, bty = 'n', cex = 1.5)

adaptive.ca0.estimates$true_la0 <- l_a0(adaptive.ca0.estimates$a0)
adaptive.ca0.estimates$norm_error <- (adaptive.ca0.estimates$lc_a0- adaptive.ca0.estimates$true_la0)/adaptive.ca0.estimates$true_la0

adaptive.ca0.estimates
mean(abs(adaptive.ca0.estimates$norm_error[-1]))

#######
midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)

K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

true.lca0s <- l_a0(pred_a0s)

gam.preds.list <- list(
  gam =  data.frame (a0 = pred_a0s, lca0 = preds.gam$mean, dev = preds.gam$mean - true.lca0s, lwr = preds.gam$lwr,
                     upr = preds.gam$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, dev = deriv.preds - true.lca0s, lwr = NA, upr = NA,
                           approximating_function = "gam-derivative", design = "adaptive_numerical")
)

##########################

## RMSE
lapply(gam.preds.list, function(pred) sqrt(mean( (pred$lca0 - true.lca0s)^2 )) )
## MAD
lapply(gam.preds.list, function(pred) mean( abs(pred$lca0 - true.lca0s) ))

## RMSE, a0 < 1
lapply(gam.preds.list, function(pred) sqrt(mean( (pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1])^2 )) )
## MAD, a0 < 1
lapply(gam.preds.list, function(pred) mean( abs(pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1]) ))

### Exporting

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0,
          file = paste("../data/constant_data/fitted_predictions_lca0_RegressionNIG_scenario_", scenario, ".csv", sep = ""),  row.names = FALSE)

library(ggplot2)

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p0

p1 <- ggplot(data = subset(forplot_ca0, approximating_function == "gam"),
             aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p1

ggsave(p0,
  filename = paste("../figures/estimates_log_ca0_RegressionNIG_scenario_", scenario, ".pdf", sep = ""), dpi = 300)