# Working with apply functions - sapply

# use str(temp) to see structure of temp list with vectors

# 1. Difference between lapply and sapply outputs
# temp has already been defined in the workspace

# Use lapply() to find each day's minimum temperature - returns a list of values
lapply(temp, min)

# Use sapply() to find each day's minimum temperature - returns a vector of values
sapply(temp, min)

# Use lapply() to find each day's maximum temperature
lapply(temp, max)

# Use sapply() to find each day's maximum temperature
sapply(temp, max)

# 2. Using a user defined function
# temp is already defined in the workspace

# Finish function definition of extremes_avg
extremes_avg <- function(x) {
  ( min(x) + max(x) ) / 2
}

# Apply extremes_avg() over temp using sapply()
sapply(temp, extremes_avg)

# Apply extremes_avg() over temp using lapply()
lapply(temp, extremes_avg)

# 3. Returning a vector
# Create a function that returns min and max of a vector: extremes
extremes <- function(x) {
  c(min = min(x), max = max(x))
}

# Apply extremes() over temp with sapply() - produces a matrix for the two vectors (min, max)
sapply(temp, extremes)

# Apply extremes() over temp with lapply() - produces a list of paired values for each vector element from temp
lapply(temp, extremes)

# 4. Compare the two apply methods with the identical method
# Definition of below_zero()
below_zero <- function(x) {
  return(x[x < 0])
}

# Apply below_zero over temp using sapply(): freezing_s
freezing_s <- sapply(temp, below_zero)

# Apply below_zero over temp using lapply(): freezing_l
freezing_l <- lapply(temp, below_zero)

# Are freezing_s and freezing_l identical? - return a value of TRUE showing that both methods produced the same results
identical(freezing_s, freezing_l)

# 5. Functions that return a NULL
# Definition of print_info()
print_info <- function(x) {
  cat("The average temperature is", mean(x), "\n")
}

# Apply print_info() over temp using sapply()
sapply(temp, print_info)

# Apply print_info() over temp using lapply()
lapply(temp, print_info)


#getwd()
library(dplyr)

par(mfrow = c(1, 1))

