#===========================================================
#==  Algorithms ====
#===========================================================

## Greedy variants ##

policy.greedy.pooled4 <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
  whichcol <- rep( as.numeric( which.is.max(muobs) ), J)
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind( 1:J, whichcol ) ] <- 1
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.greedy.pooled12 <- function(m,y,...){
# d$sizeandconcept  (12 unique actions)
# d$unitid  (59 unique units)
# d$placeid (133 unique places)
# d$adsize  (3 unique sizes)
  sz <- d$adsize
  J <- nrow(d)/K

  s1 <- (sz==levels(sz)[1])
    mbyK <- matrix(m[s1], ncol=K, byrow=T)
    ybyK <- matrix(y[s1], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
  s1winner <- as.numeric( which.is.max(muobs) )
  s2 <- (sz==levels(sz)[2])
    mbyK <- matrix(m[s2], ncol=K, byrow=T)
    ybyK <- matrix(y[s2], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
  s2winner <- as.numeric( which.is.max(muobs) )
  s3 <- (sz==levels(sz)[3])
    mbyK <- matrix(m[s3], ncol=K, byrow=T)
    ybyK <- matrix(y[s3], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
  s3winner <- as.numeric( which.is.max(muobs) )

  klabels <- (1:(J*K)) %% K
  klabels[klabels==0] <- K
  w <- rep(0, J*K)
  w[s1] <- as.numeric(klabels[s1] == s1winner)
  w[s2] <- as.numeric(klabels[s2] == s2winner)
  w[s3] <- as.numeric(klabels[s3] == s3winner)

  return(list(w=w))
}

policy.epsgreedy.pooled12 <- function(m,y,eps,...){
  wraw <- policy.greedy.pooled12(m,y)$w
  w <- eps*1/K + (1-eps)*wraw
  return(list(w=w))
}

policy.greedy.always <- function(m,y,always,...){
  #always play action numbered "always"=1,2,...,or K
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  whichcol <- rep(always, J)
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind(1:J, whichcol) ] <- 1
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.greedy.unpooled <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  mgt0 <- which(apply(mbyK,1,sum) > 0)
  muobsmat <- ybyK[mgt0,]/mbyK[mgt0,]
  whichcol <- as.numeric( apply(muobsmat,1,which.is.max) )
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind(mgt0, whichcol) ] <- 1
  wJbyK[ which(apply(mbyK,1,sum)==0), ] <- 1/K
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.epsgreedy.unpooled <- function(m,y,eps,...){
  wraw <- policy.greedy.unpooled(m,y)$w
  w <- eps*1/K + (1-eps)*wraw
  return(list(w=w))
}

policy.softmax.unpooled <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  mgt0 <- which(apply(mbyK,1,sum) > 0)
  meq0 <- which(apply(mbyK,1,sum)==0)
  Vmat <- ybyK[mgt0,]/mbyK[mgt0,]
  tune <- mean(Vmat)
  expVmat <- exp(Vmat/tune)
  softmaxmat <- expVmat/apply(expVmat,1,sum)
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ mgt0, ] <- softmaxmat
  wJbyK[ meq0, ] <- 1/K
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

gittins.brezzi.lai <- function( post.mean, post.var, varY, disc) {
  # post.mean = E[theta|Y]
  # post.var  = Var[theta|Y]
  # varY = Var[ Y | theta=post.mean], Variance of likelihood of Y as a function of post.mean
  # disc = e^{-c}  <-->  c = -ln(disc), disc:= discount rate approaches 1.0
  # s = post.var / (c * varY)
  # Psi.func(s):= piecwise non-linear function of s
  # Gittins Index approximation =  post.mean + sqrt(post.var)*psi.func(s)

  #======== Example: Bernoulli Bandit ========
  #a <- 2.439
  #b <- 238.411
  #post.mean.beta <- a/(a+b)
  #post.var.beta <-  a*b/( (1+a+b)*(a+b)^2 )
  #varY.binom <- post.mean.beta*(1-post.mean.beta)
  #gittins.brezzi.lai( post.mean=post.mean.beta, post.var=post.var.beta, varY=varY.binom, disc=.99)
  #[1] 0.01217715
  #==========================

  psi.func <- function(sv){
    psi <- rep(NA,length(sv))
    for (i in 1:length(sv)) {
      s <- sv[i]
      if (s <= 0.2) psi[i]<- sqrt(s/2)
      else if (s <= 1) psi[i]<- 0.49 - 0.11*s^{-.5}
      else if (s <= 5) psi[i]<- 0.63 - 0.26*s^{-.5}
      else if (s <=15) psi[i]<- 0.77 - 0.58*s^{-.5}
      else  (  psi[i]<- 2*log(s) -log(log(s)) -log(16*pi)   )^{.5}
    }
    return(psi)
  }

  c <- -log( disc )
  s <- post.var/(varY*c)
  return( post.mean + sqrt(post.var)*psi.func(s) )

}

policy.gittins.pooled12 <- function(m,y,...){
# d$sizeandconcept  (12 unique actions)
# d$unitid  (59 unique units)
# d$placeid (133 unique places)
# d$adsize  (3 unique sizes)
  sz <- d$adsize
  J <- nrow(d)/K

  s1 <- (sz==levels(sz)[1])
    mbyK <- matrix(m[s1], ncol=K, byrow=T)
    ybyK <- matrix(y[s1], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
    ## Gittins
      # Bayes updates for Posterior of arm's propensity # Beta prior,posterior
      a <- 1 ; b <- 1 ;
      yyy <- apply(ybyK, 2, sum)
      nnn <- apply(mbyK, 2, sum)
      a.update <- a + yyy
      b.update <- b + nnn - yyy
      beta.mean <- a.update/(a.update + b.update)
      beta.var  <- a.update*b.update/( (a.update + b.update)^2 * (a.update + b.update + 1) )
      gittins_vec <- gittins.brezzi.lai(post.mean=beta.mean, post.var=beta.var, varY=beta.mean*(1-beta.mean) , disc=.99)
  s1winner <- as.numeric( which.is.max(gittins_vec) )

  s2 <- (sz==levels(sz)[2])
    mbyK <- matrix(m[s2], ncol=K, byrow=T)
    ybyK <- matrix(y[s2], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
    ## Gittins
      # Bayes updates for Posterior of arm's propensity # Beta prior,posterior
      a <- 1 ; b <- 1 ;
      yyy <- apply(ybyK, 2, sum)
      nnn <- apply(mbyK, 2, sum)
      a.update <- a + yyy
      b.update <- b + nnn - yyy
      beta.mean <- a.update/(a.update + b.update)
      beta.var  <- a.update*b.update/( (a.update + b.update)^2 * (a.update + b.update + 1) )
      gittins_vec <- gittins.brezzi.lai(post.mean=beta.mean, post.var=beta.var, varY=beta.mean*(1-beta.mean) , disc=.99)
  s2winner <- as.numeric( which.is.max(gittins_vec) )

  s3 <- (sz==levels(sz)[3])
    mbyK <- matrix(m[s3], ncol=K, byrow=T)
    ybyK <- matrix(y[s3], ncol=K, byrow=T)
    muobs <- apply(ybyK, 2, sum)/apply(mbyK, 2, sum)
    ## Gittins
      # Bayes updates for Posterior of arm's propensity # Beta prior,posterior
      a <- 1 ; b <- 1 ;
      yyy <- apply(ybyK, 2, sum)
      nnn <- apply(mbyK, 2, sum)
      a.update <- a + yyy
      b.update <- b + nnn - yyy
      beta.mean <- a.update/(a.update + b.update)
      beta.var  <- a.update*b.update/( (a.update + b.update)^2 * (a.update + b.update + 1) )
      gittins_vec <- gittins.brezzi.lai(post.mean=beta.mean, post.var=beta.var, varY=beta.mean*(1-beta.mean) , disc=.99)
  s3winner <- as.numeric( which.is.max(gittins_vec) )

  klabels <- (1:(J*K)) %% K
  klabels[klabels==0] <- K
  w <- rep(0, J*K)
  w[s1] <- as.numeric(klabels[s1] == s1winner)
  w[s2] <- as.numeric(klabels[s2] == s2winner)
  w[s3] <- as.numeric(klabels[s3] == s3winner)

  return(list(w=w))
}

policy.gittins.unpooled <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  mgt0 <- which(apply(mbyK,1,sum) > 0)
  meq0 <- which(apply(mbyK,1,sum)==0)
    ## Gittins
      # Bayes updates for Posterior of arm's propensity # Beta prior,posterior
      a <- 1 ; b <- 1 ;
      yyy <- ybyK[mgt0,]
      nnn <- mbyK[mgt0,]
      a.update <- a + yyy
      b.update <- b + nnn - yyy
      beta.mean <- a.update/(a.update + b.update)
      beta.var  <- a.update*b.update/( (a.update + b.update)^2 * (a.update + b.update + 1) )
      gittins.mat <- gittins.brezzi.lai(post.mean=beta.mean, post.var=beta.var, varY=beta.mean*(1-beta.mean) , disc=.99)
  whichcol <- as.numeric( apply(gittins.mat,1,which.is.max) )
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind(mgt0, whichcol) ] <- 1
  wJbyK[ meq0, ] <- 1/K
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.UCB1.unpooled <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  mgt0 <- which(apply(mbyK,1,sum) > 0)
  meq0 <- which(apply(mbyK,1,sum)==0)
    ## UCB1
      yyy <- ybyK[mgt0,]
      nnn <- mbyK[mgt0,]
      rowsum_m <- apply(nnn,1,sum)
      ov <- sqrt(2*log(rowsum_m)/nnn)   #option value
      ucb.mat <- yyy/nnn + ov
  whichcol <- as.numeric( apply(ucb.mat,1,which.is.max) )
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind(mgt0, whichcol) ] <- 1
  wJbyK[ meq0, ] <- 1/K
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.UCBtuned.unpooled <- function(m,y,...){
  J <- nrow(d)/K
  mbyK <- matrix(m, ncol=K, byrow=T)
  ybyK <- matrix(y, ncol=K, byrow=T)
  mgt0 <- which(apply(mbyK,1,sum) > 0)
  meq0 <- which(apply(mbyK,1,sum)==0)
    ## UCBtuned
      yyy <- ybyK[mgt0,]
      nnn <- mbyK[mgt0,]
      rowsum_m <- apply(nnn,1,sum)
        Var_upbd_mat <- nnn*(yyy/nnn)*(1-yyy/nnn) + sqrt(2*log(rowsum_m)/nnn)
        Var_upbd_or_25_vec <- apply( cbind( c(Var_upbd_mat), c(nnn)*1/4 ), 1, min)
        Var_upbd_or_25_mat <- matrix(Var_upbd_or_25_vec, ncol=K, byrow=F)
      ov <- sqrt( Var_upbd_or_25_mat * log(rowsum_m)/nnn )   #option value
      ucb.mat <- yyy/nnn + ov
  whichcol <- as.numeric( apply(ucb.mat,1,which.is.max) )
  wJbyK <- matrix(0, nrow=J, ncol=K)
  wJbyK[ cbind(mgt0, whichcol) ] <- 1
  wJbyK[ meq0, ] <- 1/K
  w <- as.vector( t(wJbyK) )
  return(list(w=w))
}

policy.exp.then.exp <- function(hinit,policytouse,...) {
# hinit
#
#Mhobs.cur <- Mhobs.combo
#mutruemat
#d
#J
#K
#hend
K <- 4
yhstar.all <- array(0, dim=c(J*K,hend,nworlds))
mhstar.all <- array(0, dim=c(J*K,hend,nworlds))
wstarend <- matrix(0, J*K, nworlds)
for (i in 1:nworlds){
  yhstar <- matrix(0,J*K,hend)
  mhstar <- matrix(0,J*K,hend)
  wstar <- matrix(0,J*K,hend)
 # explore for hinit periods
  wmat.explore <- matrix(1/K, nrow=J*K, ncol=hinit)
  wstar[,1:hinit] <- wmat.explore
  mhstar.explore <- round(Mhobs.cur[,1:hinit]*wmat.explore)
  mhstar[,1:hinit] <- mhstar.explore
  yhstar[,1:hinit] <- rbinom( J*K*hinit, mhstar.explore, mutruemat[,1:hinit] )
  if (hinit==1) {mtstar.hinit <- mhstar[,1]; ytstar.hinit <- yhstar[,1];
  } else {
  mtstar.hinit <- apply(mhstar[,1:hinit],1,sum)
  ytstar.hinit <- apply(yhstar[,1:hinit],1,sum)
  }
 # after explore, identify winner
  res <- policytouse(m=mtstar.hinit,y=ytstar.hinit)
  w <- res$w
 # then exploit for hremain periods
  hremain = length( (hinit+1):hend )
  wmat.exploit <- matrix(w, nrow=J*K, ncol=hremain, byrow=F)
  wstar[,(hinit+1):hend] <- wmat.exploit
  mhstar.exploit <- round(Mhobs.cur[,(hinit+1):hend]*wmat.exploit)
  mhstar[,(hinit+1):hend ] <- mhstar.exploit
  yhstar[,(hinit+1):hend ] <- rbinom( J*K*hremain, mhstar.exploit, mutruemat[,(hinit+1):hend] )

 #store
  mhstar.all[,,i] <- mhstar
  yhstar.all[,,i] <- yhstar
  wstarend[,i] <- wstar[,hend]
}

ystarovertime <- apply(yhstar.all,3:2,sum)
mstarovertime <- apply(mhstar.all,3:2,sum)
ystarovertimecum <- t( apply(ystarovertime,1,cumsum) )
mstarovertimecum <- t( apply(mstarovertime,1,cumsum) )
pstarovertimecum <- ystarovertimecum/mstarovertimecum

ytotal <- apply(yhstar.all,3,sum)
mtotal <- apply(mhstar.all,3,sum)
ptotal <- ytotal/mtotal

return( list(ptotal=ptotal,
             pstarovertimecum=pstarovertimecum,
             wstarend=wstarend ) )
} # END  function policy.exp.then.exp


plotQuantiles = function(dat)
{
  qps=seq(.1,.9,.2);
  nq=length(qps)
  dat$q=dat$q[as.character(qps),,]
  plot(y=NULL,x=NULL,ylim=range(dat$q),xlim=c(0,1),main=s,ylab="",xlab="")
  points(x=rep(dat$p,each=nrow(dat$q)),y=dat$q[,"cor",],pch=4,col="green3",lwd=2)
  use=(1-dat$p)>.00   # only plot if more than 2% corrects
  points(x=rep(1-dat$p[use],each=nrow(dat$q[,,use])),y=dat$q[,"err",use],pch=4,col="red2",lwd=2);
}


setwd('/home/pc-752828/Dev/results-search-master/outputs-normal')

library(ggplot2)
library(dplyr)
library(extrafont)
library(dplyr)
library('EnvStats')
library("tikzDevice")
library(survJamda)

data <- read.csv(file = 'output-n-norm.csv', sep = ',', header = T)
data_new <- data
value <- function(x, name) {
  mym = median(x)
  mysd = sd(x)
  #mysd = mean(x)

  #mysd = geoSD(x, na.rm = FALSE, sqrt.unbiased = TRUE)
  mysqrt = sqrt(length(x))
  Q1 <- quantile(x, probs = 0.25)
  Q2 <- quantile(x, probs = 0.50)
  Q3 <- quantile(x, probs = 0.75)

  mym =  geoMean(x, na.rm = FALSE)
  print(mym)
  print(exp(mean(log(x))))
  #mym = mean(log(x))
  #mysd = geoSD(x, na.rm = FALSE, sqrt.unbiased = TRUE)
  mysd <- ci.gm(x)
  return(c(mn = mym, sd = mysd, bo = name))
}

data_f<-data.frame(data_new[data_new['bo'] == 'bo1' & data_new['target'] == 0,])
bo1 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EIdef')))
bo1 <- as.data.frame(as.list(bo1))

data_f<-data.frame(data_new[data_new['bo'] == 'bo3',])
bo3 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6sel-EIdef')))
bo3 <- as.data.frame(as.list(bo3))

data_f<-data.frame(data_new[data_new['bo'] == 'bo4',])
bo4 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'PB3Opt')))
bo4 <- as.data.frame(as.list(bo4))

