library(RSQLite)
library(ggplot2)

get.data.from.sqlite <- function(db.name, table.name) {
  con <- dbConnect(SQLite(), dbname=db.name)
  db.query <- paste('select * from', table.name)
  table.data <- dbGetQuery(con, db.query)
  return(table.data)
}

game.data <- get.data.from.sqlite("bgg_data.db", "board_games")

collected.ranks <- grep('[[:digit:]]+', game.data$rank, value=TRUE)
collected.ranks <- as.numeric(collected.ranks)

missing.data <- as.matrix(setdiff(1:4999, collected.ranks))

hist(missing.data, breaks = 50)
# currently missing 20% of top games, and 10% of bottom games
# I have all of the middle games

#####
# Clean the data
#####

clean.data <- game.data %>%
  filter(grepl('[[:digit:]]+', rank)) %>% mutate(rank = as.numeric((rank))) %>%
  filter(grepl('[[:digit:]]+', num_votes)) %>% mutate(num_votes = as.numeric((num_votes))) %>%
  filter(grepl('[[:digit:]]+', year_published)) %>% mutate(year_published = as.numeric((year_published))) %>%
  filter(grepl('[[:digit:]]+', num_comments)) %>% mutate(num_comments = as.numeric((num_comments))) %>%
  filter(grepl('[[:digit:].]+', geek_rating)) %>% mutate(geek_rating = as.numeric((geek_rating))) %>%
  filter(grepl('[[:digit:].]+', avg_rating)) %>% mutate(avg_rating = as.numeric((avg_rating))) %>%
  filter(grepl('[[:digit:].]+', avg_rating_std_deviations)) %>% mutate(avg_rating_std_deviations = as.numeric((avg_rating_std_deviations))) %>%
  filter(grepl('[[:digit:].]+', weight)) %>% mutate(weight = as.numeric((weight)))

######

rank.votes <- clean.data %>% select(rank, num_votes)
rank.votes <- rank.votes[complete.cases(rank.votes), ]

ggplot(rank.votes, aes(x=rank, y=num_votes)) + geom_point()

######

year.votes <- clean.data %>% select(year_published, num_votes) %>% filter(year_published > 1950)
year.votes <- year.votes[complete.cases(year.votes), ]

ggplot(year.votes, aes(x=year_published, y=num_votes)) + geom_point()

######

year.comments <- clean.data %>% select(year_published, num_comments) %>% filter(year_published > 1950)
year.comments <- year.comments[complete.cases(year.comments), ]

ggplot(year.comments, aes(x=year_published, y=num_comments)) + geom_point()

######

votes.comments <- clean.data %>% select(num_votes, num_comments, rank)
votes.comments <- votes.comments[complete.cases(votes.comments), ]

ggplot(votes.comments, aes(x=num_votes, y=num_comments, color=rank)) + geom_point() + scale_colour_continuous("Rank", limits= c(1, 5000), low="green", high="blue") + scale_x_log10() + scale_y_log10()

######

weight.rating <- clean.data %>% select(weight, avg_rating, rank)
weight.rating <- weight.rating[complete.cases(weight.rating), ]

ggplot(weight.rating, aes(x=weight, y=avg_rating, color=rank)) + geom_point() + scale_colour_continuous("Rank", limits= c(1, 5000), low="green", high="blue")


## 1. Introduction ##

library(readr)
houses  <-  read_tsv('AmesHousing_1.txt')

scale_land  <-  'ordinal'
scale_roof  <-  'nominal'
kitchen_variable  <-  'discrete'

## 2. The Mode for Ordinal Variables ##

library(dplyr)

compute_mode <- function(vector) {
    counts_df  <-  tibble(vector) %>%
        group_by(vector) %>%
        summarise(frequency=n()) %>%
        arrange(desc(frequency))

    counts_df$vector[1]
}

computed_mode  <-  compute_mode(houses$`Land Slope`)

## 3. The Mode for Nominal Variables ##

# The function we wrote (you can copy-paste yours from the previous screen)
library(dplyr)

compute_mode <- function(vector) {
    counts_df  <-  tibble(vector) %>%
        group_by(vector) %>%
        summarise(frequency = n()) %>%
        arrange(desc(frequency))

    counts_df$vector[1]
}
compute_mode_table <- function(vector) {
    counts_df  <-  tibble(vector) %>%
        group_by(vector) %>%
        summarise(frequency = n()) %>%
        arrange(desc(frequency))

    list('mode' = counts_df$vector[1], 'values' = counts_df$frequency)
}

mode <- compute_mode_table(houses$`Roof Style`)$mode
value_counts  <-  compute_mode_table(houses$`Roof Style`)$values

## 4. The Mode for Discrete Variables ##

library(dplyr)

compute_mode <- function(vector) {
    counts_df  <-  tibble(vector) %>%
        group_by(vector) %>%
        summarise(frequency = n()) %>%
        arrange(desc(frequency))

    counts_df$vector[1]
}
bedroom_variable  <-  'discrete'
bedroom_mode  <-  compute_mode(houses$`Bedroom AbvGr`)

price_variable  <-  'continuous'
price_mode <- compute_mode(houses$SalePrice)

## 5. Special Cases ##

library(dplyr)

houses %>%
    mutate(intervals_group = cut(SalePrice,
                                 breaks = seq(0,800000,100000))) %>%
    group_by(intervals_group) %>%
    summarize(frequency = n())
mode  <-  150000
mean  <-  mean(houses$SalePrice)
median  <-  median(houses$SalePrice)

sentence_1  <-  TRUE
sentence_2  <-  TRUE

## 6. Skewed Distributions ##

distribution_1  <-  c('mean' = 3021 , 'median' = 3001, 'mode' = 2947)
distribution_2  <-  c('median' = 924 , 'mode' = 832, 'mean' = 962)
distribution_3  <-  c('mode' =  202, 'mean' =  143, 'median' = 199)
shape_1  <-  'right skew'
shape_2  <-  'right skew'
shape_3  <-  'left skew'

## 7. Challenge: Symmetrical Distributions ##

library(dplyr)

compute_mode <- function(vector) {
    counts_df  <-  tibble(vector) %>%
        group_by(vector) %>%
        summarise(frequency = n()) %>%
        arrange(desc(frequency))

    counts_df$vector[1]
}
library(ggplot2)

ggplot(data = houses,
    aes(x = `Mo Sold`)) +
    geom_density(alpha = 0.1,
                 color='blue',
                 fill='blue') +
    geom_vline(aes(xintercept = compute_mode(`Mo Sold`),
                   color = 'Mode'),
               size = 1.2 ) +
    geom_vline(aes(xintercept = median(`Mo Sold`),
                   color = 'Median'),
               size = 1.2 ) +
    geom_vline(aes(xintercept = mean(`Mo Sold`),
                   color = 'Mean'),
               size = 1.2 ) +
    scale_y_continuous(labels = scales::comma) +
    xlim(1,12)+
    scale_colour_manual(values = c("Mode" = "green",
                                   "Median" = "black",
                                   "Mean" = "orange"),
                        name = "") +
    theme_bw() +
    theme(legend.position='top') +
    xlab("Mo Sold") +
    ylab("Density")

Data Analyst in R/Step 5 - Probability and Statistics/2. Statistics Intermediate in R Averages and Variability/3. The Mode.r


## libraries
library(ggplot2)
library(dplyr)
library(magick)
library(gganimate)
## some packages only available via github
## devtools::install_github("thomasp85/transformr")
library(transformr)

study <- round(runif(10,80,100))
no_study <- round(runif(10,40,90))
study_df<-data.frame(student=seq(1:10),study,no_study)
mean_original<-data.frame(IV=c("studied","did not study"),
                          means=c(mean(study),mean(no_study)))
t_df <- data.frame(sims=rep(1,20),
                   IV=rep(c("studied","did not study"),each=10),
                   values=c(study,no_study),
                   rand_order=rep(c(0,1),each=10))
raw_df<-t_df
for(i in 2:10){
    new_index<-sample(1:20)
    t_df$values<-t_df$values[new_index]
    t_df$rand_order<-t_df$rand_order[new_index]
    t_df$sims<-rep(i,20)
    raw_df<-rbind(raw_df,t_df)
}
raw_df$rand_order<-as.factor(raw_df$rand_order)
rand_df<-aggregate(values~sims*IV,raw_df,mean)
names(rand_df)<-c("sims","IV","means")
rand_df$rand_order <- as.factor(1)
a <- ggplot(data = raw_df,aes(x=IV,y=values,color=rand_order), color = c("red","blue")) +
    geom_point(stat="identity",alpha=.5,size = 6) +
    geom_point(data=mean_original,aes(x = IV,y = means),
               stat="identity",shape=21,size = 6,color="black",fill="black") +
    geom_point(data=rand_df,aes(x=IV,y=means),stat="identity",
               shape=21,size=6,color="gold",fill="gold") +
    geom_text(data=rand_df,aes(x = IV,y=means,label = "Randomized mean"),stat="identity", color = "black",
              nudge_x = -0.3) +
    coord_cartesian(ylim=c(40, 100)) +
    ylab("Exam grade") +
    scale_color_manual(values = c("red","blue"),
                       labels = c("studied","did not study"),name = "Original data") +
    annotate("text",x = c(1.25,2.25), y = rev(mean_original$means), label = "Original mean") +
    theme(legend.position="bottom",
          axis.title.x=element_blank(),
          panel.background = element_blank(),
          panel.grid.minor = element_blank(),
          panel.grid.major = element_blank(),
          panel.border = element_rect(colour='black', fill=NA)) +
    transition_states(
        sims,
        transition_length = 1,
        state_length = 2
    ) + enter_fade() +
    exit_shrink() +
    ease_aes('sine-in-out')

anim_save("randomisation.gif",animate(a,nframes=100,fps=5))


library(ggplot2)
library(reshape2)
library(sandwich)
library(lmtest)
library(tseries)
library(dplyr)
library(urca)
library(forecast)
library(data.table)

rm(list=ls())
gc()

source("startest.r")
source("lstar.r")
source("estar.r")

## see 01-subset.r for the brief description of this function
ar_order <- function(x,max_lag=12,method="SIC",bg=TRUE){
  ic_func <- function(i){# optimal lag based on (A/S)IC
    fmla <- as.formula(paste("x~",paste0("x",c(1:i),collapse="+")))
    reg <- lm(fmla,data=d)
    if(method=="SIC"){
      log(crossprod(reg$resid))+log(nrow(d))*length(reg$coefficients)/nrow(d)
    }else{
      log(crossprod(reg$resid))+2*length(reg$coefficients)/nrow(d)
    }
  }
  bg_func <- function(i){# Breusch-Godfrey
    fmla <- as.formula(paste("x~",paste0("x",c(1:i),collapse="+")))
    as.numeric(bgtest(lm(fmla,data=d))[4])
  }
  d <- data.table(x=as.numeric(x))
  d <- d[,paste0("x",c(1:max_lag)) := shift(x,n=1:max_lag,fill=NA,type="lag")]
  d <- d[complete.cases(d)]
  ic_vec <- sapply(c(1:max_lag),ic_func)
  opt_lag <- which.min(ic_vec)
  if(bg){
    bg_vec1 <- sapply(c(opt_lag:1),bg_func)
    if(!is.na(which(bg_vec1 < .05)[1])){
      opt_lag <- opt_lag-which(bg_vec1 < .05)[1]+2
    }
    bg_vec2 <- sapply(c(opt_lag:max_lag),bg_func)
    if(!is.na(which(bg_vec2 < .05)[1])){
      if(which(bg_vec2 < .05)[1]==1){
        opt_lag <- opt_lag+sort(unlist(lapply(split(which(bg_vec2 < .05),cumsum(c(1,diff(which(bg_vec2 < .05)))!=1)),max),use.names=F))[1]
      }
    }
  }
  p <- ifelse(p<=max_lag,opt_lag,max_lag)
  return(p)
}

## the multi-step version of the previous function
arh_order <- function(x,h,max_lag=12,method="SIC",bg=TRUE){
  ic_func <- function(i){# optimal lag based on (A/S)IC
    fmla <- as.formula(paste("x~",paste0("x",c((j+1):(j+i)),collapse="+")))
    reg <- lm(fmla,data=d)
    if(method=="SIC"){
      log(crossprod(reg$resid))+log(nrow(d))*length(reg$coefficients)/nrow(d)
    }else{
      log(crossprod(reg$resid))+2*length(reg$coefficients)/nrow(d)
    }
  }
  bg_func <- function(i){# Breusch-Godfrey
    fmla <- as.formula(paste("x~",paste0("x",c((j+1):(j+i)),collapse="+")))
    as.numeric(bgtest(lm(fmla,data=d))[4])
  }
  j <- h-1
  d <- data.table(x=as.numeric(x))
  d <- d[,paste0("x",c((j+1):(j+max_lag))) := shift(x,n=(j+1):(j+max_lag),fill=NA,type="lag")]
  d <- d[complete.cases(d)]
  ic_vec <- sapply(c(1:max_lag),ic_func)
  opt_lag <- which.min(ic_vec)
  if(bg){
    bg_vec1 <- sapply(c(opt_lag:1),bg_func)
    if(!is.na(which(bg_vec1 < .05)[1])){
      opt_lag <- opt_lag-which(bg_vec1 < .05)[1]+2
    }
    bg_vec2 <- sapply(c(opt_lag:max_lag),bg_func)
    if(!is.na(which(bg_vec2 < .05)[1])){
      if(which(bg_vec2 < .05)[1]==1){
        opt_lag <- opt_lag+sort(unlist(lapply(split(which(bg_vec2 < .05),cumsum(c(1,diff(which(bg_vec2 < .05)))!=1)),max),use.names=F))[1]
      }
    }
  }
  p <- ifelse(p<=max_lag,opt_lag,max_lag)
  return(p)
}

# load the data
load("subset.RData")

c_num <- ncol(subset_dt)-1

p <- 12 # max lag length
h <- 12 # horizon length

B <- 5000 # bootstrap sample size

frac <- .8

# in-sample and out-of-sample periods
n <- nrow(subset_dt)
R <- round(frac*n)
P <- n-R-h+1

# empty array to store: realized values, naive forecasts, iterated and direct
# forecasts from STAR models, iterated and direct forecasts from AR models
array_forecast <- array(dim=c(h,6,P,c_num))
array_pval <- array(dim=c(h,P,c_num))
array_order <- array(dim=c(h,P,c_num))

c_names <- as.character(names(subset_dt)[1:c_num])