# Načtení dat z xlsx souboru
data_xlsx = readxl::read_excel("./1S/ukol_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data_xlsx = data_xlsx[,-1] # odstraníme první sloupec s indexy
colnames(data_xlsx)=c("A22","A5","B22","B5","C22","C5","D22","D5")
head(data_xlsx)

data_xlsx$A_d = data_xlsx$A22-data_xlsx$A5
data_xlsx$B_d = data_xlsx$B22-data_xlsx$B5
data_xlsx$C_d = data_xlsx$C22-data_xlsx$C5
data_xlsx$D_d = data_xlsx$D22-data_xlsx$D5

data=reshape(data=as.data.frame(data_xlsx),
                  direction="long",
                  varying=list(c("A5", "B5", "C5", "D5"),
                               c("A22","B22","C22","D22"),
                               c("A_d","B_d","C_d","D_d")),
                  v.names=c("C5","C22","delta"),
                  times=c("Amber","Bright","Clear","Dim"),
                  timevar="vyrobce")
row.names(data) = 1:nrow(data)
data = data[-length(data)]
data = na.omit(data)

head(data)
tail(data)

# data_A = data %>% filter(vyrobce=="Amber")
# data_A = data_A[-1]

# data_B = data %>% filter(vyrobce=="Bright")
# data_B = data_B[-1]

# data_A_d = data_A$C22-data_A$C5

# data_A_DK = quantile(data_A_d, 0.25, na.rm=T)
# data_A_HK = quantile(data_A_d, 0.75, na.rm=T)
# data_A_IQR = data_A_HK - data_A_DK
# data_A_DM = data_A_DK - 1.5*data_A_IQR
# data_A_HM = data_A_HK + 1.5*data_A_IQR

# data_A_d_bezOP = data_A_d
# data_A_d_bezOP[data_A_d<=data_A_DM|data_A_d>=data_A_HM] = NA

data_A_d = data %>% filter(vyrobce=="Amber") %>% pull(delta)
data_A_d_bezOP = data_A_d
data_A_d_bezOP[data_A_d_bezOP %in% boxplot(data_A_d, plot = FALSE)$out] = NA

# data_B_d = data_B$C22-data_B$C5

# data_B_DK = quantile(data_B_d, 0.25, na.rm=T)
# data_B_HK = quantile(data_B_d, 0.75, na.rm=T)
# data_B_IQR = data_B_HK - data_B_DK
# data_B_DM = data_B_DK - 1.5*data_B_IQR
# data_B_HM = data_B_HK + 1.5*data_B_IQR

# data_B_d_bezOP = data_B_d
# data_B_d_bezOP[data_B_d<=data_B_DM|data_B_d>=data_B_HM] = NA

data_B_d = data %>% filter(vyrobce=="Bright") %>% pull(delta)
data_B_d_bezOP = data_B_d
data_B_d_bezOP[data_B_d_bezOP %in% boxplot(data_B_d, plot = FALSE)$out] = NA

sd(data_A_d_bezOP, na.rm=TRUE)
sd(data_B_d_bezOP, na.rm=TRUE)

par(mfrow = c(1, 1))

boxplot(data_A_d, data_B_d, names=c("Amber","Bright"), ylab="pokles světelného toku (lm)", main="Boxploty světelnosti")

par(mfrow = c(2, 2))

hist(data_A_d_bezOP,
    main="Amber",
    xlab="pokles světelného toku (lm)",
    ylab="četnost",
    xlim=c(-15,15),
    ylim=c(0,15))

qqnorm(data_A_d_bezOP,
        xlab="Teoretické kvantily",
        ylab="Výběrové kvantily",
        main="Amber")
qqline(data_A_d_bezOP)

hist(data_B_d_bezOP,
    main="Bright",
    xlab="pokles světelného toku (lm)",
    ylab="četnost",
    xlim=c(-15,15),
    ylim=c(0,15))

qqnorm(data_B_d_bezOP,
        xlab="Teoretické kvantily",
        ylab="Výběrové kvantily",
        main="Bright")
qqline(data_B_d_bezOP)

moments::skewness(data_A_d_bezOP, na.rm=T)
moments::skewness(data_B_d_bezOP, na.rm=T)

moments::kurtosis(data_A_d_bezOP, na.rm=T)-3
moments::kurtosis(data_B_d_bezOP, na.rm=T)-3

# test normality Shapirovovým - Wilkovovým testem
shapiro.test(data_A_d_bezOP)$p.value
shapiro.test(data_B_d_bezOP)$p.value

# test symetrie
lawstat::symmetry.test(data_A_d_bezOP, boot=FALSE)$p.value
lawstat::symmetry.test(data_B_d_bezOP, boot=FALSE)$p.value

mean(data_A_d_bezOP, na.rm=T)
mean(data_B_d_bezOP, na.rm=T)

t.test(data_A_d_bezOP, conf.level = 0.95, alternative = "greater")$conf.int
t.test(data_B_d_bezOP, conf.level = 0.95, alternative = "greater")$conf.int

t.test(data_A_d_bezOP, alternative="greater", conf.level=0.95)$p.value
t.test(data_B_d_bezOP, alternative="greater", conf.level=0.95)$p.value

var(data_A_d_bezOP,na.rm=T)
var(data_B_d_bezOP,na.rm=T)

prumer = mean(data_A_d_bezOP, na.rm=T) - mean(data_B_d_bezOP, na.rm=T)

# F-Test
var.test(x = data_A_d_bezOP, y = data_B_d_bezOP, ratio = 1, conf.level = 0.95, alternative = "two.sided")$p.value

# 95% oboustranný interval
t.test(x = data_A_d_bezOP, y = data_B_d_bezOP, mu = prumer, conf.level = 0.95, alternative = "two.sided")$conf.int

# Dvouvýběrový studentův T-test (p-hodnota)
t.test(x = data_A_d_bezOP, y = data_B_d_bezOP, mu = prumer, conf.level = 0.95, alternative = "two.sided")$p.value

# medián x0,1 - median()
# stř.hodnota je mean() - průměr


#' windspeed
#'
#' @description Calculate meteorological wind speed.
#'
#' @param u numeric U zonal component (m/s),
#' @param v numeric V meridian component (m/s),
#' @return wind speed (m/s)
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords Scaler speed wind
#'
#'
#' @export

windspeed=function(u, v) {return(sqrt(u^2+v^2))}


# Simpson's paradox

# Generate data
datalist = list()

for (i in seq(0, 100, 10)) {
  age = runif(10, i, i + 10)
  exercise = (runif(10) + .1 * age) / 10 + .1 * rnorm(10, 0, 2)
  cholesterol = (i / 10) - exercise + .4 * rnorm(10, 0, 2)
  df = data.frame(age, exercise, cholesterol)
  datalist[[(i / 10) + 1]] = df
}

# Combine all data
data_simpson = do.call(rbind, datalist)

# Plot
plot(data_simpson$age, data_simpson$exercise)
plot(data_simpson$age, data_simpson$cholesterol)
plot(data_simpson$exercise, data_simpson$cholesterol)

# Model
model_1 = lm(cholesterol ~ exercise, data=data_simpson)
model_2 = lm(cholesterol ~ exercise + age, data=data_simpson)

# Check
summary(model_1)
summary(model_2)


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

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

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

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

[Workspace loaded from ~/.RData]
 install.packages("glmnet")

 library(ggplot2)
 library(glmnet)

 datafile <- file.path("d:","epic_recipes.txt")

 recipes_data <- read.table(datafile, fill=TRUE, col.names=1:max(count.fields(datafile)), na.strings=c("", "NA"), stringsAsFactors = FALSE)

 agg <- aggregate(recipes_data[,-1], by=list(recipes_data[,1]), paste, collapse=",")

 agg$combined <- apply(agg[,2:ncol(agg)], 1, paste, collapse=",")

 agg$combined <- gsub(",NA","",agg$combined)

 cuisines <- as.data.frame(table(recipes_data[,1]))

 cuisines

 ingredients_freq <- lapply(lapply(strsplit(a$combined,","), table), as.data.frame)

 names(ingredients_freq) <- agg[,1]

 proportion <- lapply(seq_along(ingredients_freq), function(i) {
     colnames(ingredients_freq[[i]])[2] <- names(ingredients_freq)[i]
     ingredients_freq[[i]][,2] <- ingredients_freq[[i]][,2]/cuisines[i,2]
     ingredients_freq[[i]]}
 )

 names(proportion) <- a[,1]

 final <- Reduce(function(...) merge(..., all=TRUE, by="Var1"), proportion)

 row.names(final) <- final[,1]

 final <- final[,-1]

 final[is.na(final)] <- 0

 prop_matrix <- t(final)

 s <- sort(apply(prop_matrix, 2, sd), decreasing=TRUE)

 final_imp<- scale(subset(prop_matrix, select=names(which(s > 0.1))))

 heatmap.2(final_imp, trace="none", margins = c(6,11), col=topo.colors(7), key=TRUE, key.title=NA, keysize=1.2, density.info="none")

 pca_computation <- princomp(final_imp)

 pca_computation

 biplot(pca_computation, pc.biplot=TRUE, col=c("black","red"), cex=c(0.9,0.8), xlim=c(-2.5,2.5), xlab="PC1, 39.7%", ylab="PC2, 24.5%")

Chapter 04/3Principal Component Analysis - Understanding world cuisine.r


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('parsurv')

## ----hr-vs-surv,echo=FALSE,cap='Absolute clinical benefit as a function of survival in a control subject and the relative benefit (hazard ratio).  The hazard ratios are given for each curve.',scap='Absolute clinical benefit as a function of survival in a control subject and the relative benefit.'----
plot(0, 0, type="n", xlab="Survival for Control Subject",
     ylab="Improvement in Survival",
     xlim=c(0,1), ylim=c(0,.7))
i <- 0
hr <- seq(.1, .9, by=.1)
for(h in hr) {
  i <- i + 1
  p <- seq(.0001, .9999, length=200)
  p2 <- p^h
  d <- p2 - p
  lines(p, d, lty=i)
  maxd <- max(d)
  smax <- p[d==maxd]
  text(smax,maxd+.02, format(h), cex=.6)
}

## ----t-hazard,mfrow=c(2,2),top=1,h=5,w=5,cap='$\\log(T)$ distribution for $\\sigma=0.25, 0.6, 1, 2$ and for degrees of freedom $1, 2, 3, 5, 7, 15, 500$ (almost log-normal).  The top left plot has degrees of freedom written in the plot.',scap='Hazard functions for $\\log(T)$ distribution'----
require(rms)
haz <- survreg.auxinfo$t$hazard
times <- c(seq(0, .25, length=100), seq(.26, 2, length=150))
high <- c(6, 1.5, 1.5, 1.75)
low  <- c(0, 0, 0, .25)
dfs  <- c(1, 2, 3, 5, 7, 15, 500)
cols <- rep(1, 7)
ltys <- 1:7
i <- 0
for(scale in c(.25, .6, 1, 2)) {
  i <- i + 1
  plot(0, 0, xlim=c(0,2), ylim=c(low[i], high[i]),
    xlab=expression(t), ylab=expression(lambda(t)), type="n")
  col <- 1.09
  j <- 0
  for(df in dfs) {
    j <- j+1
    ## Divide by t to get hazard for log t distribution
    lines(times,
          haz(log(times), 0, c(log(scale), df))/times,
          col=cols[j], lty=ltys[j])
    if(i==1) text(1.7, .23 + haz(log(1.7), 0,
         c(log(scale),df))/1.7, format(df))
  }
  title(paste("Scale:", format(scale)))
}   # Figure (*\ref{fig:parsurv-t-hazard}*)

## ----kprats-check,mfrow=c(2,2),h=5,w=6,bot=1,ps=9,cap='Altschuler--Nelson--Fleming--Harrington nonparametric survival estimates for rats treated with DMBA,~\\cite{pik66} along with various transformations of the estimates for checking distributional assumptions of three parametric survival models.',scap='Examples of checking parametric survival model assumptions'----
getHdata(kprats)
kprats$group <- factor(kprats$group, 0:1, c('Group 1', 'Group 2'))
dd <- datadist(kprats); options(datadist="dd")

S <- with(kprats, Surv(t, death))
f <- npsurv(S ~ group, type="fleming", data=kprats)
survplot(f, n.risk=TRUE, conf='none',   # Figure (*\ref{fig:parsurv-kprats-check}*)
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Nonparametric estimates", adj=0, cex=.7)

# Check fits of Weibull, log-logistic, log-normal
xl <- c(4.8, 5.9)
survplot(f, loglog=TRUE, logt=TRUE, conf="none", xlim=xl,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Weibull (extreme value)", adj=0, cex=.7)
survplot(f, fun=function(y)log(y/(1-y)), ylab="logit S(t)",
         logt=TRUE, conf="none", xlim=xl,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Log-logistic", adj=0, cex=.7)
survplot(f, fun=qnorm, ylab="Inverse Normal S(t)",
         logt=TRUE, conf="none",
         xlim=xl,cex.label=.7,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Log-normal", adj=0, cex=.7)

## ----fittedpsm,results='asis'-------------------------------------------------
fw <- psm(S ~ group, data=kprats, dist='weibull')
fl <- psm(S ~ group, data=kprats, dist='loglogistic',
          y=TRUE)
fn <- psm(S ~ group, data=kprats, dist='lognormal')
latex(fw, fi='')
latex(fl, fi='')
latex(fn, fi='')

## ----kprats-psm-np,w=3.75,h=2.5,cap='Agreement between fitted log-logistic model and nonparametric survival estimates for rat vaginal cancer data.',scap='Fitted log-logistic model'----
survplot(f, conf.int=FALSE,   # Figure (*\ref{fig:parsurv-kprats-psm-np}*)
         levels.only=TRUE, label.curves=list(keys='lines'))
survplot(fl, add=TRUE, label.curves=FALSE, conf.int=FALSE)

## ----echo=FALSE,results='asis'------------------------------------------------
latex(pphsm(fw), fi='', digits=4)

## ----kprats-resid-np,w=3.75,h=2.5,cap='Kaplan--Meier estimates of distribution of standardized censored residuals from the log-logistic model, along with the assumed standard log-logistic distribution (dashed curve).  The step functions in red is the estimated distribution of all residuals, and the step functions in black are the estimated distributions of residuals stratified by group, as indicated.  The blue curve is the assumed log-logistic distribution.',scap='Checking AFT distributional assumption using residuals'----
r <- resid(fl, 'cens')
survplot(npsurv(r ~ group, data=kprats),
         conf='none', xlab='Residual',
         label.curves=list(keys='lines'), levels.only=TRUE)
survplot(npsurv(r ~ 1), conf='none', add=TRUE, col='red')
lines(r, lwd=1, col='blue')   # Figure (*\ref{fig:parsurv-kprats-resid-np}*)

## ----eval=FALSE---------------------------------------------------------------
## psm(Surv(d.time, event) ~ 1)

## ----eval=FALSE---------------------------------------------------------------
## units(d.time) <- "Year"
## f <- psm(Surv(d.time,cdeath) ~ lsp(age,65)*sex)
## # default is Weibull
## anova(f)
## summary(f)          # summarize effects with delta log T
## latex(f)            # typeset math. form of fitted model
## survest(f, times=1) # 1y survival est. for all subjects
## survest(f, expand.grid(sex="female", age=30:80), times=1:2)
## # 1y, 2y survival estimates vs. age, for females
## survest(f, data.frame(sex="female",age=50))
## # survival curve for an individual subject
## survplot(f, sex=NA, age=50, n.risk=T)
## # survival curves for each sex, adjusting age to 50
## f.ph <- pphsm(f)    # convert from AFT to PH
## summary(f.ph)       # summarize with hazard ratios
##                     # instead of changes in log(T)

## ----kprats-Functions,results='asis'------------------------------------------
med   <- Quantile(fl)
meant <- Mean(fl)
haz   <- Hazard(fl)
surv  <- Survival(fl)
latex(surv, file='', type='Sinput')

## ----kprats-hazard,w=4,h=2.75,top=.6,ps=9,cap='Estimated hazard functions for log-logistic fit to rat vaginal cancer data, along with median survival times.',scap='Estimated log-logistic hazard functions'----
# Plot estimated hazard functions and add median
# survival times to graph
survplot(fl, group, what="hazard")   # Figure (*\ref{fig:parsurv-kprats-hazard}*)
# Compute median survival time
m <- med(lp=predict(fl,
           data.frame(group=levels(kprats$group))))
m
med(lp=range(fl$linear.predictors))
m <- format(m, digits=3)
text(68, .02, paste("Group 1 median: ", m[1],"\n",
                    "Group 2 median: ", m[2], sep=""))
# Compute survival probability at 210 days
xbeta <- predict(fl,
                 data.frame(group=c("Group 1","Group 2")))
surv(210, xbeta)


server <- function(input, output) {
  output$coolplot <- renderPlot({
    n<-input$n
    x<-input$x
    H0<-input$H0
    H1<-input$H1
    LR<-round(max(dbinom(x,n,H0)/dbinom(x,n,H1),dbinom(x,n,H1)/dbinom(x,n,H0)),digits=2) #Calculate LR (H1 over H0 and H0 over H1, pick max)
    H0H1<-ifelse(dbinom(x,n,H0)>dbinom(x,n,H1),"The data are more likely under the null hypothesis than the alternative hypothesis","The data are more likely under the alternative hypothesis than the null hypothesis")
    theta<- seq(0,1,len=1000)
    like <- dbinom(x,n,theta)
    plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', lwd=2)
    points(H0,dbinom(x,n,H0), lwd=2)
    points(H1,dbinom(x,n,H1), lwd=2)
    segments(H0, dbinom(x,n,H0), x/n, dbinom(x,n,H0), lty=2, lwd=2)
    segments(H1, dbinom(x,n,H1), x/n, dbinom(x,n,H1), lty=2, lwd=2)
    segments(x/n, dbinom(x,n,H0), x/n, dbinom(x,n,H1), lwd=2)
    abline(v=H0, col="gray40", lty=3, lwd=2)
    abline(v=H1, col="gray40", lty=3, lwd=2)
    title(paste('Likelihood Ratio:',LR))

    #create Table
    studies<-c(0:n)
    ProbH0<-dbinom(studies,n,H0)
    ProbH1<-dbinom(studies,n,H1)
    table<-cbind(studies,ProbH0,ProbH1)
    colnames(table) <- c("Number of significant studies", "Probability of observing x out of n significant studies when H0 is true","Probability of observing x out of n significant studies when H1 is true")

    output$text1 <- renderText({
      paste("When H1 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given" ,H1, "power, is:", dbinom(x,n,H1),". If all studies examine true effects with",100*H1,"% power,",100*round(dbinom(x,n,H1),digits=4),"% of published articles with",n,"studies should observe",x,"significant results. When power is less than",100*round(0.5^(1/n), digits=4),"% observing",n,"out of",n,"significant results is less likely (i.e., occurs less than 50% of the time) than observing mixed results.")
    })
    output$text2 <- renderText({
      paste("When H0 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given a" ,H0, "Type 1 error rate, is:", round(dbinom(x,n,H0),digits=10),". When all studies examine null-effects with a",100*H0,"% Type 1 error rate,",100*round(dbinom(x,n,H0),digits=4),"% of published articles with",n,"studies should observe",x,"significant results.")
    })
    output$text3 <- renderText({
      paste(H0H1, "with a likelihood ratio of",LR,".")
    })
    output$table = renderDataTable(
      table,
      options = list(paging = FALSE, searching = FALSE)
    )
  })
}


   fb = function(i) exp(2.198848 + 0.315026*i)
    # fb = female bound in cw where i=1 when cw = ~ 12.5 mm,
    # instar 5 is bounded by fb(1) and fb(2)
    # prior to instar 5 moulting can be variable and so should not be
    # relied upon to heavily
    #  see "model.size.structure.r" for details of derivation


library(corrplot)

#Set working directory
setwd("C:/Work/movieProject/MovieProjectShikha")

source("C:\\Work\\movieProject\\MovieProjectShikha\\code\\helperFunction.r")
dataPath <- "C:\\Work\\movieProject\\MovieProjectShikha\\data\\dataExtract\\movie_data.csv"
# Nature of data
allData = loadData(dataPath)

png(filename = 'results\\preProcessGraphs\\responseVars1.png')
par(mfrow=c(2,2))
# Step 0: Check the distribution of Independent variables
hist(allData[abs(allData$ROI)<quantile(abs(allData$ROI),0.95,na.rm=TRUE),]$ROI, breaks=60,col="blue",main="Histogram of ROI",xlab="ROI",
     ylab="Frequency",xaxt='n')
axis(side=1, at=seq(-1,10, 1), labels=seq(-1,10,1))
hist(allData[abs(allData$NetProfit)<quantile(abs(allData$NetProfit),0.95,na.rm=TRUE),]$NetProfit, breaks=60,col="blue",main="Histogram of NetProfit",xlab="NetProfit", ylab="Frequency")
hist(allData[allData$gross<quantile(allData$gross,0.95,na.rm=TRUE),]$gross, breaks=60,col="blue",main="Histogram of Gross",xlab="Gross", ylab="Frequency")
hist(allData$imdb_score, breaks=40,col="blue",main="Histogram of imdb_score",xlab="imdb_score", ylab="Frequency",xaxt='n')
axis(side=1, at=seq(0,10, 1), labels=seq(0,10,1))
dev.off()

png(filename = 'results\\preProcessGraphs\\responseVars2.png')
par(mfrow=c(2,2))
hist(allData[(allData$movie_facebook_likes>150)&(allData$movie_facebook_likes<50000)]$movie_facebook_likes, breaks=100,
     col="blue",main="Hist:Movie_facebook_likes",xlab="movie_facebook_likes", ylab="Frequency")
hist(allData[allData$num_voted_users<quantile(allData$num_voted_users,0.95,na.rm=TRUE),]$num_voted_users, breaks=60,col="blue",main="Hist:Num_voted_users",xlab="num_voted_users", ylab="Frequency")
hist(allData[allData$num_critic_for_reviews<quantile(allData$num_critic_for_reviews,0.95,na.rm=TRUE),]$num_critic_for_reviews,
     breaks=60,col="blue",main="Hist:Num_critic_for_reviews",xlab="num_critic_for_reviews", ylab="Frequency")
hist(allData[allData$num_user_for_reviews<quantile(allData$num_user_for_reviews,0.95,na.rm=TRUE),]$num_user_for_reviews, breaks=60,col="blue",main="Hist:Num_user_for_reviews",xlab="num_user_for_reviews", ylab="Frequency")
dev.off()

responseVars = allData[!allData$ROI=='NA'][,c('ROI','NetProfit','imdb_score','movie_facebook_likes','num_voted_users','num_critic_for_reviews','num_user_for_reviews')]
colnames(responseVars) = c('ROI','NetProfit','imbd','movieFbLikes','votedUsers','criticReviews','userReviews')
responseVars[is.na(responseVars)]=0
respCor = cor(responseVars)
png(filename = 'results\\preProcessGraphs\\responseVarsCor.png')
corrplot(respCor,type='upper')
dev.off()

#demographic factors
#### Language
langDataAll = getLanguageData(allData)
langData = langDataAll[, list(ROI=median(ROI),NetProfit=median(NetProfit),numMovies=length(ROI)),by=language][order(ROI),]
langData[langData$numMovies>5]
#### Language Over years
langDataYr = langDataAll[, list(ROI=median(ROI),Med_NetProfit=median(NetProfit),Total_NetProfit=sum(NetProfit),
                                numMovies=length(ROI)),by=c('decade','language')][order(decade),]
engData = langDataYr[langDataYr$language=='English']

# Country
countryDataAll = getCountryData(allData)
countryData = countryDataAll[, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit),Total_NetProfit=sum(NetProfit),
                                    numMovies=length(ROI)),by=country][order(Med_ROI),]
tail(countryData[order(Total_NetProfit),])
#### Country Over Years
countryData = countryDataAll[, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit),Total_NetProfit=sum(NetProfit),numMovies=length(ROI)),by=c('decade','country')][order(Med_ROI),]
countryData[(countryData$country=='USA')&(countryData$numMovies>10)][order(decade),]
countryData[(countryData$country=='UK')&(countryData$numMovies>10)][order(decade),]

#Content Rating Data
contentDataAll = allData[(!(allData$ROI=='NA'))&(!(allData$language=="")),c('content_rating','ROI','NetProfit')]
contentData = contentDataAll[, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit)),by=content_rating][order(Med_ROI),]