data_f<-data.frame(data_new[data_new['bo'] == 'bo4' & data_new['target'] == 3,])
bo5 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'Abordagem Proposta - Ótimo')))
bo5 <- as.data.frame(as.list(bo5))

data_f<-data.frame(data_new[data_new['bo'] == 'bo4' & data_new['target'] == 4,])
bo6 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'Abordagem Proposta - Pior')))
bo6 <- as.data.frame(as.list(bo6))

data_f<-data.frame(data_new[data_new['bo'] == 'bo4' & data_new['target'] == 5,])
bo7 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'Abordagem Proposta - Aleatório')))
bo7 <- as.data.frame(as.list(bo7))

data_f<-data.frame(data_new[data_new['bo'] == 'rs',])
bo7 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'Ranking Search')))
bo7 <- as.data.frame(as.list(bo7))

data_f<-data.frame(data_new[data_new['bo'] == 'bo5',])
bo8 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EInova')))
bo8 <- as.data.frame(as.list(bo8))

df <- rbind(bo1, bo3, bo8, bo4, bo7)

df <- rbind(bo1, bo3, bo8)

View(data)

df$x.mn = as.numeric(as.character(df$x.mn))
df$Group.1 = as.numeric(as.character(df$Group.1))
df$x.sd1 = as.numeric(as.character(df$x.sd1))
df$x.sd2 = as.numeric(as.character(df$x.sd2))
df_new <- df