for(k in 1:c_num){

  cmd <- c_names[k]

  y <- as.matrix(log(subset_dt[,..cmd]))

  res <- array(dim=c(h,6,P))
  pval <- matrix(nrow=h,ncol=P)
  lag_order <- matrix(nrow=h,ncol=P)

  dy <- c(0,diff(y))

  for(r in 1:P){

    # the expanding window for estimation
    w <- y[1:(R-1+r)]
    dw <- dy[1:(R-1+r)]

    ord_w <- ar_order(w,max_lag=p,method="SIC",bg=F)

    y_realised <- y[(R+r):(R+r+h-1)] # the out-of-sample realized values
    y_last <- y[(R-1+r)]

    # random walk forecast
    y_naive <- rep(y_last,h)

    # iterated method

    dmat <- embed(dw,p+h+1)
    lmat <- embed(w,p+h+1)

    dy_f <- c(dw,rep(NA,h))
    y_f <- c(w,rep(NA,h))

    dmat_f <- embed(dy_f,p+h+1)
    lmat_f <- embed(y_f,p+h+1)

    ## linear iterated

    if(ord_w>1){
      est_ar <- lm(dmat[,1]~dmat[,2:ord_w])
    }else{
      est_ar <- lm(dmat[,1]~1)
    }

    b <- est_ar$coef
    e <- est_ar$resid

    y_boot <- matrix(nrow=h,ncol=B)

    set.seed(k)
    e_boot <- matrix(sample(e,h*B,replace=T),nrow=h,ncol=B)

    for(itnum in 1:B){

      e_f <- e_boot[,itnum]

      for(i in 1:h){

        if(ord_w>1){
          dmat_f[nrow(dmat)+i,2:ord_w] <- dmat_f[nrow(dmat)+i-1,1:(ord_w-1)]
          dmat_f[nrow(dmat)+i,1] <- b[1:ord_w]%*%c(1,dmat_f[nrow(dmat)+i,2:ord_w])+e_f[i]
        }else{
          dmat_f[nrow(dmat)+i,1] <- b+e_f[i]
        }

      }

      y_boot[,itnum] <- dmat_f[(nrow(dmat)+1):(nrow(dmat)+h),1]

    }

    y_boot <- apply(rbind(y_last,y_boot),2,cumsum)[-1,]

    y_lin_iter <- rowMeans(y_boot)

    ## nonlinear iterated
    if(ord_w>1){
      test_nl <- startest(y=dmat[,1],x=cbind(1,dmat[,2:ord_w]),x.n=cbind(1,dmat[,2:ord_w]),tvar=dmat[,2:ord_w],tvar.lag=0,contemp=F,ascending=T)
    }else{
      test_nl <- startest(y=dmat[,1],x=rep(1,nrow(dmat)),x.n=rep(1,nrow(dmat)),tvar=dmat[,2],tvar.lag=0,contemp=F,ascending=T)
    }

    d <- as.numeric(substr(rownames(test_nl$star)[1],3,4))

    s_t <- dmat[,(1+d)]

    p_vec <- test_nl$star[1,c("p.3","p.2","p.1")]
    t_min <- p_vec[which.min(p_vec)]
    if(which.min(p_vec)==2){
      tf <- "e"
    }else{
      tf <- "l"
    }

    if(ord_w>1){
      if(tf=="l"){
        est_star <- lstar(y=dmat[,1],x.0=cbind(1,dmat[,2:ord_w]),x.1=cbind(1,dmat[,2:ord_w]),tv=s_t)
      }else{
        est_star <- estar(y=dmat[,1],x.0=cbind(1,dmat[,2:ord_w]),x.1=cbind(1,dmat[,2:ord_w]),tv=s_t)
      }
    }else{
      if(tf=="l"){
        est_star <- lstar(y=dmat[,1],x.0=rep(1,nrow(dmat)),x.1=rep(1,nrow(dmat)),tv=s_t)
      }else{
        est_star <- estar(y=dmat[,1],x.0=rep(1,nrow(dmat)),x.1=rep(1,nrow(dmat)),tv=s_t)
      }
    }

    b <- est_star$coef
    e <- est_star$resid

    y_boot <- matrix(nrow=h,ncol=B)

    set.seed(k)
    e_boot <- matrix(sample(e,h*B,replace=T),nrow=h,ncol=B)

    for(itnum in 1:B){

      e_f <- e_boot[,itnum]

      for(i in 1:h){

        if(ord_w>1){
          dmat_f[nrow(dmat)+i,2:ord_w] <- dmat_f[nrow(dmat)+i-1,1:(ord_w-1)]
          s_f <- dmat_f[nrow(dmat)+i-d,1]
          if(tf=="l"){
            g_f <- (1+exp(-b["g1"]*(s_f-b["c1"])/sd(s_t)))^(-1)
          }else{
            g_f <- (1-exp(-b["g1"]*((s_f-b["c1"])/sd(s_t))^2))
          }
          dmat_f[nrow(dmat)+i,1] <- b[1:ord_w]%*%c(1,dmat_f[nrow(dmat)+i,2:ord_w])+(b[(ord_w+1):(ord_w*2)]%*%c(1,dmat_f[nrow(dmat)+i,2:ord_w]))*g_f+e_f[i]
        }else{
          s_f <- dmat_f[nrow(dmat)+i-d,1]
          if(tf=="l"){
            g_f <- (1+exp(-b["g1"]*(s_f-b["c1"])/sd(s_t)))^(-1)
          }else{
            g_f <- (1-exp(-b["g1"]*((s_f-b["c1"])/sd(s_t))^2))
          }
          dmat_f[nrow(dmat)+i,1] <- b[1]+b[2]*g_f+e_f[i]
        }

      }

      y_boot[,itnum] <- dmat_f[(nrow(dmat)+1):(nrow(dmat)+h),1]

    }

    y_boot <- apply(rbind(y_last,y_boot),2,cumsum)[-1,]

    y_nln_iter <- rowMeans(y_boot)

    # direct method

    y_dlin <- matrix(nrow=h,ncol=B)
    y_dnln <- matrix(nrow=h,ncol=B)

    for(j in 0:(h-1)){

      dj <- c(rep(0,j+1),diff(w,j+1))

      dmat_j <- embed(dj,p+h+1)

      ord_w <- arh_order(w,j+1,max_lag=p,method="SIC",bg=F)

      ## linear direct
      if(ord_w>1){
        est_ar <- lm(dmat_j[,1]~dmat[,(j+2):(j+ord_w)])
      }else{
        est_ar <- lm(dmat_j[,1]~1)
      }
      b <- est_ar$coef
      e <- est_ar$resid

      set.seed(k)
      e_boot <- matrix(sample(e,h*B,replace=T),nrow=h,ncol=B)
      e_f <- e_boot[j+1,]

      if(ord_w>1){
        y_dlin[j+1,] <- y_last+as.numeric(b%*%c(1,dmat_f[nrow(dmat),1:(ord_w-1)]))+as.matrix(e_f)
      }else{
        y_dlin[j+1,] <- y_last+as.numeric(b)+as.matrix(e_f)
      }

      ## nonlinear direct
      if(ord_w>1){
        test_nl <- startest(y=dmat_j[,1],x=cbind(1,dmat[,(j+2):(j+ord_w)]),x.n=cbind(1,dmat[,(j+2):(j+ord_w)]),tvar=dmat[,(j+2):(j+ord_w)],tvar.lag=0,contemp=F,ascending=T)
      }else{
        test_nl <- startest(y=dmat_j[,1],x=rep(1,nrow(dmat)),x.n=rep(1,nrow(dmat)),tvar=dmat[,(j+2)],tvar.lag=0,contemp=F,ascending=T)
      }

      dd <- as.numeric(substr(rownames(test_nl$star)[1],3,4))

      s_t <- dmat[,(j+1+dd)]
      s_f <- dmat[nrow(dmat),dd]

      p_vec <- test_nl$star[1,c("p.3","p.2","p.1")]
      t_min <- p_vec[which.min(p_vec)]
      if(which.min(p_vec)==2){
        tf <- "e"
      }else{
        tf <- "l"
      }

      if(ord_w>1){
        if(tf=="l"){
          est_star <- lstar(y=dmat_j[,1],x.0=cbind(1,dmat[,(j+2):(j+ord_w)]),x.1=cbind(1,dmat[,(j+2):(j+ord_w)]),tv=s_t)
          b <- est_star$coef
          g_f <- (1+exp(-b["g1"]*(s_f-b["c1"])/sd(s_t)))^(-1)
        }else{
          est_star <- estar(y=dmat_j[,1],x.0=cbind(1,dmat[,(j+2):(j+ord_w)]),x.1=cbind(1,dmat[,(j+2):(j+ord_w)]),tv=s_t)
          b <- est_star$coef
          g_f <- (1-exp(-b["g1"]*((s_f-b["c1"])/sd(s_t))^2))
        }
      }else{
        if(tf=="l"){
          est_star <- lstar(y=dmat_j[,1],x.0=rep(1,nrow(dmat)),x.1=rep(1,nrow(dmat)),tv=s_t)
          b <- est_star$coef
          g_f <- (1+exp(-b["g1"]*(s_f-b["c1"])/sd(s_t)))^(-1)
        }else{
          est_star <- estar(y=dmat_j[,1],x.0=rep(1,nrow(dmat)),x.1=rep(1,nrow(dmat)),tv=s_t)
          b <- est_star$coef
          g_f <- (1-exp(-b["g1"]*((s_f-b["c1"])/sd(s_t))^2))
        }
      }

      e <- est_star$resid

      set.seed(k)
      e_boot <- matrix(sample(e,h*B,replace=T),nrow=h,ncol=B)
      e_f <- e_boot[j+1,]

      if(ord_w>1){
        y_dnln[j+1,] <- y_last+as.numeric(b[1:ord_w]%*%c(1,dmat_f[nrow(dmat),1:(ord_w-1)])+(b[(ord_w+1):(ord_w*2)]%*%c(1,dmat_f[nrow(dmat),1:(ord_w-1)]))*g_f)+as.matrix(e_f)
      }else{
        y_dnln[j+1,] <- y_last+as.numeric(b[1]+b[2]*g_f)+as.matrix(e_f)
      }

      pval[j+1,r] <- as.numeric(t_min)

      lag_order[j+1,r] <- ord_w

    }

    y_lin_dir <- rowMeans(y_dlin)
    y_nln_dir <- rowMeans(y_dnln)

    res[,,r] <- cbind(y_realised,y_naive,y_lin_iter,y_nln_iter,y_lin_dir,y_nln_dir)

  }

  array_forecast[,,,k] <- res
  array_pval[,,k] <- pval
  array_order[,,k] <- lag_order
  print(k)

}

save(array_forecast,array_pval,file="forecast80.RData")


is.luhn <- function(cc){
  numbers <- as.numeric(rev(unlist(strsplit(cc,""))))
  (sum(numbers[seq(1,length(numbers),by=2)]) + sum({numbers[seq(2,length(numbers),by=2)]*2 ->.;  .%%10 +.%/%10})) %% 10 == 0
}

sapply(c("49927398716","49927398717","1234567812345678","1234567812345670"),is.luhn)


anscombe.sum <- function(df){
results <- as.list(new.env()); # create a list to return with data
results$n <- length(df$x) # sample size
results$x.mean <- mean(df$x) # mean of x
results$y.mean <- mean(df$y) # mean of y
lm.xy <- lm(y ~ x, data=df) # fit slr
results$eq.reg <- lm.xy$coefficients # regression coefficients
results$b1.se <- summary(lm.xy)$coefficients[2,2] # SE of slope
results$b1.t <- summary(lm.xy)$coefficients[2,3] # t-stat of slope
results$x.SS <- sum((df$x-results$x.mean)^2) # x sum of squares
results$ResSS <- sum(lm.xy$residuals^2) # residual SS of y
results$RegSS <- sum((df$y-results$y.mean)^2)-results$ResSS # reg SS
results$xy.cor <- cor(df$x, df$y) # correlation
results$xy.r2 <- summary(lm.xy)$r.squared # R^2 for regression
return(results)
}
# calculate and store summaries by data group g
results.temp <- by(anscombe.long, anscombe.long$g, anscombe.sum)
# make a table
x.table <- cbind( t(t(unlist(results.temp[[1]])))
, t(t(unlist(results.temp[[2]])))
, t(t(unlist(results.temp[[3]])))
, t(t(unlist(results.temp[[4]])))
, t(t(unlist(results.temp[[5]])))
, t(t(unlist(results.temp[[6]])))
, t(t(unlist(results.temp[[7]])))
, t(t(unlist(results.temp[[8]])))
, t(t(unlist(results.temp[[9]])))
, t(t(unlist(results.temp[[10]])))
, t(t(unlist(results.temp[[11]])))
, t(t(unlist(results.temp[[12]])))
, t(t(unlist(results.temp[[13]])))
, t(t(unlist(results.temp[[14]])))
, t(t(unlist(results.temp[[15]])))
, t(t(unlist(results.temp[[16]])))
, t(t(unlist(results.temp[[17]])))
, t(t(unlist(results.temp[[18]])))
, t(t(unlist(results.temp[[19]])))
, t(t(unlist(results.temp[[20]])))
, t(t(unlist(results.temp[[21]])))
, t(t(unlist(results.temp[[22]])))
, t(t(unlist(results.temp[[23]])))
, t(t(unlist(results.temp[[24]])))
, t(t(unlist(results.temp[[25]])))
)
colnames(x.table) <- 1:4 # label the table columns


# Exercise 6
#
# Time: 15 minutes

# In Part 3 today, we saw how to subset data from the iris dataset using base R.
# Now let's try to get the same results using the dplyr package.

# 1) Let's analyze just the petal widths of the versicolor species in 'iris'. We can
#    create a new data frame by extracting a subet of all versicolor records,...

# Base R:
versicolor <- iris[iris$Species == 'versicolor',]
versicolor

# dplyr:

# 2) ...then create a numeric vector of versicolor petal widths...

# Base R:
versicolor_pw <- versicolor$Petal.Width
versicolor_pw

# dplyr:

# 3) ...or, do the same thing all in one line

# Base R:
versicolor_pw <- iris[iris$Species == 'versicolor', 'Petal.Width']
versicolor_pw

# dplyr:

# 4) Simple statistics on versicolor_pw:

# Base R:
versicolor_pw <- iris[iris$Species == 'versicolor', 'Petal.Width']
mean(versicolor_pw)
median(versicolor_pw)
var(versicolor_pw)
sd(versicolor_pw)

# dplyr (start with the complete iris dataset):

# 5) Do all statistical summaries in question 4 for each species in one data frame (start with the complete iris dataset):


heart <- read.table("http://stat.ethz.ch/Teaching/Datasets/heart.dat", header = TRUE)

neg.ll <- function(beta, data) {
    llh = 0
    for (i in 1:nrow(data)) {
        g = beta[1] + beta[2] * data$age[i]
        llh = llh + log(choose(data$m[i], data$N[i])) + data$N[i] * g - data$m[i] * log(1 + exp(g))
    }
    -llh
}