summary(allData$color)

png(filename = 'results\\preProcessGraphs\\durationAspect.png')
par(mfrow=c(2,1))
#check the impact of technical factors
durData = getDurationData(allData)
par(mar = c(5,5,2,5))
with(durData, plot(DurationRange, ROI, type="l", col="red3",xlab="Duration(minutes)", ylab="avg ROI", ylim=c(0,30)))
# par(new = T)
with(durData, plot(DurationRange, numMovies,type="l", col="blue", axes=F, xlab=NA, ylab=NA, cex=1.2))
axis(side = 4)
mtext(side = 4, line = 3, 'numMovies')
legend("topright", legend=c("ROI", "numMovies"), lty=c(1,1), pch=c(NA, NA), col=c("red3", "blue"))

par(mar = c(5,5,2,5))
with(durData, plot(DurationRange, NetProfit, type="l", col="red3",xlab="Duration(minutes)", ylab="median Net Profits ", ylim=c(-10e7,10e7)))
par(new = T)
with(durData, plot(DurationRange, numMovies,type="l", col="blue", axes=F, xlab=NA, ylab=NA, cex=1.2))
axis(side = 4)
mtext(side = 4, line = 3, 'numMovies')
legend("topright", legend=c("Med NetProfit", "numMovies"), lty=c(1,1), pch=c(NA, NA), col=c("red3", "blue"))

#bounding aspect ratio with 5 percentile and 99 percentile
aspect= getAspectData(allData)
# aspectRatio over years
aspectDataDecade = aspectDataAll[, list(aspect_ratio=median(aspect_ratio),numMovies=length(aspect_ratio)),by=c('decade')]
par(mar = c(5,5,2,5))
with(aspectDataDecade, plot(decade,aspect_ratio, type="l", col="red3", xlab="Year",ylab="Aspect Ratio"))
par(new = T)
with(aspectDataDecade, plot(decade, numMovies,type="l", col="blue", axes=F, xlab=NA, ylab=NA, cex=1.2))
axis(side = 4)
mtext(side = 4, line = 3, 'numMovies')
legend("topleft", legend=c("aspectRatio", "numMovies"), lty=c(1,1), pch=c(NA, NA), col=c("red3", "blue"))

dev.off()

dev.copy(png,'FactorsNext.png')
par(mfrow=c(2,2))
aspectData= aspect[[1]]
aspectDataAll = aspect[[2]]
par(mar = c(5,5,2,5))
with(aspectData, plot(aspect_ratio, ROI, type="l", col="red3",xlab="Aspect Ratio", ylab="avg ROI", ylim=c(0,15)))
par(new = T)
with(aspectData, plot(aspect_ratio, numMovies,type="l", col="blue", axes=F, xlab=NA, ylab=NA, cex=1.2))
axis(side = 4)
mtext(side = 4, line = 3, 'numMovies')
legend("topright", legend=c("ROI", "numMovies"), lty=c(1,1), pch=c(NA, NA), col=c("red3", "blue"))

par(mar = c(5,5,2,5))
with(aspectData, plot(aspect_ratio, NetProfit, type="l", col="red3",xlab="Aspect Ratio", ylab="median Net Profits", ylim=c(-1e8,3e8)))
par(new = T)
with(aspectData, plot(aspect_ratio, numMovies,type="l", col="blue", axes=F, xlab=NA, ylab=NA, cex=1.2))
axis(side = 4)
mtext(side = 4, line = 3, 'numMovies')
legend("topright", legend=c("Med NetProfits", "numMovies"), lty=c(1,1), pch=c(NA, NA), col=c("red3", "blue"))

# Step 3: genre factors genres and plot keywords
genreRoiAll = getGenreData(allData)
genreRoi = genreRoiAll[(!genreRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit), numMovies=length(ROI)), by = Genre]
topGenresNP = tail(genreRoi[order(genreRoi$Med_NetProfit)])
topGenresROI = tail(genreRoi[order(genreRoi$Med_ROI)])
topGenresNP
topGenresROI

genreByDecade = genreRoiAll[(!genreRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit), numMovies=length(ROI)), by = c('decade','Genre')]
tail(genreByDecade[genreByDecade$Genre=='Animation'])
tail(genreByDecade[genreByDecade$Genre=='Family'])

png(filename = 'results\\preProcessGraphs\\genre.png')
par(mfrow=c(2,1))
genre2010 =genreByDecade[genreByDecade$decade==2010]
topGenres2010=tail(genre2010[order(genre2010$Med_NetProfit)])
counts <- topGenres2010$Med_NetProfit
barplot(counts, main="Top Genres 2000-2010", names.arg=topGenres2010$Genre, col='blue', ylab = "Med Net Profits")

genre2020 =genreByDecade[genreByDecade$decade==2020]
topGenres2020=tail(genre2020[order(genre2020$Med_NetProfit)])
counts <- topGenres2020$Med_NetProfit
barplot(counts, main="Top Genres 2010-2020", names.arg=topGenres2020$Genre, col='blue', ylab = "Med Net Profits")

dev.off()

### Plot Keywords Analysis
plotRoiAll = getPlotData(allData)
plotTable = plotRoiAll[(!plotRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit),numMovies=length(ROI)), by = Plot]
plotRoi = plotTable[plotTable$numMovies>20]
tail(plotRoi[order(plotRoi$Med_ROI)])
tail(plotRoi[order(plotRoi$numMovies)])

plotByDecade = plotRoiAll[(!plotRoiAll$ROI=='NA'),][, list(Med_ROI=median(ROI),Med_NetProfit=median(NetProfit),numMovies=length(ROI)), by = c('decade','Plot')]
tail(plotByDecade[plotByDecade$Plot=='friend'])
tail(plotByDecade[plotByDecade$Plot=='police'])

png(filename = 'results\\preProcessGraphs\\plotKeywords.png', width = 1000,height = 1000)
par(mfrow=c(2,1))

plot2010 =plotByDecade[(plotByDecade$decade==2010)&(plotByDecade$numMovies>5)]
topPlots2010=tail(plot2010[order(plot2010$Med_NetProfit)])
counts <- topPlots2010$Med_NetProfit
barplot(counts, main="Top Plots 2000-2010", names.arg=topPlots2010$Plot, col='blue', ylab = "Med Net Profits")

plot2020 =plotByDecade[(plotByDecade$decade==2020)&(plotByDecade$numMovies>5)]
topPlots2020=tail(plot2020[order(plot2020$Med_NetProfit)])
counts <- topPlots2020$Med_NetProfit
barplot(counts, main="Top Plots 2010-2020", names.arg=topPlots2020$Plot, col='blue', ylab = "Med Net Profits")
dev.off()

png(filename = 'results\\preProcessGraphs\\facebook.png')
#checking relevance of facebook data
fbData = getFbData(allData)
plot(fbData$title_year,fbData$avgLikesPrMovie,main="Distrib. of FB activity over years",xlab="Year", ylab="Avg Likes Per Movie", pch=19,col="blue")
lines(lowess(fbData$title_year,fbData$avgLikesPrMovie), col="red")
dev.off()


library(neuralnet)
library(nnet)
library(NeuralNetTools)
library(plyr)

# Read the data
Startups <- read.csv(file.choose())
View(Startups)
class(Startups)

Startups$State <- as.numeric(revalue(Startups$State,
                                     c("New York"="0", "California"="1",
                                       "Florida"="2")))
str(Startups)

Startups <- as.data.frame(Startups)
attach(Startups)

# Exploratory data Analysis :

plot(R.D.Spend, Profit)

plot(Administration, Profit)

plot(Marketing.Spend, Profit)

plot(State, Profit)

windows()
# Find the correlation between Output (Profit) & inputs (R.D Spend, Administration, Marketing, State) - SCATTER DIAGRAM
pairs(Startups)

summary(Startups)

sum(is.na(Startups))
dim(Startups)

names(Startups)

startup1 <- Startups[,-4] #We exclude the 4th column as it holds the Name of the States

cor(startup1) #we can see that R.D.Spend and Profit are Highly Correlated.

#Standard Deviation
sd(R.D.Spend)
sd(Administration)
sd(Marketing.Spend)
sd(Profit)

#Variance
var(R.D.Spend)
var(Administration)
var(Marketing.Spend)
var(Profit)

#Plots
plot(R.D.Spend,Administration, type = "p")

plot(Marketing.Spend,Profit, main = "Marketing Expense vs Profit")
#Lets Normalize the data
normalise <- function(x) {
  return((x - min(x))/(max(x) - min(x)))
}

startup_norm <- as.data.frame(lapply(startup1, normalise))

#Lets Split the Dataset into Train and Test Set Randomly
split1 <- sort(sample(nrow(startup_norm),nrow(startup_norm)*0.7)) #Here we are Splitting it in 70:30 ratio
train1 <- startup_norm[split1,]
test1 <- startup_norm[-split1,]

plot(startup_norm, rep = "best")

par(mar = numeric(4), family = 'serif')
plot(startup_norm, alpha = 0.6)


rule {
	testSuite;
}

# assert rules
assert(*B) {
	assert(*B, *RES);
        writeLine("stdout", "*RES");
}

assertFalse(*B) {
	assertFalse(*B, *RES);
        writeLine("stdout", "*RES");
}