p2<-ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  geom_errorbar(aes(ymin=x.sd1, ymax=x.sd2,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  coord_cartesian(ylim=c(1,2), xlim=c(1,30))+
  labs(color = element_blank(), x="Iteração", y="Média do Melhor Custo Normalizado")+
  theme(legend.justification=c(1, 1),legend.position=c(.9, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  ggtitle('b) Zoom da Figura a')+
  scale_x_continuous(breaks = seq(1, 30, 1))

p1<-ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  geom_errorbar(aes(ymin=x.sd1, ymax=x.sd2,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  labs(color = element_blank(), x="Iteração", y="Média do Melhor Custo Normalizado")+
  theme(legend.justification=c(1, 1),legend.position=c(.9, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8),
        legend.background = element_rect(fill=alpha('white', 0.6)))+
  ggtitle('a) Melhor Custo Encontrado')+
  scale_x_continuous(breaks = seq(1, 30, 1))

tikz('fig1.tex')
grid.arrange(p1, p2, nrow = 2, ncol=1, top="", left="Média do Melhor Custo Normalizado")
dev.off()


################################################################################
# pairwiseDiffMatrix function  -  (matrix)
#
# Author: Heidi Lischer
# Date: 10.2008
################################################################################

pairwiseDiffMatrix <- function(xmlText, Labels=NULL, timeAttr,outfile=outfiles){
  # convert string data (half matrix) to a numeric matrix ----------------------
  # split string---------
  tagData2 <- as.character(xmlText)

  tagData3 <- strsplit(tagData2, "\n")
  tagMatrix <- as.matrix(as.data.frame(tagData3))
  tagMatrix <- subset(tagMatrix, tagMatrix[,1] != "") #trim empty lines
  tagMatrix <- tagMatrix[2:nrow(tagMatrix)]
  tagMatrix  <- gsub(" + ", " ", tagMatrix)   # trim white space
  Data <- strsplit(tagMatrix, " ")

  Row <- length(Data)

  #to numeric matrix ---------------------
  Matrix <- as.matrix(as.data.frame(Data[1]))
  Matrix <- subset(Matrix, Matrix[,1] != "")
  Matrix <- Matrix[2:nrow(Matrix),]
  numericList <- as.numeric(Matrix)
  numericMatrix <- t(as.matrix(numericList))

  if(Row >= 2){
      for(n in 2:(Row)){
        nextrow <- as.matrix(as.data.frame(Data[n]))
        nextrow <- subset(nextrow, nextrow[,1] != "")
        nextrow <- nextrow[2:nrow(nextrow),]
        numericList <- as.numeric(nextrow)
        numericMatrix <- rbind(numericMatrix, t(as.matrix(numericList)))
      }
  }

  nCol <- ncol(numericMatrix)

      # get underMatrix ------------------------------------------------------------
      underMatrix <- matrix(NA, ncol=nCol, nrow=1)
  if(nCol >= 2){
      for(i in 2:nCol){
        nextrow <- numericMatrix[i,1:(i-1)]
        nextrow <- cbind(t(nextrow), matrix(NA, ncol=nCol-(i-1), nrow=1))

        underMatrix <- rbind(underMatrix, nextrow)
      }
  }

      # get upperMatrix ------------------------------------------------------------
      upperMatrix <- matrix(NA, ncol=1, nrow=1)
      if(nCol >= 2){
      upperMatrix <- cbind(upperMatrix, t(numericMatrix[1,2:nCol]))

      if(nCol > 2){
        for (i in 3:nCol){
          nextrow <- matrix(NA, ncol=(i-1), nrow=1)
          nextrow <- cbind(nextrow, t(numericMatrix[(i-1), i:nCol]))

          upperMatrix <- rbind(upperMatrix, nextrow)
        }
      }
      upperMatrix <- rbind(upperMatrix, matrix(NA, ncol=nCol, nrow=1))
    }

  # get diagonalMatrix ---------------------------------------------------------
  diagonalMatrix <- numericMatrix[1,1]
  diagonalMatrix <- cbind(diagonalMatrix, matrix(NA, ncol=nCol-1, nrow=1))

  if(nCol >= 2){
      for(i in 2:nCol){
        nextrow <- matrix(NA, ncol=(i-1), nrow=1)
        nextrow <- cbind(nextrow, t(numericMatrix[i,i]))
        nextrow <- cbind(nextrow, matrix(NA, ncol=ncol(numericMatrix)-i, nrow=1))

        diagonalMatrix <- rbind(diagonalMatrix, nextrow)
      }
  }

  # graphic --------------------------------------------------------------------
  a <- ncol(numericMatrix)
  b <- nrow(numericMatrix)

  x <- c(1:a)
  y <- c(1:b)

  # define colors
  colorRampBlue <- colorRampPalette(c("white", "steelblue1", "blue3"))
  colorRampGreen <- colorRampPalette(c("white", "green3", "darkgreen"))
  colorRampOrange <- colorRampPalette(c("white", "orange", "orangered2"))

  #----Mirror matrix (left-right)----
  mirror.matrix <- function(x) {
    xx <- as.data.frame(x);
    xx <- rev(xx);
    xx <- as.matrix(xx);
    xx;
  }

  #----Rotate matrix 270 clockworks----
  rotate270.matrix <- function(x) {
    mirror.matrix(t(x))
  }

      underMatrix <- rotate270.matrix(underMatrix)
      upperMatrix <- rotate270.matrix(upperMatrix)
      diagonalMatrix <- rotate270.matrix(diagonalMatrix)

  # draw graphic --------------------------------------------
  outfileGraphic <- paste(outfile, "pairwiseDiffMatrix ", timeAttr, ".png",
                            sep="")

  #save graphic
  png(outfileGraphic, width=1300, height=1300, res=144)

    # devide plot region in 4 parts
    def.par <- par(no.readonly = TRUE) # save default, for resetting...
      layout(rbind(c(1,2), c(1,3), c(1,4)),
             heights=rbind(c(2,1), c(2,1), c(2,1)),
             respect=rbind(c(0,1), c(0,0), c(0,0)))

    # draw matrixe plots --------------------
      op <- par(mar=c(7.6, 6.8, 8.6, 0.6))
        image(x, y, underMatrix, col=colorRampBlue(64), xlab="", ylab="",
               axes = FALSE)
        image(x,y, upperMatrix, col=colorRampGreen(64), xlab="", ylab="",
               axes = FALSE, add=TRUE)
        image(x,y, diagonalMatrix, col=colorRampOrange(64), xlab="", ylab="",
               axes = FALSE, add=TRUE)
           box()
           mtext(text="Average number of pairwise differences",
                   line=4.5, cex=1.2, font=2)

            #add labels
            if(is.null(Labels)){
              axis(1, at = c(1:a))
              axis(2, at = c(1:b), labels=c(b:1))
              mtext(text="Population", side=1, line=3)
              mtext(text="Population", side=2, line=3)
            }else{
              axis(1, at = c(1:a), labels=Labels[1:ncol(Labels)], cex.axis=1.1,
                     las=2)
              axis(2, at = c(1:b), labels=Labels[ncol(Labels):1], cex.axis=1.1,
                     las=2)
            }
      par(op)

    # draw legends----------------------------
    # upper legend --------
      op2 <- par(mar=c(0, 1.2, 4.2, 6.2))
        if(nCol >= 2){
            # define parameters
            Min <- min(upperMatrix, na.rm=TRUE)
            Max <- max(upperMatrix, na.rm=TRUE)
            binwidth <- (Max - Min) / 64
            y <- seq(Min + binwidth/2, Max - binwidth/2, by = binwidth)
            z <- matrix(y, nrow = 1, ncol = length(y))

            image(1, y, z, col = colorRampGreen(64), axes=FALSE)

                # adjust axis if only one value exists
                if(Min == Max){
                  axis(side=4, las = 2, at=Min, labels=round(Min, 2), cex.axis=1.1)
                } else {
                  axis(side=4, las = 2, cex.axis=1.1)
                }

                mtext(text="between populations", side=4, line=4, cex=1)
                box()
        }
      par(op2)

    # diagonal legend --------
      op3 <- par(mar=c(1.3, 1.2, 1.9, 6.2))

        # define parameters
        Min <- min(diagonalMatrix, na.rm=TRUE)
        Max <- max(diagonalMatrix, na.rm=TRUE)
        binwidth <- (Max - Min) / 64
        y <- seq(Min + binwidth/2, Max - binwidth/2, by = binwidth)
        z <- matrix(y, nrow = 1, ncol = length(y))

        image(1, y, z, col = colorRampOrange(64), axes=FALSE)

            # adjust axis if only one value exists
            if(Min == Max){
              axis(side=4, las = 2, at=Min, labels=round(Min, 2), cex.axis=1.1)
            } else {
              axis(side=4, las = 2, cex.axis=1.1)
            }

           mtext(text="within populations", side=4, line=4, cex=1)
           box()
      par(op3)

    # under legend --------
      op4 <- par(mar=c(3.6, 1.2, 0.6, 6.2))
        if(nCol >= 2){
            # define parameters
            Min <- min(underMatrix, na.rm=TRUE)
            Max <- max(underMatrix, na.rm=TRUE)
            binwidth <- (Max - Min) / 64
            y <- seq(Min + binwidth/2, Max - binwidth/2, by = binwidth)
            z <- matrix(y, nrow = 1, ncol = length(y))

            image(1, y, z, col = colorRampBlue(64), axes=FALSE)

                # adjust axis if only one value exists
                if(Min == Max){
                  axis(side=4, las = 2, at=Min, labels=round(Min, 2), cex.axis=1.1)
                } else {
                  axis(side=4, las = 2, cex.axis=1.1)
                }

               mtext(text="Nei's distance (d)", side=4, line=4, cex=1)
               box()
        }
      par(op4)

    par(def.par)  #reset to default

  dev.off()

}


# 4. faza: Analiza podatkov
source("lib/uvozi.zemljevid.r")
# Uvozimo funkcijo za uvoz spletne strani.
source("lib/xml.r")
library(mgcv)
library(dplyr)

# Funkcija, ki podatke preuredi glede na vrstni red v zemljevidu
preuredi <- function(podatki, zemljevid) {
  nove.svet <- c()
  manjkajo <- ! nove.svet %in% rownames(podatki)
  M <- as.data.frame(matrix(nrow=sum(manjkajo), ncol=length(podatki)))
  names(M) <- names(podatki)
  row.names(M) <- nove.svet[manjkajo]
  podatki <- rbind(podatki, M)

  out <- data.frame(podatki[order(rownames(podatki)), ])[rank(levels(zemljevid$NAME_1)[rank(zemljevid$NAME_1)]), ]
  if (ncol(podatki) == 1) {
    out <- data.frame(out)
    names(out) <- names(podatki)
    rownames(out) <- rownames(podatki)
  }
  return(out)
}

# Narišemo graf v datoteko PDF.
cat("Rišem graf...\n")
cairo_pdf("slike/grafi2.pdf", width = 9.27, height = 5.69, family = "Arial")

c=1995:2014
plot(c, k3,
     main = "Število novih odprtih sistemov v vsakem letu",
     xlab = "",
     ylab = "",
)

#LINEARNA METODA
lin <- lm(k3 ~ c)
abline(lin, col="blue")

#KVADRATNA METODA
kv <- lm(k3 ~ I(c^2) + c)
curve(predict(kv, data.frame(c=x)), add = TRUE, col = "red")

#LOESS MODEL
mls1 <- loess(k3 ~ c)
curve(predict(mls1, data.frame(c=x)), add = TRUE, col = "green")

#GAM MODEL
mgam1 <- gam(k3 ~ s(c))
curve(predict(mgam1, data.frame(c=x)), add = TRUE, col = "purple")

legend("topleft", legend=c("Linearna: lm(sistemi ~ leto)",
                              "Kvadratna: lm(sistemi ~ I(leto^2) + leto)", "Loess", "Gam"), lty="solid",
       cex = 0.8, col = c("blue", "red", "green","purple"))

dev.off()
vsota.kvadratov<-sapply(list(lin, kv, mls1, mgam1), function(x) sum(x$residuals^2))
#  2259.0128  1055.2984  802.6469  791.2780

cat("Rišem graf...\n")
cairo_pdf("slike/grafi4.pdf", width = 9.27, height = 5.69, family = "Arial")

qw1<-ifelse(is.na(svet$st.koles.prebivalstvo),FALSE,TRUE)
qw<-sort(svet$st.koles.prebivalstvo[qw1])
drzavee<-svet$admin[order(svet$st.koles.prebivalstvo, decreasing=TRUE)[1:5]]
rr<-c(qw[length(qw)],qw[length(qw)-1],qw[length(qw)-2],qw[length(qw)-3],qw[length(qw)-4])
names(rr)<-drzavee

barplot(rr, main= "Prvih pet držav z najboljšimi razmerji med
               število razpoložljivih koles in število prebivalcev")

dev.off()

#ANIMACIJA
koordinate<-coordinates(svet[,])
imena <- as.character(svet$name)
rownames(koordinate) <- imena
names(imena) <- imena

zz<-levels(t4$Country)
zz1<-levels(svet$name_long)
cc1<-select(t4,Country,Year.inaugurated,Bicycles)
cc2<-group_by(cc1, Country,Year.inaugurated)
cc3<-summarise(cc2, st=sum(Bicycles,na.rm=TRUE))
cc3<-cc3[!is.na(cc3[,2]),]

aq95<-data.frame(cc3[cc3[,2]==1995,])
aq97<-data.frame(cc3[cc3[,2]==1997,])
aq98<-data.frame(cc3[cc3[,2]==1998,])
aq00<-data.frame(cc3[cc3[,2]==2000,])
aq01<-data.frame(cc3[cc3[,2]==2001,])
aq03<-data.frame(cc3[cc3[,2]==2003,])
aq04<-data.frame(cc3[cc3[,2]==2004,])
aq05<-data.frame(cc3[cc3[,2]==2005,])
aq06<-data.frame(cc3[cc3[,2]==2006,])
aq07<-data.frame(cc3[cc3[,2]==2007,])
aq08<-data.frame(cc3[cc3[,2]==2008,])
aq09<-data.frame(cc3[cc3[,2]==2009,])
aq10<-data.frame(cc3[cc3[,2]==2010,])
aq11<-data.frame(cc3[cc3[,2]==2011,])
aq12<-data.frame(cc3[cc3[,2]==2012,])
aq13<-data.frame(cc3[cc3[,2]==2013,])
aq14<-data.frame(cc3[cc3[,2]==2014,])

# Narišimo zemljevid v PDF.
cat("Rišem zemljevid...\n")
cairo_pdf("slike/anim1.pdf",width = 9.27, height = 5.69, family = "Arial",
          onefile = TRUE)

plot(svet)
title("Nove sisteme v 1995")
points(koordinate[zz[aq95[,1]],c(1,2)],pch=16,col="red",cex=1.3)

plot(svet)
title("Nove sisteme v 1997")
points(koordinate[zz[aq97[,1]],1],koordinate[zz[aq97[,1]],2],pch=16,col="red",cex=1.3)

plot(svet)
title("Nove sisteme v 1998")
points(koordinate[zz[aq98[,1]],1],koordinate[zz[aq98[,1]],2],pch=16,col="red",cex=1.3)

plot(svet)
title("Nove sisteme v 2000")
points(koordinate[zz[aq00[,1]],c(1,2)],pch=16,col="red",
       cex=1.3)

plot(svet)
title("Nove sisteme v 2001")
points(koordinate[zz[aq01[,1]],1],koordinate[zz[aq01[,1]],2],pch=16,col="red",cex=1.3)

plot(svet)
title("Nove sisteme v 2003")
points(koordinate[zz[aq03[,1]],c(1,2)],pch=16,col="red",
       cex=1+aq03[,3]/norm(as.matrix(aq03[,3])))

plot(svet)
title("Nove sisteme v 2004")
points(koordinate[zz[aq04[,1]],1],koordinate[zz[aq04[,1]],2],pch=16,col="red",cex=1.3)

plot(svet)
title("Nove sisteme v 2005")
points(koordinate[zz[aq05[,1]],c(1,2)],pch=16,col="red",
       cex=1+aq05[,3]/norm(as.matrix(aq05[,3])))

plot(svet)
title("Nove sisteme v 2006")
points(koordinate[zz[aq06[,1]],c(1,2)],pch=16,col="red",
       cex=1+aq06[,3]/norm(as.matrix(aq06[,3])))

plot(svet)
title("Nove sisteme v 2007")
points(koordinate[zz[aq07[,1]],c(1,2)],pch=16,col="red",
       cex=1+aq07[,3]/norm(as.matrix(aq07[,3])))

zz[aq08[8,1]]<-"Korea"
plot(svet)
title("Nove sisteme v 2008")
points(koordinate[zz[aq08[,1]],1],koordinate[zz[aq08[,1]],2],pch=16,
       col="red",cex=1.3+aq08[,3]/norm(as.matrix(aq08[,3])))

plot(svet)
title("Nove sisteme v 2009")
points(koordinate[zz[aq09[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq09[,3]/norm(as.matrix(aq09[,3])))

plot(svet)
title("Nove sisteme v 2010")
points(koordinate[zz[aq10[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq10[,3]/norm(as.matrix(aq10[,3])))

plot(svet)
title("Nove sisteme v 2011")
points(koordinate[zz[aq11[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq11[,3]/norm(as.matrix(aq11[,3])))

plot(svet)
title("Nove sisteme v 2012")
points(koordinate[zz[aq12[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq12[,3]/norm(as.matrix(aq12[,3])))

zz[aq13[14,1]]<-"Russia"
plot(svet)
title("Nove sisteme v 2013")
points(koordinate[zz[aq13[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq13[,3]/norm(as.matrix(aq13[,3])))

plot(svet)
title("Nove sisteme v 2014")
points(koordinate[zz[aq14[,1]],c(1,2)],pch=16,col="red",
       cex=1.3+aq14[,3]/norm(as.matrix(aq14[,3])))
dev.off()


arr1 <- lapply(strsplit(x, ','), as.numeric)[[1]]
arr2 <- lapply(strsplit(y, ','), as.numeric)[[1]]

pearson <- cor.test(arr1,arr2,method="pearson",exact=F)
ttest <- t.test(arr1,arr2)

print(pearson$p.value)


pdf_file<-"pdf/maps_europe_choropleth_countries.pdf"
cairo_pdf(bg="grey98", pdf_file,width=13,height=11)

par(omi=c(0,0,0,0),mai=c(0,0,0,0),family="Lato Light",las=1)
library(maptools)
library(RColorBrewer)
library(sp)
library(rgdal) # for spTransform
library(gdata)

# Import data and prepare chart

myData<-read.csv("myData/prop.table EVS cntr.csv",sep=";",dec=",")
myData[is.na(myData$ATHE),"ATHE"]<--9
data(wrld_simpl)
w <- wrld_simpl[!(wrld_simpl@data[, "ISO2"] %in% myData$Country),]
w <- w[w@data[, "NAME"] != "Antarctica",]
m <- spTransform(w, CRS=CRS("+proj=merc"))

# Create chart

plot(m,xlim=c(-2000000,5000000),ylim=c(4000000,10000000),col=rgb(160,160,160,100,maxColorValue=255),border=F)

x<-readShapeSpatial("myData/NUTS-2010/NUTS_RG_60M_2010.shp",proj4string=CRS("+proj=longlat"))
y<-x[x$NUTS_ID %in% myData$Country,]
m <- spTransform(y, CRS=CRS("+proj=merc"))

myClasses<-c(-10,0,10,20,30,50)
myColourPalette<-c("cornflowerblue",brewer.pal(4,"Reds"))

id<-m$NUTS_ID
n<-length(id)
position<-vector()
for (i in 1:n){
	position[i]<-match(m$NUTS_ID[i], myData$Country)
}
myColour_no<-cut(myData$ATHE[position],myClasses)
levels(myColour_no)<-c("missing","0 to 10","10 to 20","20 to 30","30 to 50")
plot(m,col=myColourPalette[myColour_no],border="white",add=T)

legend("bottomleft",levels(myColour_no),cex=1.45,border=F,bty="n",fill= myColourPalette,text.col="black")

# Titling

mtext("Atheism in Europe",at=-1300000,cex=2,adj=0,line=-3)
mtext("",at=-1300000,cex=2,adj=0,line=-4.8)
mtext("Source: European Values Study",1,at=3200000,cex=1.7,adj=0,line=-2.3,font=3)
dev.off()


check <- function(x) {
  message.result <- c("vector is not numeric")
  if (is.numeric(x) == TRUE) {message.result <- "vector is numeric"}
  return(message.result)
}

x <- c( 1:10)
x
check(x)

xy <- c(1:20, "a")
xy
check(xy)

data <-data.frame(v1=1:6, v2=letters[1:6], v3= c(1:3, letters[1:3]))

check.data.frame <- function(x) {
  message.result <- ""
  for (index in 1:dim(x)[2]) {
    message.result[index] <- paste(names(data)[index], ifelse(is.numeric(x[,index]) == TRUE,": variable is numeric",": variable is not numeric"))
  }
  return(message.result)
}

check.data.frame(data)


########## LOAD REQUIRED LIBS #########
library(effects, warn.conflicts = FALSE)
library(latex2exp, warn.conflicts = FALSE)
library(multcomp, warn.conflicts = FALSE)
library(pander, warn.conflicts = FALSE)
library(papeR, warn.conflicts = FALSE)
library(pubh, warn.conflicts = FALSE)

panderOptions("table.split.table", Inf)
set.alignment("right", row.names = "left", permanent = TRUE)
trellis.par.set(tactile.theme())

library(arulesCBA)
library(corrplot)
library(magrittr)
library(dplyr)
library(ggplot2)
library(gee)
library(naniar)

##### READ DATA #######
farmerdat<- read.csv("E:/w6_C_stat.csv", sep= "," , header = TRUE) #reading farmer level data

#K-means clustering by 4 groups 14,42.4) [42.4,58.1) [58.1,69.6)   [69.6,96]
#table(discretize(farmerdat$Median, method = "cluster", breaks = 4))

#table(discretize(farmerdat$Median, method = "fixed", breaks = c(0,65, 79)))

#farmerdat$agec <- mutate((discretize(farmerdat$age,method = "fixed", breaks = c(14, 42, 58, 70, 96))))

##### MISSING DATA VIZ #####
gg_miss_upset(farmerdat, nsets = n_var_miss(farmerdat))

#############FORMATING################################
#converted all intigers to numeric
farmerdat[sapply(farmerdat, is.integer)]<-lapply(farmerdat[sapply(farmerdat, is.integer)],
                                                 as.numeric)
#factorial/binary variables
fvar <- c("resp_exposures___1", "resp_exposures___2", "respiratory___1", "respiratory___2",
          "respiratory___3","respiratory___4", "respiratory___5",
          "respiratory___6", "respiratory___7", "sex",
          "operation", "percent_worktime", "operator_num",
          "occupation", "resp_dis_num", "resp_dis_bin", "rhn_categ", "age_grp", "Livest_Y_N",
          "resp_exposures___3", "resp_exposures___4", "resp_exposures___5",
          "resp_exposures___6", "resp_exposures___7", "resp_exposures___8","resp_exp_other")
farmerdat[,fvar]<-lapply(farmerdat [,fvar], factor)

#data structure summary
str(farmerdat)

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

#contingency table 2 by 2
tbl <- table(farmerdat$resp_exposures___2, farmerdat$resp_exposures___5)
tbl
mosaicplot(tbl, main = "Title", color = T)
chisq.test(tbl) #chisquare test (2 groups)

#percentage table
prop.table(table(farmerdat$resp_exposures___2, farmerdat$resp_exposures___7))*100

#proportion table (currently not using for the study)
prop.table(table(farmerdat$resp_exposures___2, farmerdat$resp_exposures___7),
           margin = 2)*100

#operator and age

#distribution box plot
boxplot(farmerdat$age ~ farmerdat$operator_num)
#kruskal wallis test
kruskal.test(age~operator_num, data = farmerdat)

#univariate analysis
tapply(farmerdat$age , farmerdat$operator_num, summary)
aggregate(farmerdat$age~farmerdat$operator_num+farmerdat$operation+farmerdat$sex,
          FUN = summary)

#age distribution
ggplot(data = farmerdat, mapping = aes(x = age, fill= sex, color = sex)) +
  geom_histogram(binwidth=1, alpha=0.2, position="identity")

#density distribution
ggplot(farmerdat) + geom_density(aes(x = age, color = sex, alpha=0.5))

#cereal grains by state
boxplot(farmerdat$fm_Cereal_Grains ~ farmerdat$fm_state.1)
tapply(farmerdat$Median , farmerdat$fm_state.1, summary)

#Dichotamizing continous variable
farmerdat <- mutate(farmerdat, ppe_group = factor(1*(perct_resp >50),
                                                  labels = c("good", "bad")))

#PPE use summary
tapply(farmerdat$ppe_group , farmerdat$operator_num, summary)

#2 by 2 table
tbppe <- table(farmerdat$ppe_group , farmerdat$operator_num)
tbppe
mosaicplot(tbppe, main = "ppe and operator", color = T)
chisq.test(tbppe) #chisquare test (2 groups)

################## WORKING VARIABLES ###################
farmerdat$resp_exposures___2<- relevel(farmerdat$resp_exposures___2, ref = "0")
farmerdat$occupation<- relevel(farmerdat$occupation, ref = "2")

#GEE with Exchangable

#univariate
fit.gee2 <- gee(resp_dis_bin~resp_exposures___2, id=record_id, family=binomial,
                corstr="exchangeable", data=farmerdat) #crude

#multivariate model - adjusted analysis
fit.gee2 <- gee(resp_dis_bin~resp_exposures___7+percent_worktime+occupation+sex+
                  age_grp+operator_num+rhn_categ+operation, id=record_id, family=binomial,
                corstr="exchangeable", data=farmerdat)

summary(fit.gee2)
glm_coef(fit.gee2)
pander(glm_coef(fit.gee2 ))

################## MODEL - Final result ###################
#GEE with Exchangable
fit.gee2 <- gee(resp_dis_bin~resp_exposures___2+age_grp+sex+resp_exposures___3+resp_exposures___4
                +resp_exposures___5+resp_exposures___6+resp_exposures___7+resp_exposures___8
                , id=record_id,
                family=binomial,corstr="exchangeable", data=farmerdat)
summary(fit.gee2)
glm_coef(fit.gee2)
pander(glm_coef(fit.gee2 ))


# Goal: To make a latex table with results of an OLS regression.

# Get an OLS --
x1 = runif(100)
x2 = runif(100, 0, 2)
y = 2 + 3*x1 + 4*x2 + rnorm(100)
m = lm(y ~ x1 + x2)

# and print it out prettily --
library(xtable)
# Bare --
xtable(m)
xtable(anova(m))

# Better --
print.xtable(xtable(m, caption="My regression",
                    label="t:mymodel",
                    digits=c(0,3,2,2,3)),
             type="latex",
             file="xtable_demo_ols.tex",
             table.placement = "tp",
             latex.environments=c("center", "footnotesize"))

print.xtable(xtable(anova(m),
                    caption="ANOVA of my regression",
                    label="t:anova_mymodel"),
             type="latex",
             file="xtable_demo_anova.tex",
             table.placement = "tp",
             latex.environments=c("center", "footnotesize"))

# Read the documentation of xtable. It actually knows how to generate
# pretty latex tables for a lot more R objects than just OLS results.
# It can be a workhorse for making tabular out of matrices, and
# can also generate HTML.

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


## R sample code for the Linux data science VM (https://azure.microsoft.com/en-us/marketplace/partners/microsoft-ads/linux-data-science-vm/)

# before running the code, download the spambase data file and add a header. At a command line:
# wget http://archive.ics.uci.edu/ml/machine-learning-databases/spambase/spambase.data
# echo 'word_freq_make, word_freq_address, word_freq_all, word_freq_3d,word_freq_our, word_freq_over, word_freq_remove, word_freq_internet,word_freq_order, word_freq_mail, word_freq_receive, word_freq_will,word_freq_people, word_freq_report, word_freq_addresses, word_freq_free,word_freq_business, word_freq_email, word_freq_you, word_freq_credit,word_freq_your, word_freq_font, word_freq_000, word_freq_money,word_freq_hp, word_freq_hpl, word_freq_george, word_freq_650, word_freq_lab,word_freq_labs, word_freq_telnet, word_freq_857, word_freq_data,word_freq_415, word_freq_85, word_freq_technology, word_freq_1999,word_freq_parts, word_freq_pm, word_freq_direct, word_freq_cs, word_freq_meeting,word_freq_original, word_freq_project, word_freq_re, word_freq_edu,word_freq_table, word_freq_conference, char_freq_semicolon, char_freq_leftParen,char_freq_leftBracket, char_freq_exclamation, char_freq_dollar, char_freq_pound, capital_run_length_average,capital_run_length_longest, capital_run_length_total, spam' > headers
# cat spambase.data >> headers
# mv headers spambaseHeaders.data

data <- read.csv("spambaseHeaders.data")
set.seed(123)

# examine the data
summary(data)
str(data)

# spam was read as an integer, but it's a factor
data$spam <- as.factor(data$spam)

## make a few plots

library(ggplot2)

# plot the frequency of the exclamation mark character
ggplot(data) + geom_histogram(aes(x=char_freq_exclamation), binwidth=0.25)

# the zero bar is skewing the plot, so remove it
email_with_exclamation = data[data$char_freq_exclamation > 0, ]
ggplot(email_with_exclamation) + geom_histogram(aes(x=char_freq_exclamation), binwidth=0.25)

# look at the density above 1%
ggplot(data[data$char_freq_exclamation > 1, ]) + geom_histogram(aes(x=char_freq_exclamation), binwidth=0.25)

# and split it by spam vs ham
ggplot(data[data$char_freq_exclamation > 1, ], aes(x=char_freq_exclamation)) +
geom_density(lty=3) +
	geom_density(aes(fill=spam, colour=spam), alpha=0.55) +
	xlab("spam") +
	ggtitle("Distribution of spam \nby frequency of !") +
	labs(fill="spam", y="Density")

## create train and test sets
rnd <- runif(dim(data)[1])
trainSet = subset(data, rnd <= 0.7)
testSet = subset(data, rnd > 0.7)

## make a decision tree
require(rpart)
model.rpart <- rpart(spam ~ ., method = "class", data = trainSet)
plot(model.rpart)
text(model.rpart)

# and see how well it performs
testSetPred <- predict(model.rpart, newdata = testSet, type = "class")
t <- table(`Actual Class` = testSet$spam, `Predicted Class` = testSetPred)
accuracy <- sum(diag(t))/sum(t)
print(paste0("Decision tree test set accuracy is ", accuracy))

## try a random forest
require(randomForest)
trainVars <- setdiff(colnames(data), 'spam')
model.rf <- randomForest(x=trainSet[, trainVars], y=trainSet$spam)

# and see how well it does
trainSetPred <- predict(model.rf, newdata = trainSet[, trainVars], type = "class")
table(`Actual Class` = trainSet$spam, `Predicted Class` = trainSetPred)
testSetPred <- predict(model.rf, newdata = testSet[, trainVars], type = "class")
t <- table(`Actual Class` = testSet$spam, `Predicted Class` = testSetPred)
accuracy <- sum(diag(t))/sum(t)
print(paste0("Random forest test set accuracy is ", accuracy))

## xgboost

require(xgboost)

trainSet$spam <- as.numeric(levels(trainSet$spam))[trainSet$spam]
testSet$spam <- as.numeric(levels(testSet$spam))[testSet$spam]
bst <- xgboost(data = data.matrix(trainSet[,0:57]), label = trainSet$spam, nthread = 2, nrounds = 2, objective = "binary:logistic")

pred <- predict(bst, data.matrix(testSet[, 0:57]))
accuracy <- 1.0 - mean(as.numeric(pred > 0.5) != testSet$spam)
print(paste("xgboost test accuracy = ", accuracy))

## finally, publish a simplified decision tree to AzureML. If you don't have an account, sign up for one at https://studio.azureml.net/.
require(AzureML)

# Enter your workspace ID and authorization token here. To find them, sign in to the
# Azure Machine Learning Studio. You'll need your workspace ID and an authorization token.
# To find these, click Settings on the left-hand menu. Note your workspace ID.
# Next click Authorization Tokens from the overhead menu and note your Primary Authorization Token.
wsAuth = "<authorization-token>"
wsID = "<workspace-id>"

# make a simplified decision tree
colNames <- c("char_freq_dollar", "word_freq_remove", "word_freq_hp", "spam")
smallTrainSet <- trainSet[, colNames]
smallTestSet <- testSet[, colNames]
model.rpart <- rpart(spam ~ ., method = "class", data = smallTrainSet)

predictSpam <- function(char_freq_dollar, word_freq_remove, word_freq_hp) {
    predictDF <- predict(model.rpart, data.frame("char_freq_dollar" = char_freq_dollar,
    "word_freq_remove" = word_freq_remove, "word_freq_hp" = word_freq_hp))
    return(colnames(predictDF)[apply(predictDF, 1, which.max)])
}

# publish it to AzureML
spamWebService <- publishWebService("predictSpam",
    "spamWebService",
    list("char_freq_dollar"="float", "word_freq_remove"="float","word_freq_hp"="float"),
    list("spam"="int"),
    wsID, wsAuth)

# view some information about the published endpoint
spamWebService[[2]]

# and call it
consumeDataframe(spamWebService$endpoints[[1]]$PrimaryKey, spamWebService$endpoints[[1]]$ApiLocation, smallTestSet[1:10, 1:3])


#Build models with missing data. Then fill in missing data points.

train=read.csv('train.csv',header=T)
train1=train
train1$Pclass=as.factor(train1$Pclass)
train1$Survived=as.factor(train1$Survived)

#Remove missing Age
train2=train1[complete.cases(train1$Age),]

#Keep relevant features(PClass,Age,Sex,SibSp,Parch,Fare,Embarked)
train3=train2[,c(2,3,5,6,7,8,10,12)]
names(train3)
[1] "Survived" "Pclass"   "Sex"      "Age"      "SibSp"    "Parch"
[7] "Fare"     "Embarked"

#Get test data
test=read.csv('test.csv',header=T)
dim(test)
[1] 418  11
names(test)
 [1] "PassengerId" "Pclass"      "Name"        "Sex"         "Age"
 [6] "SibSp"       "Parch"       "Ticket"      "Fare"        "Cabin"
[11] "Embarked"

#Change Pclass to factor. "test" has missing data in Age and Fare.
test1=test
test1$Pclass=as.factor(test1$Pclass)
sum(is.na(test1$Age))
[1] 86
sum(is.na(test1$Fare))
[1] 1

#Add a column "Survived" as "test2"
Survived=rep('None',nrow(test1))
test2=data.frame(test1,Survived)
dim(test2)
[1] 418  12

#Take the revelant features as "test3"
test3=test2[,c(12,2,4,5,6,7,9,11)]
names(test3)
[1] "Survived" "Pclass"   "Sex"      "Age"      "SibSp"    "Parch"
[7] "Fare"     "Embarked"

#"test" has three levels for "Embarked".Change that to four levels.
levels(test3$Embarked)
[1] "C" "Q" "S"
levels(test3$Embarked)=c("","C","Q","S")

#Build randomForest model with "train3" and predict on "test3"
library(randomForest)
rf1=randomForest(Survived~.,data=train3,mtyr=2,importance=TRUE)
pred1=predict(rf1,test3)

#Combine "pred1" with "PassengerId"
final=data.frame(test2$PassengerId,pred1)
dim(final)
[1] 418   2
sum(is.na(final))
[1] 87

#But records with missing data cannot be predicted

#Fill in missing fare
test2[is.na(test$Fare),]
    PassengerId Pclass               Name  Sex  Age SibSp Parch Ticket
153        1044      3 Storey, Mr. Thomas male 60.5     0     0   3701
    Fare Cabin Embarked Survived
153   NA              S     None
#This passenger is in Pclass=3.Fill in missing Fare with median price from train$Fare where Pclass=3.
summary(train1[train1$Pclass==3,]$Fare)

test2[153,]$Fare=8.05

#To fill in missing Age, use Title from name
extractTitle=function(name){
+ if (length(grep('Miss',name))>0){return ('Miss')}
+ if (length(grep('Master',name))>0){return ('Master')}
+ if (length(grep('Mrs',name))>0){return ('Mrs')}
+ if (length(grep('Mr',name))>0){return ('Mr')}
+ else {return ('other')}
+ }

#Use median age to fill in missingAge in "train1" to get "trainComplete"
Title=NULL
for (i in 1:nrow(train1)){
+ Title=c(Title,extractTitle(train1[i,'Name']))
+ }
table(Title)
Title
Master   Miss     Mr    Mrs  other
    40    182    518    127     24
train1.title=data.frame(train1,Title)
trainNA=train1.title[is.na(train1.title$Age),]
summary(train1.title[train1.title$Title=='Miss',]$Age)
trainNA[trainNA$Title=='Miss',]$Age=21.00
summary(train1.title[train1.title$Title=='Master',]$Age)
trainNA[trainNA$Title=='Master',]$Age=3.500
summary(train1.title[train1.title$Title=='Mrs',]$Age)
trainNA[trainNA$Title=='Mrs',]$Age=35.00
summary(train1.title[train1.title$Title=='Mr',]$Age)
trainNA[trainNA$Title=='Mr',]$Age=30.00
summary(train1.title[train1.title$Title=='other',]$Age)
trainNA[trainNA$Title=='other',]$Age=44.00
trainA=train1.title[complete.cases(train1.title$Age),]
trainComplete=rbind(trainA,trainNA)
sum(is.na(trainComplete$Age))
[1] 0


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# This script calls the following five different scripts running the respective simulation.
# The results will be written out in files, which requires the definition a working directory
# below. Otherwise the files will be stored in the same folder as the scripts.
# Subsequently, a sixth script is called which creates the figure shown in
# Supplementary Fig. 5 of the article thereby importing the newly stored result files.
#
# Rcode_Seebens-etal_InvasionModel_Constant.r
# Rcode_Seebens-etal_InvasionModel_Linear.r
# Rcode_Seebens-etal_InvasionModel_Exponential.r
# Rcode_Seebens-etal_InvasionModel_Trade.r
# Rcode_Seebens-etal_InvasionModel_BotGar.r
#
# Rcode_Seebens-etal_InvasionModel_Plot.r to create the final plot.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# may change during the simulation depending on the scenario to account for increases
# in propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
# Five scenarios were simulated assuming different increases in the rate of
# introduction (constant, linear or exponential increase, related to import
# volumes or the number of founded botanic gardens).
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

graphics.off() # close windows
rm(list=ls()) # clear R environment

# setwd("/home/hanno/Bioinvasion/InvAccu")

source("Rcode_Seebens-etal_InvasionModel_Constant.r")
source("Rcode_Seebens-etal_InvasionModel_Linear.r")
source("Rcode_Seebens-etal_InvasionModel_Exponential.r")
source("Rcode_Seebens-etal_InvasionModel_Trade.r")
source("Rcode_Seebens-etal_InvasionModel_BotGar.r")

source("Rcode_Seebens-etal_InvasionModel_Plot.r")

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_PropPress_MAIN.r


setwd("G:\\My Drive\\JHO_lab\\recall_curve_papers\\JASA\\2021-09-07\\power_figures\\binorm")
source("compare_power.r")
source("convenience.r")

pdf("power_figure.pdf")
pi.0 = 1/500; m = 150000; rlim = .1;
plus2 = F; lift.ylim = 50; mu = c(sqrt(2) * .8, sqrt(2) * .6);
distr = "binorm";
par(mfrow = c(2, 2), mar = c(4, 4, 3, 3))
set.seed(125)

c <- seq(-5, 5, .0001)

F.plus1 <- pnorm(c, mean = mu[1], sd = 1)
F.plus2 <- pnorm(c, mean = mu[2], sd = 1)
F.neg <- pnorm(c, mean = mu[2], sd = 1)
f.neg <- dnorm(c, mean = 0, sd = 1)
f.plus1 <- dnorm(c, mean = mu[1], sd = 1)
f.plus2 <- dnorm(c, mean = mu[2], sd = 1)

# PDFs
col.list <- list(c("blue", "orange"), c("green", "orange"))
params.ls <- list(c(mu[1], 0), c(mu[2], 0))

plot(c, f.plus1, xlab="s", type = "l",
     ylab="f(s)", col = "blue", cex.lab=1.3)
lines(c, f.plus2, xlab="s", type = "l",
      ylab="f(s)", col = "orange")
lines(c, f.neg, xlab="s", type = "l",
      ylab="f(s)", col = "black")
legend(x="top", legend=c("Algorithm 1","Algorithm 2"),
       col=c(col.list[[1]][1], col.list[[1]][2]),
       lty=c(1,1), cex=.75, bty = "n", lwd = 2)
fig_label("A", cex=2.5, region="figure", pos="topleft")

xlim = log2(c(1/150000, .1)*150000)
for(metric in  c("k")) {
  for(pi.0 in c(1/500)){
    if (metric == "k") {
      plot(1, type="n", xaxt = 'n', ylab = "Recall", xlab = "Expected Compounds Tested (n = 150,000)",
           ylim = c(0,1), xlim = xlim)
      ticks <- c(1, 2, log(10, base = 2), seq(6, 8, by = 2), log(1500, base = 2), log(15000, base = 2))
      axis(1, at = ticks, labels = 2^ticks)
      fig_label("B", cex=2.5, region="figure", pos="topleft")
    }
    for(i in 1:2) {
      params <- params.ls[[i]]
      #print(distr)
      if (distr == "binorm") {
        c <- seq(-10, 10, .0001)
        F.plus <- pnorm(c, mean = params[1], sd = 1)
        F.neg <- pnorm(c, mean = params[2], sd = 1)
        f.plus <- dnorm(c, mean = params[1], sd = 1)
        f.neg <- dnorm(c, mean = params[2], sd = 1)
      } else if (distr == "binorm") {
        c <- seq(0, 1, .001)
        F.plus <- pbeta(c, params[[1]][1], params[[1]][2])
        F.neg <- pbeta(c, params[[2]][1], params[[2]][2])
        f.plus <- dbeta(c, params[[1]][1], params[[1]][2])
        f.neg <- dbeta(c, params[[2]][1], params[[2]][2])
      } else if (distr == "unif") {
        c <- seq(0, 1, .00001)
        F.plus <- punif(c, params[[1]][1], params[[1]][2])
        F.neg <- punif(c, params[[2]][1], params[[2]][2])
        f.plus <- dunif(c, params[[1]][1], params[[1]][2])
        f.neg <- dunif(c, params[[2]][1], params[[2]][2])
      }

      r <- 1 - pi.0 * F.plus - (1 - pi.0) * F.neg
      # only look at beginning of the curve
      idx <- r < rlim & (r > 1/m)
      r <- r[idx]
      frac <- log(150000*r, base = 2)
      k <- 1 - F.plus[idx]
      pi <- k*pi.0/r
      if (plus2){
        # Expected number of actives tested divided by expected number of actives
        k_c <- (m*pi.0*k+2)/(m*pi.0+4)
        # Expected number of actives tested divided by expected number of tested
        pi_c <- (m*r*pi+2)/(m*r+4)
      }
      f.s <- pi.0*f.plus[idx] + (1-pi.0)*f.neg[idx]
      lam <- pi.0*f.plus[idx]/f.s

      if (plus2){
        var.k.ratio <- 1-2*lam+(lam^2*(1-r))/(pi_c*(1-k_c))
        var.k.b <- ((m*pi.0)^-1)*k_c*(1-k_c)
        var.k <- var.k.b*var.k.ratio
      } else {
        var.k.ratio <- 1-2*lam+(lam^2*(1-r))/(pi*(1-k))
        var.k.b <- ((m*pi.0)^-1)*k*(1-k)
        var.k <- var.k.b*var.k.ratio
      }

      if (metric == "k") {
        lines(frac, k, lty = 1, lwd=1, col = col.list[[1]][i])
        ucl <- k + 1.96*sqrt(var.k); ucl <- ifelse(ucl > 1, 1, ucl)
        lcl <- k - 1.96*sqrt(var.k); lcl <- ifelse(lcl < 0, 0, lcl)
        polygon(c(frac, rev(frac)), c(ucl, rev(lcl)),
                col = add.alpha(col.list[[1]][i], .25), border = NA)
        lines(frac, 2^frac/150000, col = "grey")
      }
    }
  }
}

fixK <- function(ls1, ls2){
  for(i in 1:3) {
    ls1[[i]][[1]] <- ls2[[i]][[1]]
  }
  ls1
}

load("power_all_binorm_unpooled_nocorr.rdata")
ls <- k.ls

allMetric(ls, legend = 1)
fig_label("C", cex=2.5, region="figure", pos="topleft")

load("power_all_binorm_unpooled_corr.rdata")
ls <- k.ls

allMetric(ls, legend = 0)
fig_label("D", cex=2.5, region="figure", pos="topleft")

dev.off()


# impute train and test (no y) with Amelia

library( Amelia )

# for parallelism
ncpus = 8

setwd( 'data' )

train = read.csv( 'train.csv' )
test = read.csv( 'test.csv' )

output_file_stem = 'train_and_test_imp'

#

cols = colnames( train )
noms = cols[ -c( which( cols == 'YOB' ), which( cols == 'votes' ),
	which( cols == 'UserID' ), which( cols == 'Happy' )) ]				# can be done this way, can't it?
print( noms )

# join train and test - we need Happy in test

test['Happy'] = NA
data = rbind( train, test )

data[data == ''] = NA

# amelia

a.out = amelia( data, m = 8, idvars = c( 'UserID', 'Happy' ), noms = noms, parallel = 'multicore', ncpus = ncpus )

write.amelia( a.out, file.stem = output_file_stem )


#'@title  Trim a monthly time series object to so that partial years are removed
#'
#'@usage  tsData <- tsCompleteYears(tsData)
#'
#'@details This function is only supported for monthly time series
#'
#'@param tsData  A time series object
#'
#'@return A time series with partial years removed.
#'
#'@export

tsCompleteYears <- function(tsData)
{

	if (frequency(tsData) != 12) {
		stop("This function is only supported for monthly time series.")
	}

	origStartMonth <- start(tsData)[2]
	origStartYear  <- start(tsData)[1]
	origEndMonth   <- end(tsData)[2]
	origEndYear    <- end(tsData)[1]

	newStartMonth <- 1
	newEndMonth   <- 12

	tsObj <- tsData

	if (origStartMonth > 1) tsObj <- window(tsObj, start=c(origStartYear+1,newStartMonth))
	if (origEndMonth < 12)  tsObj <- window(tsObj, end=c(origEndYear-1,newEndMonth))

	return (tsObj)
}


#' ---
#' title: Section 4. Plotting Expression values
#' author:
#' output: github_document
#' ---

#' This is a complement to the hands on session for lecture 13.
#' First we need to load our expression data from a file (that you downloaded):

#expr <- read.table("rs8067378_ENSG00000172057.6.txt")

#' Or we can read from online.
url <- "https://bioboot.github.io/bimm143_S18/class-material/rs8067378_ENSG00000172057.6.txt"
expr <- read.table(url)

#' Check the genotype sample size and overall summary stats
summary(expr)

#' Lets break it down to the three genotypes by
#'
summary( expr[expr[,2] == "A/A",3] )
summary( expr[expr[,2] == "G/G",3] )
summary( expr[expr[,2] == "A/G",3] )

#' We could of also used `expr$geno == "A/A"` in the above, e.g.
summary( expr$exp[ expr$geno == "A/A" ] )

#' Lets generate some nice plots of our results

# Generate a boxplot for expression data of different genotype groups
p <- boxplot(exp~geno, data=expr, xlab="rs8067378 genotype", ylab="ENSG00000172057.4 (RPKM)", notch=T)

#' Look at the output 'p' and you will see the median values etc. used to generate the plot
p

#' ## Optional: Using ggplot2

#' We could also use the **ggplot2** package to make our plots

library(ggplot2)

## Boxplot
ggplot(expr, aes(geno, exp)) + geom_boxplot()

## Histogram of the exp column with ggplot2
ggplot(expr, aes(exp, fill = geno)) + geom_density(alpha = 0.2)

# Boxplot with the data shown
ggplot(expr, aes(geno, exp, fill=geno)) +
  geom_boxplot(notch=TRUE, outlier.shape = NA) +
  geom_jitter(shape=16, position=position_jitter(0.2), alpha=0.4)


# set the working directory (where the files are, so no paths are needed when loading/saving data)
# change this to your directory
setwd('E:teaching/2015_acg5075_r/introR')

# read csv file with columns: month,orders,costs
myData = read.csv("chapter14/dataset.csv")

# without setwd, the read would be:
# myData = read.csv("E:teaching/2015_acg5075_r/introR/chapter14/dataset.csv")

#outputs dataset
myData  #display contents
#   month orders costs
# 1     1   3000 32000
# 2     2   1500 22400
# 3     3   4000 52000
# 4     4   2800 31200
# 5     5   2300 25600
# 6     6   1000 16000
# 7     7   2000 24000

#push it into a matrix (another data type that allows more functions on it)
myMatrix = as.matrix(myData)
myMatrix #display contents
#      month orders costs
# [1,]     1   3000 32000
# [2,]     2   1500 22400
# [3,]     3   4000 52000
# [4,]     4   2800 31200
# [5,]     5   2300 25600
# [6,]     6   1000 16000
# [7,]     7   2000 24000

# extract some values
myMatrix[1,1]
# month
#     1

myMatrix[1,3]
# costs
# 32000

# third row
myMatrix[3,]
# month orders  costs
#     3   4000  52000

# get second column (as a vector)
myMatrix[, 2]
#[1] 3000 1500 4000 2800 2300 1000 2000

# can also use column name
myMatrix[ , 'orders']
#[1] 3000 1500 4000 2800 2300 1000 2000

# assign order vector to a variable
orders <- myMatrix[ , 'orders']

# function to get the minimum number
min (5, 2, 0, -20)
#[1] -20

#what is the lowest order number?
min(orders)
#[1] 1000

#what position has some entry in a vector? (1, 2, 3, ...)
which.min(orders)
#[1] 6
# means that the 6th month is the month with the lowest orders

# get the 6th row vs get the row that has the lowest orders
myMatrix[6, ]
# month orders  costs
#     6   1000  16000
myMatrix[which.min(orders), ]
# month orders  costs
#     6   1000  16000

#get the costs for the month with the lowest orders
myMatrix[which.min(orders), "costs"]
# costs
# 16000

#variable costs: difference in costs vs difference in activity
diffCosts <- myMatrix[which.max(orders), "costs"] - myMatrix[which.min(orders), "costs"]
diffCosts
# costs
# 36000

diffActivity <- myMatrix[which.max(orders), "orders"] - myMatrix[which.min(orders), "orders"]
diffActivity
# orders
#   3000

variableCosts <- diffCosts / diffActivity
variableCosts
# costs
#    12


# Synthetic Data Project
# Common Functions

# Author:
# Version:  5/14/2017

# Copyright 2017

# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
# associated documentation files (the "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the
# following conditions:

# The above copyright notice and this permission notice shall be included in all copies or substantial
# portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
# LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

frequencyMode <- function(x, nbins=25, nTopMean=1) {

  # compute mode of vector x as weighted mean of top nTopMean frequencies using nbins cut intervals
  # tabulate frequencies
  # take weighted mean of all bin midpoints in top nTopMean frequencies
  xtab <- table(cut(x, nbins))
  # identify top nTopMean frequencies
  k <- which(xtab %in% sort(unique(xtab), decreasing=T)[1:nTopMean])
  sum(mapply(k, FUN=function(i) {
                      # multiply interval centerpoints by frequencies
                      # format is "(b0,b1]" from cut()
                      interval <- names(xtab)[i]
                      # locate comma
                      cpos <- regexpr(",", interval)[1]
                      # exclude leading ( and trailing ]
                      b0 <- as.numeric(substr(interval, 2, cpos-1))
                      b1 <- as.numeric(substr(interval, cpos+1, nchar(interval)-1))
                      # multiply frequency by midpoint of lower and upper bounds
                      as.numeric(xtab[i])*(b0+b1)/2
                    })) / sum(xtab[k])

}


# Copyright 2015 Google Inc. All rights reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

##########################################
# Optional: Install Required Packages
##########################################

# For visualization
# install.packages("ggplot2", repos="http://cran.rstudio.com/")
library(ggplot2)

# Check the VIF, to find multicollinearity.
# install.packages("car", repos="http://cran.rstudio.com/")
library(car)

# To Plot ROC curve
# install.packages("ROCR", repos="http://cran.rstudio.com/")
library(ROCR)

# To check model
# install.packages("rms", repos="http://cran.rstudio.com/")
library(rms)

########################################
# Process the Data
########################################

data1 <- read.csv("./sample_data/train_data.csv")
names(data1)

# Delete unnecessary columns
data1 <- data1[c(-1,-2,-12,-22)]

# Calculate correlation coefficient
cor(data1)
symnum(abs(cor(data1)),cutpoints = c(0, 0.2, 0.4, 0.6, 0.9, 1), symbols = c(" ", ".", "_", "+", "*"))

# Delete "SUM_totals_hits" & "diffdays_oldest" as those correlation
# coefficients are higher than 0.9
data1 <- data1[c(-3,-7)]
names(data1)

# If we ran the model now, we would find that the regression
# coefficient for the "midnight_flag" variable would be undefined
# so we remove this variable from the model as well.
data1 <- data1[,c(-13)]
names(data1)

# Run the logistic analysis
model <- glm(formula = b_CV_flag ~., data = data1, family = binomial("logit"))
result <- summary(model)
result

# Check the VIF, to find multicollinearity.
vif(model)

# When check the result from the VIF calculation above, there are two
# variables that are over 10, "SUM_totals_pageviews" (over 30) and
# "SUM_hits_hitNumber" (over 27). In other words, multicollinearity occurs.
# Therefore, we have to delete one of the variables, in this case
# "SUM_totals_pageviews" and rerun the logistic analysis.

# Delete the "SUM_totals_pageviews" variable. And rerun the logistic regression analysis.
data1_2 <- data1[,c(-2)]
model1_2 <- glm(formula = b_CV_flag ~., data = data1_2, family = binomial("logit"))
result1_2 <- summary(model1_2)
result1_2

# Check VIF again to verify that the multicollinearity is no longer occuring.
vif(model1_2)

# None of the variables have values over 10, so there is no multicollinearity
# and we can use this model.

############################
# Generate GAIN Curve
############################

prob <- data.frame(predict(model1_2, data1_2, type = "response"))
gain <- cumsum(sort(prob[, 1], decreasing = TRUE)) / sum(prob)

# Save the plot in local file
png('gain_curve_plot.png')
plot(gain,main ="Gain chart",xlab="number of users", ylab="cumulative conversion rate")
dev.off()

############################
# Generate ROC Curve
############################

pred <- prediction(prob, data1_2$b_CV_flag)
perf <- performance(pred, measure = "tpr", x.measure = "fpr")

# Plot and save as Rplots.pdf in local file
pdf('Rplots.pdf')
qplot(x = perf@x.values[[1]], y = perf@y.values[[1]], xlab = perf@x.name, ylab = perf@y.name, main="ROC curve")
dev.off()

#####################################
# Model Verification
#####################################

# Check model with R package
Logistic_Regression_Model <- lrm(b_CV_flag ~., data1_2)
Logistic_Regression_Model

# Check AIC (An Information Criteria) of the two models
# to verify which is better. A smaller number is better.
AIC(model)
AIC(model1_2)

# Summarize the coefficient values for easy transfer to BigQuery
# SQL statement
coef <- names(model1_2$coefficient)
value <- as.vector(model1_2$coefficient)
result <- data.frame(coef, value)
result