beta0.grid <- seq(-10, 10, length = 101)
beta1.grid <- seq(-1, 1, length = 101)

neg.ll.values <- matrix(nrow = 101, ncol = 101)

for (b0 in 1:101) {
    for (b1 in 1:101) {
        neg.ll.values[b0, b1] <- neg.ll(c(beta0.grid[b0], beta1.grid[b1]), heart)
    }
}

contour(beta0.grid, beta1.grid, neg.ll.values, nlevels = 10)

fit <- glm(cbind(N, m - N) ~ age, family = binomial, data = heart)

print(fit)

print(optim(c(0, 0), neg.ll, data = heart))

predict(fit, newdata = data.frame(age = 20:69), type = "response")


##### 1. Electricity
### Obj : 빌딩의 전력량 예측하는 모델
### Data : Electric
### Hypothesis : surface_area를 input으로 쓰면 electricity를 예측하는데 도움이 될 것이다.
### feature : surface_area(Input), electricity(Output)
### Process : Data Load -> EDA -> Modeling -> Test

##### Data Load
Elec <- read.csv('/Users/mac/Downloads/dev/study/R_ML/Class 1/Data/Electric.csv')

##### EDA ... Data Structure & Plot
str(Elec)
plot(Elec$surface_area, Elec$electricity, cex = 3, pch = 19)

##### 난수 발생 알고리즘 초기값 고정 ... Training 할 때마다 샘플이 동일한 기준에서 돌아가야 하니까
set.seed(3)

##### Training Set을 전체 데이터의 70% 지정 (Training Data)
train <- sample(1:nrow(Elec), 0.7 * nrow(Elec))

##### 실제 전력량 (Output, Answer)
real_electricity <- Elec$electricity[-train]

##### Model_1 ... 전력량과 면적의 1차 함수
Model_1 <- lm(electricity ~ surface_area, data = Elec[train, ])
predicted_electricity_1 <- predict(Model_1, Elec[-train, ])
test_error_1 <- mean((real_electricity - predicted_electricity_1)^2)

##### Model_5 ... 전력량과 면적의 5차 함수
Model_5 <- lm(electricity ~ poly(surface_area, 5), data = Elec[train, ])
predicted_electricity_5 <- predict(Model_5, Elec[-train, ])
test_error_5 <- mean((real_electricity - predicted_electricity_5)^2)

##### Model_10 ... 전력량과 면적의 10차 함수
Model_10 <- lm(electricity ~ poly(surface_area, 10), data = Elec[train, ])
predicted_electricity_10 <- predict(Model_10, Elec[-train, ])
test_error_10 <- mean((real_electricity - predicted_electricity_10)^2)

##### 각각의 Error(Cost) 값
test_error_1
test_error_5
test_error_10

## EDA ... 구현한 모든 모델 시각화
plot(Elec$surface_area, Elec$electricity, cex = 3, pch = 15)
a <- seq(500, 820, length = 1000) # surface_area의 값 범위(500~820)를 1000등분 함

points(a, predict(Model_1, data.frame(surface_area = a)), type = 'l', lwd = 10, col = 1)
points(a, predict(Model_5, data.frame(surface_area = a)), type = 'l', lwd = 10, col = 5)
points(a, predict(Model_10, data.frame(surface_area = a)), type = 'l', lwd = 3, col = 10)

##### 2. Cars
### obj : 자동차의 연비를 예측하는 모델
### Data : Cars.csv
### Hypothesis : weight를 Input으로 쓰면 mpg를 예측하는데 도움이 될 것이다.
### Feature : weight(Input), mpg(Output)
### Process : Data Load -> EDA -> Modeling(Train) -> (Validation) -> Test -> Visualization

##### Data Load
Cars <- read.csv("/Users/mac/Downloads/dev/study/R_ML/Class 1/Data/Cars.csv")

##### Data Structure
str(Cars)

##### 데이터 샘플링 초기값 설정
set.seed(1)

##### Training Set을 전체 데이터의 60%로 지정
train <- sample(1:nrow(Cars), 0.6 * nrow(Cars))
##### Validatiaon Set을 전체 데이터의 20%로 지정
validation <- sample(setdiff(1:nrow(Cars), train), 0.2 * nrow(Cars)) # setdiff = 뺸 나머지, 1:768의 vector 주머니에서 train을 빼라
##### Test Set을 전체 데이터의 20%로 지정
test <- setdiff(1:nrow(Cars), c(train, validation))

##### Model_1 : weight(무게)와 mpg(연비) 1차 함수
Model_1 <- lm(mpg ~ weight, data = Cars[train, ])
pred_weight_1 <- predict(Model_1, Cars[validation, ])
validation_error_1 <- mean((Cars$mpg[validation] - pred_weight_1)^2)

##### Model_2 : weight(무게)와 mpg(연비) 10차 함수
Model_2 <- lm(mpg ~ poly(weight, 10), data = Cars[train, ])
pred_weight_2 <- predict(Model_2, Cars[validation, ])
validation_error_2 <- mean((Cars$mpg[validation] - pred_weight_2)^2)

##### Model_3 : weight + horsepower
Model_3 <- lm(mpg ~ weight + horsepower, data = Cars[train, ])
pred_weight_3 <- predict(Model_3, Cars[validation, ])
validation_error_3 <- mean((Cars$mpg[validation] - pred_weight_3)^2)

plot(Cars$weight, Cars$mpg, cex = 3, pch = 15)

##### Machine Learning System Design
### 일반적으로 이 과정을 수십, 수백, 수천 번 반복한다.
### 이 실험의 과정이 한 달이 걸리고, 한 달이 지났을 때,
### Validation Error가 제일 낮아지는 모형을 선택했다.
### 이제 Model에 대한 Test Error를 한 번 딱 측정하고 끝낸다.

##### K-Fold로 나눴다면, 실험이 끝날 때까지 가지고 가야 한다.
##### Cross Validation은 독립적이라서 병렬처리할 수 있다.
# 구조화된 데이터 ... Random Forest, Boost, Decision Tree (~14년 Random Forest, 그 이후에는 Boost 계열이 많이 활용)
# 비구조화된 데이터(이미지, 음성, 텍스트 데이터) ... Deep Learning


hist_nwj <- function(x, alpha=0.01, pvalue=0.99, breaks=NULL, suppress='no') {
    ## plot histogram and normal, Weibull, and Johnson distributions
    ## add lines for upper tolerance limits for given alpha and pvalue
    ## alpha  = 1 - confidence
    ## pvalue = coverage (tolerance interval only)

    ## install.packages('tolerance')
    library(tolerance)
    ## install.packages('SuppDists')
    library(SuppDists)

    ## normal distribution calculations
    tol_out_norm <- normtol.int(x, alpha = alpha, P=pvalue, side=1)
    upper_tolerance_limit_norm <- tol_out_norm$'1-sided.upper'

    ## Weibull distribution calculations
    if (min(x) < 0) {
        cat('\n')
        cat('#####################################################################\n')
        cat('Skip Weibull: Negative values cannot be fit with Weibull distribution\n')
        cat('              Some day I should add logic to skip if that is the case\n')
        cat('#####################################################################\n')
    } else {
        tol_out_weib <-  exttol.int(x, alpha=alpha, P=pvalue, side=1, dist="Weibull")
        shape   <- tol_out_weib$'shape.1'
        scale   <- tol_out_weib$'shape.2'
        upper_tolerance_limit_weib <- tol_out_weib$'1-sided.upper'
    }

    ## Johnson distribution calculations
    tol_out_john <- johnson_tol(x, alpha=alpha, P=pvalue, side=1)
    jparms   <- tol_out_john$jparms
    if (jparms$type == 'SB') {
        upper_tolerance_limit_john <- NA
    } else {
        upper_tolerance_limit_john <- tol_out_john$xtol_upper$`root approximation`
    }

    ## create vectors with density distributions
    xmin    <- min(x)
    xmax    <- max(x,
                   upper_tolerance_limit_norm,
                   upper_tolerance_limit_weib,
                   upper_tolerance_limit_john,
                   na.rm = TRUE)
    chuncks <- (xmax-xmin)/1000
    xrange  <- seq(xmin,xmax,by=chuncks)
    xmean   <- mean(x)
    xsd     <- sd(x)
    xdensity_norm <- dnorm(xrange,xmean,xsd)
    xdensity_weib <- dweibull(xrange,shape=shape,scale=scale)
    xdensity_john <- dJohnson(xrange, jparms)
    maxdensity <- max(xdensity_norm, xdensity_weib, xdensity_john, na.rm=TRUE)

    ## make histogram
    ## warning: xlim range can mess up x-axis
    ## obtain histogram parameters but suppress plot
    out <- hist(x, plot=FALSE)
    if (is.null(breaks)) breaks <- length(out$breaks)
    ymax <- max(out$density, maxdensity)
    ## create plot
    hist(x, breaks=breaks,
         xlim=c(xmin,xmax+(xmax-xmin)/breaks),
         ylim=c(0,maxdensity),
         freq=FALSE)

    ## add distributions
    lines(x=xrange, y=xdensity_norm, col='red',   lty=1)
    lines(x=xrange, y=xdensity_weib, col='blue',  lty=1)
    lines(x=xrange, y=xdensity_john, col='black', lty=1)

    ## add lines for mean and upper 1-sided 99/99 tolerance limits
    abline(v=xmean,col="red")
    abline(v=upper_tolerance_limit_norm,col="red",  lty=2)
    abline(v=upper_tolerance_limit_weib,col="blue", lty=2)
    abline(v=upper_tolerance_limit_john,col="black",lty=2)

    ## print to screen
    if (suppress == 'no') {
        cat("Tolerance limit input parameters:\n")
        cat("   upper, 1-sided,", pvalue*100,"/",(1-alpha)*100,"\n")
        cat("\n")
        cat("Normal distribution (red):\n")
        cat("   mean               =",xmean,"\n")
        cat("   standard deviation =",xsd,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_norm,"\n")
        cat("\n")
        cat("Weibull distribution (blue):\n")
        cat("   shape              =",shape,"\n")
        cat("   scale              =",scale,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_weib,"\n")
        cat("\n")
        cat("Johnson distribution (black):\n")
        cat("   gamma              =",jparms$gamma ,"\n")
        cat("   delta              =",jparms$delta ,"\n")
        cat("   xi                 =",jparms$xi    ,"\n")
        cat("   lambda             =",jparms$lambda,"\n")
        cat("   type               =",jparms$type  ,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_john,"\n")
    }

    return(list(tol_out_norm=tol_out_norm,
                tol_out_weib=tol_out_weib,
                tol_out_john=tol_out_john))

}
## out   <- hist_nwj(mtcars$mpg)
## gamma <- out$tol_out_john$jparms$gamma


set.seed(6666)

N_0 <- 1000
true.alpha <- .2
true.betas <- c(-10, 1, 5, -.5)
P <- 4
X_0 <- matrix(NA, nrow = N_0, ncol = P)
for(i in 1:P) X_0[, i] <- rnorm(N_0)
mu_0 <- true.alpha  + X_0%*%true.betas
y_0 <- rbinom(N_0, size = 1, prob = arm::invlogit(mu_0)  )

as <- .5
bs <- 2
vb <- 1.5

### will draw from the same process for simplicity
N <- 100
X <- matrix(NA, nrow = N, ncol = P)
for(i in 1:P) X[, i] <- rnorm(N)
mu <- true.alpha  + X%*%true.betas
y <- rbinom(N, size = 1, prob = arm::invlogit(mu))

eta <- 1
nu <- 1


> x
[1] 3 6 8
> y
[1] 2 9 0
> x + y
[1]  5 15  8
> x + 1    # 1 is recycled to (1,1,1)
[1] 4 7 9
> x + c(1,4)    # (1,4) is recycled to (1,4,1) but warning issued
[1]  4 10  9
Warning message:
In x + c(1, 4) :
longer object length is not a multiple of shorter object length


# First generate a random forest

rm(list=ls())

dim_rf <- 10

matrix(0,dim_rf,dim_rf)

matrix(1:dim_rf,dim_rf)

matrix(1:(dim_rf*dim_rf),dim_rf)

# We need a function to fill the matrix with random numbers
# to set each site to 1 or 0

runif(10)

rf <- matrix(runif(dim_rf*dim_rf),ncol=dim_rf)

# the probability to set each site to 1 or 0

p <- 0.5

set_tree <- function(elem,prob) {
  if(elem>prob)
      elem <- 0
  else
      elem <- 1
}

set_tree(rf,0.5)

rf <-apply(rf,1:2,set_tree,0.5)

image(rf,asp=1,axes=F,col=c("white","black"))

#require(lattice)
#levelplot(rf,scales = list(draw = FALSE),xlab =NULL, ylab = NULL,
#           useRaster=T,col.regions = c("white","black"))

# now we can do a function to generate a random forest with
# side dimension and probability as parameters

generate_rf <- function(sideDim,p)
{
  rf <- matrix(runif(sideDim*sideDim),ncol=sideDim)
  rf <-apply(rf,1:2,set_tree,p)
  image(rf,asp=1,axes=F,col=c("white","black"))
}

generate_rf(100,0.1)

generate_rf(100,0.5)

generate_rf(100,0.59)

### Fire the forest

generate_rf <- function(sideDim,p)
{
  rf <- matrix(runif(sideDim*sideDim),ncol=sideDim)
  rf <-apply(rf,1:2,set_tree,p)
  image(rf,asp=1,axes=F,col=c("white","black"))
  return(rf)
}

rf <- generate_rf(100,0.51)

# let's test the commands to build the function

rf[1,] <- 2

for(i in 2:nrow(rf))
  for(j in 1:ncol(rf))
  {
    if( rf[i-1,j]==2 && rf[i,j]==1)
      rf[i,j] <- 2
  }
image(rf,asp=1,axes=F,col=c("white","black","red"))

# wrong we have to test all neighbors

for(i in 2:nrow(rf))
  for(j in 2:(ncol(rf)-1))
  {
    if((rf[i-1,j]==2 || rf[i-1,j-1]==2 || rf[i-1,j+1]==2) && (rf[i,j]==1))
          rf[i,j] <- 2
  }
image(rf,asp=1,axes=F,col=c("white","black","red"))

# So we can build the function

fire_rf <- function(rf) {
  dimi=nrow(rf)
  dimj=ncol(rf)-1
  rf[1,] <- 2
  for(i in 2:dimi)
    for(j in 2:dimj)
    {
      if((rf[i-1,j]==2 || rf[i-1,j-1]==2 || rf[i-1,j+1]==2) && (rf[i,j]==1))
          rf[i,j] <- 2
    }
  return(rf)
}