assertError(*B, *RES) {
	assert(*B, *RES);
        if(*RES like "[error]*") {
                *RES="[passed]";
        } else {
                *RES="[failed]";
        }

}

assert(*B,*RES) {
        if (errormsg(*RET = eval(*B),*E)==0) {
            if (*RET) {
                *RES="[passed]";
            } else {
                *RES="[failed]";
            }
        } else {
            *RES="[error]\n*E\n";
        }
	writeLine("stdout", "*B");
}

assertFalse(*B, *RES) {
    assert("*B == false", *RES);
}

# test suite

testWhitespace(*RES)||assert("1 >0 && 1>0", *RES)|nop

testMod1(*RES)||assert("3%2==1", *RES)|nop
testMod2(*RES)||assertFalse("3%2!=1", *RES)|nop
testMod3(*RES)||assert("1%2==1", *RES)|nop

testMul(*RES)||assert("1*2==2", *RES)|nop

testAdd(*RES)||assert("1 + 2==3", *RES)|nop
testAdd2(*RES)||assert("1 + ( 2 + 3 )==6", *RES)|nop

testFloor||assert("floor 2.2==2")|nop

testPow(*RES)||assert("2 ^ 10==1024", *RES)|nop

testMax||assert("max(1,2,3,4,5,6)==6")|nop

testMin||assert("min(1,2,3,4,5,6)==1")|nop

testAverage||assert("average(1,2,3,4,5,6)==3.5")|nop

testExp||assert("abs(exp 1-2.718282)<0.001 ")|nop

testLog||assert("abs(log 2-0.693147)<0.001")|nop

testArith1(*RES)||assert("1 + 2 * 3==7", *RES)|nop
testArith2(*RES)||assert("1 + 2 * 3 ^ 10 + 100==118199", *RES)|nop
testArith3(*RES)||writeLine("stdout", abs(log 100-(1 / 2  + 2)*3))##assert("abs(log 100-(1 / 2  + 2)*3--2.894830)<0.001", *RES)|nop
testArith4(*RES)||assert("(100+( 100 * 100 ) -100)^^2^2==10000", *RES)|nop
testPolyArith(*RES) {
    assert("1/2+3==3+1/2", *RES);
}

testStr1(*RES)||assert("'abc'=='abc'", *RES)|nop
testStr2(*RES)||assertFalse("'abc'!='abc'", *RES)|nop

testWildcard1(*RES)||assert("'abc'like'a*'", *RES)|nop
testWildcard2(*RES)||assert("!('abc'not like'a*')", *RES)|nop
testWildcard3(*RES)||assert("'a[][]'like'a[]*'", *RES)|nop
testWildcard4(*RES)||assert("'a^[]'like'a^*'", *RES)|nop
testRegex1(*RES)||assert("'abc'like regex'a\\\*b\\\*c\\\*'", *RES)|nop
testRegex2(*RES)||assertFalse("!('abc'like regex'a\\\*b\\\*c\\\*')", *RES)|nop

testNoError||assert("errorcode(assign(\*A,exp(10)))==0")|nop
testError1||assert("errorcode(( 1 / 0 ) + 2)!=0")|nop
testError2||assert("errorcode(\*A)!=0")|nop

testWhileExec1(*RES)||assign(*A, 0)##whileExec(*A<10, assign(*A,*A+1), nop)##assert("*A == 10",*RES)|nop
testWhileExec2(*RES)||assign(*A, 0)##whileExec(*A<10, assign(*A,*A+1)##break, nop)##assert("*A == 1",*RES)|nop
testWhileExec3(*RES)||assign(*A, 0)##whileExec(*A<10, assign(*A,*A+1), nop)##assert("*A == 10",*RES)|nop

testForeachExec(*RES)||assign(*A, list(1,2,3))##writeLine("stdout", *A)##forEachExec(*A,assign(*B, *A), nop)##assert("true", *RES)|nop

testList||assert("elem(list(1,2,3,4,5,6),0)==1")|nop

testLAnd(*RES) {
	assert("true && true", *RES);
}

testLOr1(*RES) {
	assert("true %% false", *RES);
}

testLOr2(*RES) {
	assert("true || false", *RES);
}

testLOr3(*RES) {
	assert("false || true", *RES);
}

testWriteLine(*RES) {
	*A = 1;
	writeLine("stdout", "*A");
	assert("true", *RES);
}

testTrimL0 {
    assert("triml('xyz','y')=='z'");
}
testTrimL1 {
    assert("triml('xyz','x')=='yz'");
}
testTrimL2 {
    assert("triml('xyz','xy')=='z'");
}
testTrimL3 {
    assert("triml('xyz','')=='xyz'");
}
testTrimR0 {
    assert("trimr('xyz','y')=='x'");
}
testTrimR1 {
    assert("trimr('xyz','z')=='xy'");
}
testTrimR2 {
    assert("trimr('xyz','yz')=='x'");
}
testTrimR3 {
    assert("trimr('xyz','')=='xyz'");
}
testSplitString1(*RES) {
	*A = split("true,false", ",");
	assert(elem(*A, 0), *RES);
}
testSplitString2(*RES) {
	*A = split("true,false", ",");
	assert("!"++elem(*A, 1), *RES);
}
testSplitString3(*RES) {
	*A = split(" true,false ", ", ");
	assert(elem(*A, 0), *RES);
}
testSplitString4(*RES) {
	*A = split(" true,false ", ", ");
	*B = size(*A);
	assert("*B == 2", *RES);
}

testFuncgetstdout(*RES) {
	writeLine("stdout", "abc");
	getstdout(writeLine("stdout", "lmn"), *OUT);
	writeLine("stdout", "xyz");
	assert("'*OUT' == 'lmn\n'", *RES);
}

testNonStringWriteLine(*RES) {
    writeLine("stdout", 1);
    writeLine("stdout", true);
    writeString("stdout", 1);
    writeString("stdout", true);
    assert("true", *RES);
}

testEvalRule(*RES) {
	*a = errorcode(evalrule("rule{writeLine('stdout', 'evalrule');}"));
	assert("*a == 0", *RES);
}

testEvalRule2(*RES) {
	*a = errorcode(evalrule("rule{msiAdmAddAppRuleStruct('add');testRule1();}"));
	assert("*a == 0", *RES);
}

testAdmShowCoreRE(*RES) {
	msiAdmShowCoreRE();
	assert("true", *RES);
}

testAdmShowIRB(*RES) {
	msiAdmShowIRB();
	assert("true", *RES);
}

testStrTime(*RES) {
    *a = str(time);
    assert("true", *RES);
}
testSuite {
    runTests("test.*");
}
runTests(*Pattern) {
    *Start = time();
    *A = listextrules;
    *P=0;
    *F=0;
    *E=0;
    *O=0;
    *U=0;
    *FN="";
    *EN="";
    *C=0;
    foreach(*A) {
        if(*A like regex *Pattern && *A != "testSuite") then {
		writeLine("stdout", "*C: *A");
		if(arity(*A) == 1) then {
			eval("*A(\*RES)");
			writeLine("stdout", *RES);
			if(*RES like "[passed]*") then {*P=*P+1;}
			else if(*RES like "[failed]*") then {*F=*F+1;*FN="*FN*A\n"}
			else if(*RES like "[error]*") then {*E=*E+1;*EN="*EN*A\n"}
			else { *O=*O+1; }
		} else {
			*U=*U+1;
			eval(*A);
		}
		*C=*C+1;
	}
    }
    writeLine("stdout", "\nsummary *P passed *F failed *E error *O other *U undefined");
    if(*F!=0) {
        writeLine("stdout", "failed: *FN");
    }
    if(*E!=0) {
        writeLine("stdout", "error: *EN");
    }
    *Finish = time();
    *Time = double(*Finish) - double(*Start);
    writeLine("stdout", "time: *Time s");
}

INPUT null
OUTPUT ruleExecOut


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  R = qr.R(qr(x))
  Q = qr.Q(qr(x))
} else {
  x = NULL
}

dx = expand(x)

R_test = qr_R(dx)
dQ = qr_Q(dx, R_test)

Q_test = collapse(dQ)

# the direction of the vectors can differ, so we have to account for sign
comm.print(all.equal(abs(R), abs(R_test)))
comm.print(all.equal(abs(Q), abs(Q_test)))

finalize()


###############################################################################
# "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) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=500)
           +(normal_lpdf(y|theta,sigob))*(y>500);
		  ### +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u);   #### +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 b0;
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]*exp(u*exp(-b0*n)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.24,0.01);
b0 ~ normal(0.031,0.001);
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);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

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

  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.24,b0=0.031,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

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

####  threshold =500

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

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

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=7

