#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health
## Florida Charts Census Tract Mortality Data: Code Script by DrewC!

#### Section A: Import Libraries and Datasets and Prepare Data

### Import Libraries and Data

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Hadley Wickham Libraries
library(tidyverse) # All of the libraries above in one line of code

## Import Statistics Libraries
library(ineq) # Gini coefficient and Lorenz curve
library(pROC) # ROC tests with AUC output

## Import Data
setwd("C:/Users/drewc/GitHub/HNB") # Set wd to project repository
df_fl = read.csv("_data/flcharts_50_stage.csv") # Import dataset from _data folder

### Step 2: Prepare Data for Classificaiton

## Tidy data types and objects
df_fl = df_fl %>% mutate_if(is.factor, as.numeric) # Change character to numeric values
df_fl = na.omit(df_fl) # Omit rows with NA from Data Frame
df_fl = subset(df_fl, select = -c(X.2, X.1, X)) # Remove variables with high missing values

## Verify Data
glimpse(df_fl) # Rows, columns, variable types and 10

### Step 3: Develop Inequality Measures for Data

## Sort by mortality total
df_causes = subset(df_fl, select = -c(Tract, Total.Population, Pop.per.10000, Other.Non.rankable.Cause.of.Death)) # Remove variables with high missing values
df_sum = colSums(df_causes)
df_sum = as.data.frame(df_sum)
df_sum = rownames_to_column(df_sum) ## Invert Rows and Columns
colnames(df_sum) <- c("Cause", "Total") ## Change Column Names
df_sum = arrange(df_sum, desc(Total)) # Descend by variable in data frame
head(df_sum, 10)

## Create new column as sum of others
df_fl$Vascular = df_fl$Heart.Diseases + df_fl$Cerebrovascular.Diseases +  df_fl$Essen.Hypertension...Hypertensive.Renal.Dis + df_fl$ Aortic.Aneurysm...Dissection + df_fl$Atherosclerosis  # Create new column based on conditions
df_fl$Metabolic = df_fl$Diabetes.Mellitus + df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis # Create new column based on conditions
df_fl$Cancer = df_fl$In.Situ..Benign..Uncertain.and.Unknown.Behavior.Neoplasms + df_fl$Malignant.Neoplasm.or.Cancer

## Gini coefficient
gini_Metabolic = ineq(df_fl$Metabolic, type = "Gini")
gini_Vascular = ineq(df_fl$Vascular, type = "Gini")
gini_Cancer = ineq(df_fl$Cancer, type = "Gini")

## Sum
sum_Metabolic = sum(df_fl$Metabolic)
sum_Vascular = sum(df_fl$Vascular)
sum_Cancer = sum(df_fl$Cancer)

## Combine into Data Frame
df_topcause = data.frame("Cause" = c("Metabolic", "Vascular", "Cancer"), "Sum" = c(sum_Metabolic, sum_Vascular, sum_Cancer), "Gini" = c(gini_Metabolic, gini_Vascular, gini_Cancer))
print(df_topcause)