rf <- generate_rf(100,0.6)
rf1 <- fire_rf(rf)
image(rf1,asp=1,axes=F,col=c("white","black","red"))

# now we need to count the number of burned sites

bur <-0
for(i in 2:nrow(rf1))
  for(j in 1:ncol(rf1))
  {
    if(rf1[i,j]==2 )
        bur <- bur + 1
  }
bur

# build the function

countBurned <- function(rf)
{
  bur <-0
  dimi=nrow(rf)
  dimj=ncol(rf)

  for(i in 2:dimi)
    for(j in 1:dimj)
    {
      if(rf1[i,j]==2 )
        bur <- bur + 1
    }
  return(bur/((dimi-1)*dimj))
}

bur <-countBurned(rf1)
bur

# Exercise

# Infection
rm(list=ls())
# We can do this in a similar way
dim_in <- 10
time_in <- 20

inf<-matrix(0,time_in,dim_in)

# at time one we need to infect some sites to start

inf[1,] <- ifelse(runif(dim_in)>0.5,1,0)

# Now we have to propagate the infection

lambda = 1
mu= 0.4
for(i in 2:(time_in-1))
  for(j in 2:(dim_in-1))
  {
    if(inf[i,j]==0){

      if(inf[i,j-1]==1){
        inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
      }
      else if(inf[i,j+1]==1 ){
        inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
      }
    }
    else
    {
      inf[i+1,j] <- ifelse(runif(1)<=mu,0,1)
    }
  }
image(inf,asp=1,axes=F,col=c("grey","brown"))

# Now we do the function
rm(inf,lambda,mu,dim_in,time_in)

mu= 0.5

simulate_inf <- function(lambda,mu,dim_in,time_in){

  inf<-matrix(0,time_in,dim_in)
  inf[1,] <- ifelse(runif(dim_in)>0.5,1,0)
  for(i in 1:(time_in-1))
    for(j in 2:(dim_in-1))
    {
      if(inf[i,j]==0){

        if(inf[i,j-1]==1){
          inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
        }
        else if(inf[i,j+1]==1 ){
          inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
        }
      }
      else
      {
        inf[i+1,j] <- ifelse(runif(1)<=mu,0,1)
      }
    }
    image(inf,asp=1,axes=F,col=c("grey","brown"))
}
debug(simulateInf)
mu= 0.5

simulate_inf(.4,.4,50,100)


#We will calculate the following

# Diversity index

# shortest distance of one POI layers to other POI layer

# shortest distance to nearby road

#loading in library
library(dplyr)
library(ggplot2)
library(reshape2)
library(rgdal)
library(sf)
library(rgeos)
library(tmap)
library(RColorBrewer)

#reading the shapefile

OA.Census <- st_read("Camden/Census_OA_Shapefile.shp")
plot(OA.Census)
House.Points <- st_read("Camden/Camden_house_sales.shp")
plot(House.Points)

#calculate centroid points

cent_sf <- st_centroid(OA.Census)
cent_sf
plot(cent_sf)

tm_shape(OA.Census) +
  tm_fill("olivedrab4") +
  tm_borders("grey", lwd = 1) +
  # the points layer
  tm_shape(cent_sf) +
  tm_bubbles("Lw_Occp", title.size = "% Occupancy", col = "gold")

## now we want to estimate the distance from every house to the Centroid --> pretending that the POIs is like Metro, Bus Stop or House White :)

## we can do this separately

House.Points

plot(House.Points)

nrow(House.Points)
nrow(cent_sf)

house.cordinate <-data.frame(st_coordinates(House.Points))
cent.cordinate <-data.frame(st_coordinates(cent_sf))

head(house.cordinate)
head(cent.cordinate)

coordinates(house.cordinate) <- ~X + Y

str(house.cordinate)
class(house.cordinate)

proj4string(house.cordinate)

proj4string(house.cordinate) <- CRS("+init=epsg:27700")

class(house.cordinate)
house.cordinate <- spTransform(house.cordinate, CRS("+init=epsg:4326"))
head(house.cordinate@coords)
head(house.cordinate@coords)

coordinates(cent.cordinate) <- ~X + Y
str(cent.cordinate)
proj4string(cent.cordinate)
proj4string(cent.cordinate) <- CRS("+init=epsg:27700")
class(cent.cordinate)
cent.cordinate <- spTransform(cent.cordinate, CRS("+init=epsg:4326"))

head(cent.cordinate@coords)

plot.new()
plot(house.cordinate, col ="red")
points(cent.cordinate, col = "blue")

cent.cordinate@coords
library(geosphere)

house.cordinate@coords
cent.cordinate@coords

distance.house.cent <- distm(house.cordinate@coords[,c('X','Y')], cent.cordinate@coords[,c('X','Y')], fun=distVincentyEllipsoid)

distance.house.cent

row <- length(distance.house.cent[,1])
column <- length(distance.house.cent[1,])

x1<-matrix(double(1),nrow=row,ncol=1)
x2<-matrix(double(1),nrow=row,ncol=1)
for (i in 1:row){
  #  for (j in 1: column){
  x1[i] <- which.min(distance.house.cent[i,])
  x2[i] <- distance.house.cent[i,x1[i]]
  #  }
}
x1.x2 <- cbind(x1,x2)
head(x1.x2)

head(x1.x2[,1])
head(x1.x2[,2])

House.Points <-House.Points%>%
  mutate(cent.index = x1.x2[,1], dist.cent = x1.x2[,2])

# for calculation of the same layer

#https://www.seascapemodels.org/rstats/2020/02/08/calculating-distances-in-R.html

#https://stackoverflow.com/questions/59674971/r-for-a-dataframe-of-locations-find-the-nearest-member-from-another-dataframe

#https://stackoverflow.com/questions/21977720/r-finding-closest-neighboring-point-and-number-of-neighbors-within-a-given-rad

#---------THE END ------------- do not use the code below
# how is about to combine with original data
# cent_sf.coordinate <- cent_sf %>%
#   mutate(lat = unlist(map(cent_sf$geometry,1)),
#          lon = unlist(map(cent_sf$geometry,2)))
# # but we want to combine with the original dataset
# library(tidyverse)
# cent_sf.coordinate <- cent_sf %>%
#   mutate(lat = unlist(map(cent_sf$geometry,1)),
#          long = unlist(map(cent_sf$geometry,2)))
#
# cent_sf.coordinate
#
# House.Points <- House.Points %>%
#   mutate(lat = unlist(map(House.Points$geometry,1)),
#          long = unlist(map(House.Points$geometry,2)))

# library(geosphere)
#
# str(House.Points)
# str(cent_sf.coordinate)
#
# dist.01 <- distm(House.Points[,c('long','lat')], cent_sf.coordinate[,c('long','lat')], fun=distVincentyEllipsoid)

### Error: (list) object cannot be coerced to type 'double'
# how to fix it --> the value shall be numeric instead of double.
#x_num <- as.numeric(unlist(x))

# glimpse(House.Points)
# glimpse(cent_sf.coordinate)
#
# House.Points$lat <- as.numeric(unlist(House.Points$lat))
# House.Points$long <- as.numeric(unlist(House.Points$long))
#
# cent_sf.coordinate$lat <- as.numeric(unlist(cent_sf.coordinate$lat))
# cent_sf.coordinate$long <- as.numeric(unlist(cent_sf.coordinate$long))
#
#
# dist.01 <- distm(House.Points[,c('long','lat')], cent_sf.coordinate[,c('long','lat')], fun=distVincentyEllipsoid)


# Decision Tree regression for machine learning.
#
# Decision tree builds regression or classification models in the form of a tree
# structure. It brakes down a dataset into smaller and smaller subsets while at
# the same time an associated decision tree is incrementally developed. The final
# result is a tree with decision nodes and leaf nodes.

# Importing the data set
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Splitting the Dataset into a Training set and a Test set
# install.packages('caTools')
# library(caTools)
# set.seed(123) # choose random number, only same number for debugging
# split = sample.split(dataset$Salary, SplitRatio = 0.8)
# training_set = subset(dataset, split==TRUE)
# test_set = subset(dataset, split==FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fit Decision Tree Regression to the dataset
# install.packages('rpart')
# library(rpart)
regressor = rpart(formula = dataset$Salary ~ .,
                  data = dataset,
                  control = rpart.control(minsplit = 1))

# Predict a new result with Decision Tree Regression model
y_pred = predict(regressor, newdata = data.frame(Level = 6.5))

# HIGH RESOLUTION: Visualize graphic result of the Decision Tree Regression model
# install.packages('ggplot2')
# library(ggplot2)
x_grid = seq(min(dataset$Level), max(dataset$Level), 0.01)
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = x_grid, y = predict(regressor, newdata = data.frame(Level=x_grid))),
            colour='blue') +
  ggtitle('Truth or Bluff (Decision Tree Regression)') +
  xlab('Level') + ylab('Salary')


data =  rbind(c(38,4), c(14,7) )

print(data)
# fisher test
fisher.test(data, alternative="greater")
alpha=0.025
# as pvalue > alpha then  we conclude that there is not
#significant evidence that the proportion of patients obtaining a successful outcome
#is higher for drug PV than for drug P.


library(copent)
library(mnormt)
library(copula)

# normal distribution
n1 = 200
n2 = 300
rho1 = 0.9
rho2 = 0.5
rho3 = 0.8
mu0 = c(0,0)
mu1 = c(1,1)
sigma1 = matrix(c(1,rho1,rho1,1),2,2)
sigma2 = matrix(c(1,rho2,rho2,1),2,2)
sigma = matrix(c(1,rho3,rho3,1),2,2)
x1a = rmnorm(n1, mu0, sigma1)
x2a = rmnorm(n2, mu1, sigma2)
x3a = rnorm(n1+n2)
xa = rbind(x1a,x2a)
ya = pmnorm(xa,mu0,sigma)
rho = c(rep(rho1,n1),rep(rho2,n2)) + 0.0000005 * runif(n1+n2)
ci1a = ci(xa[,1],ya,rho)
ci2a = ci(xa[,2],ya,rho)
ci3a = ci(x3a,ya,rho)
cia = c(ci1a,ci2a,ci3a)

## plot simulated data
x11()
plot(xa, col = "white", xlab = "x1", ylab = "x2")
points(x1a, col = 2, pch = 1)
points(x2a, col = 3, pch = 2)
legend(min(xa[,1]),max(xa[,2]), legend = c(expression(paste(rho,"=0.9")),expression(paste(rho,"=0.5"))), col = c(2,3), pch = c(1,2), bg = 7)

## plot test results
x11()
names(cia) = c("x1","x2","x3")
min1 = min(cia)
if (min1>0) min1 = 0.035
xci1 = barplot(cia, col = "grey", border = "grey", ylab = "CI", ylim = c(min1-0.035, max(cia)+0.035))
text(cex = 1, x = xci1, y = cia+ sign(cia) * 0.02, labels = round(cia,digits = 4), col = "red")

## copula functions
n1 = 300
n2 = 500
theta1 = 0.3
cl1 = claytonCopula(theta1)
x1b = rCopula(n1, cl1)
theta2 = 3
cl2 = claytonCopula(theta2)
x2b = rCopula(n2, cl2)
x3b = runif(n1+n2)
xb = rbind(x1b,x2b)
fc1 = frankCopula(0.5)
yb = pCopula(xb,fc1)
theta = c(rep(theta1,n1),rep(theta2,n2)) + 0.000005 * runif(n1+n2)
ci1b = ci(yb,xb[,1],theta)
ci2b = ci(yb,xb[,2],theta)
ci3b = ci(yb,x3b,theta)
cib = c(ci1b,ci2b,ci3b)

## plot simulated data
x11()
plot(x1b, col = "white", xlab = "x1", ylab = "x2")
points(x1b, col = 2, pch = 1)
points(x2b, col = 3, pch = 2)
legend(0,1, legend = c(expression(paste(theta,"=0.3")),expression(paste(theta,"=3.0"))), col = c(2,3), pch = c(1,2), bg = 7)

## plot test results
x11()
names(cib) = c("x1","x2","x3")
min1 = min(cib)
if (min1>0) min1 = 0.035
xci1 = barplot(cib, col = "grey", border = "grey", ylab = "CI", ylim = c(min1-0.035, max(cib)+0.035))
text(cex = 1, x = xci1, y = cib+ sign(cib) * 0.02, labels = round(cib,digits = 4), col = "red")


source("read_write_data.r")
source("benchmark_analysis.r")

hypothesis_testing<-function(bench_data_src,significance){

  print(paste0("Dataset ",bench_data_src))

  b_data<-read_benchmark_data(bench_data_src)

  print("###########################################")
  print("###########################################")
  print(paste0("For a significance level of of ",significance ,", can we reject the null hypothesis that synth-validation isn't a better estimator than a specific method (the error of synth-validation is greater or equal than the error of this method)?"))

  for(i in 1:4){
    print("###########################################")
    print(paste0("method -> ",names(b_data)[2+i]))
    test<-t.test(b_data$synth_validation,b_data[,2+i],alternative = "less")
    print(test)
    res<-test$p.value
    print(paste0("significance ->",significance))
    print(paste0("p-value ->",res))
    print(paste0("rejected? ->",res<significance))
  }

  print("###########################################")
  print("###########################################")
  print(paste0("For a significance level of ",significance ,", can we reject the null hypothesis that to use synth-validation isn't any better than picking from the methods at random (synth-validation doesn't pick one of the first n best estimations more often than by picking them at random)?"))

  cumulated_picks <- get_sv_success_rate(b_data)[,3]
  k <-cumulated_picks[4]

  for(i in 1:3){
    res<-pbinom(cumulated_picks[i],k,0.25*i,lower.tail = FALSE)
    print("###########################################")
    print(paste0("n = ",i))
    print(paste0("significance ->",significance))
    print(paste0("p-value ->",res))
    print(paste0("rejected? ->",res<significance))
  }
}

hypothesis_testing("all_runs",0.05)

hypothesis_testing("benchmark_real_data_raw/all_runs_real_data_raw",0.05)

hypothesis_testing("benchmark_real_data_simulated/all_runs_real_data_simulated",0.05)

hypothesis_testing("benchmark_random_generated_data/all_runs_random_generated_data",0.05)


beta <- c(9.9029, -3.3733,  4.3080,  1.2049, -0.4126,  0.4739, -0.0366)

startDate <- as.Date("2020-3-2")

logistic <- function (x) 1 / (1 + exp(-x))
logit <- function (x) log(x / (1 - x))

pred <- function (case_ir, death_r, log_gdp_ppp, date, pop) {
  death_r <- death_r + 1e-5
  logistic(beta[1] +
           beta[2]*logit(case_ir) + beta[3]*logit(death_r) +
           (beta[4] + beta[5]*logit(case_ir) + beta[6]*logit(death_r)) * log_gdp_ppp +
           beta[7] * date/30)
}