pdf(paste("M2_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

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

dev.off()

pdf(paste("M2_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2"), inc_warmup = T,  nrow = 2, ncol = 1, window = NULL, include = TRUE)
dev.off()

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

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

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

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

pdf(paste("M2_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=2

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

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

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

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

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot/")

pdf(paste("M2_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),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=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

#####################################################################################################################################################
######################################      forecast          ###################################

GP.r <- function(L, s)
{

v=0
Lp=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
sLp=Lp

# calculate the vector of cum pmf
v=1
while((sLp<0.9999999) & ((L + v * s )> 0))
{Lp1=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
Lp=c(Lp,Lp1)
sLp=sLp+Lp1
v=v+1
}

csLp=c(cumsum(Lp),1) ##### add a max for it
x=length(Lp)

# first check if you are in the first interval

U = runif(1)
B = FALSE
i = 1

while(B == FALSE) {

  if(U > csLp[i])  ### U may greater than max of csLp if do not set 1
    { i=i+1}
  else
    {X=i-1
     B=TRUE}

}

return(X)

}

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

P=20
Mu=matrix(,nrow=90000,ncol=P)
X=matrix(,nrow=90000,ncol=P)

lambda_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,1]
u_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,2]
b0_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,3]
sig2_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,4]

set.seed(999)

for (r in 1:90000){

Mu[r,1]=y[length(y)]
for (s in 1:(P-1) ){

e=rnorm(1,0,sig2_p[r])

Mu[r,s+1]=Mu[r,s]*exp(u_p[r]*exp(-b0_p[r]*(s+length(y)))+e)

}}

sigob=1000
for (r in 1:90000){
for (s in 1:P ){

X[r,s]=rnorm(1,Mu[r,s], sigob)

}}

Xm=apply(X,2,mean)

X5 <- apply( X , 2 , quantile, probs=0.05 )

X9 <- apply( X , 2 , quantile, probs=0.95 )

Zm=c(y,Xm)
Z5=c(y,X5)
Z9=c(y,X9)

##### read forecast
setwd("./covid19modelrisk/data/covid19_infected/")

##  FT=read.csv("COVID-19_confirmed__Germany_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Italy_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Japan_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Spain_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__United Kingdom_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__US_FT.csv")[,2]
FT=read.csv("COVID-19_confirmed_Australia_FT.csv")[,2]

M=length(FT)

e=FT-Xm
mae=mean(abs(e))
rmse=sqrt(mean(e^2))
############ PR
 p=e/FT
# p1=e1/mean(mo1)
mape=mean(abs(p))
########## QR
md=sum(abs(FT[2:M]-FT[1:(M-1)]))/(M-1)
qj=e/md
mase=mean(abs(qj))

list(mae,rmse,mape,mase)

Z_FT=c(y,FT)

k=7

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

m=length(Zm)

setwd("./covid19modelrisk/output/forecast/")

pdf(paste("M2_",abn[k],"_F.pdf",sep=""), width = 16.5, height = 8.50)

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(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
polygon(c(rev(newx), newx), c(rev(Z9[1:m]), Z5[1:m]), col = "grey80", border = NA)

par(new=TRUE)
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
lines(newx,Z9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Z5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(Z_FT[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
legend("topleft", legend=c("Observed data", "Forecasted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)

# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/27","Mar/17","May/05","Jun/25","Aug/06"))   ### GM
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/13","May/09","Jun/29","Aug/06"))   ### IT
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### JP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Feb/01","Mar/20","May/10","Jun/30","Aug/06"))   ### SP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/21","May/09","Jun/29","Aug/06"))   ### UK
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### US
axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/26","Mar/16","May/04","Jun/24","Aug/06"))   ### AU

dev.off()

######   RMSE results        ###############################################################

### Germany
> list(mae,rmse,mape,mase)
[[1]]
[1] 12517.73

[[2]]
[1] 14479.24

[[3]]
[1] 0.05425658

[[4]]
[1] 10.42504

## Italy
> list(mae,rmse,mape,mase)
[[1]]
[1] 28633.06

[[2]]
[1] 33356.15

[[3]]
[1] 0.1114455

[[4]]
[1] 42.5554

## Japan
> list(mae,rmse,mape,mase)
[[1]]
[1] 3407.51

[[2]]
[1] 3475.616

[[3]]
[1] 0.06044399

[[4]]
[1] 3.404822

## Spain
> list(mae,rmse,mape,mase)
[[1]]
[1] 6404.752

[[2]]
[1] 7764.212

[[3]]
[1] 0.01816862

[[4]]
[1] 1.153605

## UK
> list(mae,rmse,mape,mase)
[[1]]
[1] 21333.73

[[2]]
[1] 24918.48

[[3]]
[1] 0.06618652

[[4]]
[1] 20.42946

## US
> list(mae,rmse,mape,mase)
[[1]]
[1] 378799.5

[[2]]
[1] 464800.3

[[3]]
[1] 0.06784786

[[4]]
[1] 8.161634

## AU
> list(mae,rmse,mape,mase)
[[1]]
[1] 3069.551

[[2]]
[1] 3986.055

[[3]]
[1] 0.1254013

[[4]]
[1] 12.61277

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

u=0.04
b0=0.004

n=length(y)

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

x[i+1]=x[i]*exp(u*exp(-b0*i))
}
x=round(x)

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

#####   initial values         ##########################################################################

### Germany
u=0.24
b0=0.031#u*0.08 ###

## 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 frame
#   Друга структура за съхраняване на данни в R е data frame. Разликата с матрицата е,
#   че елементите в матрицата е вектор от вектори и всички елементи са от един тип, докато
#   data frame-a е лист от вектори и елементите на data frame-а са от един тип, само в рамките
#   на отделния вектор.

set.seed(104)

#	Искаме да създадем data frame със симулирани 30 наблюдения.
N <- 30

girl_names <- c("Ashley Cooper", "Doris Parker", "Linda Torres", "Cynthia Collins", "Paula Taylor",
                "Maria Perez", "Kelly Gray", "Wanda Bryant", "Kimberly Griffin", "Theresa Watson",
                "Ruby Brown", "Christine Wright", "Rose Washington", "Marilyn Perry", "Teresa Baker",
                "Andrea Roberts", "Amanda Reed", "Tina Harris", "Judy Murphy", "Nicole Howard",
                "Susan Flores", "Janice Martin", "Pamela Johnson")

boys_dating_diary <- data.frame(
  #	Dates - 30 дни от днес назад
  asking_for_dating_DATE = as.Date(Sys.time()) - N:1,
  #	Strings - names of the girls
  girl_names = sample(x = girl_names, size = N, replace = T),
  # Boolean
  accept = sample(x = c(T, F), size = N, replace = T, prob = c(0.1, 0.9)),
  # Uniform distribution from 1 to 10
  rating = round(runif(N, 1, 10))
)

sample(x = girl_names, size = N, replace = T)
sample(x = c(T, F), size = N-10, replace = T, prob = c(0.1, 0.9))
sort(round(runif(N, 1, 10)))
?runif

#	- N:1 - създава се вектор с числа от N до 1 (намаляващ вариационен ред)
#	- sample(x, size, replace, prob) - на случаен принцип се избират
#	 - x - вектор, от който се избират елементите,
#	 - size - размерът на желаната извадка (в нашия случай 30),
#	 - replace - опцията дали да се преизбират наново елементи.
#   Ако size > x, то задължително трябва replace = TRUE
#	 - prob - вектор с вероятностите за избиране на случаен елемент.
#   Трябва дължината на prob да бъде равна на дължината на x и сборът да бъде равен на 1.

# Date frame to string
str(boys_dating_diary)

# В R можем да вземем първите и последните няколко реда с помощта на функциите head() и tail()
# Default for n is 6
head(x = boys_dating_diary)
head(x = boys_dating_diary, n = 3)
tail(x = boys_dating_diary, n = 3)

# Обединяване на матрици и data frame-ове по редове и колони
# Union of metrices by rows and cols
M1 <- matrix(data = 1:20, nrow = 10, byrow = T)
M2 <- matrix(data = 21:30, nrow = 2, byrow = T)
M1; M2

# Функциите за обединяване на две матрици/data frame-ове са:
# - rbind - обединение по редове - долепя втората матрица под първата
# - cbind - обединение по колони - долепя втората матрица след първата

# Error! Numbers of Rows and Columns must match!
rbind(M1, M2)

# Check dimensions of matrices
nrow(M1)
ncol(M1)
dim(M2)

# Transponse matrices
# Нека да транспонираме втората матрица (транспонирането е операция, за която редовете се
# превръщат в колони). Функцията за транспониране в R е t()
M2.t <- t(M2)
M2
M2.t
dim(M2.t)

rbind(M1, M2.t)

# Union of cols
M3 <- matrix(data = 21:40, nrow = 10, byrow = T)
cbind (M1, M3)

# cbind and rbind on Date Frames
boys_dating_diary_2 <- data.frame(
  #	Dates - 30 дни от днес назад
  asking_for_dating_DATE = as.Date(Sys.time()) - 30 -N:1,
  #	Strings - names of the girls
  girl_names = sample(x = girl_names, size = N, replace = T),
  # Boolean
  accept = sample(x = c(T, F), size = N, replace = T, prob = c(0.5, 0.5)),
  # Uniform distribution from 1 to 10
  rating = round(runif(N, 1, 10))
)
test = cbind(boys_dating_diary, boys_dating_diary_2)

# Функциите apply, lapply, sapply и т.н. могат да се прилагат и върху data frame-ове

# Взимане на ред, колона и елемент от data frame
# Всеки от начините, които споменахме при взиамне на елементи от матрица, са приложими и
# за data frame, като отделно имаме и допълнителни.

#	dataframe[rows, cols]

# First row and every columns
boys_dating_diary[1, ]

# First col of every row
boys_dating_diary[, 1]
boys_dating_diary[1:nrow(boys_dating_diary), 2]

# Fifth row - second and third col
boys_dating_diary[5, c(2, 3)]

# Fifth row, second col
boys_dating_diary[5, 2]

#	Get or set row names
row.names(boys_dating_diary)
row.names(boys_dating_diary) <- paste("try", 1:nrow(boys_dating_diary), sep = "_")
#	С paste() обединяваме вектори със стрингове (n-тия елемент на единия вектор с n-тия елемент на друг вектор)
# Имената трябва да са уникални

# При data frame-а можем да вземем елементи и посредством техните имена

# - По колони
#	С "$" взимаме елементи от листа. Data frame-а е ЛИСТ от ВЕКТОРИ => взимаме вектора
boys_dating_diary$girl_names
boys_dating_diary[, "girl_names"]
boys_dating_diary[, 2]
# Последните 3 са еквивалентни

# - По редове - име на реда
boys_dating_diary["try_1", ]

# - По имена на редове и колони
boys_dating_diary["try_1", c("girl_names", "accept")]

# -----------
# Филтриране
# Следващата стъпка е филтрирането на данни и взимането на подгрупи по зададен признак

#	& - логическо "и", | - логическо "или", == - проверка за равенство

# which() - Връща вектор с индекстите на елементите, за които булевото условие връща TRUE.
#	Тоест взимаме индексите на елементите, които ни вълнуват по някакъв начин.

# Нека да проверим кои от всички 30 опита са се оказали сполучиливи. Тоест,
# приели са поканата на момчето
# Връща реда
which(boys_dating_diary$accept)
# Prints the rows
boys_dating_diary[which(boys_dating_diary$accept), girl_names]
# Prints only the names
boys_dating_diary[which(boys_dating_diary$accept), "girl_names"]

# More complex filter
boys_dating_diary[which(boys_dating_diary$rating >= 7 & boys_dating_diary$accept), ]
# Returns only FALSE AND TRUE for every row
boys_dating_diary$rating >= 7

# Where IN
boys_dating_diary[which(boys_dating_diary$girl_names %in% c("Doris Parker", "Theresa Watson")), ]

# Как да вземем имената на момичетата, с които въпросният индивид се е опитал да се свърже през последната седмица?
# Дали са приели?
lastWeekdays <- as.Date(Sys.time()) - 7:0
boys_dating_diary[which(boys_dating_diary$asking_for_dating_DATE %in% lastWeekdays), ]

attach(boys_dating_diary)
girl_names
detach(boys_dating_diary)

# ------------------------------------------------------------------------
#                           О П И С А Т Е Л Н А    С Т А Т И С Т И К А
#   1. Променливи
#   Най-простата дефиниция за променливи е характеристика, която се варира от един човек/обект
#   до друг. Променливите са категоризирани в два типа
#   - количествени или числови (представят се с числа)
#   - категорийни или качествени (нечислово изобразяване)

#   Категорийните променливи се разбиват на два подтипа
#   - номинални (без подредба) - Примери за стойности на НОМИНАЛНИ променливи са: видове заведения, различни
#   държави и организции, видове алкохол, раси и т.н.
#   - ординални (с подредба) -  Примери за стойности на ОРДИНАРНИ променливи са:
#   степени на образование/квалификация, нива на социалните общества и т.н.

#   Количествените се разбиват на два подтипа
#   - Непрекъснати (стойностите могат да варират в даден числов интервал)  - възраст, различни съотношения, тегло
#   - Дискретни (възможните стойности могат да бъдат изброени) - брой катастрофи на шофьори, брой на деца

#   2. Разпределения
#   Разпределение - това е таблица, графика или формула, съдържаща стойностите на наблюденията
#   и колко често се случват. Разпределенията се характеризират с
#   - форма
#   - модалност (modality)
#   - локация
#   - размах
#   - симетричност/асиметричност
#   - ексцес.
#   - плътност

# ------------------------------------------------------
#   На графиката по-долу са представени няколко от формите на плътността на разпределенията
N <- 2*(10^4) # 20k
distributions <- c("Kambanovidna", "J-", "Pravoygylna", "Dqsno asimetrichna", "Dvumodalna")
par(mfrow = c(2, 3))

for (distr in distributions) {
  distribution_values <- switch(distr,
    "Kambanovidna" = rnorm(N), # Normal distribution
    "J-" = rexp(N), # Exponential distribution
    "Pravoygylna" = round(runif(N), 2), # Uniform distribution - Равномерно разпределение
    "Dqsno asimetrichna" = rgamma(N, shape = 5),   # Gamma distribution
    "Dvumodalna" = c(rnorm(N, mean = -2, sd = 2), rnorm(N, mean = 3, sd = 1)) #
  )

  distr_density <- density(distribution_values)
  ?hist
  hist(
    distribution_values,
    col = "pink",
    prob = T,
    main = paste(distr, "forma na razpredelenie"),
    ylab = "Density",
    xlab = "Values",
    ylim = range(distr_density$y),
    xlim = range(distr_density$x)
  )

    lines(distr_density, lwd = 3, col = "blue") # lwd - width of line
}
par(mfrow = c(1, 1))

# ----------------------------------------------------------------------
# Salaries
country = c('Switzerland', 'Norway', 'Iceland', 'Denmark', 'Finland', 'Netherlands', 'Germany',
            'Ireland', 'Sweden', 'United Kingdom', 'Austria', 'Belgium', 'France', 'Italy',
            'Spain', 'Malta', 'Slovenia', 'Estonia', 'Czech Republic', 'Portugal', 'Slovakia',
            'Poland', 'Croatia', 'Lithuania', 'Greece', 'Latvia', 'Hungary', 'Romania',
            'Bulgaria', 'Russia', 'Bosnia And Herzegovina', 'Serbia', 'Belarus', 'Albania',
            'Macedonia', 'Ukraine', 'Moldova')

avg_sal_in_USD = c(4959.48, 3416.1, 3136.95, 2975.8, 2583.43, 2575.2, 2538.92, 2521.51, 2494.39,
                   2394.78, 2219.23, 2162.23, 2140.64, 1675.32, 1480.64, 1278.04, 1180.66,
                   1158.76, 1069.03, 925.84, 894.2, 884.81, 852.23, 804.68, 795.34, 771.91,
                   708.91, 649.68, 611.41, 558.01, 481.17, 412.22, 409.62, 348.56, 346.15,
                   293.26, 284.94)

salaryDF <- data.frame(country, avg_sal_in_USD)

# Cars
Country <- c("Austria", "Belgium", "Croatia", "Czechia", "Denmark", "Estonia", "Finland",
             "France", "Germany", "Greece", "Hungary", "Ireland", "Italy", "Latvia",
             "Lithuania", "Luxembourg", "Netherlands", "Norway", "Poland", "Portugal",
             "Romania", "Slovakia", "Slovenia", "Spain", "Sweden", "Switzerland", "UK")

Car <- c("Volkswagen", "Volkswagen", "Skoda", "Skoda", "Peugeot", "Toyota", "Nissan",
         "Renault", "Volkswagen", "Toyota", "Suzuki", "Hyundai", "Fiat", "Volkswagen",
         "Fiat", "Volkswagen", "Volkswagen", "Nissan", "Skoda", "Renault", "Dacia",
         "Skoda", "Renault", "Seat", "Volvo", "Skoda", "Ford")

carsDF <- data.frame(Country, Car)

# --------------------------------------------------------------------------------
#                   А Н А Л И З    Н А    Е Д Н О М Е Р Н А    П Р О М Е Н Л И В А
#                                   (UNIVARIATE ANALYSIS)

#  ------------
#  3. Категорийни променливи
#  Категорийните промеенливи като цяло носят по-малко информация отколкото числовите променливи.
#  Често обаче, те носят по-голяма стабилност за прогнозните моделите отколкото числовите.

#   Освен графично представяне на данните (ще го разгледаме по-късно), най-добре честотата се
#   вижда посредством таблици. Функцията, която ни трябва е table()

# Взима първите 6 реда
head(carsDF)

# Взима честотното разпределение на категориините променливи
tt <- table(carsDF$Car)
tt
sort(tt)

# Взима процентното разпределение на променливите
round(prop.table(tt) * 100, 2)
sort(round(prop.table(tt) * 100, 2))

# Volkswagen държи най-голям пазарен дял по страни в Европа, следван от Skoda

# --------------
# 4. Числови променливи
#   4.1. Оценка на центъра (локацията) на разпределение (mean)
#       4.1.1. Средна стойност (Очакване)
meanFunc <- function(x) {
  sum(x) / length(x)
}

salaryDF$avg_sal_in_USD
meanFunc(salaryDF$avg_sal_in_USD)
mean(salaryDF$avg_sal_in_USD)

#       4.1.2. Медиана (Median)
#       Подреждаме данните във вариационен ред. Взимаме средната стойност (при нечетен брой)
#   или средната стойност на средните два елемента (при четен брой елементи).

medianFunction <- function(x) {
  x_sorted <- sort(x)
  length_of_x <- length(x_sorted)

  if (length_of_x %% 2 == 0) {
    x_sorted[length_of_x/2 + c(0, 1)]
    return (mean(x_sorted[length_of_x/2 + c(0, 1)]))
  } else {
    print(round(length_of_x/2 + 0.25))
    return (x_sorted[round(length_of_x/2 + 0.25)])
  }
}

medianFunction(c(1, 2, 3))
medianFunction(salaryDF$avg_sal_in_USD)
median(salaryDF$avg_sal_in_USD)

medianFunction(1:10)
median(1:10)

#     4.1.3. Мода - най-често срещаната стойност
modeFunction <- function(x) {
  tt <- table(x)

  return (names(tt))[tt == max(tt)]
}

table(round(salaryDF$avg_sal_in_USD / 100))

modeFunction(round(salaryDF$avg_sal_in_USD / 100))

#   Модата може да има повече от една стойност
#   table() - честотоното разпределение на променлива (коя стойност колко пъти се повтаря)
#   which.max() - връща индекса на първото число, което приема МАКСИМАЛНА стойност
#   which.min() - връща индекса на първото число, което приема МИНИМАЛНА стойност
#   names() - връща имената на стойностите

#   Описателна статистика за центъра на разпределението
summary(salaryDF$avg_sal_in_USD)

# Квантили
quantile(salaryDF$avg_sal_in_USD, prob = seq(0.1, 0.9, by = 0.1))
?quantile

#   Задача 1 - Ежедневни инциденти с мотоциклети
#   Шотландският изпълнителен директор в отдел "Аналитични услуги" на Транспортна
#   статистика събира данни за произшествията с мотоциклети. В таблицата по-долу са
#   представени, броят на инцидентите с мотоциклети в Шотландия по пътища с ограничение
#   до 30 и над 30 мили в час, случили се по дни от седмицата.
Day <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
Built_up <- c(88, 100, 76, 98, 103, 85, 69)
Non_built_up <- c(70, 58, 59, 53, 56, 94, 102)

motorcycleAccidentsDF <- data.frame(Day, Built_up, Non_built_up)
#   а. Каква е средната стойност и медианата на броя на произшествията за двата вида пътища
mean(motorcycleAccidentsDF$Built_up)
median(motorcycleAccidentsDF$Built_up)

mean(motorcycleAccidentsDF$Non_built_up)
median(motorcycleAccidentsDF$Non_built_up)

#   б. Каква е формата на разпределението по различните пътища. Интересува ни само модалността.

# Задача 2 - Инвестиции в акциите "LMT" и "FB"
Date <- c('2015-09', '2015-10', '2015-11', '2015-12', '2016-01', '2016-02', '2016-03', '2016-04',
          '2016-05', '2016-06', '2016-07', '2016-08', '2016-09', '2016-10', '2016-11', '2016-12',
          '2017-01', '2017-02', '2017-03', '2017-04', '2017-05', '2017-06', '2017-07', '2017-08',
          '2017-09', '2017-10', '2017-11', '2017-12', '2018-01', '2018-02', '2018-03', '2018-04',
          '2018-05', '2018-06', '2018-07', '2018-08', '2018-09')
FB <- c(89.9, 101.97, 104.24,
        104.66, 112.21, 106.92, 114.1, 117.58, 118.81, 114.28, 123.94, 126.12, 128.27, 130.99,
        118.42, 115.05, 130.32, 135.54, 142.05, 150.25, 151.46, 150.98, 169.25, 171.97, 170.87,
        180.06, 177.18, 176.46, 186.89, 178.32, 159.79, 172, 191.78, 194.32, 172.58, 175.73,
        164.46)
LMT <- c(207.31, 219.83, 219.16, 217.15, 211, 215.79, 221.5, 232.38, 236.23, 248.17, 252.73,
         242.97, 239.72, 246.38, 265.25, 249.94, 251.33, 266.58, 267.6, 269.45, 281.13, 277.61,
         292.13, 305.39, 310.29, 308.16, 319.12, 321.05, 354.85, 352.44, 337.93, 320.84, 314.54,
         295.43, 326.1, 320.41, 345.96)
stocksDF <- data.frame(Date, LMT, FB)

#   Анализът трябва да се извърши върху възвръщаемостите на цените, получени по diff(log(x)),
#   където "x" е цената на актива

#   а. Какви са средните стойности и медианите. Според вас как се интерпретират тези числа
#   б. Можете ли да кажете в кой актив бихте инвестирали при наличието само на тази информация

log(10, base = 10)

x = 1:5


#' @export
summary.boot <- function (object, CI.method = c("Percentile", "BC", "BCa"), gini=T, alpha.b = 0.05,prints=F, big.ci=F,    ...) {
    if (!inherits(object, "boot"))
        stop("Not a legitimate boot object, need to run boot.strata() first")
    options(digits = 4)
    CI.method <- match.arg(CI.method)
    boot.est <- mean(object$boot.means)
    ci.boot=list()
    if (CI.method == "Percentile") {
        ci.boot[[1]] <- ci.boot.mean <- quantile(object$boot.means, probs = c(alpha.b/2,
            (1 - alpha.b/2), 0.5))
       if(gini) ci.boot.gini <- quantile(object$gini, probs = c(alpha.b/2,
            (1 - alpha.b/2), 0.5),na.rm=T)
       if(big.ci) return(quantile(object$boot.means, probs = seq(0.01,0.99,by=0.01)))
      }
    if (CI.method == "BC") {

        loc.bc <- sum(object$boot.means < boot.est)
        lim.bc <- sort(object$boot.means)[c(loc.bc, loc.bc +
            1)]
        z0 <- (loc.bc + ((boot.est - lim.bc[1])/(lim.bc[2] -
            lim.bc[1])))
        z0 <- qnorm(z0/length(object$boot.means))
        probs.z0 <- pnorm(qnorm(c(alpha.b/2, (1 - alpha.b/2),
            0.5)) + 2 * z0)
        ci.boot[[1]] <- quantile(object$boot.means, probs = probs.z0)
       if(gini) ci.boot.gini <- quantile(object$gini, probs = c(alpha.b/2,
            (1 - alpha.b/2), 0.5),na.rm=T)

    }
    if (CI.method == "BCa") {
        if (is.na(object$accel))
            stop("One or more strata have 1 or less observations.\nNo acceleration estimate possibl\ne.")
        loc.bc <- sum(object$boot.means < boot.est)
        lim.bc <- sort(object$boot.means)[c(loc.bc, loc.bc +
            1)]
        z0 <- (loc.bc + ((boot.est - lim.bc[1])/(lim.bc[2] -
            lim.bc[1])))
        z0 <- qnorm(z0/length(object$boot.means))
        a1 <- pnorm(z0 + (z0 + qnorm(alpha.b/2))/(1 - object$accel *
            (z0 + qnorm(alpha.b/2))))
        a2 <- pnorm(z0 + (z0 + qnorm(1 - alpha.b/2))/(1 - object$accel *
            (z0 + qnorm(1 - alpha.b/2))))
        a3 <- pnorm(z0 + (z0 + qnorm(0.5))/(1 - object$accel *
            (z0 + qnorm(0.5))))
        ci.boot <- quantile(object$boot.means, probs = c(a1,
            a2, a3))
    }
   if(prints) {cat("\n", "Original Mean =", format(object$orig.mean), "\n",
        "Original Variance =", format(object$orig.var), "\n",
        "Number of bootstraps = ", length(object$boot.means),
        "\n", "Bootstrap Mean=", format(boot.est), "\n", "Variance of Bootstrap Mean=",
        format(var(object$boot.mean)), "\n", c(CI.method, "CI's for alpha="),
        alpha.b, "are ", format(ci.boot.mean[1:2]), "\n", "Length =",
        format(ci.boot.mean[2] - ci.boot.mean[1]), "\n", "Shape=", format(log((ci.boot.mean[2] -
            ci.boot.mean[3])/(ci.boot.mean[3] - ci.boot.mean[1]))), "\n", "Method = ",
        object$method, "\n")
   }
   if(gini) ci.boot[[2]] = ci.boot.gini

    return(ci.boot)
}


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), function(s) {
  lo <- 0
  hi <- as.integer(s[1])
  for (i in s[2:length(s)]) {
    if (i == "Lower") {
      hi <- ceiling((lo+hi)/2)-1
    } else if (i == "Higher") {
      lo <- ceiling((lo+hi)/2)+1
    }
  }
  ceiling((lo+hi)/2)
}), sep="\n")


#' Minimum encoding length (MLE)
#'
#' This function calculates the mininmum encoding length associated with a subset of variables given a background knowledge graph.
#' @param bs - A list of bitstrings associated with a given patient's perturbed variables.
#' @param pvals - The matrix that gives the perturbation strength significance for all variables (columns) for each patient (rows)
#' @param ptID - The row name in data.pvals corresponding to the patient you specifically want encoding information for.
#' @param G - A list of probabilities with list names being the node names of the background graph.
#' @return df - a data.frame object, for every bitstring provided in bs input parameter, a row is returned with the following data:
#'              the patientID; the bitstring evaluated where T denotes a hit and 0 denotes a miss; the subsetSize, or the number of
#'              hits in the bitstring; the individual p-values associated with the variable's perturbations, delimited by '/';
#'              the combined p-value of all variables in the set using Fisher's method; Shannon's entropy, IS.null;
#'              the minimum encoding length IS.alt; and IS.null-IS.alt, the d.score.
#' @export mle.getEncodingLength
#' @keywords minimum length encoding
#' @import gmp
#' @examples
#' # Identify the most significant subset per patient, given the background graph
#' data_mx.pvals = t(apply(data_mx, c(1,2), function(i) 2*pnorm(abs(i), lower.tail = FALSE)))
#' for (pt in 1:ncol(data_mx)) {
#'     ptID = colnames(data_mx)[pt]
#'     res = mle.getEncodingLength(ptBSbyK[[ptID]], data_mx.pvals, ptID, G)
#'     res = res[order(res[,"d.score"], decreasing=TRUE),]
#'     print(res)
#' }
mle.getEncodingLength = function(bs, pvals, ptID, G) {
  if (is.null(pvals)) {
    results = data.frame(optimalBS=character(), subsetSize=integer(), opt.T=integer(),
                         IS.null=numeric(), IS.alt=numeric(), d.score=numeric(), stringsAsFactors = FALSE)
  } else {
    results = data.frame(patientID=character(), optimalBS=character(), subsetSize=integer(), opt.T=integer(), varPvalue=numeric(),
                         fishers.Info=numeric(), IS.null=numeric(), IS.alt=numeric(), d.score=numeric(), stringsAsFactors = FALSE)
  }
  row = 1
  for (k in 1:length(bs)) {
    # Assume k=1 corresponds to subset of size 1
    optBS = bs[[k]]
    mets.k = names(optBS)[which(optBS==1)]
    found = sum(optBS)
    not_found = k-found
    e = (not_found+1)*log2(length(G)) + length(optBS)-1

    optBS.tmp = gsub("1", "T", paste(as.character(optBS), collapse=""))
    if (!is.null(pvals) && !is.null(ptID)) {
      results[row, "patientID"] = ptID
      results[row, "varPvalue"] = paste(format(pvals[ptID, mets.k], digits=2, width=3), collapse="/")
      results[row, "fishers.Info"] = -log2(stats.fishersMethod(pvals[ptID, mets.k]))
    }
    results[row, "optimalBS"] = optBS.tmp
    results[row, "subsetSize"] = k
    results[row, "opt.T"] = found
    results[row, "IS.null"] =  log2(chooseZ(length(G), k))
    results[row, "IS.alt"] = e
    results[row, "d.score"] = round(log2(chooseZ(length(G), k)) - e, 3)
    row = row + 1
  }
  return (results)
}


# 4. faza: Analiza podatkov

l <- data.frame(leto=c(2020, 2021, 2022))

# Graf za napoved števila delovno aktivnih moških z visokošolsko ali višješolsko izobrazbo

visokoizobrazeni_moski <- tabela_po_izobrazbi %>% filter(izobrazba == 'Višješolska, visokošolska') %>%
  filter(spol == 'Moški')
visokoizobrazeni_moski$leto = as.numeric(as.character(visokoizobrazeni_moski$leto))

model_visokoizobrazeni.moski <- lm(stevilo ~ leto, data=visokoizobrazeni_moski)
napoved_moski <- mutate(l, stevilo=predict(model_visokoizobrazeni.moski,l))

graf_napovedi_visokoizobrazeni.moski <- ggplot(visokoizobrazeni_moski, aes(x=leto, y=stevilo)) +
  geom_point() + geom_smooth(method=lm, fullrange=TRUE) +
  geom_point(data=napoved_moski, aes(x=leto, y=stevilo), color='plum1', size=3) +
  scale_x_continuous(breaks=2008:2022) + theme_minimal() +
  labs(title = 'Napoved števila delovno aktivnih moških \nz visokošolsko ali višješolsko izobrazbo',
       x = 'Leto', y = 'Število v 1000')

# Graf za napoved števila delovno aktivnih žensk z visokošolsko ali višješolsko izobrazbo

visokoizobrazene_zenske <- tabela_po_izobrazbi %>% filter(izobrazba == 'Višješolska, visokošolska') %>%
  filter(spol == 'Ženske')
visokoizobrazene_zenske$leto = as.numeric(as.character(visokoizobrazene_zenske$leto))

model_visokoizobrazene.zenske <- lm(stevilo ~ leto, data=visokoizobrazene_zenske)
napoved_zenske <- mutate(l, stevilo=predict(model_visokoizobrazene.zenske,l))

graf_napovedi_visokoizobrazene.zenske <- ggplot(visokoizobrazene_zenske, aes(x=leto, y=stevilo)) +
  geom_point() + geom_smooth(method=lm, fullrange=TRUE) +
  geom_point(data=napoved_zenske, aes(x=leto, y=stevilo), color='plum1', size=3) +
  scale_x_continuous(breaks=2008:2022) + theme_minimal() +
  labs(title = 'Napoved števila delovno aktivnih žensk \nz visokošolsko ali višješolsko izobrazbo',
       x = 'Leto', y = 'Število v 1000')


#' Calculate the realized volatility for a transction price time-series
#'
#' @param price and xts object containting transaction prices
#' @param interval the window size to calculate realized volatility over. The
#' default is 5 mintes.
#' @param interval const the number of trading periods specified by the interval
#  for example if you are looking at daily this should be set to 252, which
#' is the number of trading days in a year. It should be noted that this is
#' only needed for calculations like realized volatility. For comparison
#' of two stocks over the same intervals it is fine to leave this as 1.
#' @examples
#' data(aapl_fix)
#' ctp = consolidate_prices(aapl_fix$sys_date, aapl_fix$sys_time,
#'  aapl_fix$td_price, aapl_fix$td_size, date_format="%Y-%m-%d",
#'  time_format="%H:%M:%S")
#' rv = realized_volatility(ctp$price)
#' plot(rv)
#' @export
realized_volatility = function(price, interval=minutes(5),
                               interval_const=1) {
  log_price = log(price)
  log_diff_price = na.omit(diff(log_price))
  if (is.null(getDoParName())) registerDoSEQ()
  ret=foreach(it=inclusive_window_gen(time(log_diff_price), interval),
    .combine=rbind) %dopar% {
    ldp = log_diff_price[it]
    data.frame(
      list(volatility=
        100*sqrt(interval_const/length(ldp)*mean(ldp^2, na.rm=TRUE)),
        time=tail(time(ldp), 1)))
  }
  xts(ret$volatility, order.by = ret$time)
}


library(bivpois)
data(ex3.health)
# Bivariate Poisson models
ex3.model.a<-lm.bp(doctorco~sex+age+income, prescrib~sex+age+income, data=ex3.health)
ex3.model.b<-lm.bp(doctorco~sex+age+income, prescrib~sex+age+income,l3=~sex, data=ex3.health)
# Double Poisson model
ex3.model.c<-lm.bp(doctorco~sex+age+income, prescrib~sex+age+income,data=ex3.health, zeroL3=TRUE)
#
# diagonal inflated models
ex3.dibp.a<-lm.dibp(doctorco~sex+age+income, prescrib~sex+age+income,  data=ex3.health, jmax=0)          # model (a)
ex3.dibp.b<-lm.dibp(doctorco~sex+age+income, prescrib~sex+age+income,l3=~sex, data=ex3.health, jmax=0)   # model (b)

# save models
dump('ex3.model.a','c:/ex3bp1.r')
dump('ex3.model.b','c:/ex3bp2.r')
dump('ex3.model.c','c:/ex3bp3.r')

dump('ex3.dibp.a','c:/ex3dibp1.r')
dump('ex3.dibp.b','c:/ex3dibp2.r')
#
# load models
#source('c:/ex3bp1.r')
#source('c:/ex3bp2.r')
#source('c:/ex3bp3.r')

#source('c:/ex3dibp1.r')
#source('c:/ex3dibp2.r')


### Obtain effectRatio code from GitHub ###
source("https://raw.githubusercontent.com/hyunseungkang/matchIV/master/effectRatio.r")

##### Example Run #####
### Generate simulated data ###

### Simulated data contains n=1000 individuals,
### the response (denoted as R), the exposure
### (denoted as D), the instrument (denoted as
###  Z), and the covariates (denoted as X)

### Simulated Data Characteristics
### R is continuous (e.g. height)
### D is continuous (e.g. amount of malaria parasite in plasma)
### Z is binary (1/0 e.g. Sickle cell trait status)
### X1 is a continuous variable (e.g. birthweight),
### X2 is a binary variable (1/0, e.g. sex)
### NOTE1: our method can handle continuous, discrete, binary R,D,Xs,
###       and many covariates. Our method only
###       requires that Z is binary (1/0) and non-missing.
### NOTE2: If some values of Xs are missing
###        (e.g. contains NAs), then
###        you must provide a "cleaned" X
###        without NAs, depending on how
###        you want to take care of missing
###        values (e.g. imputation, MCAR, MAR, etc.)
### NOTE3: If R or D are missing, then you must provide a
###        cleaned R and D without NAs.

set.seed(1) #Random number generator seed. Change it as you please!
n = 1000
Z = runif(n) < 0.5
X1 = rnorm(n,rep(c(0,1),n/2))
X2 = rep(c(0,1),n/2)
X = cbind(X1,X2)

# Generate R and D
# Note that R and D are non-linear functions of X.
# -3 is the true value of the causal effect of D on R in this example
# Our point estimator should be close to -3 and our confidence interval
# should have the desired level of coverage
D = -1 + 0.2 * Z + X1 - 2*X1^2 - 2 * X2 + rnorm(n)
R = 2 - 3 * D + X1 - 2*X1^2 - 2 * X2 + rnorm(n)

### Run our method (automatically matches and estimateds Lambda)
estLambda(Z,R,D,X)

### Run 2SLS
est2SLS(Z,R,D,X)

### EXPECTED RESULT:
###         In most cases, you will notice that our method (estLambda)'s
###         point estimate will be closer to -3. Furthermore, our confidence
###         interval should have the desired 95% level of coverage.
###         In contrast, 2SLS (est2SLS) will be off from -3 most of the
###         time and its confidence interval will not have the desired
###         95% level of coverage.

#### Some other functions
### Match analysis
fullmatchvec = matching(Z,X) #full-match individuals
balanceCheck(Z,X,fullmatchvec) #checks balance of covariates


setwd("~/Desktop/code_COVID_xlsx/conferencia.xlsx")
library("bstats")
library(lmtest)
library(readxl)

conferencia <- read_excel("conferencia.xlsx")
pares<- read_excel("pares_conf.xlsx")

i=1
A=as.character(pares[i,1])
B=as.character(pares[i,2])
xyA=as.matrix(conferencia[conferencia$location==A,2:3])
xyB=conferencia[conferencia$location==B,2:3]
deaths = (xyA - xyB)[,1]
iso   = (xyA - xyB)[,2]
model = lm(deaths~iso)
ds = summary(model)

coefs = model$coefficients
pv=coef(ds)[,4]
# Residual analysis
resd = model$residuals
tests = c(shapiro.test(resd)$p.value, # H0: normality
          white.test(model)$p.value, # H0:  homoskedasticity
          bgtest(model)$p.value, # H0: uncorrelated errors
          resettest(model)$p.value) # Model is functionally well specified
coint = as.numeric(PP.test(lm(deaths~iso)$residuals)[3])

fr=data.frame("A" = A, "B" = B, "intercept" = as.numeric(coefs[1]), "coef_isol" = as.numeric(coefs[2]),
              "p.value_iso" = pv[2], "Shapiro" = shapiro.test(resd)$p.value,
              "White" = white.test(model)$p.value, "LM-test" = bgtest(model)$p.value,
              "Reset" = resettest(model)$p.value, "Coint" = coint)

for(i in 2:dim(pares)[1]){
  A=as.character(pares[i,1])
  B=as.character(pares[i,2])
  xyA=as.matrix(conferencia[conferencia$location==A,2:3])
  xyB=conferencia[conferencia$location==B,2:3]
  deaths = (xyA - xyB)[,1]
  iso   = (xyA - xyB)[,2]
  model = lm(deaths~iso)
  ds = summary(model)
  coefs = model$coefficients
  pv=coef(ds)[,4]
  # Residual analysis
  resd = model$residuals
  coint = as.numeric(PP.test(lm(deaths~iso)$residuals)[3])

  fr=rbind(fr,data.frame("A" = A, "B" = B, "intercept" = as.numeric(coefs[1]), "coef_isol" = as.numeric(coefs[2]),
                         "p.value_iso" = pv[2], "Shapiro" = shapiro.test(resd)$p.value,
                         "White" = white.test(model)$p.value,  "LM-test" = bgtest(model)$p.value,
                         "Reset" = resettest(model)$p.value, "Coint" = coint))
}

write.table(fr, file = "Todos_conf.csv", sep = ",", row.names = F)


#' Community weighted mean trait values
#'
#' @param comm Site by species weights matrix; if presence-absence (1-0), the function returns the community mean
#' @param traits Matrix of traits; rownames will be matched to colnames in \code{comm}
#' @param na.rm Logical, whether to remove NAs when computing the mean
#' @return site by trait CWM matrix
#' @export
cwm <- function(comm, traits, na.rm=FALSE)
{
	# make sure all species in comm and in traits match
	taxa <- sort(intersect(colnames(comm), rownames(traits)))
	if(length(taxa) < ncol(comm))
		warning(ncol(comm) - length(taxa), " taxa were dropped from comm because they were not in traits")
	if(length(taxa) < nrow(traits))
		warning(nrow(traits) - length(taxa), " taxa were dropped from traits because they were not in comm")
	traits <- traits[taxa, taxa]
	comm <- comm[,taxa]

	apply(traits, 2, function(x) colMeans(t(comm) * x, na.rm=na.rm))
}


#  James Rekow

computeSSRatio = function(inputMat, centers){

  #  ARGS: inputMat - matrix or data frame of vectors to apply kmeans to
  #        centers - number of centers to use in kmeans algorithm
  #
  #  RETURNS: SSRatio - ratio of total between clusters sum of squares to total within clusters sum of
  #                     squares

  #  perform kmeans on the input data matrix using the given number of centers
  kmr = kmeans(inputMat, centers = centers, iter.max = 1000, nstart = 100)

  #  compute the ratio of the total between clusters sum of squares to the total within clusters sum of
  #  squares
  SSRatio = kmr$betweenss / kmr$tot.withinss

  return(SSRatio)

} #  end computeSSRatio function


## Copyright (C) 1999-2000 Paul Kienzle
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

## usage: [S [, f [, t]]] = specgram(x [, n [, Fs [, window [, overlap]]]])
##
## Generate a spectrogram for the signal. This chops the signal into
## overlapping slices, windows each slice and applies a Fourier
## transform to determine the frequency components at that slice.
##
## x: vector of samples
## n: size of fourier transform window, or [] for default=256
## Fs: sample rate, or [] for default=2 Hz
## window: shape of the fourier transform window, or [] for default=hanning(n)
##    Note: window length can be specified instead, in which case
##    window=hanning(length)
## overlap: overlap with previous window, or [] for default=length(window)/2
##
## Return values
##    S is complex output of the FFT, one row per slice
##    f is the frequency indices corresponding to the rows of S.
##    t is the time indices corresponding to the columns of S.
##    If no return value is requested, the spectrogram is displayed instead.
##
## Example
##    x = chirp([0:0.001:2],0,2,500);  # freq. sweep from 0-500 over 2 sec.
##    Fs=1000;                  # sampled every 0.001 sec so rate is 1 kHz
##    step=ceil(20*Fs/1000);    # one spectral slice every 20 ms
##    window=ceil(100*Fs/1000); # 100 ms data window
##    specgram(x, 2^nextpow2(window), Fs, window, window-step)
##
##    ## Speech spectrogram
##    [x, Fs] = auload(file_in_loadpath("sample.wav")); # audio file
##    step = fix(5*Fs/1000);     # one spectral slice every 5 ms
##    window = fix(40*Fs/1000);  # 40 ms data window
##    fftn = 2^nextpow2(window); # next highest power of 2
##    [S, f, t] = specgram(x, fftn, Fs, window, window-step)
##    S = abs(S(2:fftn*4000/Fs,:)); # magnitude in range 0<f<=4000 Hz.
##    S = S/max(S(:));           # normalize magnitude so that max is 0 dB.
##    S = max(S, 10^(-40/10));   # clip below -40 dB.
##    S = min(S, 10^(-3/10));    # clip above -3 dB.
##    imagesc(flipud(log(S)));   # display in log scale
##
##
##     imagesc(flipud(log(S(idx,:))))

## 2001-07-05 Paul Kienzle <pkienzle@users.sf.net>
## * remove "See also spectrogram"
## * add notes on selecting parameters for the spectrogram

specgram_rev <- function(x, n = min(256, length(x)), Fs = 2, window = hanning(n),
     overlap = ceiling(length(window)/2)){
  ## if only the window length is given, generate hanning window

  if(!is.numeric(x))
    stop("'x' has to be a numeric.")

  if (length(window) == 1)
    window <- hanwin(window)
  asc <- sum(window)

  ## should be extended to accept a vector of frequencies at which to
  ## evaluate the fourier transform (via filterbank or chirp
  ## z-transform)
  if (length(n) > 1)
    stop("specgram does not handle frequency vectors yet")

  ## compute window offsets
  win_size <- length(window)
  if (win_size > n) {
    n <- win_size
    warning("specgram fft size adjusted to", n)
  }
  step <- win_size - overlap

  ## build matrix of windowed data slices
  if (length(x) > win_size)
    offset <- seq(1, length(x)-win_size, by = step)
  else
    offset <- 1
  S <- matrix(0, n, length(offset))
  for (i in seq_along(offset)) {
    S[1:win_size, i] <- x[offset[i]:(offset[i] + win_size - 1)] * window
  }

  ## compute fourier transform
  S <- mvfft(S)

  ## extract the positive frequency components
  if (n %% 2 == 1)
    ret_n <- (n+1)/2
  else
    ret_n <- n/2
  S <- S[1:ret_n, ]

  f <- (0:(ret_n-1))*Fs/n
  t <- 1000.0 * offset/Fs
  af <- 2.0 / asc

  res <- list(S = S, f = f, t = t, af = af)
  class(res) <- "specgram"
  res
}

print.specgram <- plot.specgram <- function(x, col=gray.colors(128,start=0,end=1,rev=T),
                                            zlim=c(20,60),
                                            xlab="Time (msec)", logsc=TRUE,
                                            ylab="Frequency (Hz)", ...) {
  if (logsc) {
    a <- 20.0 * log10(x$af * abs(x$S) + 0.001)
  } else {
    a <- x$af * abs(x$S)
  }

  mx = max(a)
  a <- ifelse(a < zlim[1], zlim[1], a)
  a <- ifelse(a > zlim[2], zlim[2], a)

  image(x$t, x$f, t(a), zlim=zlim, col=col, xlab=xlab, ylab=ylab,...)
}

###specgram(chirp(seq(-2, 15, by = .001), 400, 10, 100, 'quadratic'))
###specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), Fs = 8000)
###
###
###Fs=1000
###x = chirp(seq(0,2, by = 1/Fs), 0, 2, 500)   # freq. sweep from 0-500 over 2 sec.
###step = ceiling(20*Fs/1000)      # one spectral slice every 20 ms
###window = ceiling(100*Fs/1000)   # 100 ms data window
###specgram(x)

#! ## test of returned shape
#!assert (rows(S), 128)
#!assert (columns(f), rows(S))
#!assert (columns(t), columns(S))
#!test [S, f, t] = specgram(x')
#!assert (rows(S), 128)
#!assert (columns(f), rows(S))
#!assert (columns(t), columns(S))
#!error (isempty(specgram([])))
#!error (isempty(specgram([1, 2 ; 3, 4])))
#!error (specgram)

#!demo
#! Fs=1000
#! x = chirp([0:1/Fs:2],0,2,500);  # freq. sweep from 0-500 over 2 sec.
#! step=ceil(20*Fs/1000);    # one spectral slice every 20 ms
#! window=ceil(100*Fs/1000); # 100 ms data window
#!
#! ## test of automatic plot
#! [S, f, t] = specgram(x)
#! specgram(x, 2^nextpow2(window), Fs, window, window-step)
#! disp("shows a diagonal from bottom left to top right")
#! input("press enter:","s")
#!
#! ## test of returned values
#! S = specgram(x, 2^nextpow2(window), Fs, window, window-step)
#! imagesc(20*log10(flipud(abs(S))))
#! disp("same again, but this time using returned value")

#!demo
#! ## Speech spectrogram
#! [x, Fs] = auload(file_in_loadpath("sample.wav")); # audio file
###data(sampleWav)
###Fs = wav$rate
###step = trunc(5*Fs/1000);     # one spectral slice every 5 ms
###window = trunc(40*Fs/1000);  # 40 ms data window
###fftn = 2^nextpow2(window); # next highest power of 2
###spg = specgram(wav$sound, fftn, Fs, window, window-step)
###S = abs(spg$S[2:(fftn*4000/Fs),]) # magnitude in range 0<f<=4000 Hz.
###S = S/max(S);         # normalize magnitude so that max is 0 dB.
###S[S < 10^(-40/10)] = 10^(-40/10)   # clip below -40 dB.
###S[S > 10^(-3/10)] = 10^(-3/10))    # clip above -3 dB.
###image(t(20*log10(S)), axes = FALSE) #, col = gray(0:255 / 255))
#!
#! % The image contains a spectrogram of 'sample.wav'


# Load necessary libraries
library(devtools)
library(plotly)
library(dplyr)
library(RColorBrewer)

year <- c(2018,2019,2020,2021,2022,2023,2024)
gdp  <- c(100,104,98,103,105,107,109)
hyp <- c(100,101.45,102.91,104.40,105.91,107.44,109)

data <- data.frame(year,gdp,hyp)
data$lngdp <- log(data$gdp)
data$lnhyp <- log(data$hyp)

fig <- plot_ly(data, x = ~year, y = ~lngdp, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP',range=c(4.4,4.8)),
              hovermode="x unified")
api_create(fig, filename = "me-level-data")

fig <- plot_ly(data, x = ~year)
fig <- fig %>% add_trace(y = ~lngdp, name = 'Actual GDP', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnhyp, name = 'Hypothetical GDP', type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP',range=c(4.4,4.8)),
              hovermode="x unified")
api_create(fig, filename = "me-level-hyp")

fake <- data.frame(year)
fake$series1 <- log(75) + .02*(fake$year-2018)
fake$series2 <- log(100) + .02*(fake$year-2018)
fake$series3 <- log(75) + .10*(fake$year-2018)
fake$series4 <- log(100) + .10*(fake$year-2018)

fig <- plot_ly(fake, x = ~year)
fig <- fig %>% add_trace(y = ~series1, name = 'A0=75, gA=.02', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~series2, name = 'A0=100, gA=.02', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~series3, name = 'A0=75, gA=.10', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~series4, name = 'A0=100, gA=.10', type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Theoretical log GDP over time', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP',range=c(4,5.5)),
              hovermode="x unified")
api_create(fig, filename = "me-level-theory")