## Write Output to File
result = df_topcause # Save result df to variable
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "w") # Open file and "a" to append
write("Top Causes of Mortality",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Vascular

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Vascular",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Cancer

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Cancer",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file

###

## Outcome
df_fl$Outcome = df_fl$Nephritis..Nephrotic.Syndrome..Nephrosis

## Group by County for internal Gini
tib_gini = df_fl %>% group_by(County) %>% summarise(ineq(Outcome, type = "Gini")) # Group By Columns and Average
df_gini = as.data.frame(tib_gini) # Convert tiblle to Data Frame
colnames(df_gini) <- c("County", "Gini") # Change Column Names

tib_sum = df_fl %>% group_by(County) %>% summarise(sum(Outcome)) # Group By Columns and Average
df_sum = as.data.frame(tib_sum) # Convert tiblle to Data Frame
colnames(df_sum) <- c("County", "Sum") # Change Column Names

tib_pop = df_fl %>% group_by(County) %>% summarise(sum(Total.Population)) # Group By Columns and Average
df_pop = as.data.frame(tib_pop) # Convert tiblle to Data Frame
colnames(df_pop) <- c("County", "Population") # Change Column Names

df_join = inner_join(df_gini, df_pop, by = "County") ## Join By Columns
df_join = inner_join(df_join, df_sum, by = "County") ## Join By Columns
df_join$Rate = df_join$Sum/df_join$Population
df_top = arrange(df_join, desc(Gini)) # Descend by variable in data frame
head(df_top, 10)

## Spearman Rank
corr_gini = cor.test(x = df_join$Gini, y = df_join$Rate, method = "pearson") # Pearson's Rank for Q->Q
corr_gini

## Write Output to File
result2 = head(df_join, 10)
result3 = corr_gini
file = file("cedric/cedric_flcharts_gini_results.txt") # Open result file in subproject repository
open(file, "a") # Open file and "a" to append
write("Nephritis..Nephrotic.Syndrome..Nephrosis",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result2, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
write("Pearson Rank",  file) # Insert title
write(" ", file) # Insert space below title
capture.output(result3, file = file, append = TRUE) # write summary to file
write(" ", file) # Insert space below result
close(file) # Close file


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 10

rm(list = ls())

observed <- c(40, 32, 15, 7, 6)

(k <- length(observed))
# 5

(n <- sum(observed))
# 100

(expected <- n * c(dgeom(0:(k - 2), prob = 0.5), 1 - pgeom(k - 2, prob = 0.5)))
# 50 25 12.5 6.25 6.25

(Q <- sum((observed - expected)^2 / expected))
# 4.56

(pvalue <- 1- pchisq(Q, df = k - 1))
# 0.335492198026963


#' myncurve
#'
#' @param mu mean value
#' @param sigma standard defiation value
#' @param a upper bound of lower tail problem
#'
#' @return a normal distribution graph with probability place on it
#' @export
#'
#' @examples
#' myncurve(mu=10,sigma=5, a=6)
myncurve = function(mu, sigma, a){
  curve(dnorm(x,mean=mu,sd=sigma), xlim = c(mu-3*sigma, mu + 3*sigma))
  xcurve=seq(mu-3*sigma, a,length=1000)
  ycurve=dnorm(xcurve,mean=mu,sd=sigma)
  polygon(c(mu-3*sigma,xcurve,a),c(0,ycurve,0),col="Red")
  prob=pnorm(a,mean=mu,sd=sigma)
  prob=round(prob,4)
  text(x=(a-(mu-3*sigma))/2, y=max(ycurve)/2, paste("Area = ", prob, sep=""))
}


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Gender analysis: utility  functions
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# adapted from https://github.com/lukeholman/genderGapCode/

pfunc <- function(t, r, c) exp(0.5*r*t) / (2*exp(0.5*r*t) + c)
pfunc.deriv <- function(p, r) r*p*(0.5-p)

# log likelihood of data given the parameters, assuming binomial distribution
# returns the negative log-likelihood to be minimised with optim()
find.ll <-function(data, par) {

    sample <- dbinom(
        x=data$nFemales, size=data$n,
        prob=pfunc(t=data$date, r=par[1], c=par[2]), log=TRUE
    )

    -1 * sum(sample)
}

# Internal function to perform 1D optimisation and find
# the parameters r and c that optimises the log likelihood
# for the focal set of data. Arbitrarily chosen starting values
run.optimiser <- function(data) optim(par = c(0.1, 1), find.ll, data = data)

# Used to find the 95% CIs on a proportion
# (uses default method of the binom.test function).
# Works for a pair of columns nFemales and nMales
get.CIs <- function(nFemales.column, nMales.column){

    CIs <- data.frame(lowerCI = numeric(length(nFemales.column)), upperCI = NA)

    for(i in 1:length(nFemales.column)){

        CIs.foc <- as.numeric(binom.test(
            nFemales.column[i],
            nFemales.column[i] + nMales.column[i]
        )$conf.int)

    CIs$lowerCI[i] <- CIs.foc[1]
    CIs$upperCI[i] <- CIs.foc[2]

    }

    return(100 * CIs)

}

Mode <- function(x) {
    ux <- unique(x)
    ux[which.max(tabulate(match(x, ux)))]
}
##############################

find.response.variables <- function(data) {

    # This function runs the optimiser on a focal bit of resampled data,
    # and gets the current gender ratio, rate of change, and
    # the year at which the ratio got within
    # 5% of gender parity using the pfunc model with optimised parameters

    optim.results <- run.optimiser(data)
    r <- optim.results$par[1]
    c <- optim.results$par[2]

    # Compute the predicted gender ratio at the "present",
    # i.e. the first year with data
    gender.ratio.at.present <- pfunc(max(data$date), r, c)

    # Compute the rate of change in the gender ratio at the "present"
    current.rate.of.change <- pfunc.deriv(p = gender.ratio.at.present, r = r)

    # Compute parity year
    year.range <- 0:9999
    predicted.gender.ratio <- pfunc(year.range, r, c)

    # check if female ratio increasing
    is_female_ratio_increasing <- ifelse(
        predicted.gender.ratio[2] > predicted.gender.ratio[1], TRUE, FALSE
    )

    if(is_female_ratio_increasing) { # becoming more female biased

    parity.year <- ifelse(
        gender.ratio.at.present < 0.5,
        # record first year it got within 5% of parity
        year.range[which(predicted.gender.ratio > 0.45)][1],
        "Female-biased and becoming more so"
    )

    } else { # becoming more male biased

    parity.year <- ifelse(
        gender.ratio.at.present > 0.5,
        # record first year it got within 5% of parity
        year.range[which(predicted.gender.ratio < 0.55)][1],
        "Male-biased and becoming more so"
    )

    }

    return(data.frame(
        gender.ratio.at.present = gender.ratio.at.present,
        current.rate.of.change = current.rate.of.change,
        parity.year = parity.year, r = r, c = c,
        stringsAsFactors = F)
    )
}


## ---- echo = FALSE---------------------------------------------------------------------
knitr::opts_chunk$set(
  message = FALSE,
  warning = FALSE,
  collapse = TRUE,
  comment = "",
  fig.height = 4,
  fig.width = 8,
  fig.align = "center",
  cache = FALSE
)

## ----load packages, echo = FALSE-------------------------------------------------------
library(tidyverse)
library(lubridate)
library(broom)
library(broom.mixed)
library(lme4)

## ----setting up, echo=FALSE------------------------------------------------------------
load(here::here("data/french_fries.rda"))

## ----models and model output-----------------------------------------------------------

ff_long <- french_fries %>% pivot_longer(potato:painty, names_to = "type", values_to = "rating")
ff_lm <- lm(rating~type+treatment+time+subject,
data=ff_long)

## ----examine the model fit-------------------------------------------------------------
summary(ff_lm)

## ----goodness of fit statistics--------------------------------------------------------
glance(ff_lm)

## ----model estimates-------------------------------------------------------------------
ff_lm_tidy <- tidy(ff_lm)
glimpse(ff_lm_tidy)

## ----model diagnostics-----------------------------------------------------------------
ff_lm_all <- augment(ff_lm)
glimpse(ff_lm_all)

## ----residual plot---------------------------------------------------------------------
ggplot(ff_lm_all, aes(x=.fitted, y=.resid)) + geom_point()

## ----add random intercepts for each subject, results='hide'----------------------------
library(lme4)
fries_lmer <- lmer(rating~type+treatment+time+subject + ( 1 | subject ),
data = ff_long)

## ----solution to french fries modeling, eval=FALSE, echo=FALSE-------------------------
## ## the model is pretty bad:
## glance(fries_lmer)
## tidy(fries_lmer)
##
## ff_lmer_all <- augment(fries_lmer)
##
## ggplot(ff_lmer_all, aes(x=.fitted, y=.resid)) + geom_point() +
##   coord_equal()
##
## ggplot(ff_lmer_all, aes(x=.fitted, y=rating)) + geom_point() +
##   coord_equal()

## ----select a subset of the observations-----------------------------------------------
load(here::here("data/french_fries.rda"))
french_fries %>%
    filter(subject == 3, time == 1)

## ----order the observations------------------------------------------------------------
french_fries %>%
    arrange(desc(rancid)) %>%
    head

## ----select a subset of the variables--------------------------------------------------
french_fries %>%
    select(time, treatment, subject, rep, potato) %>%
    head

## ----summarize observations into one-number statistic----------------------------------
french_fries %>%
    summarise(mean_rancid = mean(rancid, na.rm=TRUE),
              sd_rancid = sd(rancid, na.rm = TRUE))

## ----summarise and group_by------------------------------------------------------------
french_fries %>%
    group_by(time, treatment) %>%
    summarise(mean_rancid = mean(rancid), sd_rancid = sd(rancid))

## ----checking design completeness------------------------------------------------------
french_fries %>%
  group_by(subject) %>%
  summarize(n = n())

## ----counts for subject by time--------------------------------------------------------
french_fries %>%
  na.omit() %>%
  count(subject, time) %>%
  spread(time, n)

## ----do scores change over time, fig.show='hide'---------------------------------------
ggplot(data=ff_long, aes(x=time, y=rating, colour=treatment)) +
  geom_point() +
  facet_grid(subject~type)

## ----echo=FALSE, fig.width=12, fig.height=9--------------------------------------------
ggplot(data=ff_long, aes(x=time, y=rating, colour=treatment)) +
  geom_point() +
  facet_grid(subject~type)

## ----echo=FALSE------------------------------------------------------------------------
ff_av <- ff_long %>%
  group_by(subject, time, type, treatment) %>%
  summarise(rating=mean(rating))

ggplot(data=ff_long, aes(x=time, y=rating, colour=treatment)) +
  facet_grid(subject~type) +
  geom_line(data=ff_av, aes(group=treatment))

## ----fig.width=12, fig.height=9--------------------------------------------------------
ggplot(data=ff_long, aes(x=time, y=rating, colour=treatment)) +
  facet_grid(subject~type) +
  geom_line(data=ff_av, aes(group=treatment))


x<-c(7,8,1,4,10,20,30,8,9,6);x
y<-1:10;y
z<--3.5:8;z

typeof(x)
class(x)
typeof(z)
t=seq(17);t
r=seq(10,23,by=2);r
s=seq(10,15);s
s=seq(15,by=-3);s
class(t)
typeof(t)

#using position []
x<-c(7,8,1,4,10,20,30,8,9,6)
x[3]
x[c(1,3,8,10,15)]
x[4:8]

#logical indexing
x<-c(7,8,1,4,10,20,30,8,9,6);x #total value are 10
x[c(T,F,T,T,F,F,T)] #passed logical index for 7

x<-c(7,8,1,4,10,20,30,8,9,6);x
x[c(T,F,F)]
x[15]<-55
x
rm(x)
x<-c(7,8,1,4,10,20,30,8,9,6);x
x[-5]
x[c(-5.-7,-9)]
x[-c(5,7,9)]
x[c(10,7,4)]

#using 0/1 Indexing
x<-c(7,8,1,4,10,20,30,8,9,6);x
x[c(0,1,0,0,1,0,1,1,1,1)]
x[c(0,0,0,0,0,1)]

#vector manipulation
v1<-c(7,8,9,4,56,12) ;v1
v2<-c(10,20,30,58,78,15);v2

addvec<-v1+v2;addvec
subvec<-v1-v2;subvec
mulvec<-v1*v2;mulvec
(divvec<-v2/v1)
(modvec<-v2%%v1) #remainder
(quovec<-v2%/%v1)

#vector element recycling
#when my vectors are of unequal length
v3<-c(10,40,56,95,78,45,32)
v4<-c(6,20) #len2
v3+v4

#vector sorting
(sortvec<-sort(v3,decreasing=T))


########################
# R Script for Class 6 #
########################
# based in part on Germán Rodríguez GLM
# lecture notes and R scripts.
# Rodríguez, G. (2007). Lecture Notes on Generalized Linear Models. URL: http://data.princeton.edu/wws509/notes/

library(stargazer)
library(lavaan)
library(ggplot2)
library(scatterplot3d)
library(rgl)
library(calibrate)

setwd('~/Dropbox/upf_global_studies/2017/slides/global_studies_research_methods/images')

fpe <- read.table("http://data.princeton.edu/wws509/datasets/effort.dat")

p = ggplot(fpe, aes(x = setting, y = change))
p + geom_point()
p + geom_point() + geom_smooth(method = "lm", se = TRUE)

pairs(fpe)

M = lm(change~setting+effort, data=fpe)
summary(M)

stargazer(M, type="html")

newdat <- expand.grid(effort=seq(0,35,by=.5),setting=seq(30,90,by=.5))
newdat$change = predict(M, newdata=newdat)
with(fpe,plot3d(effort,setting,change, col="blue", size=1, type="s"))
with(newdat,surface3d(unique(effort),unique(setting),change,alpha=0.3,front="line", back="line"))
writeWebGL(dir="fp_3Dreg", width=1000)

fpe.g = fpe

fpe.g$effort <- cut(fpe$effort, breaks=c(min(fpe$effort),5,15,max(fpe$effort)), right=FALSE, include.lowest=TRUE, labels=c("Weak","Moderate","Strong"))

M2 = lm(change~setting+effort, data=fpe.g)
summary(M2)
M2l = data.frame(intercept = coef(M2)[1], slope=coef(M2)[2], effort = "Weak")
M2m = data.frame(intercept = (coef(M2)[1]+coef(M2)[3]), slope=coef(M2)[2], effort="Moderate")
M2s = data.frame(intercept = (coef(M2)[1]+coef(M2)[4]), slope=coef(M2)[2], effort = "Strong")
M2r = rbind(M2l, M2m, M2s)

stargazer(M2, type="html")

p = ggplot(fpe.g, aes(x = setting, y = change))
p + geom_point(aes(colour=effort))
ggsave("fp_reg_cat.png")

p = ggplot(fpe.g, aes(x = setting, y = change))
p + geom_point(aes(colour=effort)) + geom_abline(aes(intercept=intercept, slope=slope, colour=effort), data=M2r) + guides(colour=guide_legend("effort"))
ggsave("fp_reg_ints.png")

M3 = lm(change~setting+effort+setting*effort, data=fpe.g)
summary(M3)
M3l = data.frame(intercept = coef(M3)[1], slope=coef(M3)[2], effort = "Weak")
M3m = data.frame(intercept = (coef(M3)[1]+coef(M3)[3]), slope=(coef(M3)[2]+coef(M3)[5]), effort="Moderate")
M3s = data.frame(intercept = (coef(M3)[1]+coef(M3)[4]), slope=(coef(M3)[2]+coef(M3)[6]), effort = "Strong")
M3r = rbind(M3l, M3m, M3s)

stargazer(M3, type="html")

p = ggplot(fpe.g, aes(x = setting, y = change))
p + geom_point(aes(colour=effort)) + geom_abline(aes(intercept=intercept, slope=slope, colour=effort), data=M3r) + guides(colour=guide_legend("effort"))
ggsave("fp_reg_ints_slopes.png")

M3 = lm(change~setting+effort+setting*effort, data=fpe)
summary(M3)

stargazer(M3, type="html")

p = ggplot(fpe.g, aes(x = setting, y = change))
p + geom_point(aes(colour=effort)) + geom_abline(aes(intercept=intercept, slope=slope, colour=effort), data=M3r) + guides(colour=guide_legend("effort"))
ggsave("fp_reg_ints_slopes.png")

newdat <- expand.grid(effort=seq(0,35,by=.5),setting=seq(30,90,by=.5))
newdat$change = predict(M3, newdata=newdat)
with(fpe,plot3d(effort,setting,change, col="blue", size=1, type="s"))
with(newdat,surface3d(unique(effort),unique(setting),change,alpha=0.3,front="line", back="line"))
writeWebGL(dir="fp_int_3Dreg", width=1000)

fpe$setting_sq = fpe$setting^2

M4 = lm(change~setting + setting_sq, data=fpe)
summary(M4)
stargazer(M4, type="html")

M40 = lm(change~setting, data=fpe)
summary(M40)
stargazer(M40, M4, type="html")

p = ggplot(fpe, aes(x = setting, y = change))
p + geom_point() + stat_smooth(method="lm", se=TRUE, fill="grey", formula=y ~ poly(x, 2, raw=TRUE))
ggsave("fp_reg_quad.png")

fpe$high_change = fpe$change > 20
p = ggplot(fpe, aes(x = setting, y = high_change))
p + geom_point()

glm(high_change~setting, data=fpe, family = binomial(link=logit))

p + geom_point() + geom_abline(aes(intercept=intercept, slope=slope, colour=effort), data=M3r) + guides(colour=guide_legend("effort"))
ggsave("fp_reg_ints_slopes.png")


#' @title rmse
#'
#' @description Calculates the root mean square error (RMSE) from observed and
#' predicted values.
#'
#' @inheritParams e
#'
#' @return The root mean square err or (RMSE) calculated from the observed and
#' the predicted values.
#'
#' @details rmse = sqrt(mean((observed - predicted)^2))
#'
#' @examples
#' o<-1:5
#' p<-c(2,2,4,3,5)
#' rmse(observed=o, predicted=p)
#'
#' @export
rmse<-function(observed, predicted) return(sqrt(mean((observed - predicted)^2)))


#!/usr/bin/R -q -f
#
# R script to calculate pearson distance
#
# Objective: To calculate the pearson distance for a mock-up dataset
#
# Input : a mock-up 6-row, 2-column data frame
#
# Output: STDOUT, a single value for the pearson distance
#

# load dplyr package
library(dplyr)

# load the mockup data into a 2 column, 6 row data frame
data <- data_frame(c(3,4,7,6,8,2),c(5,3,10,8,12,5))

# assign the column names so the data is more readable
colnames(data) <- c('x', 'y')

# check the data
data

# add STDEV, MEAN, and COUNT into the dataset
mutate(data, xmean = mean(x), sdx = sd(x), ymean = mean(y), sdy = sd(y), n1 = nrow(data)-1) %>%
# add the intermediate value into the dataset
mutate(xx = ((x-xmean)/(n1*sdx))*((y-ymean)/(sdy))) %>%
# only select the intermediate value column
select(xx) %>%
# sum it to get the pearson distance
sum()


install.packages("gapminder")
library(gapminder)
library(dplyr)

data(gapminder)
head(gapminder)

life_exp_countries_1952 <- filter(gapminder, year == 1952) %>% select(country, lifeExp)

# Pre Quiz Exploration
hist(select(life_exp_countries_1952, lifeExp) %>% unlist)

life_exp_1952 <- select(life_exp_countries_1952, lifeExp)

# Q1
mean(life_exp_1952 <= 40)

# Q2
mean(life_exp_1952 <= 60) - mean(life_exp_1952 <= 40)

# Q3

prop = function(q) {
  mean(life_exp_1952 <= q)
}

qs = seq(from=min(life_exp_1952), to=max(life_exp_1952), length=20)

props = sapply(qs, prop)

plot(qs, props)


rm(list = ls())                                       # Clean environment

### Load data
X <- as.matrix(iris[, -5])                            # Dimension 150 by 4
X.cid <- as.numeric(iris[, 5])                        # True id

### Transformation and check
X.std <- scale(X)                                     # Standardize
mu <- colMeans(X.std)                                 # Columns means are near 0
cov <- cov(X.std)                                     # Diagonals are near 1
print(mu)
print(cov)

### SVD
X.svd <- svd(X.std)

### Project on column space of singular vectors
A <- X.std %*% diag(X.svd$d)
B <- X.std %*% X.svd$v
C <- prcomp(X.std)$x                                # A = B = C

X.prj <- C[, 1:2]                                   # project onto first 2 PC's

### Clustering
set.seed(1234)                                        # Set overall seed
X.kms <- kmeans(X.std, 3)                             # K-means
X.kms
X.kms.cid <- X.kms$cluster                            # Classification

library(EMCluster)                                    # Model-based clustering
X.mbc <- init.EM(X.std, 3)                            # Initial by em-EM
X.mbc
X.mbc.cid <- X.mbc$class                              # Classification

### Validation
X.kms.adjR <- RRand(X.cid, X.kms.cid)$adjRand       # Adjusted Rand index
X.mbc.adjR <- RRand(X.cid, X.mbc.cid)$adjRand

### Swap classification id
X.kms.cid[X.kms.cid == 2] <- 4
X.kms.cid[X.kms.cid == 3] <- 2
X.kms.cid[X.kms.cid == 4] <- 3

### Display on first 2 components
pdf("serial_plot.pdf")

par(mfrow = c(2, 2))
plot(X.prj, col = X.cid + 1, pch = X.cid,
     main = "iris (true)", xlab = "PC1", ylab = "PC2")
plot(X.prj, col = X.kms.cid + 1, pch = X.kms.cid,
     main = paste("iris (k-Means)", sprintf("%.4f", X.kms.adjR)),
     xlab = "PC1", ylab = "PC2")
plot(X.prj, col = X.mbc.cid + 1, pch = X.mbc.cid,
     main = paste("iris (Model-based)", sprintf("%.4f", X.mbc.adjR)),
     xlab = "PC1", ylab = "PC2")
accuracy <- c(X.kms.adjR, X.mbc.adjR)
names(accuracy) <- c("k-Means", "Model-based")
barplot(accuracy, main = "Clustering Accuracy")

dev.off()


# rpois_trunc <- function(n, lambda, lb = 0){
#   thres <- ppois(lb,  lambda = lambda)
#   us <- runif(n, min = thres, max = 1)
#   samples <- qpois(us, lambda = lambda)
#   return(samples)
# }
generate_one_data_point <- function(theta, alpha, lambda){
  # N <- rpois_trunc(1, lambda = theta) ## generate from a zero-truncated Poisson
  N <- rpois(1, lambda = theta) ## generate from a zero-truncated Poisson
  if(N > 0){
    ## convert between parametrisations
    a <- alpha
    b <- exp(-lambda/alpha)
    Z <- rweibull(N, shape = a, scale = b)
  }else{
    Z <- Inf
  }
  return(min(Z))
}
#
r_cure_rate <- function(n, theta, alpha, lambda){
  ys <- sapply(1:n, function(i) generate_one_data_point(theta = theta, alpha = alpha, lambda = lambda))
  return(ys)
}
#
generate_n_data_points <- function(n, beta, alpha, lambda, X, tcs){
  theta <-  exp(X%*%beta)
  samples <- rep(NA, n)
  for(i in 1:n){
    samples[i] <- r_cure_rate(n = 1, theta = theta[i], alpha = alpha, lambda = lambda)
  }
  deltas <- as.numeric(samples < tcs)
  samples_cens <- ifelse(deltas == 1, samples, tcs)
  return(
    list(
      y = samples,
      y_censored = samples_cens,
      delta_censored = deltas
    )
  )
}


#############################################
# Data Preparation
#############################################
# Set the random number generator or seed
# to make the results reproducible
set.seed(314159)

# set the number of items I and persons P
I.items <- 30
P.persons <- 2000

# set the fixed item and population parameters
a.disc <- 1 + runif(I.items, -0.5, 0.5)
b.diff <- seq(-3,3,length = I.items )

mean.theta <- 0
sig2.theta <- (1.25^2)

# generate thetas and the I x P matrix of response probabilities
theta.abl <- rnorm(P.persons, mean = mean.theta, sd = sqrt(sig2.theta))
term.1 <- outer(theta.abl,a.disc)
term.2 <- matrix(rep(a.disc*b.diff, P.persons), nrow = P.persons, byrow = TRUE)
P.prob <- plogis(term.1 - term.2) ### 1/(1+exp(term.2-term.1))

# generate the 0/1 responses U as a matrix of Bernoulli draws
U <- ifelse(runif(I.items * P.persons) < P.prob, 1, 0)


#Multiple Linear Regr

#Importing the dataset
dataset = read.csv('50_Startups.csv')

# Encoding categorical data
dataset$State = factor(dataset$State,
                         levels = c('New York', 'California', 'Florida'),
                         labels = c(1, 2, 3))

# Split the dataset into the Training set and test set
library(caTools)
set.seed(123)
split = sample.split(dataset$Profit, SplitRatio = 0.8)
training_set = subset(dataset, split==TRUE)
test_set = subset(dataset, split==FALSE)

# Fitting multiple Linear Regression to the Training Set
# Profit ~ R.D.Spend + Administration + Marketing.Spend + State
regressor = lm(formula = Profit ~ .,
               data = training_set)

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

# building the optimal model using Backward Elinmination
regressor = lm(formula = Profit ~ R.D.Spend + Administration + Marketing.Spend + State,
               data = dataset)

summary(regressor)

Machine Learning A-Z Template Folder/Part two - Regression/Section 5 - Multiple Linear Regression/mul_lin_reg.r


library("devtools")
#install_github("gianmarcoalberti/CAseriation")
library(CAseriation)

pdf()

plot.clusters.rows <- function (data, x,y){
  res.ca <- CA(data, axes=c(x, y), graph=FALSE)
  resclust.rows<-HCPC(res.ca, nb.clust=-1, metric="euclidean", method="ward", order=TRUE, graph.scale="inertia", graph=FALSE, cluster.CA="rows")
  plot(resclust.rows, axes=c(x,y), choice="map", draw.tree=FALSE, ind.names=TRUE, new.plot=TRUE)
  write.xlsx(resclust.rows$data.clust, "CAseriation_rows_clust.xlsx", sheetName="rowClusters", col.names=TRUE, row.names=TRUE, append=FALSE)
}

sort.table <- function (data, dim){
  # get some details about the input table in order to calculate the table's dimensionality
  nrows <- nrow(data)
  ncols <- ncol(data)
  numb.dim.cols<-ncol(data)-1
  numb.dim.rows<-nrow(data)-1
  a <- min(numb.dim.cols, numb.dim.rows) #dimensionality of the table
  #get the CA dataframe after the 'ca' package, selecting a number of dimensions equal to the table's dimensionality
  res.ca<-ca(data, nd=a)
  #get the coordinates on the selected CA axis
  row.c<-res.ca$rowcoord[,dim]
  col.c<-res.ca$colcoord[,dim]
  #seriation
  #sort the table according to the coord of the selected CA dimension and plot seriation chart (Bertin plot)
  print(sorted.table<-data[order(row.c), order(col.c)]) #sort the table
  print(sorted.table.PA<-apply(sorted.table, 2, function(x) ifelse(x>0, 1, 0))) #transform the sorted table into incidence table (presence/absence) to be used for Bertin plot
  bertinplot(as.matrix(sorted.table.PA), options = list(panel=panel.squares, spacing = 0)) #plot the sorted incidence table
  bertinplot(as.matrix(sorted.table.PA), options = list(panel=panel.squares, spacing = 0, reverse=TRUE)) #plot the sorted incidence table reversed
  #plot the battleship chart for the seriated table
  battleship.plot(sorted.table)
  #plot the battleship chart for the trasposed seriated table
  battleship.plot(t(sorted.table))
  #export relevant data to Excel
  write.xlsx(data, "CAseriation.xlsx", sheetName="originalDATA", col.names=TRUE, row.names=TRUE, append=FALSE)
  write.xlsx(sorted.table, "CAseriation.xlsx", sheetName="sorted_table", col.names=TRUE, row.names=TRUE, append=TRUE)
  write.xlsx(sorted.table.PA, "CAseriation.xlsx", sheetName="sorted_table_PA", col.names=TRUE, row.names=TRUE, append=TRUE)
}

# read data from choosen table
mydata <- read.table(file="data/pfg-cpl-headers.txt", row.names=1, header=T)
pfg <- data.frame(mydata)
check.ca.plot(pfg,1,2)
sort.table(pfg,1)
plot.clusters.rows(pfg,1,2)
#plot.clusters.cols(pfg,1,2)


library(derivr)
library(dplyr)
library(plotly)

# Greeks

# Option
strike <- 180
days <- 10
vol <- 0.25
r <- 0.001
spot_price <- seq(100, 200)

price <- bs_call(strike, spot_price, days, vol, r)
delta <- delta_call(strike, spot_price, days, vol, r)
vega  <- vega_call_put(strike, spot_price, days, vol, r)
gamma <- gamma_call_put(strike, spot_price, days, vol, r)
theta <- theta_call(strike, spot_price, days, vol, r)
rho   <- rho_call(strike, spot_price, days, vol, r)

data <- data.frame(spot_price)
plotly::plot_ly(data, x= ~spot_price, y = ~price, name='Value', type='scatter', mode='lines') %>%
  plotly::add_trace(y = ~delta, name='delta', line = list(dash = 'dash')) %>%
  plotly::add_trace(y = ~vega, name='vega', line = list(dash = 'dash'))  %>%
  plotly::add_trace(y = ~gamma, name='gamma', line = list(dash = 'dash'))  %>%
  plotly::add_trace(y = ~theta, name='theta', line = list(dash = 'dash'))  %>%
  plotly::add_trace(y = ~rho, name='rho', line = list(dash = 'dash'))

df <- data.frame(spot_price, price, delta, vega, gamma, theta, rho)
View(df)


#the code for calculating EM must first be run for initializing the means!

#use of stats library
# mixtools library
library("mixtools")
library("stats")
library("mvtnorm")

#EM algorithm

pdf('standardized_em.pdf')

#--------------(1)-------Initialize the means μk , covariances Σk and mixing coefficients πk--------

	#in the following comment there are the means in case the k-means algorithm is not run.

	k=3;
	#construct the covariance matrices
	#add each covariance matrix to a node in the list S

	a = matrix(nrow=3,ncol=2)
	S = rep(list(a),3)
	for(t in 1:k){
		a= which(rnk_matrix==t)
		tr1=matrix(nrow=length(a),ncol=2)
		counter1=1;
		for (i in a){
			tr1[counter1,1]=dataset[i,1]
			tr1[counter1,2]=dataset[i,2]
			counter1= counter1+1
		}
		S[[t]]=cov(tr1)
	}

	N=length(dataset[,1])
	#array pk -> mixing coefficients

	pk = matrix(nrow=3,ncol=1)
	for(t in 1:k){
		pk[t,] = length(which(rnk_matrix==t))/N
	}

par(mfrow=c(2,2))

plot(dataset[,1],dataset[,2],col="green",xlim=c(-3.2,3.2),ylim=c(-3.2,3.2),panel.first = grid(),xlab="x",ylab="y",pch=20,main="Initialized data from kmeans")
color_=rgb(0,0,0,alpha=0.6)
points(mean_Ar[,1],mean_Ar[,2],col=color_,pch=4)
ellipse(mean_Ar[1,], S[[1]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[2,], S[[2]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[3,], S[[3]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)

#-----evaluate the initial value of the log likelihood-------

likelihood=0;

Nk =matrix(nrow=k,ncol=1)
for(t in 1:k){
	Nk[t,1] =  length(which(rnk_matrix==t));
}

#evaluate the likelihood using the formula
likelihood=0;
for(i in 1:N){
	sum1=0;
	for(t in 1:k){

	b=S[t];
 	b = matrix(unlist(b),ncol = 2, byrow = TRUE);
sum1=sum1 +pk[t,]*(  ((2*pi)^(-2/2)) )*(  (det(b)) ^(-0.5) )*exp(-0.5*t(as.vector(dataset[i,]-mean_Ar[t,]))%*%(solve(b))%*%(as.vector(dataset[i,]-mean_Ar[t,])));
	}
	likelihood = likelihood +log(sum1);
}

print(likelihood)

#----------------(2)----------------------------E step. Evaluate the responsibilities using the current parameter values-------

flag=0;
#rg is the responsibility gamma
rg=matrix(nrow=N,ncol=k)

lh<-c(likelihood)
if(likelihood>0 ){
new_likelihood =likelihood-10000000;
}else{
new_likelihood =likelihood+10000000000
}

while(abs(new_likelihood-likelihood)>1){
if(flag==0){
flag=1;
new_likelihood =likelihood;
}

likelihood=new_likelihood;

for(i in 1:N){
for(t in 1:k){
		sum1=0;

		for(j in 1:k){

			b=S[[j]];
 			b = matrix(unlist(b),ncol=2, byrow=TRUE);
			a=pk[j,1]*dmvnorm(dataset[i,], mean_Ar[j,],b);
			sum1 = sum1 + a;
		}

		b=S[[t]];
 		b = matrix(unlist(b),ncol = 2, byrow = TRUE);
	 a=pk[t,]*dmvnorm(dataset[i,], mean_Ar[t,],b);
	rg[i,t]=a/sum1;
	}
}

#----------------(3)----------M step. Re-estimate the parameters using the current responsibilities------------------------------------

#find new mean
for(t in 1:k){
	sum1=c(0,0);
	for(i in 1:N){
		sum1= sum1+rg[i,t]*dataset[i,]
	}
	mean_Ar[t,]= sum1/Nk[t,1]
}

#find new Nk
for(j in 1:k){
Nk[j,1]=0;
for(i in 1:N){
	Nk[j,1] =  Nk[j,1] + rg[i,j]
}
}

#find new covariance matrix
for(t in 1:k){
	sum1=matrix(c(0,0,0,0),nrow=2,ncol=2);
	for(i in 1:N){
		sum1= sum1+rg[i,t]*(dataset[i,]- mean_Ar[t,])%*%t(dataset[i,]- mean_Ar[t,])
	}
	S[[t]]= sum1/Nk[t,1]
}

#find new mixture coefficient
for(t in 1:k){
pk[t,]=Nk[t,1]/N;
}

#(4)-------------------------Evaluate the log likelihood--------------

#evaluate the likelihood using the formula
new_likelihood=0;
for(i in 1:N){
sum1=0;
	for(t in 1:k){

	b=S[t];
 	b = matrix(unlist(b),ncol = 2, byrow = TRUE);
sum1=sum1 +pk[t,]*(  (  (2*pi)^(-2/2)))* (  (det(b)) ^(-0.5) )*exp(-0.5*t(as.vector(dataset[i,]-mean_Ar[t,]))%*%(solve(b))%*%(as.vector(dataset[i,]-mean_Ar[t,])));
	}
	new_likelihood = new_likelihood +log(sum1);
}

print(new_likelihood)
lh= c(lh,new_likelihood)

#-----------------plots--------------------------------------------

#---------------------plot classes-----------------------------

plot(0,0,col="white",xlim=c(-3.2,3.2),ylim=c(-3.2,3.2),pch=20,panel.first = grid(),xlab="x",ylab="y",main=toString(likelihood))
for (i in 1:N){

color_=rgb(0.9,0,0,alpha=rg[i,1])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

color_=rgb(0,0.9,0,alpha=rg[i,2])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

color_=rgb(0,0,0.9,alpha=rg[i,3])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

}
color_=rgb(0,0,0,alpha=0.4)
points(mean_Ar[,1],mean_Ar[,2],col=color_,pch=4)

ellipse(mean_Ar[1,], S[[1]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[2,], S[[2]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[3,], S[[3]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
}

#plot one-standard deviation
#---------------end of while------if there is convergence in likelihood stop

dev.off()

print(mean_Ar)
print(S)
print(pk)


source("data_Poisson.r")

library(npowerPrioR)

po.data <- list(
  N0 = N_0,
  y0 = y_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = NA
)
###
get_l_a0_poisson <- function(y0, n0, alpha0, beta0, a_0){
  logPprime <- sum(lfactorial(y0))
  S <- sum(y0)
  ans <- -a_0 * logPprime + lgamma(a_0 * S + alpha0) - (a_0 * S + alpha0)* log(a_0 *n0 + beta0) + (alpha0*log(beta0) - lgamma(alpha0))
  return(ans)
}
############
l_a0 <- function(x) {
  get_l_a0_poisson(
    y0 = po.data$y0,
    n0 = po.data$N0,
    alpha0 = po.data$alpha0,
    beta0 = po.data$beta0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
###
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

analytical_l_p <- function(x){
  logPprime <- sum(lfactorial(y_0))
  S <- sum(y_0)
  tt <- alpha_0 + S*x
  gg <- beta_0 + N_0 * x
  result <- -logPprime -N_0 *tt/gg - S*log(gg) + S * digamma(tt)
  return(result)
}
####################
J <- 20
maxA <- 1

adaptive.ca0.estimates <- read.csv(paste("../../data/constant_data/Poisson_logCA0_adaptive_J=", J, ".csv", sep = ""))

curve(l_a0_p, 0, maxA, lwd = 2, lty = 2, col = 2,  ylab = "", xlab = expression(a[0]), ylim = c(-200, 200))
abline(h = 0 , lwd = 2 , lty = 3)
curve(l_a0, 0, maxA, lwd = 2, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0)
curve(l_a0_pp, 0, maxA, lwd = 2, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, col = 3)
legend(x = "bottomright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"), col = 1:3, lwd = 2, bty = 'n')
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc, col = 2)

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

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

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

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

true.lca0s <- l_a0(pred_a0s)

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

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

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

### Exporting

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

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

library(ggplot2)

dev_plot <- ggplot(data = forplot_ca0, aes(x = a0, y = dev, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  scale_x_continuous(expression(a[0])) +
  theme_bw(base_size = 16)
dev_plot

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

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


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

# https://cran.r-project.org/web/packages/earlyR/earlyR.pdf
## example: onsets on days 1, 5, 6 and 12; estimation on day 24

# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/
weibull_mean = 6.4
weibull_sd = 2.3

e = exp(1)
r0=3.765201
incubation_period = 5
infection_rate = r0/incubation_period
t = 0:65
n0=1
e = exp(1)
n_t = n0*e^(infection_rate*t)
par(mfrow = c(1,1))
plot(t, n_t)

n_t2 = 0.007900 * r0^(t/incubation_period)
plot(n_t2, n_t)

##### pull in data ####
johns_hopkins_cases = read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv') %>%
  pivot_longer(cols = matches('^([0-9])'), names_to = 'date', values_to = 'cases')

names(johns_hopkins_cases) = names(johns_hopkins_cases) %>% tolower() %>% str_replace('[\\/]', '_')

us_jh_cases = filter(johns_hopkins_cases, country_region == 'US') %>%
  mutate(date = as.Date(date, format = '%m/%d/%y')) %>%
  arrange(date) %>%
  mutate(
    lag_cases = lag(cases, 1),
    new_cases = cases - lag_cases,
    new_cases = ifelse(is.na(new_cases), 1, new_cases),
    t = as.numeric(date - min(date))
  ) %>%
  filter(
    date <= as.Date('2020-03-26')
  )

# fit a simple exponnetial model using non-linear least squares
exponential_model_long_incubation = nls(cases ~  case_networks * r0^(t/6.4), data = us_jh_cases,
                               start = list(case_networks = 1, r0 = 2.5))
summary(exponential_model_long_incubation)

exponential_model_short_incubation = nls(cases ~  case_networks * r0^(t/5), data = us_jh_cases,
                                       start = list(case_networks = 1, r0 = 2.5))
summary(exponential_model_short_incubation)

mGT_weibull <- generation.time("weibull", c(6.4, 2.3))
mGT_gamma <- generation.time("gamma", c(5, 1.5))

par(mfrow = c(2, 1))
plot(mGT_weibull$time, mGT_weibull$GT)
lines(mGT_weibull$time, mGT_weibull$GT)
plot(mGT_gamma$time, mGT_gamma$GT)
lines(mGT_gamma$time, mGT_gamma$GT)

est.R0.EG(us_jh_cases$new_cases, mGT_weibull, begin=as.integer(1), end=as.integer(length(us_jh_cases$new_cases)))
est.R0.EG(us_jh_cases$new_cases, mGT_gamma, begin=as.integer(1), end=as.integer(length(us_jh_cases$new_cases)))

# https://web.stanford.edu/~jhj1/teachingdocs/Jones-Epidemics050308.pdf
# λ(t) = λ(0)e^(Λt)
# Λ = ν(R0 − 1)

# Formula: cases ~ case_networks * r0^(t/6.4)
#
# Parameters:
#   Estimate Std. Error t value Pr(>|t|)
# case_networks  9.14908    2.09934   4.358 4.17e-05 ***
#   r0             2.48856    0.05072  49.063  < 2e-16 ***
#   ---
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Residual standard error: 8936 on 74 degrees of freedom
#
# Number of iterations to convergence: 9
# Achieved convergence tolerance: 7.431e-06

# Formula: cases ~ case_networks * r0^(t/5)
#
# Parameters:
#   Estimate Std. Error t value Pr(>|t|)
# case_networks 0.004309   0.001168   3.691 0.000474 ***
#   r0            3.729612   0.082046  45.457  < 2e-16 ***
#   ---
#   Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#
# Residual standard error: 887.8 on 62 degrees of freedom
#
# Number of iterations to convergence: 23
# Achieved convergence tolerance: 4.429e-06

# fit using existing R package, R0

# this is the generation time or incubation period
# https://annals.org/aim/fullarticle/2762808/incubation-period-coronavirus-disease-2019-covid-19-from-publicly-reported

# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/
# mGT <- generation.time("gamma", c(6.5, 2.6))

# Reproduction number estimate using  Exponential Growth  method.
# R :  3.836266[ 3.799067 , 3.873994 ]

### plot confirmed vs. predicted ###
us_jh_cases$simple_exp_prediction = predict(simple_exponential_model)
us_jh_cases_long = pivot_longer(us_jh_cases, cols = c('simple_exp_prediction', 'cases'))

ggplot(us_jh_cases_long, aes(date, value, colour = name)) +
  geom_line() +
  scale_colour_hue(name = 'Estimate', labels = c('cases' = 'Confirmed Cases', 'simple_exp_prediction' = 'Modeled Cases')) +
  scale_y_continuous(labels = comma) +
  labs(x = 'Date', y = 'Cases', title = 'Exponential Growth Model vs. Confirmed Cases')
ggsave('exp_growth_vs_cases.png', height = 6, width = 6, units = 'in', dpi = 600)

# get shape/scale for weibull distribution
fit_weibull = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  the_sd = abs(sd(the_dist) - 2.3)
  the_mean =  abs(mean(the_dist) - 6.4)
  return(
    the_sd * the_mean
  )
}
the_solution = optim(par = c(3, 7), fn = fit_weibull)
#
# > the_solution$par
# [1] 3.005484 7.201339
the_weibull = rweibull(1000, the_solution$par[1], the_solution$par[2])
#
# r0_dist = map_dbl(the_weibull, function(gen_time){
#   return_val = NA
#   tryCatch({
#     simple_exponential_model = nls(cases ~  case_networks * r0^(t/gen_time), data = us_jh_cases,
#                                    start = list(case_networks = 1, r0 = 2.5))
#
#     return_val = coef(simple_exponential_model)[2]
#   }, error = function(e){
#     return(return_val)
#   })
#
#   return(return_val)
# })
summary(r0_dist)

cumulative_dist = tibble(
  time = mGT$time,
  proportion = mGT$GT,
  cum_prop = cumsum(proportion)
)

?SIR

# covid
parameters <- c(beta = 2.5/5, gamma = 1/5)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

covid_sir <- SIR(pars = parameters, init = initials, time = 0:180)

# flu
parameters <- c(beta = 1.3/5, gamma = 1/5)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

# Solve and plot.
flu_sir <- SIR(pars = parameters, init = initials, time = 0:180)
# PlotMods(sir)

distancing_effect = 0.6

comb_sirs = tibble(
  time = covid_sir$time,
  covid_s = covid_sir$results$S * 15e6,
  new_cases = round(lag(covid_s, 1) - covid_s),
  covid_i = covid_sir$results$I,
  flu_i = flu_sir$results$I
) %>%
  mutate(
    new_cases = ifelse(is.na(new_cases), 0, new_cases),
    deaths = rbinom(length(comb_sirs$new_cases), comb_sirs$new_cases, prob = 0.004)
  )

comb_sirs$deaths
sum(comb_sirs$new_cases, na.rm = T) / 60e6
sum(comb_sirs$deaths, na.rm = T)

filter(comb_sirs, time <= 42) %>% pull(deaths) %>% sum(na.rm=T)

ggplot(comb_sirs, aes(time, deaths)) +
  geom_point()

sum(comb_sirs$covid_i * 19e6)

sum(comb_sirs$flu_deaths)
sum(comb_sirs$covid_deaths)

ggplot(comb_sirs, aes(time)) +
  geom_line(aes(y = covid_i)) +
  geom_line(aes(y = flu_i))
sum(comb_sirs$covid_i)

# http://rstudio-pubs-static.s3.amazonaws.com/6852_c59c5a2e8ea3456abbeb017185de603e.html

# simulate proportion of deaths
# x1 = 1:(30*6)
#
# z = 0.15 + 0.015*x1
# pr = 1/(1+exp(-z))         # pass through an inv-logit function
# y = rbinom(length(x1),1,pr)      # bernoulli response variable
#
# #now feed it to glm:
# df = data.frame(y=y,x1=x1)
# mod = glm( y~x1,data=df,family="binomial")
#
# plot(x1, predict(mod, type = 'response'))
# summary(pr)
#
#


# 4. faza: Analiza podatkov

#############################################################
#REGRESIJSKA PREMICA ZA ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH V NASLEDNJIH LETIH

grup <- group_by(umrli, Leto)
umrli_slo <- summarise(grup, Stevilo=(sum(Umrli, na.rm = TRUE)))
umrli_slo <- transform(umrli_slo, Stevilo = (Stevilo / 12))
umrli_slo$Stevilo <- round(umrli_slo$Stevilo, digits=2)
prileg <- lm(data = umrli_slo, Stevilo ~ Leto )
m <- data_frame(Leto=seq(2018,2022,1))
napoved <- mutate(m, Stevilo=predict(prileg,m))
napoved$Stevilo <- round(napoved$Stevilo, digits = 2)

graf_regresija_umrli <- ggplot(umrli_slo, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Napoved števila smrti v prometu v naslednjih letih', y="Stevilo")

# REGRESIJSKA PREMICA ZA ŠTEVILO OSEBNIH AVTOMOBILOV NA 1000 PREBIVALCEV V PRIHODNOSTI
avti <- group_by(avtomobili,Leto)
avti1 <- summarise(avti, Stevilo=sum(Avtomobili, na.rm=TRUE))
avti_regije <- transform(avti1, Stevilo = Stevilo / 12)
avti_regije$Stevilo <- round(avti_regije$Stevilo, digits=2)
prileg <- lm(data = avti_regije, Stevilo ~ Leto )
napoved_avti <- mutate(m, Stevilo=predict(prileg, m))

graf_regresija_avti <- ggplot(avti_regije, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved_avti, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Napoved števila osebnih avtomobilov na 1000 prebivalcev v prometu v naslednjih letih', y="Stevilo")

##################################################################################
# CLUSTER REGIJ ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH

# umrli
grp <- group_by(umrli, Regija)
umrli_sum <- summarise(grp, vsote=sum(Umrli, na.rm = TRUE))

umrli_e <- dcast(umrli, Regija~Leto, value.var = 'Umrli' )
umrli_e <- left_join(umrli_e, umrli_sum, by = 'Regija')
umrli_e <- umrli_e[order(umrli_e$vsote, decreasing = FALSE),]
umrli_b <- umrli_e[,-19]
umrli_b <- umrli_b[,-1]

n <- 5
fit <- hclust(dist(scale(umrli_b)))
skupine4 <- cutree(fit, n)

cluster4 <- mutate(umrli_e, skupine4)
cluster4 <- cluster4[,-2:-19]
colnames(cluster4) <- c("Regija", "Umrli")
# zemljevid

regije <- unique(zemljevid$NAME_1)
regije <- as.data.frame(regije, stringsAsFactors=FALSE)
names(regije) <- "Regija"
skupaj <- left_join(regije, cluster4, by="Regija")

zemljevid_cluster_umrli <- ggplot() + geom_polygon(data=left_join(zemljevid, skupaj, by=c("NAME_1"="Regija")),
                                              aes(x=long, y=lat, group=group,
                                                  fill=factor(Umrli))) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  guides(fill=guide_colorbar(title="Skupine")) +
  ggtitle('Razvrstitev regij v skupine glede na število umrlih v cestnoprometnih nesrečah') +
  labs(x = " ") +
  labs(y = " ") +
  scale_fill_brewer(palette="YlOrRd", na.value = "#e0e0d1")

###################################################################################
# SHINY

graf.regije <- function(regija){
  ggplot(umrli %>% filter(Regija %in% regija)) + aes(x=Leto, y=Umrli, group=Regija, color=Regija) +
    geom_line() + geom_point()+ xlab("Leto") + ylab("Število umrlih") +
    theme(axis.text.x = element_text(angle = 90, vjust = 0.3, hjust=1))
}

graf_avto <- function(cifra) {
  ggplot(avtomobili %>% filter(Leto==cifra), aes(x=Regija, y=Avtomobili, fill=factor(Regija))) +
    ylim(0, 650) + geom_bar(stat = "identity") +
    xlab("Regija") + ylab("Število avtomobilov") +
    theme(axis.text.x = element_text(angle = 90, size = 8)) +
    labs(fill='Regija')

}

#==================================================================================


y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500

alpha=0.05
tstar=qt(1-alpha/2,df=25)
MSError=0.0153
LSD=tstar*sqrt((2*MSError)/6)
print(LSD)

#  the 95% confidence interval for y3bar-y1bar
left_i=(y3bar-y1bar)-LSD
right_i=(y3bar-y1bar)+LSD
print("Confidence interval is")
print(left_i)
print(right_i)


alpha_beta <- function(twr, twrbench,
                       plot=FALSE, xlabel=NULL, ylabel=NULL, main=NULL, range=NULL) {

    ##-----------------------------------------------------------------------------
    ## pull label from the name of the vector if not specified otherwise
    if (is.null(xlabel)) xlabel   <- deparse(substitute(twrbench))
    if (is.null(ylabel)) ylabel   <- deparse(substitute(twr))

    ##-----------------------------------------------------------------------------
    ## fit return against benchmark and extract beta as slope and alpha as intercept
    if (isFALSE(plot)) {
         ## perform fit to find slope and intercept but do not make plot
         out <- lm(twr ~ twrbench)
         beta  <- out$coefficients[[2]]
         alpha <- out$coefficients[[1]]
    } else {
         out <- plotfit(xx = twrbench, yy = twr, xlab=xlabel, ylab=ylabel, main=main,
                        xlimspec = range, ylimspec = range)
         beta  <- out$fits$slope
         alpha <- out$fits$intercept
    }

    ## alternate method to find beta
    ## beta <- cov(twr, twrbench) / var(twrbench)

    return(list(alpha=alpha, beta=beta))
}

## out <- equityget(c('SPY', 'AAPL'), period='months')
## extract last 5 years of monthly data
## AAPL <- as.numeric( xts::last(out$twr$AAPL, n=12*5) )
## SPY  <- as.numeric( xts::last(out$twr$SPY,  n=12*5) )
## alpha_beta(AAPL, SPY)
## alpha_beta(AAPL, SPY, plot=TRUE)


#########################################
# A toy example of Gibbs sampling
# author: Alberto Lumbreras
#########################################
library(mvtnorm)
library(coda)

# Parameters of a multivarite gaussian
mu1 <- 0
mu2 <- 0
cov12 <- 0.5 # same than cov21

# Plot the target distribution
dugly <- function(xy) {
  x <- xy[1]
  y <- xy[2]
  covariance <- matrix(c(1, cov12, cov12, 1), nrow=2)
  mvtnorm::dmvnorm(c(x,y), mean = c(mu1,mu2), sigma=covariance)
}
x <- seq(-3, 3, length.out=100)
y <- seq(-3, 3, length.out=100)
z <- matrix(NA, nrow=100, ncol=100)
i <- 1
for (n in 1:length(x)){
  for(m in 1:length(y)){
    z[n,m] <- dugly(c(x[n],y[m]))
    i <- i+1
  }
}
contour(x,y,z)
title("Gibbs sampling")

# Gibbs sampler
nsamples <-1000
samples <- matrix(NA,nsamples, 2)
samples[1,] <-c(0,0) # init
for(i in 2:nsamples){
  # Sample x1 given last x2
  samples[i,1] <- rnorm(1, mu1 + cov12*(samples[i-1,2]-mu2), sqrt(1-cov12^2)) # easy!
  # Sample x2 given last x1
  samples[i,2] <- rnorm(1, mu2 + cov12*(samples[i,1]-mu1), sqrt(1-cov12^2)) # easy!
}

# Plot samples showing the unidimensional steps at each iteration
steps.x1 <- rep(samples[,1], each=2)
steps.x2 <- rep(samples[,2], each=2)
lines(steps.x1[1:(length(steps.x1)-1)], steps.x2[2:(length(steps.x2))], col="green")
lines(samples, col='yellow')
points(samples, col='red', pch=19, cex=0.5)

# Check the MCMC traces
plot(mcmc(samples))


# Example : 2   Chapter : 6.6     Page No: 356
# Similar matrices  with repeated eigen values
A<-matrix(c(0,0,1,0),ncol=2)
Aev<-eigen(A)$values
A1<-matrix(c(1,1,-1,-1),ncol=2)
A1ev<-round(eigen(A1)$values)
print("Both th egiven matrices are similar because their eigen values are same")
print(Aev)
print(A1ev)
#The  answer may slightly vary due to  rounding off values


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.

 library(graphics)
 library(splines)

 matrx = matrix(cbind(1,.99, .99,1),nrow=2)

 cholsky = t(chol(matrx))

 nvars = dim(cholsky)[1]

 numobs = 1000

 set.seed(1)

 random_normal = matrix(rnorm(nvars*numobs,10,1), nrow=nvars, ncol=numobs)

 X = cholsky %*% random_normal

 newX = t(X)

 raw = as.data.frame(newX)

 head(raw)

 raw_original = as.data.frame(t(random_normal))

 names(raw) = c("response","predictor1")

 raw$predictor1_3 = raw$predictor1^3

 head(raw$predictor1_3)

 raw$predictor1_2 = raw$predictor1^2

 head(raw$predictor1_2)

 fit = lm(raw$response ~ raw$predictor1_3)

 fit

 plot(raw$response ~ raw$predictor1_3, pch=16, cex=.4, xlab="Predictor", ylab="Response", col ="red", main="Simulated Data with Slight Curve")

 abline(fit)

 x_axis <- with(cars, speed)

 y_axis <- with(cars, dist)

 eval_length = 50

 fit_loess <- loess.smooth(x_axis, y_axis, evaluation = eval_length, family="gaussian", span=.75, degree=1)

 fit_loess

 fit_loess_2 <- loess(y_axis ~ x_axis, family="gaussian", span=.75, degree=1)

 fit_loess_2

 new_x_axis = seq(min(x_axis),max(x_axis), length.out=eval_length)

 new_x_axis

 conf_int = cbind(
     predict(fit_loess_2, data.frame(x=new_x_axis)),
     predict(fit_loess_2, data.frame(x=new_x_axis))+
         predict(fit_loess_2, data.frame(x=new_x_axis), se=TRUE)$se.fit*qnorm(1-.05/2),
     predict(fit_loess_2, data.frame(x=new_x_axis))-
         predict(fit_loess_2, data.frame(x=new_x_axis), se=TRUE)$se.fit*qnorm(1-.05/2)
 )

 fit_lm = lm(y_axis ~ x_axis)

 fit_lm

 fit_poly = lm(y_axis ~ poly(x_axis,3) )

 fit_poly

 fit_nat_spline = lm(y_axis ~ ns(x_axis, 3) )

 fit_nat_spline

 fit_smth_spline = smooth.spline(y_axis ~ x_axis, nknots=15)

 fit_smth_spline

 plot(x_axis, y_axis, xlim=c(min(x_axis),max(x_axis)), ylim=c(min(y_axis),max(y_axis)), pch=16, cex=.5, ylab = "Stopping Distance (feet)", xlab= "Speed (MPH)", main="Comparison of Models", sub="Splines")

 matplot(new_x_axis, conf_int, lty = c(1,2,2), col=c(1,2,2), type = "l", add=T)

 lines(new_x_axis, predict(fit_lm, data.frame(x=new_x_axis)), col="red", lty=3)

 lines(new_x_axis, predict(fit_poly, data.frame(x=new_x_axis)), col="blue", lty=4)

 lines(new_x_axis, predict(fit_nat_spline, data.frame(x=new_x_axis)), col="green", lty=5)

 lines(fit_smth_spline, col="dark grey", lty=6)

 lines(ksmooth(x_axis, y_axis, "normal", bandwidth = 5), col = 'purple', lty=7)


#The naïve Bayes classifier is one of the simplest approaches to the
#classification task that is still capable of providing reasonable accuracy

#It is superior for certain specific application domains, with text classification
#being the most prominent example. Its simplicity—conceptual, implementational, and
#computational—makes it easy and inexpensive to try besides or before more
#sophisticated classifiers.

library(dmr.stats)
library(dmr.util)
data(weather, package="dmr.data")
data(weatherc, package="dmr.data")

## calculate the posterior probability given prior and inverse probabilities
bayes.rule <- function(prior, inv)
{
  prior*inv/sum(prior*inv)
}

# posterior probabilities
bayes.rule(c(0.2, 0.3, 0.5), c(0.9, 0.9, 0.5))

  # let P(burglery)=0.001,
  # P(alarm|burglery)=0.95,
  # P(alarm|not burglery)=0.005
  # calculate P(burglery|alarm)
bayes.rule(c(0.001, 0.999), c(0.95, 0.005))[1]


#!/usr/bin/env Rscript

############################################################
### Least squares estimation
### y = beta0 + beta1*x --> Y = (1, X)beta
### Y = XB ---> X 不一定可逆
### t(X)Y = t(X)XB -->  inverse(t(X)X)t(X)Y = B
############################################################

X = cbind(rep(1, 5), c(1.00, 2.00, 3.00, 4.00, 5.00))
Y = c(3.70, 4.20, 4.90, 5.70, 6.00)

beta.hat = solve(t(X) %*% X) %*% t(X) %*% Y


##' @title
##' Cohen’s Kappa
##'
##' @description
##'
##' \code{mtr_cohen_kappa} computes Kappa statistic which measures inter-rater
##' agreement for categorical items.
##'
##' The form of Kappa statistic is: \eqn{Kappa = (O - E) / (1 - E)} where O is
##' the observed accuracy and E is the expected accuracy based on the marginal
##' total of the confusion matrix. The statistic can take on values between -1
##' and 1; a value of 0 means there is no agreement between the actual and the
##' predicted, while a value of 1 indicates perfect concordance of the model
##' prediction and the observed classes.
##'
##' @references
##'
##' \itemize{
##'   \item Max Kuhn and Kjell Johnson, Applied Predictive Modeling (New York: Springer-Verlag, 2013)
##'   \item \href{https://stats.stackexchange.com/questions/82162/cohens-kappa-in-plain-english}{"Classification - Cohen’s Kappa in Plain English, Cross Validated"}
##' }
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @include helper-functions.r
##' @export
##' @examples
##'
##' act <- c(1, 0, 1, 0, 1)
##' pred <- c(0.1, 0.9, 0.3, 0.5, 0.2)
##' mtr_cohen_kappa(act, pred)
##'
##'
##' set.seed(2093)
##' pred <- runif(1000)
##' act <- round(pred)
##' pred[sample(1000, 300)] <- runif(300) # noises
##' mtr_cohen_kappa(act, pred)
##'
mtr_cohen_kappa <- function(actual, predicted, cutoff = 0.5) {

    check_equal_length(actual, predicted)
    check_cutoff_range(cutoff)
    check_binary(actual)

    conf_mat <- mtr_confusion_matrix(actual, predicted, cutoff = cutoff)
    n <- sum(conf_mat)

    observed_accuracy <- mtr_accuracy(actual, predicted, cutoff = cutoff)

    expected_accuracy <- sum((rowSums(conf_mat) * colSums(conf_mat)) / n) / n

    kappa <- (observed_accuracy - expected_accuracy) / (1 - expected_accuracy)
    kappa
}


# ......................................................................................
# ..................Exercise 1 - Brief introduction to R, Combinatorics.................
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

# First we will go through some basics of R.
#
#  Brief introduction to R ####
#

# simple arithmetic operations
2+4
5/2

# BEWARE of brackets! Only round ones are used for counting!
# Square and compound have a different role in R.!
(((10+2)*(340-33))-2)/3

# combination number, factorials
choose(10,2)
factorial(4)

# data types ->numeric, character, logical,(complex)
# the class function determines the type of the object
a=2+3
class(a)

b="some text"
class(b)

c=(1>3)
class(c)

d=3+1i
class(d)

# * data structures in R ####
#
# - vector (column vector)
#
# - factor (special case of vector)
#
# - matrix (matrix with dimensions n x m)
#
# - data.frame (data frame with columns representing diferent types of informations and
# rows representing single records)

# vector definition
a = c(3,4,6,7)
a <- c(3,4,6,7)
a[2]

# other options
rep(1,4) # creates a vector with four ones

seq(1,10,2) # sequence from 1 to 10 with step 2

1:10  # sequence from 1 to 10 with step 1

b=c("A","B","C","D")
b

class(b)

# redefining an object to another type - eg as.vector, as.matrix, as.factor,...
b=as.factor(b)
b

# working with vectors - merging by columns/rows
cbind(a,b)

rbind(a,b)

c(a,b)

# matrix definition
A=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3)
B=matrix(c(3,4,6,7,3,2),nrow=2,ncol=3,byrow=TRUE)
C=matrix(c(3,4,6,7,3,2),nrow=3,ncol=2)

B

B[1,3]

A[1,]

A[,2:3]

# diagonal matrix
diag(4)

diag(4,2)

# matrix operations - pay attention to matrix multiplication -> %*%
A+B

A-B

A*B

A%*%C


# Utility for returning all relevant classification accuracy statistics

AccuracyStats = function(predicted, observed, relative=FALSE)
{
    RMSE = sqrt(mean(unlist(predicted - observed)^2))
    MAE = mean(abs(unlist(predicted - observed)))
    ME = mean(unlist(predicted - observed))
    RMSEAdj = sqrt(mean(unlist(predicted - observed - ME)^2))
    Result = data.frame(RMSE, MAE, ME, RMSEAdj)
    if (relative)
        Result = Result/mean(unlist(observed))
    return(Result)
}

AccuracyStatTable = function(predicted, observed, relative=FALSE)
{
    Result = AccuracyStats(predicted, observed, relative=relative)
    row.names(Result) = "Overall"
    for (i in 1:ncol(observed))
    {
        RMSE = sqrt(mean(unlist(predicted[,i] - observed[,i])^2))
        MAE = mean(abs(unlist(predicted[,i] - observed[,i])))
        ME = mean(unlist(predicted[,i] - observed[,i]))
        ColResult = data.frame(RMSE, MAE, ME)
        if (relative)
            ColResult = ColResult/mean(unlist(observed[,i]))
        Result = rbind(Result, ColResult)
        row.names(Result)[i+1] = names(observed[i])
    }
    return(Result)
}

# Simply return a table of differences; used for ANOVA
CalcErrors = function(predicted, observed, ...)
{
    SE = unlist(predicted - observed)^2
    AE = abs(unlist(predicted - observed))
    return(data.frame(AE, SE, ...))
}


# Calculate slope and aspect of a digital terrain model

slope<-function(r, res=1){
  # returns a slope surface of elevation raster r of resolution res,
  # according to Burrough et McDonnell 2000, p. 191
  newr<-matrix(0, nrow=nrow(r), ncol=ncol(r))
  h<-nrow(r)
  w<-ncol(r)
  for(i in 2:(h-1)){
    for(j in 2:(w-1)){
      newr[i,j]<-sqrt( ((r[i+1,j]-r[i-1,j])/(2*res))^2 + ((r[i,j+1]-r[i,j-1])/(2*res))^2 )
    }
  }
  newr[1,]<-0; newr[h,]<-0; newr[,1]<-0; newr[,w]<-0; #adjust border
  return(newr)
}

# parameters
input_terrain <- 'c:/temp/terrain.txt'

# read data
m<-as.matrix(read.table(input_terrain))

# calculate slope
s<-slope(m)

# plot results
image(m, main="elevation")
image(s, main="slope")


## Strategy: For a bunch of Ns, compute the z_star by achieving desired alpha, then
## compute what beta would be for that N using the acquired z_star.
## Pick the smallest N at which beta crosses the desired value

# Inputs:
#   The desired alpha for a two-tailed test
# Returns: The z-critical value
get_z_star = function(alpha) {
    return(-qnorm(alpha / 2))
}

# Inputs:
#   z-star: The z-critical value
#   s: The standard error of the metric at N=1
#   d_min: The practical significance level
#   N: The sample size of each group of the experiment
# Returns: The beta value of the two-tailed test
get_beta = function(z_star, s, d_min, N) {
    SE = s /  sqrt(N)
    return(pnorm(z_star * SE, mean=d_min, sd=SE))
}

# Inputs:
#   s: The standard error of the metric with N=1 in each group
#   d_min: The practical significance level
#   Ns: The sample sizes to try
#   alpha: The desired alpha level of the test
#   beta: The desired beta level of the test
# Returns: The smallest N out of the given Ns that will achieve the desired
#          beta. There should be at least N samples in each group of the experiment.
#          If none of the given Ns will work, returns -1. N is the number of
#          samples in each group.

required_size = function(s, d_min, Ns=1:20000, alpha=0.05, beta=0.2) {
    for (N in Ns) {
        if (get_beta(get_z_star(alpha), s, d_min, N) <= beta) {
            return(N)
        }
    }

    return(-1)
}

# Example analytic usage
# This is the example from Lesson 1, for which the online calculate gave 3,623
# samples in each group

# s is the pooled standard error for N=1 in each group,
# which is sqrt(p*(1-p)*(1/1 + 1/1))
required_size(s=sqrt(0.1*0.9*2), d_min=0.02)

# Sizing: Example
# Cookie-based diversion
# Since the standard error is proportional to 1/sqrt(N), s, or
# the standard error for N=1, is equal to the mesaured standard error with 5000
# in each group times sqrt(5000)
required_size(s=0.00515*sqrt(5000), d_min=0.02)
# User-id-based diversion
required_size(s=0.0119*sqrt(5000), d_min=0.02)

# Sizing: Quiz
# Original size
required_size(s=0.0628*sqrt(1000), d_min=0.01, Ns=seq(10, 500000, 100))
# Size with event-based diversion
required_size(s=0.0209*sqrt(1000), d_min=0.01, Ns=seq(10, 500000, 100))
# Size with event-based diversion and English-only traffic
required_size(s=0.0188*sqrt(1000), d_min=0.015)
# Size with cookie-based diversion, English-only traffic, and
# click-through-probability instead of click-through-rate
required_size(s=0.0445*sqrt(1000), d_min=0.015, Ns=seq(10, 500000, 100))


#' Check whether basis vectors are circuits
#'
#' A circuit is a vector with minimal support by inclusion and coprime (non-zero) entries. This function checks whether each column of a matrix U is a circuit of the solution set for y = Ax
#' @param A Configuration matrix with ncol(A) >= nrow(A)
#' @param U A matrix with columns comprising some basis for the integer lattice kernel of A
#' @return A logical vector of length ncol(U) indicating whether each column of U is a circuit
#' @export

is_circuit <- function(A,U){
	r <- nrow(U)
	nU <- ncol(U)
	circuit <- numeric(nU)
	for (i in 1:nU){
		supp <- (U[,i] != 0)
		Ai <- as.matrix(A[,supp])
		circuit[i] <- (1+qr(Ai)$rank)==nrow(Ai)
	}
	circuit
}


# Working with data visualization plots

# 1. Line Plots
library(gapminder)
library(dplyr)
library(ggplot2)

# Summarize the median gdpPercap by year, then save it as by_year
by_year <- gapminder %>%
                group_by(year) %>%
                summarize(medianGdpPercap = median(gdpPercap))

# Create a line plot showing the change in medianGdpPercap over time
ggplot(by_year, aes(x = year, y = medianGdpPercap)) +
    geom_line() +
    expand_limits(y = 0)

# Summarize the median gdpPercap by year & continent, save as by_year_continent
by_year_continent <- gapminder %>%
                        group_by(year, continent) %>%
                        summarize(medianGdpPercap = median(gdpPercap))

# Create a line plot showing the change in medianGdpPercap by continent over time
ggplot(by_year_continent, aes(x = year, y = medianGdpPercap, color = continent)) +
    geom_line() +
    expand_limits(y = 0)

# 2. Bar plots
# Summarize the median gdpPercap by continent in 1952
by_continent <- gapminder %>%
                    filter(year == 1952) %>%
                    group_by(continent) %>%
                    summarize(medianGdpPercap = median(gdpPercap))

# Create a bar plot showing medianGdp by continent
ggplot(by_continent, aes(x = continent, y = medianGdpPercap)) +
    geom_col()

# Filter for observations in the Oceania continent in 1952
oceania_1952 <- gapminder %>%
                    filter(continent == "Oceania", year == 1952)

# Create a bar plot of gdpPercap by country
ggplot(oceania_1952, aes(x = country, y = gdpPercap)) +
    geom_col()

# 3. Histograms
gapminder_1952 <- gapminder %>%
  filter(year == 1952) %>%
  mutate(pop_by_mil = pop / 1000000)

# Create a histogram of population (pop_by_mil). Only the x axis aesthetic is required. Can make alterations within the geom_histogram layer
ggplot(gapminder_1952, aes(x = pop_by_mil)) +
  geom_histogram(bins = 50)

# Filter data
gapminder_1952 <- gapminder %>%
  filter(year == 1952)

# Create a histogram of population (pop), with x on a log scale
ggplot(gapminder_1952, aes(x = pop)) +
  geom_histogram() +
  scale_x_log10()

# 4. Boxplot

# Create a boxplot comparing gdpPercap among continents
ggplot(gapminder_1952, aes(x = continent, y = gdpPercap)) +
  geom_boxplot() +
  scale_y_log10()

# Add a title to this graph: "Comparing GDP per capita across continents"
ggplot(gapminder_1952, aes(x = continent, y = gdpPercap)) +
  geom_boxplot() +
  scale_y_log10() +
  labs(title = "Comparing GDP per capita across continents")


###CHAPTER 5: BIAS VARIANCE TRADE-OFF
N <- 500
x <- seq(.09,.5,len=N)
f <- 2*sin(1/x)

y <- f + rnorm(N)
postscript("Plots/plot-05-01.ps")
plot(x,y,main="True f(x)=5 sin(1/x) and observations")
lines(x,f,type="l")
dev.off()

NN <- 5

postscript("Plots/plot-05-02.ps")
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N)
       ksmooth(x,y,kernel="box",bandwidth=.01)$y
     })

par(mfrow=c(2,2),mai=c(0,0,0,0),oma=c(1,1,1,1))
plot(x,f,type="l",lwd=1.5,ylim=range(c(f,as.vector(results))))
lines(x,results[,1],lty=4)

plot(x,f,ylim=range(results),type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N)
       ksmooth(x,y,kernel="box",bandwidth=.1)$y
     })

plot(x,f,type="l",lwd=1.5)
lines(x,results[,1],lty=4)

plot(x,f,type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
dev.off()


### CHALLENGER ###

# Get the data
library(ggplot2)
library(GGally)
library(dplyr)

data_1 = read.delim('challenger_data.txt')

ggplot(data_1, aes(T, I)) +
  geom_point(color = 'dark blue', alpha = .2) +
  xlab('Temperature') +
  ylab('Damage') +
  ggtitle('Challenger - temperature vs damage')

# Regression
model_1 = lm(I ~ T, data)

summary(model_1)

# Plot with reg line
ggplot(data_1, aes(T, I)) +
  geom_point(color = 'dark blue', alpha = .2) +
  xlab('Temperature') +
  ylab('Damage') +
  ggtitle('Challenger - temperature vs damage') +
  geom_line(aes(T, fitted(model_1)), color = 'red')

# Predict for 31 degrees
predict(model_1, data.frame(T = 31), interval = 'predict')

# Posterior prediction interval (same as frequentist)
pred_1 = predict(model_1, data.frame(T = 31))

k   = length(model_1$coefficients) - 1 # Subtract one to ignore intercept
SSE = sum(model_1$residuals**2)
n   = length(model_1$residuals)

resid_std_error = sqrt(SSE / (n-(1+k))) # Residual Standard Error

pred_1 - resid_std_error * qt(.975, model_1$df.residual) * sqrt(1 + 1/23)
# 10.82052 - 2.102*qt(.975,21)*sqrt(1+1/23+((31-mean(T))^2/22/var(T)))

# posterior probability that damage index is greater than zero
1-pt((0-10.82052)/(2.102*sqrt(1+1/23+((31-mean(T))^2/22/var(T)))),21)

### HEIGHT ###

# Get the data
data_2 = read.delim('http://www.randomservices.org/random/data/Galton.txt')

# Plot
data_2 %>% select(-c('Family')) %>% ggpairs(., lower = list(continuous = wrap("smooth", alpha = 0.3, size=0.1)))

# Regress
model_2 = lm(Height ~ Father + Mother + Gender, data_2)

summary(model_2)

### GOLFERS ###

# Get the data
data_3 = read.delim('http://www.stat.ufl.edu/~winner/data/pgalpga2008.dat', header = FALSE, sep = ' ')
data_3 = data_3[, c(4, 8, 15)]

colnames(data_3) <- c('dist', 'accuracy', 'gender')   # 1 = F, 2 = M

head(data_3)

data_3 %>% filter(gender == 1) %>% ggplot(., aes(dist, accuracy)) +
                                     geom_point(alpha = .5) + geom_smooth(method = 'lm') +
                                     ggtitle('Mean distance vs accuracy - Females')

data_3 %>% filter(gender == 2) %>% ggplot(., aes(dist, accuracy)) +
                                     geom_point(alpha = .5) + geom_smooth(method = 'lm') +
                                     ggtitle('Mean distance vs accuracy - Males')

# Fit a linear regression model to the female golfer data only with
# drive distance as the explanatory variable x and accuracy as the response variable y.
# Use the standard reference (non-informative) prior.

# Recall that in a linear regression, we are modeling E(y) = b0 + b1x.

# In this particular model, the intercept term is not interpretable,
# as we would not expect to see a 0-yard drive (but it is still necessary).
# Predictions should generally be made only within the range of the observed data.

# Report the posterior mean estimate of the slope parameter b relating drive distance to accuracy.
# Round your answer to two decimal places.

data_3_F = data_3 %>% filter(gender == 1)

model_3 = lm(accuracy ~ dist, data_3_F)

summary(model_3)

# Use the posterior mean estimates of the model coefficients to obtain a posterior predictive
# mean estimate of driving accuracy for a new female golfer whose average driving distance
# is x = 260 yards. Round your answer to one decimal place.

predict(model_3, data.frame(dist = 260), interval = 'predict')


volumes <- c(25, 45, 28, 79, 74, 61, 12, 68, 93, 39, 100)
media_aritmetica <- mean(volumes)

print(media_aritmetica)


library(deSolve)
library(ggplot2)
library(RColorBrewer)
library(pracma)

set.seed(106745)

## external files
##
stoc_sirs_file 	<- paste(getwd(), "../sir-functions", "StocSIRS.r", sep = "/")
smap_file 		<- paste(getwd(), "smap.r", sep = "/")
source(stoc_sirs_file)
source(smap_file)

## parameters
##
T 		<- 5*52
i_infec <- 10
steps 	<- 7
N 		<- 500
sigma 	<- 5

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

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

## get true trajectory
##
sdeout <- StocSIRS(true_init_cond, true_pars, T, steps)

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

# plot data and true states
g <- qplot(0:T, sdeout[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
		geom_point(aes(y = infec_counts)) +
		theme_bw()

print(g)
ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

## S-map parameters
##
E <- 14
theta <- 3
stepsAhead <- 52

## run S-map
##
predictions <- smap(infec_counts, E, theta, stepsAhead)

p <- qplot(0:(T+stepsAhead), c(infec_counts, rep(NA, stepsAhead)), geom = "line", xlab = "Time", ylab = "Infection count") +
		geom_line(aes(y = c(rep(NA, T+1), predictions)), linetype = "dotted") +
		theme_bw()

print(p)
ggsave(p, filename="smap-project.pdf", height=4, width=6.5)


# -----------------------
# App Title: t-test
# Author: Jimmy Wong
# -----------------------

#####################################################################################################################
#####################################################################################################################
## t-distribution shading area function
#####################################################################################################################
#####################################################################################################################

t.dist.area = function(tstat,tail,df)
{
  x = seq(-5,5,length.out=200)
  df = round(df, digits=3)

  if(tail=="right")
  {
    xmin=tstat
    xmax=5

    area = seq(xmin,xmax,length.out=200)
    dat = data.frame(x=area,ymin=0,ymax=dt(area,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat, mapping=aes(x=x, ymin=ymin, ymax=ymax), fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  } else if(tail=="left")
  {
    xmin=-5
    xmax=tstat

    area = seq(xmin,xmax,length.out=200)
    dat = data.frame(x=area,ymin=0,ymax=dt(area,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat, mapping=aes(x=x, ymin=ymin, ymax=ymax), fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  } else if(tail=="both")
  {
    xmin1=abs(tstat)
    xmax1=5
    area1 = seq(xmin1,xmax1,length.out=200)
    dat1 = data.frame(x=area1,ymin1=0,ymax1=dt(area1,df=df))

    xmin2=-5
    xmax2=-abs(tstat)
    area2 = seq(xmin2,xmax2,length.out=200)
    dat2 = data.frame(x=area2,ymin2=0,ymax2=dt(area2,df=df))

    graph = ggplot() + geom_line(data.frame(x=x, y=dt(x,df=df)), mapping=aes(x=x, y=y)) +
      geom_ribbon(data=dat1, mapping=aes(x=x, ymin=ymin1, ymax=ymax1),fill="navy") +
      geom_ribbon(data=dat2, mapping=aes(x=x, ymin=ymin2, ymax=ymax2),fill="navy") +
      ggtitle(paste("t-distribution with", df, "degrees of freedom")) +
      xlab("t-values") + ylab("Relative frequency") + theme_bw()
  }
  return(graph)
}

#####################################################################################################################
#####################################################################################################################
## Library and data sets
#####################################################################################################################
#####################################################################################################################

options(shiny.maxRequestSize=30*1024^2)
library(ggplot2)
library(shinyBS)
data(faithful)
data(mtcars)

#####################################################################################################################
#####################################################################################################################
## Shiny server
#####################################################################################################################
#####################################################################################################################

shinyServer(function(input, output) {
  #####################################################################################################################
  #####################################################################################################################
  ## Data Exploration Panel
  #####################################################################################################################
  #####################################################################################################################

  data = reactive({
    if(is.null(input$file) & !input$usedata)
    {
      return(NULL)
    } else if(!is.null(input$file) & !input$usedata)
    {
      file = read.csv(input$file$datapath, header=input$header, sep=input$sep, quote=input$quote)
      return(file)
    } else if(input$sampdat==1 & input$usedata)
    {
      return(data.frame(eruptions=faithful$eruptions))
    } else if(input$sampdat==2 & input$usedata)
    {
      mtcars$amcoded = rep(NA,length(mtcars$hp))
      mtcars$amcoded[which(mtcars$am==0)] = "automatic"
      mtcars$amcoded[which(mtcars$am==1)] = "manual"
      return(data.frame(transmission=mtcars$amcoded, horsepower=mtcars$hp))
    }
    })

  output$data.tab = renderDataTable({
    if(!input$usedata) data()
  })

  output$data.tab1 = renderDataTable({
    if(input$usedata) data()
  })

  output$datagraph = renderPlot({
    if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
    {
      dat=unlist(data())
      dat1=data.frame(x=as.numeric(as.character(dat)))

      if(input$usedata)
        lab = "Eruption times"
      else
        lab = paste(names(data())[1])

      ggplot(data=dat1) + geom_histogram(aes(x=x), fill="navy", alpha=.5) +
        xlab(lab) + ylab("Frequency") +
        ggtitle(paste("Histogram of",lab)) + theme_bw()
    } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      dat=data()
      dat1=data.frame(x=dat[[1]],y=dat[[2]])
      if(length(unique(dat1$x))>length(unique(dat1$y)))
      {
        dat1$x = as.numeric(as.character(dat1$x))
        ggplot(data=dat1) + geom_boxplot(aes(x=factor(y),y=x,fill=factor(y)),alpha=.5) +
          xlab(paste(names(dat)[2])) + ylab(paste(names(dat)[1])) + theme_bw() +
          ggtitle(paste("Boxplots of",paste(names(dat)[1]),"by",paste(names(dat)[2]))) +
          scale_fill_manual(name=paste(names(dat)[1]),values=c("seagreen2","gold2")) +
          theme(legend.position="bottom")
      } else
      {
        dat1$y = as.numeric(as.character(dat1$y))
        ggplot(data=dat1) + geom_boxplot(aes(x=factor(x),y=y,fill=factor(x)),alpha=.5) +
          xlab(paste(names(dat)[1])) + ylab(paste(names(dat)[2])) + theme_bw() +
          ggtitle(paste("Boxplots of",paste(names(dat)[2]),"by",paste(names(dat)[1]))) +
          scale_fill_manual(name=paste(names(dat)[2]),values=c("seagreen2","gold2")) +
          theme(legend.position="bottom")
      }
    } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      dat=data()
      dat1=data.frame(x=c(as.numeric(as.character(dat[[1]])),as.numeric(as.character(dat[[2]]))),
                       y=c(rep(names(dat)[1],length(dat[[1]])),rep(names(dat)[2],length(dat[[2]]))))
       ggplot(data=dat1) + geom_boxplot(aes(x=factor(y),y=x,fill=factor(y)),alpha=.5) +
        xlab("Explanatory variable") + ylab("Response variable") +
        scale_fill_manual(name="",values=c("seagreen2","gold2")) +
        ggtitle("Boxplots") + theme_bw() + theme(legend.position="bottom")
    }
  })

  output$summarystats = renderTable({
    if(input$displaystats & ((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata)))
    {
      vec = as.numeric(as.character(data()[[1]]))
      table = t(matrix(c((as.matrix(summary(vec)[1:6])),
                         round(sd(vec,na.rm=TRUE)))))

      if(input$usedata)
        rownames(table) = "Eruption times"
      else
        rownames(table) = names(data())[[1]]

      colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
      return(table)
    } else if(input$displaystats & ((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      dat=data()
      dat1=data.frame(x=dat[[1]],y=dat[[2]])
      if(length(unique(dat1$x)) > length(unique(dat1$y)))
      {
        dat1$y = factor(dat1$y)
        dat1$x = as.numeric(as.character(dat1$x))
        dat1 = dat1[which(complete.cases(dat1)),]
        sum = tapply(dat1$x,dat1$y,summary)
        table = data.frame(matrix(c(sum[[1]],sum[[2]]),nrow=2,ncol=6,byrow=TRUE))
        std = tapply(dat1$x,dat1$y,sd,na.rm=TRUE)
        table$sd[1] = round(std[1],digits=2)
        table$sd[2] = round(std[2],digits=2)
        table = as.matrix(table)
        colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
        rownames(table) = c(levels(dat1$y)[1],levels(dat1$y)[2])
        return(table)
      } else if(length(unique(dat1$x)) < length(unique(dat1$y)))
      {
        dat1$x = factor(dat1$x)
        dat1$y = as.numeric(as.character(dat1$y))
        dat1 = dat1[which(complete.cases(dat1)),]
        sum = tapply(dat1$y,dat1$x,summary)
        table = data.frame(matrix(c(sum[[1]],sum[[2]]),nrow=2,ncol=6,byrow=TRUE))
        std = tapply(dat1$y,dat1$x,sd)
        table$sd[1] = round(std[1],digits=2)
        table$sd[2] = round(std[2],digits=2)
        table = as.matrix(table)
        colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
        rownames(table) = c(levels(dat1$x)[1],levels(dat1$x)[2])
        return(table)
      }
    } else if(input$displaystats & ((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      dat = data()
      dat[,1] = as.numeric(as.character(dat[,1]))
      dat[,2] = as.numeric(as.character(dat[,2]))
      table = data.frame(t(as.matrix(apply(dat,2,summary)[-7,])))
      table$sd[1] = round(sd(dat[,1],na.rm=TRUE),digits=2)
      table$sd[2] = round(sd(dat[,2],na.rm=TRUE),digits=2)
      table = as.matrix(table)
      colnames(table) = c("Min","Q1","Median","Mean","Q3","Max","SD")
      return(table)
    }
  })

  #####################################################################################################################
  #####################################################################################################################
  ## T-test Panel
  #####################################################################################################################
  #####################################################################################################################

  output$info = renderUI({
    HTML(as.character(code("Click here for hypothesis test information.")))
  })

  output$onesample = renderUI({
    HTML(as.character(code("Click here for one-sample t-test information.")))
  })

  output$twosample = renderUI({
    HTML(as.character(code("Click here for two-sample t-test information.")))
  })

  output$hypo1 = renderUI({
    if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
    {
      if(input$alt1=="less than")
        HTML("Ho: μ =", input$null1,"
 Ha: μ <",input$null1)
      else if(input$alt1=="greater than")
        HTML("Ho: μ =", input$null1,"
 Ha: μ >",input$null1)
      else
        HTML("Ho: μ =", input$null1,"
 Ha: μ ≠",input$null1)
    }
  })

  output$hypo2 = renderUI({
    if((input$datformat!=1 & !input$usedata) | (input$sampdat!=1 & input$usedata))
    {
      if(input$alt2=="less than")
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 <",input$null2)
      else if(input$alt2=="greater than")
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 >",input$null2)
      else
        HTML("Ho: μ1-μ2 =",input$null2,
             "
 Ha: μ1-μ2 ≠",input$null2)
    }
  })

  mod = reactive({
    input$teststart
    isolate({
    if(input$teststart>0)
    {
      if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
      {
        if(input$alt1=="less than")
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="less",mu=input$null1,conf.level=1-input$alpha)
        else if(input$alt1=="greater than")
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="greater",mu=input$null1,conf.level=1-input$alpha)
        else
          mod = t.test(x=as.numeric(as.character(unlist(data()))),alternative="two.sided",mu=input$null1,conf.level=1-input$alpha)
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          if(input$alt2=="less than")
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="less",mu=input$null2,conf.level=1-input$alpha)
          else if(input$alt2=="greater than")
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="greater",mu=input$null2,conf.level=1-input$alpha)
          else
            mod = t.test(as.numeric(as.character(dat[[1]]))~dat[[2]],
                         alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
        } else
        {
          if(input$alt2=="less than")
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="less",mu=input$null2,conf.level=1-input$alpha)
          else if(input$alt2=="greater than")
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="greater",mu=input$null2,conf.level=1-input$alpha)
          else
            mod = t.test(as.numeric(as.character(dat[[2]]))~dat[[1]],
                         alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        if(input$alt2=="less than")
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="less",mu=input$null2,conf.level=1-input$alpha)
        else if(input$alt2=="greater than")
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="greater",mu=input$null2,conf.level=1-input$alpha)
        else
          mod = t.test(x=as.numeric(as.character(dat[[1]])),y=as.numeric(as.character(dat[[2]])),
                       alternative="two.sided",mu=input$null2,conf.level=1-input$alpha)
      }
    }
    })
  })

  output$est=renderUI({
    if(input$teststart>0 & input$showpoint & ((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata)))
    {
      HTML("x̅ =",round(mod()$estimate[1],2))
    } else if(input$teststart>0 & input$showpoint & ((input$datformat!=1 & !input$usedata) | (input$sampdat!=1 & input$usedata)))
    {
      HTML("x&#7731 =",round(mod()$estimate[1],2),"
 x&#7732 =",round(mod()$estimate[2],2),
           "
 x&#7731 - x&#7732 =",round(mod()$estimate[1]-mod()$estimate[2],2))
    }
  })

  output$test = renderTable({
    input$teststart
    isolate({
    if(input$teststart>0)
    {
      tab = matrix(c(mod()$parameter,mod()$statistic,mod()$p.value),nrow=1)
      colnames(tab) = c("df","t-statistic","p-value")
      rownames(tab) = "Values"
      tab
    }
    })
  })

  output$tdist = renderPlot({
    input$teststart
    isolate({
    if(input$alt1=="less than" | input$alt2=="less than")
    {
      tail="left"
    } else if(input$alt1=="greater than" | input$alt2=="greater than")
    {
      tail="right"
    } else if(input$alt1=="two-sided" | input$alt2=="two-sided")
    {
      tail="both"
    }

    return(t.dist.area(mod()$statistic,tail=tail,mod()$parameter))
    })
  })

  output$citab = renderTable({
    if(input$ci & input$teststart>0)
    {
      tab = matrix(c(mod()$conf.int[1],mod()$conf.int[2]),nrow=1)
      colnames(tab) = c("Lower bound","Upper bound")
      rownames(tab) = paste(round(1-input$alpha, digits=3)*100,"% CI",sep="")
      tab
    }
  })

  #####################################################################################################################
  #####################################################################################################################
  ## Diagnostics Panel
  #####################################################################################################################
  #####################################################################################################################

  output$qqplot = renderPlot({
      if((input$datformat==1 & !input$usedata) | (input$sampdat==1 & input$usedata))
      {
        dat=unlist(data())
        dat1=data.frame(x=as.numeric(as.character(dat)))
        ggplot(data=dat1, aes(sample=x)) + stat_qq(geom="point",color="navy",shape=1) +
          theme_bw() + theme(text=element_text(size=15)) + ggtitle("Q-Q Plot")
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=dat[[1]],y=dat[[2]])
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          dat1$x=as.numeric(as.character(dat1$x))
          ggplot(data=dat1, aes(sample=x)) + stat_qq(aes(color=factor(y)),geom="point",shape=1) + theme_bw() +
            theme(text=element_text(size=15)) + ggtitle("Q-Q Plot") + facet_wrap(~y) +
            scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
        } else
        {
          dat1$y=as.numeric(as.character(dat1$y))
          ggplot(data=dat1, aes(sample=y)) + stat_qq(aes(color=factor(x)),geom="point",shape=1) + theme_bw() +
            theme(text=element_text(size=15)) + ggtitle("Q-Q Plot") + facet_wrap(~x) +
            scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=c(as.numeric(as.character(dat[[1]])),as.numeric(as.character(dat[[2]]))),
                        y=c(rep(names(dat)[1],length(dat[[1]])),rep(names(dat)[2],length(dat[[2]]))))
        ggplot(data=dat1, aes(sample=x)) + stat_qq(aes(color=factor(y)),geom="point",shape=1) + theme_bw() +
          theme(text=element_text(size=15)) + ggtitle("Q-Q plot") + facet_wrap(~y) +
          scale_color_manual(name="", values=c("navy","gold2")) + guides(color=FALSE)
      }
  })

  output$sw = renderTable({
      if((input$datformat==1 & !input$usedata) | (input$sampdat!=2 & input$usedata))
      {
        dat=unlist(data())
        dat1=data.frame(x=as.numeric(as.character(dat)))

        validate(
          need(try(shapiro.test(dat1$x)), "Do not need to conduct normality test")
        )

        norm = shapiro.test(dat1$x)

        tab = matrix(c(norm$statistic,norm$p.value),nrow=1)
        colnames(tab) = c("W statistic","p-value")
        rownames(tab) = "Data"
        tab
      } else if((input$datformat==2 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()
        dat1=data.frame(x=dat[[1]],y=dat[[2]])
        if(length(unique(dat[[1]])) > length(unique(dat[[2]])))
        {
          dat1$x=as.numeric(as.character(dat1$x))

          norm1 = shapiro.test(dat1$x[which(dat1$y==unique(dat1$y)[1])])
          norm2 = shapiro.test(dat1$x[which(dat1$y==unique(dat1$y)[2])])

          tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
          colnames(tab) = c("W statistic","p-value")
          rownames(tab) = c("Data 1","Data 2")
          tab
        } else
        {
          dat1$y=as.numeric(as.character(dat1$y))

          norm1 = shapiro.test(dat1$y[which(dat1$x==unique(dat1$x)[1])])
          norm2 = shapiro.test(dat1$y[which(dat1$x==unique(dat1$x)[2])])

          tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
          colnames(tab) = c("W statistic","p-value")
          rownames(tab) = c("Data 1","Data 2")
          tab
        }
      } else if((input$datformat==3 & !input$usedata) | (input$sampdat!=1 & input$usedata))
      {
        dat=data()

        norm1 = shapiro.test(as.numeric(as.character(dat[[1]])))
        norm2 = shapiro.test(as.numeric(as.character(dat[[2]])))

        tab = matrix(c(norm1$statistic,norm2$statistic,norm1$p.value,norm2$p.value),ncol=2)
        colnames(tab) = c("W statistic","p-value")
        rownames(tab) = c("Data 1","Data 2")
        tab
      }
  })

})