prediction_df <- read.csv("source-data/cases_deaths_gdp.csv")
prediction_df$date <- as.Date(prediction_df$date)
prediction_df <- prediction_df[order(prediction_df$date), ]

prediction_df$day <- as.integer(prediction_df$date - startDate)

library(runner)
make_average <- function(x, n){
  temp <- x
  for(i in 1:length(x)){
    x[i] <- mean(temp[max(c(1, i-n)):min(c(length(x), i+n))], na.rm = T)
  }
  x
}

prediction_df$pred_ir <- pred(prediction_df$case_ir, prediction_df$death_r, prediction_df$log_gdp_ppp, prediction_df$day, prediction_df$population)

prediction_df$pred_ir_low <- qbinom(0.05, 1000, prediction_df$pred_ir)/1000
prediction_df$pred_ir_high <- qbinom(0.95, 1000, prediction_df$pred_ir)/1000

# prediction_df$pred_ir <- ave(prediction_df$pred_ir, prediction_df$iso3c, FUN = function(x) max_run(make_average(x, n = 5)))
# prediction_df$pred_ir_low <- ave(prediction_df$pred_ir_low, prediction_df$iso3c, FUN = function(x) max_run(make_average(x, n = 5)))
# prediction_df$pred_ir_high <- ave(prediction_df$pred_ir_high, prediction_df$iso3c, FUN = function(x) max_run(make_average(x, n = 5)))

# From predicted sero-prevalence rates, we extract implied case counts
prediction_df$pred_cases <- prediction_df$pred_ir*prediction_df$population
prediction_df$pred_cases_low <- prediction_df$pred_ir_low*prediction_df$population
prediction_df$pred_cases_high <- prediction_df$pred_ir_high*prediction_df$population

# The following five lines creates world totals:
prediction_df$world_cases <- ave(prediction_df$cases, prediction_df$date, FUN = sum)
prediction_df$pred_world_cases <- ave(prediction_df$pred_cases, prediction_df$date, FUN = sum)
prediction_df$pred_world_cases_low <- ave(prediction_df$pred_cases_low, prediction_df$date, FUN = sum)
prediction_df$pred_world_cases_high <- ave(prediction_df$pred_cases_high, prediction_df$date, FUN = sum)

# This re-produces our inset plot:
library(ggplot2)
ggplot(prediction_df[!duplicated(prediction_df$date), ],
       aes(x=as.Date(date), ymin = 0))+geom_ribbon(aes(ymax=pred_world_cases, fill = "Probably Infected, World"))+
  theme_minimal()+geom_ribbon(aes(ymin = 0, ymax = world_cases, fill = "Reported Cases, World"))+
  # geom_line(aes(y=pred_world_cases_low), col = "white")+
  # geom_line(aes(y=pred_world_cases_high), col = "black")+
  scale_y_continuous(labels = scales::comma)+
  theme(legend.title = element_blank(), legend.position = "bottom")+xlab("")+ylab("")

latest <- prediction_df[prediction_df$date == max(prediction_df$date),]

# ggplot(latest, aes(x=country,y=pred_ir)) + geom_bar(stat="identity")

# To generate the large plot, we first-differences and by continent and a select few large countries:

# These lines define our groups (colors in the large plot)
prediction_df$continents_plus <- prediction_df$continent
prediction_df$continents_plus[prediction_df$country == "United States"] <- "United States"
prediction_df$continents_plus[prediction_df$country == "China"] <- "China"
prediction_df$continents_plus[prediction_df$country == "India"] <- "India"
prediction_df$continents_plus[prediction_df$country == "Brazil"] <- "Brazil"

new_cases_fun <- function(x) {
  x <- x - c(0, x)[1:length(x)]
  # x <- make_average(x, n = 10)
  x }

# This function takes first differences by country and sums countries together by day and group:
big_chart_data <- function(prediction_df, grouping = "continent_plus"){

  prediction_df$region <- prediction_df[, grouping]

  regions <- prediction_df

  regions$region_cases <- ave(regions$cases, paste0(regions$date, "_", regions$region), FUN = sum)
  regions$pred_region_cases <- ave(regions$pred_cases, paste0(regions$date, "_", regions$region), FUN = sum)
  regions$pred_region_cases_low <- ave(regions$pred_cases_low, paste0(regions$date, "_", regions$region), FUN = sum)
  regions$pred_region_cases_high <- ave(regions$pred_cases_high, paste0(regions$date, "_", regions$region), FUN = sum)

  new_cases_fun <- function(x) {
    x <- x - c(0, x)[1:length(x)]
    x <- make_average(x, n = 7)
    x <- make_average(x, n = 7)
    x }
  regions <- regions[!duplicated(paste0(regions$date, "_", regions$region)), ]

  # regions$pred_region_cases <- ave(regions$pred_region_cases, regions$region, FUN = function(x) make_average(x, n = 10))
  # regions$pred_region_cases_low <- ave(regions$pred_region_cases_low, regions$region, FUN = function(x) make_average(x, n = 10))
  # regions$pred_region_cases_high <- ave(regions$pred_region_cases_high, regions$region, FUN = function(x) make_average(x, n = 10))

  regions$new_cases <- ave(regions$region_cases, regions$region, FUN = new_cases_fun)
  regions$new_pred_cases <- ave(regions$pred_region_cases, regions$region, FUN = new_cases_fun)
  regions$new_pred_cases_high <- ave(regions$pred_region_cases_high, regions$region, FUN = new_cases_fun)
  regions$new_pred_cases_low <- ave(regions$pred_region_cases_low, regions$region, FUN = new_cases_fun)
  return(regions)}
continents_plus <- big_chart_data(prediction_df, grouping = "continents_plus") # This runs the above function

# This reproduces our first large plot:
ggplot(continents_plus,
       aes(x=date, ymin = 0))+geom_area(aes(y=new_pred_cases, fill = continents_plus), col = "white")+
  theme_minimal()+
  #  geom_line(aes(y=new_pred_cases_high), col = "white")+
  # geom_line(aes(y=new_pred_cases_low), col = "black")+
  scale_y_continuous(labels = scales::comma)+ylab("")+
  theme(legend.title = element_blank(), legend.position = "bottom")+xlab("")


######## Simple Gaussian distribution example.
######## This script will illustrate the effect of (not) including the normalising constant c(a0).
######## It will also show the effect of various approximations to c(a0)

source("data_Gaussian.r")
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#####################
####### Posterior using unnormalised power prior
#####################

## New data
### will draw from the same process for simplicity

unnormalised.model <- stan_model("stan/simple_Gaussian_posterior_unnormalised.stan")

gs.data.forposterior <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  eta = eta,
  nu = nu,
  N = N,
  y = y
)

get_pars_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  return(list(
    alpha_n = alpha_n,
    beta_n = beta_n,
    mu_n = (k0 * m0  + a_0 * n0 * ybar)/(k0 + a_0 * n0)
  ))
}

post_pars <- get_pars_gaussian(y0 = y_0, n0 = N_0, alpha0 = alpha_0, beta0 = beta_0, m0 = mu_0, k0 = kappa_0,
                  a_0 = 1)

unnorm.posterior.gaussian <- sampling(unnormalised.model, data = gs.data.forposterior)
unnorm.posterior.gaussian
pairs(unnorm.posterior.gaussian, pars = c("a_0", "mu", "tau"))

### The approximately normalised prior

J <- 20

constant_data <- read.csv(paste("../../data/constant_data/Gaussian_logCA0_adaptive_J=", J, ".csv", sep = ""))
library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = constant_data)

approx.normalised.model <- stan_model("stan/simple_Gaussian_posterior_normalised_approximate.stan")

Ks <- c(50, 100, 1000, 10000)

get_posterior_K <- function(K){
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  gs.data.forposterior$pred_grid_x <- a0_grid$a0
  gs.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.gauss <- sampling(approx.normalised.model,
                                          data = gs.data.forposterior, refresh = 0)
  return(approx.norm.posterior.gauss)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

### Now the normalised prior
normalised.model <- stan_model("stan/simple_Gaussian_posterior_normalised.stan")

norm.posterior.gauss <- sampling(normalised.model, data = gs.data.forposterior)
norm.posterior.gauss
pairs(norm.posterior.gauss, pars = c("a_0", "mu", "tau"))

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.gaussian, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.norm <- extract(norm.posterior.gauss, 'a_0')$a_0

a0.dt <-
  rbind(
    data.frame(a0 = c(a0.unnorm, a0.norm),
               normalisation = c( rep("none", length(a0.unnorm)),
                                  rep("exact", length(a0.norm)) )
    ),
    do.call(rbind, a0.approx.list)
  )

a0.dt$normalisation <- factor(a0.dt$normalisation,
                              levels = c("none",  paste("K=", Ks, sep = ""), "exact") )

library(ggplot2)

if(copy){
  get_l_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
    nstar <- a_0 * n0
    ybar <- mean(y0)
    s <- mean( (y0-ybar)^2 )
    kappa_n <- k0 + nstar
    alpha_n <- alpha0 + nstar/2
    beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
    ans <- lgamma(alpha_n)-lgamma(alpha0)
    ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
    ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
    return(ans)
  }
  ############
  l_a0 <- function(x) {
    get_l_a0_gaussian(
      y0 = gs.data.forposterior$y0,
      n0 = gs.data.forposterior$N0,
      alpha0 = gs.data.forposterior$alpha0,
      beta0 = gs.data.forposterior$beta0,
      m0 = gs.data.forposterior$mu0,
      k0 = gs.data.forposterior$kappa0,
      a_0 = x
    )
  }
  l_a0 <- Vectorize(l_a0)

  special_marginal_a0 <- function(x, eta = 1, nu = 1, log = FALSE){
    ans <- dbeta(x, shape1 = eta, shape2 = nu, log = TRUE) + l_a0(x + 1) - l_a0(x)
    if(!log) ans <- exp(ans)
    return(ans)
  }
  K <- integrate(special_marginal_a0, 0, 1)$value
  special_marginal_a0_norm <- function(x) special_marginal_a0(x)/K
  special_marginal_a0_norm <- Vectorize(special_marginal_a0_norm)
}

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, eta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Gaussian") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 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))

if(copy) a0_dist <- a0_dist +   stat_function(fun = special_marginal_a0_norm,
                                              geom = "line", colour = "black", linetype = "solid")

a0_dist

ggsave(paste("../../figures/a0_posterior_Gaussian_J=", J, ".pdf", sep = ""), a0_dist, dpi = 300)

a0_dist_norm <- ggplot(subset(a0.dt, normalisation != "none"),
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Gaussian") +
  scale_y_continuous("Density", expand = c(0, 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))

a0_dist_norm

ggsave(paste("../../figures/a0_posterior_Gaussian_normalisation_comparison_J=", J, ".pdf", sep = ""),
       a0_dist_norm, dpi = 300)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.gaussian, 'mu')$mu,
        extract(unnorm.posterior.gaussian, 'tau')$tau)
)
names(unnorm.pars) <- c("mu", "tau")

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'mu')$mu,
          extract(x, 'tau')$tau)
  )
  names(pars) <- c("mu", "tau")
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

#
norm.pars <- as.data.frame(
  cbind(extract(norm.posterior.gauss, 'mu')$mu,
        extract(norm.posterior.gauss, 'tau')$tau)
)
names(norm.pars) <- c("mu", "tau")

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "none"
norm.dt <- melt(norm.pars, variable.name = "parameter", value.name = "sample")
norm.dt$normalisation <- "exact"
posterior.dt <- rbind(unnorm.dt, norm.dt, do.call(rbind, app.norm.pars.df.list))

posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("none",  paste("K=", Ks, sep = ""), "exact") )

###

post.pars <- get_pars_gaussian(y0 = y_0, n0 = N_0, alpha0 = alpha_0,
                               beta0 = beta_0, m0 = mu_0, k0 = kappa_0,
                               a_0 = .95)

post.means <- data.frame(parameter = names(norm.pars), value = c(post.pars$mu_n, post.pars$alpha_n/post.pars$beta_n))

parameter_posteriors <- ggplot(data = posterior.dt,
                               aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free", labeller = label_parsed) +
  # geom_vline(data = post.means, aes(xintercept = value), linetype = "dashed") +
  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))

parameter_posteriors

ggsave(filename = paste("../../figures/parameter_posterior_Gaussian_J=", J, ".pdf", sep = ""),
       plot = parameter_posteriors, dpi = 300)


# Load the tidyverse
library(tidyverse)

# Read in the dataset
argentina <- read_csv("datasets/argentina.csv")

# Inspect the first rows of the dataset
nrow(argentina)
head(argentina)

# Add gdp_per_capita column to argentina
argentina <- argentina %>%
  mutate(gdp_per_cap = gdp / pop)

# Find the four richest provinces
( rich_provinces  <- argentina %>%
 arrange(desc(gdp_per_cap)) %>%
 select(province, gdp_per_cap) %>%
 top_n(4))

# Find the provinces with populations over 1 million
( bigger_pops <- argentina %>%
 arrange(desc(pop)) %>%
 select(province, pop) %>%
 filter(pop >= 1000000))

# Select numeric columns and cast to matrix
argentina_matrix  <- argentina  %>%
  select_if(is.numeric) %>%
  as.matrix()

# Print the first lines of the result
head(argentina_matrix)

# Load FactoMineR
library(FactoMineR)

# Apply PCA and print results
( argentina_pca  <- PCA(argentina_matrix, scale.unit = TRUE) )

# Load factoextra
library(factoextra)
# Set the size of plots in this notebook
options(repr.plot.width=7, repr.plot.height=5)

# Plot the original variables and the first 2 components and print the plot object.
( pca_var_plot <- fviz_pca_var(argentina_pca) )

( argentina_pca$eig )

# Sum the variance preserved by the first two components. Print the result.
( variance_first_two_pca <- argentina_pca$eig[1, 2] + argentina_pca$eig[2, 2] )

# Visualize Dim2 vs. Dim1
fviz_pca_ind(argentina_pca, title = "Provinces - PCA")

student_plot <- last_plot()
soln_plot <- fviz_pca_ind(soln_argentina_pca, title = "Provinces - PCA")

# Set seed to 1234 for reproducibility
set.seed(1234)

# Create an intermediate data frame with pca_1 and pca_2
argentina_comps <- tibble(pca_1 = argentina_pca$ind$coord[ ,1],
                          pca_2 = argentina_pca$ind$coord[ ,2])

# Cluster the observations using the first 2 components and print its contents
( argentina_km <- kmeans(argentina_comps, centers = 4, nstart = 20, iter.max = 50) )

# Convert assigned clusters to factor
clusters_as_factor <- factor(argentina_km$cluster)

# Plot individulas colored by cluster
fviz_pca_ind(argentina_pca,
             title = "Clustered Provinces - PCA",
             habillage = clusters_as_factor)

# Load ggrepel
library(ggrepel)

# Add cluster column to argentina
argentina <- argentina %>%
               mutate(cluster=clusters_as_factor)

# Make a scatterplot of gdp vs. cluster, colored by cluster
ggplot(argentina, aes(cluster, gdp, color = cluster)) +
  geom_point() +
  geom_text_repel(aes(label = province), show.legend = FALSE) +
  labs(x = "Cluster", y = "GDP")

# Make a scatterplot of GDP per capita vs. cluster, colored by cluster
ggplot(argentina, aes(cluster, gdp_per_cap, color = cluster)) +
  geom_point() +
  geom_text_repel(aes(label = province), show.legend = FALSE) +
  labs(x = "Cluster", y = "GDP per capita")

# Make scatterplot of poverty vs. cluster, colored by cluster
ggplot(argentina, aes(cluster, poverty, color = cluster)) +
  geom_point() +
  labs(x = "Cluster", y = "Poverty rate") +
  geom_text_repel(aes(label = province), show.legend = FALSE)

# Assign pilot provinces to the most diverse group
pilot_provinces <- 3

09. Planning Public Policy in Argentina.r


customer_data = read.csv("C:/Users/abhay/OneDrive/Desktop/customer-segmentation-dataset/Mall_Customers.csv")

str(customer_data)

names(customer_data)

head(customer_data)

summary(customer_data$Age)

summary(customer_data$Annual.Income)

sd(customer_data$Age)

sd(customer_data$Annual.Income)

summary(customer_data$Age)

sd(customer_data$Spending.Score)

#customer Gender visualization
cus_gender_vis=table(customer_data$Gender)
barplot(a,main="Using BarPlot to display Gender Comparision",
       ylab="Count",
       xlab="Gender",
       col=rainbow(2),
       legend=rownames(cus_gender_vis))

#Ratio of male and female through piechart
install.packages('plotrix')
piechart=round(a/sum(a)*100)
lbs=paste(c("Female","Male")," ",piechart,"%",sep=" ")
library(plotrix)
pie3D(a,labels=lbs,
   main="Pie Chart Depicting Ratio of Female and Male")

#Visualization based on Age
hist(customer_data$Age,
    col="green",
    main="Histogram to Show Count of Age Class",
    xlab="Age Class",
    ylab="Frequency",
    labels=TRUE)

#boxplot visualization to check the range of age
boxplot(customer_data$Age,
       col="yellow",
       main="Descriptive Analysis of Age through Boxplot")

#analysis of annual income of customers
hist(customer_data$Annual.Income,
  col="red",
  main="Histogram for Annual Income",
  xlab="Annual Income Class",
  ylab="Frequency",
  labels=TRUE)

#density plot
plot(density(customer_data$Annual.Income),
    col="yellow",
    main="Density Plot for Annual Income of customers",
    xlab="Annual Income Class",
    ylab="Density")
polygon(density(customer_data$Annual.Income..k..),
        col="blue")

#Analysing spending scores of customers
summary(customer_data$Spending.Score)

hist(customer_data$Spending.Score,
  col="black",
  main="Histogram for Spending Score",
  xlab="Spending Score Class",
  ylab="Frequency",
  labels=TRUE)

#boxplot for spending scores
boxplot(customer_data$Spending.Score,
   horizontal=TRUE,
   col="orange",
   main="BoxPlot for Descriptive Analysis of Spending Score")

#machine learning models
#k-means algorithm
#For value of k
# Elbow method
install.packages('purrr')
library(purrr)
set.seed(123)
# function to calculate total intra-cluster sum of square
iss <- function(k) {
  kmeans(customer_data[,3:5],k,iter.max=100,nstart=100,algorithm="Lloyd" )$tot.withinss
}
k.values <- 1:10
iss_values <- map_dbl(k.values, iss)
plot(k.values, iss_values,
    type="b", pch = 19, frame = FALSE,
    xlab="Number of clusters K for given dataset",
    ylab="Total intra-clusters sum of squares")

# From above graph we can conclude that 4 is appropriate value of K
#Average Silhouette Method
#installing package cluster
install.packages('cluster')
library(cluster)

#installing package gridExtra
install.packages('gridExtra')
library(gridExtra)

#installing package grid
install.packages('grid')
library(grid)

k2 <- kmeans(customer_data[,3:5],2,iter.max=100,nstart=50,algorithm="Lloyd")
s2 <- plot(silhouette(k2$cluster,dist(customer_data[,3:5],"euclidean")))

k3 <- kmeans(customer_data[,3:5],3,iter.max=100,nstart=50,algorithm="Lloyd")
s3 <- plot(silhouette(k3$cluster,dist(customer_data[,3:5],"euclidean")))

k4 <- kmeans(customer_data[,3:5],4,iter.max=100,nstart=50,algorithm="Lloyd")
s4 <- plot(silhouette(k4$cluster,dist(customer_data[,3:5],"euclidean")))

k5 <- kmeans(customer_data[,3:5],5,iter.max=100,nstart=50,algorithm="Lloyd")
s5 <- plot(silhouette(k5$cluster,dist(customer_data[,3:5],"euclidean")))

k6 <- kmeans(customer_data[,3:5],6,iter.max=100,nstart=50,algorithm="Lloyd")
s6 <- plot(silhouette(k6$cluster,dist(customer_data[,3:5],"euclidean")))

k7 <- kmeans(customer_data[,3:5],7,iter.max=100,nstart=50,algorithm="Lloyd")
s7 <- plot(silhouette(k7$cluster,dist(customer_data[,3:5],"euclidean")))

k8 <- kmeans(customer_data[,3:5],8,iter.max=100,nstart=50,algorithm="Lloyd")
s8 <- plot(silhouette(k8$cluster,dist(customer_data[,3:5],"euclidean")))

k9 <- kmeans(customer_data[,3:5],9,iter.max=100,nstart=50,algorithm="Lloyd")
s9 <- plot(silhouette(k9$cluster,dist(customer_data[,3:5],"euclidean")))

k10 <- kmeans(customer_data[,3:5],10,iter.max=100,nstart=50,algorithm="Lloyd")
s10 <- plot(silhouette(k10$cluster,dist(customer_data[,3:5],"euclidean")))

#installing and loading package ggplot2
install.packages('ggplot2')
library(ggplot2)

#installing and loading package NbClust
install.packages('NbClust')
library(NbClust)

#installing and loading package "FactoMineR"
install.packages("FactoMineR")
library(FactoMineR)

#installing and loading package faceoextra
install.packages("factoextra")
library(factoextra)

fviz_nbclust(customer_data[,3:5], kmeans, method = "silhouette")

#Gap Statistic method to calculate k
set.seed(125)
statistic_gap <- clusGap(customer_data[,3:5], FUN = kmeans, nstart = 25,
            K.max = 10, B = 50)
fviz_gap_stat(statistic_gap)

k6 <- kmeans(customer_data[,3:5],6,iter.max=100,nstart=50,algorithm="Lloyd")
k6

#From above available components
#cluster – vector denoting the cluster which has an allocation of each point.
#totss – representing the total sum of squares.
#centers – Matrix comprising of several cluster centers
#withinss – vector representing the intra-cluster sum of squares having one component per cluster.
#tot.withinss – denoting the total intra-cluster sum of squares.
#betweenss – representing the sum of between-cluster squares.
#size – total number of points that each cluster holds.

#Using two principle component visualize the clustering results

principle_component_clust <- prcomp(customer_data[,3:5],scale=FALSE)
summary(principle_component_clust)

#using first two principle component
principle_component_clust$rotation[,1:2]

#segmentation of customers for given data
#Visualization of clustering based on Annual income and spending score
set.seed(1)
ggplot(customer_data, aes(x =Annual.Income..k.., y = Spending.Score..1.100.)) +
  geom_point(stat = "identity", aes(color = as.factor(k6$cluster))) +
  scale_color_discrete(name=" ",
                       breaks=c("1", "2", "3", "4", "5","6"),
              labels=c("Customer_Cluster 1", "Customer_Cluster 2", "Customer_Cluster 3", "Customer_Cluster 4", "Customer_Cluster 5","Customer_Cluster 6")) +
  ggtitle("Segmentation of Customers for given Dataset", subtitle = "Using K-means Clustering Algorithm")

#segmentation of customers for given data
#Visualization of clustering based on Annual income and Age
set.seed(1)
ggplot(customer_data, aes(x = Spending.Score..1.100., y=Age)) +
  geom_point(stat = "identity", aes(color = as.factor(k6$cluster))) +
  scale_color_discrete(name=" ",
                       breaks=c("1", "2", "3", "4", "5","6"),
              labels=c("Customer_Cluster 1", "Customer_Cluster 2", "Customer_Cluster 3", "Customer_Cluster 4", "Customer_Cluster 5","Customer_Cluster 6")) +
  ggtitle("Segmentation of Customers for given Dataset", subtitle = "Using K-means Clustering Algorithm")

kCols=function(vec){cols=rainbow (length (unique (vec)))
return (cols[as.numeric(as.factor(vec))])}

# K-means clusters
digCluster <- k6$cluster;
dignm <- as.character(digCluster);

plot(principle_component_clust$x[,1:2], col =kCols(digCluster),pch =19,xlab ="K-means",ylab="classes")
legend("topright",unique(dignm),fill=unique(kCols(digCluster)))

Use of machine learning in customer segmentation.r


# Packages
library(tidyverse)  # data manipulation and visualization
library(modelr)     # provides easy pipeline modeling funinstactions
library(broom)      # helps to tidy up model outputs

advertising <- read_csv("https://raw.githubusercontent.com/justmarkham/scikit-learn-videos/master/data/Advertising.csv") %>%
  select(-"X1")

head(advertising)

set.seed(42)
sample <- sample(c(TRUE, FALSE), nrow(advertising), replace = T, prob = c(0.6,0.4))

train <- advertising[sample, ]
test <- advertising[!sample, ]

dim(train)
dim(test)

model1 <- lm(Sales ~ TV, data = train)

ggplot(train, aes(TV, Sales)) +
  geom_point() +
  geom_smooth(method = "lm")

test <- test %>%
  add_predictions(model1)

head(test)

rsquare(model1, data=test)


# Goal: Standard computations with well-studied distributions.

# The normal distribution is named "norm". With this, we have:

# Normal density
dnorm(c(-1.96,0,1.96))

# Cumulative normal density
pnorm(c(-1.96,0,1.96))

# Inverse of this
qnorm(c(0.025,.5,.975))
pnorm(qnorm(c(0.025,.5,.975)))

# 1000 random numbers from the normal distribution
summary(rnorm(1000))

# Here's the same ideas, for the chi-squared distribution with 10 degrees
# of freedom.
dchisq(c(0,5,10), df=10)

# Cumulative normal density
pchisq(c(0,5,10), df=10)

# Inverse of this
qchisq(c(0.025,.5,.975), df=10)

# 1000 random numbers from the normal distribution
summary(rchisq(1000, df=10))

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


# 스칼라

c(1) # c는 소문자로 쓴다
C(1)

# 벡터 (c)- 숫자형

num <- c(1,2,3,4) # c(1:4)
numT <- t(num) # 열벡터를 행벡터로 변환
View(num) # 데이터 보기
View(numT)
num %*% numT # 벡터곱셈(4*1 x 1*4) = 4*4
numT %*% num # 벡터곱셈(1*4 x 4*1) = 1*1)

# 문자형, 논리형

c("m","F","F","M")
c(TRUE, FALSE, FALSE, TRUE)

m <- 1:12
m <- c(1,2,3,4,5,6,7,8,9,10,11,12)
m

# 행렬 (Matrix 4X3)
mtx <- matrix(m, nrow=4)  #  (m을 가지고 하는데, 4개 열을 만들겠다.  nrow, ncol)
mtx

mtx[3,2] #3열 2행을 출력하라

# 배열 (array 2X3X2) # 열, 행, 깊이

arr <- array(m, c(2,3,2))
arr

# 데이터 프레임 (Data Frame)

var1 <- c(1,2,3,4)
var2 <- factor(c("M","F","F","M"))  # factor로 해야 그룹변수로 인식한다. 나중에 lable 명령어도 있다.
df = data.frame(id = var1, sex = var2)
df
str(df)

# 나중에 데이터에서 변수를 뽑아올 때에는 $표시를 한다. date.frame의 변수를 읽는 기본 구조

# 리스트

v1 <- c(1,2,3,4)
v2 <- matrix(1:12, nrow=4)
v3 <- array(1:12, c(2,3,2))
v4 <- data.frame(id = c(1,2,3,4), sex = c("M","F","F","M"))
lt <- list(v1, v2, v3, v4)
lt

str(lt) #str : 데이터 구조를 보여주어라 . [] 벡터와 행렬, [[]] 리스트 형태의 데이터이다.

ch02 - 데이터 구조 및 입력/데이터구조.r

ch02 - 데이터 구조 및 입력/데이터구조.r

ch02 - 데이터 구조 및 입력/데이터구조.r


# Example : 1   Chapter : 6.3     Page No: 313
# Solve Differential equation

# lambda1,lamda2,x1,x2,c,d are computed here.. for remaining details look textbook
A<-matrix(c(0,1,1,0),ncol=2)
lambda<-eigen(A)$values
x<-eigen(A)$vectors #These are normalised eigen vectors
#to get eigen vectors in textbook .. Multiply them with the scalars
x[,1]<-x[,1]*(1/x[1,1])
x[,2]<-x[,2]*(1/x[1,2])
print(x)
u<-c(4,2)
cd<-solve(x,u)
C<-cd[1]
D<-cd[2]
print("Lambda 1 and Lambda 2")
print(lambda)
print("x1 and x2")
print(x)
print("C and D are")
print(C)
print(D)


#' crib_fun
#' converts a vector of [0,1] values to (0,1) a la Cribari-Neto & Zeileis 2010
#' @param x a vector of values on the interval [0,1]
#' @param N alternative sample size. This is useful when tranforming a matrix in the dirchlet case, rather than just a vector as in the beta case.
#'
#' @return  a vector of values on the interval (0,1)
#' @export
#'
#' @examples
crib_fun <- function(x,N = NA){
  #default use length of vector.
  if( is.na(N)){
    out <- (x * (length(x) - 1) + 0.5) / length(x)
  }
  #custom- useful when I am in multivariate case.
  if(!is.na(N)){
    out <- (x * (N - 1) + 0.5) / N
  }
  return(out)
}


#getwd()
#setwd("./1S")
library(readxl)
library(dplyr)
library(openxlsx)
library(moments)

getwd()

par(mfrow = c(1, 1))

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

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

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

tail(data)

data.A = data %>% filter(vyrobce=="Amber")
data.A = data.A[-1]

sumarizace_5C = data.A %>%
    summarise(name="      5C",
        rozsah=sum(!is.na(C5)),
        minimum=round(min(C5,na.rm=T),digits=1),
        dolni_kvartil=round(quantile(C5,0.25,na.rm=T),digits=1),
        median=round(median(C5,na.rm=T),digits=1),
        prumer=round(mean(C5,na.rm=T),digits=1),
        horni_kvartil=round(quantile(C5,0.75,na.rm=T),digits=1),
        maximum=round(max(C5,na.rm=T),digits=1),
        #rozptyl=round(var(C5,na.rm=T),digits=1),
        smerodatna_odchylka=ceiling(sd(C5,na.rm=T)*10)/10,
        variacni_koeficient=round((100*(smerodatna_odchylka/prumer)),digits=1),
        sikmost=round((moments::skewness(C5,na.rm=T)),digits=1),
        spicatost=round((moments::kurtosis(C5,na.rm=T)-3),digits=1),
        dolni_mez = round(dolni_kvartil - 1.5*(horni_kvartil - dolni_kvartil),digits=1),
        horni_mez = round(horni_kvartil + 1.5*(horni_kvartil - dolni_kvartil),digits=1))

sumarizace_22C = data.A %>%
    summarise(name="      22C",
        rozsah=sum(!is.na(C22)),
        minimum=round(min(C22,na.rm=T),digits=1),
        dolni_kvartil=round(quantile(C22,0.25,na.rm=T),digits=1),
        median=round(median(C22,na.rm=T),digits=1),
        prumer=round(mean(C22,na.rm=T),digits=1),
        horni_kvartil=round(quantile(C22,0.75,na.rm=T),digits=1),
        maximum=round(max(C22,na.rm=T),digits=1),
        #rozptyl=round(var(C22,na.rm=T),digits=1),
        smerodatna_odchylka=ceiling(sd(C22,na.rm=T)*10)/10,
        variacni_koeficient=round((100*(smerodatna_odchylka/prumer)),digits=1),
        sikmost=round((moments::skewness(C22,na.rm=T)),digits=1),
        spicatost=round((moments::kurtosis(C22,na.rm=T)-3),digits=1),
        dolni_mez = round(dolni_kvartil - 1.5*(horni_kvartil - dolni_kvartil),digits=1),
        horni_mez = round(horni_kvartil + 1.5*(horni_kvartil - dolni_kvartil),digits=1))

data.A_bezOP = data.A
# nastavíme hodnoty které jsou mimo meze na NA
data.A_bezOP$C5[data.A_bezOP$C5 >= sumarizace_5C$horni_mez |
    data.A_bezOP$C5 <= sumarizace_5C$dolni_mez] = NA
data.A_bezOP$C22[data.A_bezOP$C22 >= sumarizace_5C$horni_mez |
    data.A_bezOP$C22 <= sumarizace_5C$dolni_mez] = NA

sumarizace_5C_bezOP = data.A_bezOP %>%
    summarise(name="   5C_bezOP",
        rozsah=sum(!is.na(C5)),
        minimum=round(min(C5,na.rm=T),digits=1),
        dolni_kvartil=round(quantile(C5,0.25,na.rm=T),digits=1),
        median=round(median(C5,na.rm=T),digits=1),
        prumer=round(mean(C5,na.rm=T),digits=1),
        horni_kvartil=round(quantile(C5,0.75,na.rm=T),digits=1),
        maximum=round(max(C5,na.rm=T),digits=1),
        #rozptyl=round(var(C5,na.rm=T),digits=1),
        smerodatna_odchylka=ceiling(sd(C5,na.rm=T)*10)/10,
        variacni_koeficient=round((100*(smerodatna_odchylka/prumer)),digits=1),
        sikmost=round((moments::skewness(C5,na.rm=T)),digits=1),
        spicatost=round((moments::kurtosis(C5,na.rm=T)-3),digits=1),
        dolni_mez = round(dolni_kvartil - 1.5*(horni_kvartil - dolni_kvartil),digits=1),
        horni_mez = round(horni_kvartil + 1.5*(horni_kvartil - dolni_kvartil),digits=1))

sumarizace_22C_bezOP = data.A_bezOP %>%
    summarise(name="  22C_bezOP",
        rozsah=sum(!is.na(C22)),
        minimum=round(min(C22,na.rm=T),digits=1),
        dolni_kvartil=round(quantile(C22,0.25,na.rm=T),digits=1),
        median=round(median(C22,na.rm=T),digits=1),
        prumer=round(mean(C22,na.rm=T),digits=1),
        horni_kvartil=round(quantile(C22,0.75,na.rm=T),digits=1),
        maximum=round(max(C22,na.rm=T),digits=1),
        #rozptyl=round(var(C22,na.rm=T),digits=1),
        smerodatna_odchylka=ceiling(sd(C22,na.rm=T)*10)/10,
        variacni_koeficient=round((100*(smerodatna_odchylka/prumer)),digits=1),
        sikmost=round((moments::skewness(C22,na.rm=T)),digits=1),
        spicatost=round((moments::kurtosis(C22,na.rm=T)-3),digits=1),
        dolni_mez = round(dolni_kvartil - 1.5*(horni_kvartil - dolni_kvartil),digits=1),
        horni_mez = round(horni_kvartil + 1.5*(horni_kvartil - dolni_kvartil),digits=1))

sumarizace2 = rbind(sumarizace_5C,sumarizace_22C,sumarizace_5C_bezOP,sumarizace_22C_bezOP)
sumarizace <- data.frame(t(sumarizace2[-1]))
colnames(sumarizace) <- sumarizace2[, 1]
rownames(sumarizace) <- c("rozsah souboru","minimum","dolní kvartil","medián","průměr","horní kvartil","maximum","směrodatná odchylka","variační koeficient (%)","šikmost","špičatost","dolní mez","horní mez")
sumarizace

data.A_boxplot = data.A
colnames(data.A_boxplot) = c("5 stupňů","22 stupňů")
boxplot(data.A_boxplot,ylab="světelný tok (lm)",main="Boxploty světelnosti, výrobce Amber")

data_A_C5_bezOP = na.omit(data.A_bezOP$C5)
data_A_C22_bezOP = na.omit(data.A_bezOP$C22)

min_x = min(c(data_A_C5_bezOP),c(data_A_C22_bezOP))*0.99
max_x = max(c(data_A_C5_bezOP),c(data_A_C22_bezOP))*1.01
min_y = 0
max_y = max(hist(data_A_C5_bezOP,breaks=10)$counts,hist(data_A_C22_bezOP,breaks=10)$counts)*1.05

hist = hist(data_A_C5_bezOP,
     main="Histogram při 5 stupních, výrobce Amber",
     xlab="Lumeny",
     ylab="Četnost",
     xlim = c(min_x,max_x),
     ylim = c(min_y,max_y),
     breaks=10)

hist = hist(data_A_C22_bezOP,
     main="Histogram, světelnost při 22 stupních, výrobce Amber",
     xlab="Lumeny",
     ylab="Četnost",
     xlim = c(min_x,max_x),
     ylim = c(min_y,max_y),
     breaks=10)

qqnorm(data_A_C5_bezOP,
       xlab="Teoretické kvantily",
       ylab="Výběrové kvantily",
       main="QQ-graf, světelnost při 5 stupních, výrobce Amber")
qqline(data_A_C5_bezOP)

qqnorm(data_A_C22_bezOP,
       xlab="Teoretické kvantily",
       ylab="Výběrové kvantily",
       main="QQ-graf, světelnost při 22 stupních, výrobce Amber")
qqline(data_A_C22_bezOP)

skewness(data_A_C5_bezOP)
kurtosis(data_A_C5_bezOP) - 3 # jiná definice posunutá o 3
mu = mean(data_A_C5_bezOP)
sigma = sd(data_A_C5_bezOP)
paste0("<", round(mu - 2*sigma,digits=1), ", ", round(mu + 2*sigma,digits=1), ">")

skewness(data_A_C22_bezOP)
kurtosis(data_A_C22_bezOP) - 3 # jiná definice posunutá o 3
mu = mean(data_A_C22_bezOP)
sigma = sd(data_A_C22_bezOP)
paste0("<", round(mu - 2*sigma,digits=1), ", ", round(mu + 2*sigma,digits=1), ">")


library("ensembleBMA")
library("ensembleMOS")
library("crch")
library("gamlss")
library("SpecsVerification")
library("scoringRules")

### MOS
## Data Prep
# Load the data into R
data("temp", package = "ensemblepp")
# Set the dates as rownames
temp$date<- as.Date(rownames(temp))
# Subset the data to include only data from Dec, Jan, and Feb
temp<- temp[format(temp$date, "%m") %in% c("12", "01", "02"),]
# Calculate the ensemble mean and standard deviation
temp$ensmean<- apply(temp[,2:12], 1, mean)
temp$enssd<- apply(temp[,2:12], 1, sd)
# Split the date into training and testing sets
temptrain<- temp[temp$date<"2010-03-01",]
temptest<- temp[temp$date>= "2010-03-01",]
# Plot the observations vs the ensemble mean of the fx
plot(temp~ensmean, data = temptrain)
abline(0, 1, lty = 2)

## MOS Model Fitting
# Fit a linear regression to the ensemble mean
MOS<- lm(temp~ensmean, data = temptrain)
abline(MOS)
# Generate MOS predictions
fcMOS<- predict(MOS, newdata = temptest)
plot(fcMOS[1:20], type = "l", lty = 2, ylab = "2m temperature",
    xlab = "date", xaxt = "n", ylim = c(-35, 10))
axis(1, at = seq(1,20,6), temptest$date[seq(1, 20, 6)])

lines(temptest$temp[1:20])
lines(temptest$ensmean[1:20], lty = 3)

## Verification
rbind(raw = c(BIAS = mean(temptest$ensmean-temptest$temp),
        MAE = mean(abs(temptest$ensmean - temptest$temp)),
        RMSE = sqrt(mean((temptest$ensmean - temptest$temp)^2))),
    MOS = c(BIAS = mean(fcMOS-temptest$temp),
        MAE = mean(abs(fcMOS - temptest$temp)),
        RMSE = sqrt(mean((fcMOS - temptest$temp)^2))))

### Univariate Ensemble Postprocessing
# Put the train and test data into "ensembleData" objects
temptrain_eD<- ensembleData(forecasts = temptrain[,2:12],
    dates = temptrain$date, observations = temptrain$temp,
    forecastHour = 24, initializationTime = "00", exchangeable = rep(1, 11))
temptest_eD<- ensembleData(forecasts = temptest[,2:12],
    dates = temptest$date, observations = temptest$temp,
    forecastHour = 24, initializationTime = "00", exchangeable = rep(1, 11))
# Plot a verification rank histogram
rank<- apply(temptrain[, 1:12], 1, rank)[1,]
hist(rank, breaks = 0:12 + 0.5, main = "Verification Rank Histogram")
# Plot a boxplot of absolute forecast errors
sdcat<- cut(temptrain$enssd,
    breaks = quantile(temptrain$enssd, seq(0, 1, 0.2)))
boxplot(abs(residuals(MOS))~sdcat, ylab = "absolute error",
    xlab = "ensemble standard deviation", main = "Spread-Skill")

## Fit a NGR Model
# Carry out maximum likelihood estimation of model coefficients
# using two different R packages "crch" and "gamlss"
NGR_crch<- crch(temp~ensmean|enssd, data = temptrain)
NGR_gamlss<- gamlss(temp~ensmean, sigma.formula =~enssd, data = temptrain)
# crch() can also be used to fit models with minimum CRPS estimatio and
# sigma parameterization
NGR_crch2<- crch(temp~ensmean|I(enssd^2), data = temptrain,
    link.scale = "quad", type = "crps")
# fitMOS() also provides another implementation of this model althought
# it requires an "ensembleData" object as input
NGR_ensembleMOS<- fitMOS(temptrain_eD, model = "normal")
# We can access the coefficients with where NGR_ensembleMOS$B is actually
# a vector of coefficients -- one for each ensemble member -- but since
# the ensemble members are considered interchangable all of these
# coefficients equal 1/11
coef_ensembleMOS<- c(NGR_ensembleMOS$a, 11 * NGR_ensembleMOS$B[1],
    NGR_ensembleMOS$c, NGR_ensembleMOS$d)
# We can compare the model coefficients produced using the different methods
rbind(crch = coef(NGR_crch),
    gamlss = c(coef(NGR_gamlss), coef(NGR_gamlss, what = "sigma")),
    ensembleMOS = coef_ensembleMOS, crch2 = coef(NGR_crch2))

## Fit a BMA and other ensemble dressing models
BMA<- fitBMA(temptrain_eD, model = "normal")
smuy2<- var(MOS$residuals)
st2<- mean(temptrain$enssd^2)
dress<- sqrt(smuy2 - (1 + 1/8) * st2)
# Compare BMA and ensemble dressing
rbind(BMA = c(BMA$biasCoefs[,1], BMA$sd), ensdress = c(coef(MOS), sd = dress))

## Fit an affine kernel dressing model
AKD<- FitAkdParameters(ens = as.matrix(temptrain[,2:12]),obs = temptrain$temp)

## Prediction
# Get the "location" and "scale" parameters
mean_NGR<- predict(NGR_crch,  newdata = temptest, type = "location")
sd_NGR<- predict(NGR_crch,  newdata = temptest, type = "scale")
mean_NGR2<- predict(NGR_crch2, newdata = temptest, type = "location")
sd_NGR2<- predict(NGR_crch2, newdata = temptest, type = "scale")
# Compute the predictive densities and probabilities
x<- seq(-10, 10, 0.1)
pdf_NGR<- dnorm(x, mean_NGR[1], sd_NGR[1])
cdf_NGR<- pnorm(0, mean_NGR, sd_NGR)
# Generate the predictive quantiles 0.25, 0.5, and 0.75 for all dates in the test set
quant_NGR<- predict(NGR_crch, newdata = temptest, type = "quantile", at = c(0.25, 0.5, 0.75))
# For BMA and the other ensemble dressing techniques,
# we first need the corrected ensemble forecasts
corrected_BMA<- apply(temptest[,2:12], 2, function(x) BMA$biasCoefs[,1] %*% rbind(1, x))
corrected_dress<- apply(temptest[,2:12], 2, function(x) coef(MOS) %*% rbind(1, x))
AKDobj<- DressEnsemble(ens = as.matrix(temptest[2:12]),
    dressing.method = "akd", parameters = as.list(AKD))
dressobj<- list(ens = corrected_dress,
    ker.wd = matrix(dress, nrow = nrow(corrected_dress), ncol = 11))
# Calculate the probabilities and quantiles
cdf_BMA<- cdf(BMA, temptest_eD, values = 0)
cdf_AKD<- rowMeans(pnorm(0,  AKDobj$ens,  AKDobj$ker.wd))
cdf_dress<- rowMeans(pnorm(0, dressobj$ens, dressobj$ker.wd))

# Plot the densities for all methods
par(mfrow = c(1,4))
plot(x, pdf_NGR, type = "l", xlab = "Temperature", ylab = "Density", lwd = 3, main = "NGR")
abline(v = temptest$temp[1], col = "orange", lwd = 3)
plot(BMA, temptest_eD[1,])
title(main = "BMA")
plot(density(dressobj$ens[1,], bw = dressobj$ker.wd[1, 1]),
    xlab= "Temperature", main = "ensemble dressing", lwd = 3)
abline(v = temptest$temp[1], col = "orange", lwd = 3)
plot(density(AKDobj$ens[1,], bw = AKDobj$ker.wd[1, 1]),
    xlab = "Temperature", main = "AKD", lwd = 3)
abline(v = temptest$temp[1], col = "orange", lwd = 3)

# Plot multiple time periods
par(mfrow = c(1,2))
plot(quant_NGR[1:20, 2], type = "l", lty = 2, ylab = "2m temperature",
    xlab = "date", xaxt = "n", ylim = c(-15, 10))
axis(1, at = seq(1, 20, 6), temptest$date[seq(1, 20, 6)])
polygon(c(1:20, 20:1), c(quant_NGR[1:20, 1], quant_NGR[20:1, 3]),
    col = gray(0.1, alpha = 0.1), border = FALSE)
lines(temptest$temp[1:20])
plot(cdf_NGR[1:20], type = "l", ylab = "Pr(T<0)",
    xlab = "date", xaxt = "n", ylim = c(0, 1))
axis(1, at = seq(1, 20, 6), temptest$date[seq(1, 20, 6)])
points(temptest$temp<0)

## Verification
# Calculate the CRPS
crps_all<- cbind(
    NGR1 = scoringRules::crps(temptest$temp, family = "normal",
        mean = mean_NGR, sd = sd_NGR),
    NGR2 = scoringRules::crps(temptest$temp, family = "normal",
        mean = mean_NGR2, sd = sd_NGR2),
    BMA  = ensembleBMA::crps(BMA, temptest_eD)[, 2],
    dress = DressCrps(dressobj, temptest$temp),
    AKD  = DressCrps(AKDobj, temptest$temp))
# Compute the average CRPS on 250 bootstrap samples
bootmean<- function(scores, nsamples = 250) {
    boot<- NULL
    for(i in 1:nsamples) {
        bindex<- sample(nrow(scores), replace = TRUE)
        boot<- rbind(boot, colMeans(scores[bindex,]))
        }
        boot
}
# Plot all the bootstrap means of the CRPS using a boxplot
boxplot(bootmean(crps_all), ylab = "CRPS")
# Compute the predictive log-density
ign_all<- cbind(
    NGR1 = -dnorm(temptest$temp, mean_NGR, sd_NGR, log = TRUE),
    NGR2 = -dnorm(temptest$temp, mean_NGR2, sd_NGR2, log = TRUE),
    BMA  = -log(rowSums(BMA$weights * dnorm(temptest$temp, corrected_BMA, BMA$sd))),
    dress = -log(rowMeans(dnorm(temptest$temp, dressobj$ens, dressobj$ker.wd))),
    AKD  = -log(rowMeans(dnorm(temptest$temp, AKDobj$ens, AKDobj$ker.wd))))
# Plot all the bootstrap means of the log-density using a boxplot
boxplot(bootmean(ign_all), ylab = "IS")

# Probability Integral Transforms (PITs) can be used to assess the reliability
# (i.e., calibration) of continuous probabilistic forecasts
pit<- cbind(
    NGR1 = pnorm(temptest$temp, mean_NGR, sd_NGR),
    NGR2 = pnorm(temptest$temp, mean_NGR2, sd_NGR2),
    BMA  = pit(BMA, temptest_eD),
    dress = rowMeans(pnorm(temptest$temp, dressobj$ens, dressobj$ker.wd)),
    AKD  = rowMeans(pnorm(temptest$temp, AKDobj$ens, AKDobj$ker.wd)))
# Plot the PITs
par(mfrow = c(1, ncol(pit)))
for(model in colnames(pit)){
    hist(pit[, model], main = model, freq = FALSE,
    xlab = "", ylab = "", ylim = c(0, 1.6))
    abline(h = 1, lty = 2)
    }


library(fastDummies)
library(pmml)

raw <- read.csv('C://Users/ludepa/OneDrive - SAS/Apresentacoes/Datasets/hmeq.csv', header=T, na.string=c(""), sep = ";")

raw <- raw[1:13]

raw <- data.frame( CLAGE = as.numeric(raw$CLAGE),
                 CLNO = as.numeric(raw$CLNO),
                 DEBTINC = as.numeric(raw$DEBTINC),
                 DELINQ = as.numeric(raw$DELINQ),
                 DEROG = as.numeric(raw$DEROG),
                 LOAN = as.numeric(raw$LOAN),
                 MORTDUE = as.numeric(raw$MORTDUE),
                 NINQ = as.numeric(raw$NINQ),
                 VALUE = as.numeric(raw$VALUE),
                 YOJ = as.numeric(raw$YOJ),
                 JOB = as.character(raw$JOB),
                 REASON = as.character(raw$REASON),
                 BAD = as.character(raw$BAD),
                 stringsAsFactors = FALSE)

raw_dummies <- dummy_cols(raw)

abt <- within(raw_dummies, rm("JOB", "REASON", "BAD_1", "BAD_0"))
abt$BAD = as.factor(abt$BAD)

model <- glm(formula = BAD ~ ., family = binomial(link = "logit"), data = abt)

s <- summary(model)

print(s)

saveXML(pmml(model, model.name="General_Regression_Model",
             app.name="Rattle/PMML",
             description="Generalized Linear Regression Model"), "R_HMEQ.xml")


#
# Example R program
#

# example from https://github.com/jyypma/nloptr/blob/master/man/nloptr.Rd

library('nloptr')

## Rosenbrock Banana function and gradient in separate functions
eval_f <- function(x) {
    return( 100 * (x[2] - x[1] * x[1])^2 + (1 - x[1])^2 )
}

eval_grad_f <- function(x) {
    return( c( -400 * x[1] * (x[2] - x[1] * x[1]) - 2 * (1 - x[1]),
                200 * (x[2] - x[1] * x[1])) )
}

# initial values
x0 <- c( -1.2, 1 )

opts <- list("algorithm"="NLOPT_LD_LBFGS",
             "xtol_rel"=1.0e-8)

# solve Rosenbrock Banana function
res <- nloptr( x0=x0,
               eval_f=eval_f,
               eval_grad_f=eval_grad_f,
               opts=opts)
print( res )

## Rosenbrock Banana function and gradient in one function
# this can be used to economize on calculations
eval_f_list <- function(x) {
    return( list( "objective" = 100 * (x[2] - x[1] * x[1])^2 + (1 - x[1])^2,
                  "gradient"  = c( -400 * x[1] * (x[2] - x[1] * x[1]) - 2 * (1 - x[1]),
                                    200 * (x[2] - x[1] * x[1])) ) )
}

# solve Rosenbrock Banana function using an objective function that
# returns a list with the objective value and its gradient
res <- nloptr( x0=x0,
               eval_f=eval_f_list,
               opts=opts)
print( res )

# Example showing how to solve the problem from the NLopt tutorial.
#
# min sqrt( x2 )
# s.t. x2 >= 0
#      x2 >= ( a1*x1 + b1 )^3
#      x2 >= ( a2*x1 + b2 )^3
# where
# a1 = 2, b1 = 0, a2 = -1, b2 = 1
#
# re-formulate constraints to be of form g(x) <= 0
#      ( a1*x1 + b1 )^3 - x2 <= 0
#      ( a2*x1 + b2 )^3 - x2 <= 0

library('nloptr')

# objective function
eval_f0 <- function( x, a, b ){
    return( sqrt(x[2]) )
}

# constraint function
eval_g0 <- function( x, a, b ) {
    return( (a*x[1] + b)^3 - x[2] )
}

# gradient of objective function
eval_grad_f0 <- function( x, a, b ){
    return( c( 0, .5/sqrt(x[2]) ) )
}

# jacobian of constraint
eval_jac_g0 <- function( x, a, b ) {
    return( rbind( c( 3*a[1]*(a[1]*x[1] + b[1])^2, -1.0 ),
                   c( 3*a[2]*(a[2]*x[1] + b[2])^2, -1.0 ) ) )
}

# functions with gradients in objective and constraint function
# this can be useful if the same calculations are needed for
# the function value and the gradient
eval_f1 <- function( x, a, b ){
    return( list("objective"=sqrt(x[2]),
                 "gradient"=c(0,.5/sqrt(x[2])) ) )
}

eval_g1 <- function( x, a, b ) {
    return( list( "constraints"=(a*x[1] + b)^3 - x[2],
                  "jacobian"=rbind( c( 3*a[1]*(a[1]*x[1] + b[1])^2, -1.0 ),
                                    c( 3*a[2]*(a[2]*x[1] + b[2])^2, -1.0 ) ) ) )
}

# define parameters
a <- c(2,-1)
b <- c(0, 1)

# Solve using NLOPT_LD_MMA with gradient information supplied in separate function
res0 <- nloptr( x0=c(1.234,5.678),
                eval_f=eval_f0,
                eval_grad_f=eval_grad_f0,
                lb = c(-Inf,0),
                ub = c(Inf,Inf),
                eval_g_ineq = eval_g0,
                eval_jac_g_ineq = eval_jac_g0,
                opts = list("algorithm"="NLOPT_LD_MMA"),
                a = a,
                b = b )
print( res0 )

# Solve using NLOPT_LN_COBYLA without gradient information
res1 <- nloptr( x0=c(1.234,5.678),
                eval_f=eval_f0,
                lb = c(-Inf,0),
                ub = c(Inf,Inf),
                eval_g_ineq = eval_g0,
                opts = list("algorithm"="NLOPT_LN_COBYLA"),
                a = a,
                b = b )
print( res1 )

# Solve using NLOPT_LD_MMA with gradient information in objective function
res2 <- nloptr( x0=c(1.234,5.678),
                eval_f=eval_f1,
                lb = c(-Inf,0),
                ub = c(Inf,Inf),
                eval_g_ineq = eval_g1,
                opts = list("algorithm"="NLOPT_LD_MMA", "check_derivatives"=TRUE),
                a = a,
                b = b )
print( res2 )


## From Bayazid Sarkar <sarkarbayazid@gmail.com>
require(Hmisc)
set.seed(1)
x <- exp(rnorm(100))
w <- sample(1:5, 100, TRUE)
g <- sample(c('a','b','c'), 100, TRUE)

Ecdf(log(x), weights=w, lty=1:3, col=1:3, group=g, label.curves=list(keys=1:3),
     subtitles=FALSE)

Ecdf(x, weights=w, lty=1:3, col=1:3, group=g, label.curves=list(keys=1:3),
     subtitles=FALSE, log='x')

## From Piotr Balwierz
reds <- rnorm(n=100, mean=5, sd=1)
blues <- rnorm(n=100, mean=0, sd=1)
g <- c(rep("red", length(reds)),
       rep("blue", length(blues)))
Ecdf(x=c(reds, blues), group=g, col=c("red", "blue"))
Ecdf(c(reds, blues), group=factor(g), col=c('blue', 'red'))


detach('package:bayes', unload=T)
require(bayes)

a <- rpois(10, 1.2)
b <- rpois(10, 1.3)

out<-bayes.poisson.test(a, b)

par(mfrow=c(3,2))
plot(out[,1], type="l")
hist(out[,1], breaks=80)
plot(out[,2], type="l")
hist(out[,2], breaks=80)
hist(out[,1]/out[,2], breaks=80)

abline(v=quantile(out[,1]/out[,2], .025), col="red")
abline(v=quantile(out[,1]/out[,2], .975), col="red")
hist(log(out[,1]/out[,2]), breaks=80)
abline(v=quantile(log(out[,1]/out[,2]), .975), col="red")
abline(v=quantile(log(out[,1]/out[,2]), .025), col="red")

poisson.test(c(sum(a), sum(b)), c(10, 10))

out <- bayes.binomial.test(matrix(c(3, 10, 25, 100), nrow=2, ncol=2))

b1 <- matrix(c(3, 10, 25, 100), nrow=2, ncol=2, byrow=T)
b2 <- matrix(c(30, 100, 27, 100), nrow=2, ncol=2, byrow=T)
out <- bayes.binomial.test(b1, b2)


#  confidence interval for the ratio of the two variances

y1bar=38.48
s1=16.37
n1=40
y2bar=26.93
s2=9.88
n2=40
alpha=0.05
FU=qf(1-alpha/2,39,39)
FL=1/FU

# confidence interval for sigma1^2/sigma2^2
left_i=(s1^2/s2^2)*FL
right_i=(s1^2/s2^2)*FU
print(left_i)
print(right_i)


#' Expected number of ENC given GC3 content
#'
#' Calculates the expected ENC based on Wright's formula given GC3 percentage
#' @param gc3 a number of GC3 content
#' @return a number of the expected ENC given the GC3 content
#'
#' @export

enc_exp <- function(gc3=0){
  return(2+gc3+29/(gc3^2+(1-gc3)^2))
}


# See for context:
#   http://ww2.coastal.edu/kingw/statistics/R-tutorials/logistic.html

# Logistic Regression: One Numerical Predictor

library("MASS")
data(menarche)
str(menarche)
summary(menarche)

plot(Menarche / Total ~ Age, data=menarche)

glm.out = glm(
	cbind(Menarche, Total - Menarche) ~ Age,
	family=binomial(logit),
	data=menarche
)

plot(Menarche / Total ~ Age, data=menarche)
lines(menarche$Age, glm.out$fitted, type="l", col="red")
title(main="Menarche Data with Fitted Logistic Regression Line")

# Recall that the response variable is log odds, so the coefficient of "Age" can be interpreted as "for every one year increase in age the odds of having reached menarche increase by exp(1.632) = 5.11 times."
summary(glm.out)
# also available: glm.out$coef, glm.out$fitted, glm.out$resid, glm.out$effects, anova(glm.out)

# calculate p-value (NOTE. pchisq uses the cumulative distribution! so adjust accordingly)
p = 1 - pchisq(26.703, df=23) # should be ~ 0.269

# Logistic Regression: Multiple Numerical Predictors