############################################################################
## Nighttime light in Mexican states at analytical units                  ##
##                                                                        ##
## Code to debug, validate, describe MUNICIPIO electoral-level statistics ##
##                                                                        ##
## Prepared by Eric Magar 6may2021                                        ##
## emagar at itam dot mx                                                  ##
############################################################################

library(DataCombine) # easy lags with slide

rm(list = ls())

edos <- c("ags", "bc", "bcs", "cam", "coa", "col", "cps", "cua", "df", "dgo", "gua", "gue", "hgo", "jal", "mex", "mic", "mor", "nay", "nl", "oax", "pue", "que", "qui", "san", "sin", "son", "tab", "tam", "tla", "ver", "yuc", "zac")
estados <- c("Aguascalientes", "Baja California", "Baja California Sur", "Campeche", "Coahuila", "Colima", "Chiapas", "Chihuahua", "Ciudad de México", "Durango", "Guanajuato", "Guerrero", "Hidalgo", "Jalisco", "México", "Micchoacán", "Morelos", "Nayarit", "Nuevo León", "Oaxaca", "Puebla", "Querétaro", "Quintana Roo", "San Luis Potosí", "Sinaloa", "Sonora", "Tabasco", "Tamaulipas", "Tlaxcala", "Veracruz", "Yucatán", "Zacatecas")

# select state to process
edon <- 1; edo <- edos[edon]; estado <- estados[edon]; print(paste("Will describe", toupper(estado), "stats"))

# municipios
dd <- c(paste0("~/Dropbox/data/mapas/luminosity/data/municipios/", edo, "/")) # municipios
setwd(dd)

# read state data into data.frames
yr <- 1992
tmp <- read.csv(file = paste0("lum", yr, ".csv"), stringsAsFactors = FALSE)
tmp$sd[is.na(tmp$sd)] <- 0 # missing sd due to single pixel, should be zero
#
l.mean   <- tmp; l.mean$median <- l.mean$sd <- l.mean$note <- NULL; colnames(l.mean)[4] <- "y1992"
l.median <- tmp; l.median$mean <- l.median$sd <- l.median$note <- NULL; colnames(l.median)[4] <- "y1992"
l.sd     <- tmp; l.sd$mean <- l.sd$median <- l.sd$note <- NULL; colnames(l.sd)[4] <- "y1992"

for (yr in 1993:2018){
    #yr <- 1993 # debug
    tmp <- read.csv(file = paste0("lum", yr, ".csv"), stringsAsFactors = FALSE)
    tmp$sd[is.na(tmp$sd)] <- 0 # missing sd due to single pixel, should be zero
    # plug yr's stats into relevant data.frame
    l.mean <- cbind(l.mean, tmp$mean); colnames(l.mean)[ncol(l.mean)] <- paste0("y", yr)
    l.median <- cbind(l.median, tmp$median); colnames(l.median)[ncol(l.median)] <- paste0("y", yr)
    l.sd <- cbind(l.sd, tmp$sd); colnames(l.sd)[ncol(l.sd)] <- paste0("y", yr)
}

# first differences and relative change
l.dif0 <- l.mean[,-c(1:3)] # drop edon seccion
l.dif1 <- l.dif0[,-1]; l.dif1 <- cbind(l.dif1, y2019=rep(NA,nrow(l.dif0)))
l.rel1 <- round((l.dif1 - l.dif0) / (l.dif0 + .001), 3) # +.001 to avoid indeterminacy when base is zero
l.dif1 <- l.dif1 - l.dif0 #  1st difference
l.dif1$y2019 <- l.rel1$y2019 <- NULL # drop last year indetermined
rm(l.dif0) # clean
l.dif1 <- cbind(l.mean[,c(1:3)], l.dif1) # add edon seccion again
l.rel1 <- cbind(l.mean[,c(1:3)], l.rel1) # add edon seccion again
head(l.dif1)
head(l.rel1)

# 1992 = 100
l.rel0 <- l.mean
#l.rel0[,-c(1:3)] <- l.rel0[,-c(1:3)] + 0.001 # smallest measure>0 is 0.01, add 0.001 to avoid indeterminacy
l.rel0[,-c(1:3)] <- l.rel0[,-c(1:3)] + 100 # largest measure is 63, sliding up to 100 should work
l.rel0[,-c(1:3)] <- l.rel0[,-c(1:3)] *100 / l.rel0[,4]

# plot y1992 = 100
clr <- rgb(190, 190, 190, maxColorValue = 255, alpha = 50)
plot(x=1992:2018,l.rel0[1,-1:-3],ylim=c(50,160),type="n", axes=FALSE,
     main = paste0(estado, ", municipios"), ylab = "Relative luminosity (1992 = 100)", xlab = "")
axis(1, at = seq(1992,2018,1), labels = FALSE)
axis(1, at = c(1992,seq(1995,2015,5),2018))
axis(2)
for (i in 1:nrow(l.rel0)) lines(x=1992:2018,l.rel0[i,-1:-3],col=clr,lwd=1)
abline(h=100,col="red")

# trend and plot it
trend <- as.list(rep(NA, nrow(l.mean)))
names(trend) <- l.mean$munn
#
for (i in 1:nrow(l.mean)){
    dat    <- data.frame(x = c(1992:2018) - 1992) # start from 0,0
    #dat    <- data.frame(x = 1992:2018)
    dat$y <- t(l.rel0[i,-c(1:3)]) - 100
    #dat$y <- t(l.rel0[i,-c(1:3)])
    #dat$y <- t(l.mean[i,-c(1:3)])
    trend[[i]] <- lm( y ~ x - 1, data = dat)
}
#
clr <- rgb(190, 190, 190, maxColorValue = 255, alpha = 50)
plot(x=1992:2018,l.rel0[1,-1:-3],ylim=c(50,160),type="n", axes=FALSE,
     main = paste0(estado, ", municipios"), ylab = "Time trend in rel. luminosity (1992 = 100)", xlab = "")
axis(1, at = seq(1992,2018,1), labels = FALSE)
axis(1, at = c(1992,seq(1995,2015,5),2018))
axis(2)
for (i in 1:length(trend)) abline(a=summary(trend[[i]])$coefficients[1,1],col=clr,lwd=1)
#for (i in 1:length(trend)) abline(trend[[i]],col=clr,lwd=1)
abline(h=100,col="red")

# 1107819448674 # folio cancelacion izzi 6may2021

## # OJO: when using spTranform in script, use line below for google earth, or next line for OSM/google maps
#x.map <- spTransform(x.map, CRS("+proj=longlat +datum=WGS84"))
#x.map <- spTransform(x.map, osm()) # project to osm native Mercator

# to use osm backgrounds
library(rJava)
library(OpenStreetMap)
library(raster)

# geospatial data
#library(spdep);
library(maptools)
# used to determine what datum rojano data has
library(rgdal)
#gpclibPermit()

rd <- c("~/Dropbox/data/mapas/luminosity/")
md <- c("~/Dropbox/data/elecs/MXelsCalendGovt/redistrict/ife.ine/mapasComparados/")

# state's borders
tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
tmp <- readOGR(dsn = tmp, layer = 'ENTIDAD')
# projects to a different datum with long and lat
tmp <- spTransform(tmp, osm())
ed.map <- tmp
#
# state's municipios
tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
mu.map <- readOGR(dsn = tmp, layer = 'MUNICIPIO')
summary(mu.map)
# projects to a different datum with long and lat
mu.map <- spTransform(mu.map, osm()) # project to osm native Mercator
#plot(mu.map)
#
# state's secciones
tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
se.map <- readOGR(dsn = tmp, layer = 'SECCION')
summary(se.map)
# projects to a different datum with long and lat
se.map <- spTransform(se.map, osm()) # project to osm native Mercator
#plot(se.map)
# prepare data.frame to receive luminosity seccion-level stats
dat <- se.map@data
dat$ord <- 1:nrow(dat)

pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
r <- raster(pth) # filenames 1992-2013
    # projects to a different datum with long and lat
r <- projectRaster(r, crs=osm()) # project to osm native Mercator
    # clip raster to state
r <- mask(r, ed.map)         # approximate poligon only
r[is.na(r)] <- 0 # make NAs zeroes
    # verify
#    png(file = "../pics/bc.png")
par(mar=c(.5,.5,2,1)) ## SETS B L U R MARGIN SIZES
plot(r, lwd = 1)
plot(r, axes = FALSE, main = edo)
plot(ed.map, add = TRUE, lwd = 1)
#    plot(se.map, add = TRUE, lwd = .1)
plot(se.map[which(dat$seccion %in% sel),], add = TRUE, lwd = 1, col = "red")
#    dev.off()
    #
        one.se <- subset(se.map, se.map@data$seccion==ses[i])
        #plot(one.se, main=paste("sección", ses[i]))
        # clip raster to seccion
        r.se <- crop(r, extent(one.se)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.se <- mask(r.se, one.se)         # approximate poligon
        ## # verify
        ## par(mar=c(.5,.5,2,4)) ## SETS B L U R MARGIN SIZES
        ## plot(one.se, main=paste("sección", ses[i]))
        ## plot(r.se, add = TRUE)
        ## plot(one.se, add = TRUE, lwd = .5)
        #
        v <- unlist(extract(r, one.se)) # get values inside poligon
        l.work$mean  [i] <- round(mean  (v),2)
        l.work$sd    [i] <- round(sd    (v),2)
        l.work$median[i] <- round(median(v),2)
    }
    ly <- rbind(ly, l.work)
    return(ly)
}

i <- 1992
for (i in 1992:2018){
    yr <- i
    ly <- calc.yr(yr=yr)
    ly <- ly[order(ly$seccion),] # sort
    ly$ord <- NULL # drop plotting order
    tail(ly)
    pth <- paste(rd, "data/secciones/", edo, "/lum", yr, ".csv", sep="") # archivo de luminosidad
    write.csv(ly, file = pth, row.names=FALSE)
}

# l will receive state/year's stats, then will be rbound to year's dataframe ly
dat.mu <- mu.map@data
dat.mu$ord <- 1:nrow(dat.mu)
l <- data.frame(ord = dat.mu$ord, edon = dat.mu$entidad, munn = dat.mu$municipio, mun = dat.mu$nombre); l$median <- l$sd <- l$mean <- NA; l$note <- ""
mus <- l$munn

calc.yr.mu <- function(yr){
    #yr <- 2000 # debug
    ly <- data.frame()
    # open raster layer
    pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
    r <- raster(pth) # filenames 1992-2013
    # projects to a different datum with long and lat
    r <- projectRaster(r, crs=osm()) # project to osm native Mercator
    # clip raster to state
    r <- mask(r, ed.map)         # approximate poligon only
    r[is.na(r)] <- 0 # make NAs zeroes
    ## # verify
    ## plot(r)
    ## plot(ed.map, add = TRUE, lwd = .2)
    ## plot(se.map, add = TRUE, lwd = .1)
    #
    # copy master data.frame
    l.work <- l
    # fill row-by-row
    for (i in 1:length(mus)){
        #i <- 1 # debug
        ## if (
        ##   (edon==1  & ses[i] %in% c(318,603:607))  # secciones shapefiles appear to be corrupted
        ## | (edon==7  & ses[i] %in%   2042:2048)
        ## | (edon==16 & ses[i] %in% c(2080,2696:2703))
        ## ){
        ##     l.work$note[i] <- "shapefile corrupted"
        ##     next
        ## }
        message(sprintf("%spct of %s-%s: i=%s mun %s", round(i*100/length(mus),0), edo, yr, i, mus[i]))
        one.mu <- subset(mu.map, mu.map@data$municipio==mus[i])
        #plot(one.se, main=paste("sección", ses[i]))
        # clip raster to seccion
        r.mu <- crop(r, extent(one.mu)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.mu <- mask(r.mu, one.mu)         # approximate poligon
        ## # verify
        ## plot(one.mu)
        ## plot(r.mu, add = TRUE)
        ## plot(one.mu, add = TRUE, lwd = .2)
        #
        v <- unlist(extract(r, one.mu)) # get values inside poligon
        l.work$mean  [i] <- round(mean  (v),2)
        l.work$sd    [i] <- round(sd    (v),2)
        l.work$median[i] <- round(median(v),2)
    }
    ly <- rbind(ly, l.work)
    return(ly)
}

i <- 1992
for (i in 1992:2018){
    yr <- i
    ly <- calc.yr.mu(yr=yr)
    ly <- ly[order(ly$munn),] # sort
    ly$ord <- NULL # drop plotting order
    tail(ly)
    pth <- paste(rd, "data/municipios/", edo, "/lum", yr, ".csv", sep="") # archivo de luminosidad
    write.csv(ly, file = pth, row.names=FALSE)
}


# (9) #########

writeLines("Now for some examples that actually work")
writeLines("but maybe not the way you expected.")
writeLines("The export may generate a warning.")
##
ct <- makeCluster(cores)
registerDoParallel(ct)
##
if(!exists("doverbose")){doverbose=FALSE}
nt<-10
asum<-0
writeLines("\nasum is zero")
bsum<-foreach(ijk=1:nt , .combine=cbind, .export=(c('asum'))) %dopar% {
	asum<-2**ijk
	asum
}
print(asum)
print(bsum)

#readline(prompt = "NEXT>")

nt<-10
asum<-vector(mode="double",length=nt)
writeLines("\nasum is vector of zero")

bsum<-foreach(ijk=1:nt , .combine=cbind,.export=(c('asum')) ) %dopar% {
	asum<-2**ijk
	asum
}
print(asum)
print(bsum)

asum=vector(mode="double",length=nt)+2000
writeLines("\nasum is vector of 2000")
bsum<-foreach(ijk=1:nt , .combine=cbind,.export=(c('asum')) ) %dopar% {
	asum<-2**ijk
	asum
}
print(asum)
print(bsum)

stopCluster(ct)
#readline(prompt = "NEXT>")


#' Number of control matrix principal components
#'
#' Fits probe intensities to principal components of the microarray control matrix
#' and calculates the resulting mean squared residuals for different
#' numbers of principal components.
#'
#' @param qc.objects A list of outputs from \code{\link{meffil.create.qc.object}()}.
#' @param number.pcs Number of principal components to include in the design matrix (Default: all).
#' @param fixed.effects Names of columns in samplesheet that should be included as fixed effects
#' along with control matrix principal components (Default: NULL).
#' @param random.effects Names of columns in samplesheet that should be included as random effects
#' (Default: NULL).
#' @return A list containing a data frame with the mean squared residuals for different numbers of principal components
#' and a plot of these residuals.
#'
#' @export
meffil.plot.pc.fit <- function(qc.objects, fixed.effects=NULL, random.effects=NULL, n.cross=10, name="autosomal.ii") {
    stopifnot(is.valid.site.subset(name))
    stopifnot(all(sapply(qc.objects, is.qc.object)))

    if (2*n.cross > length(qc.objects))
        n.cross <- floor(length(qc.objects)/2)

    n.quantiles <- length(qc.objects[[1]]$quantiles[[1]]$M)
    max.pcs <- min(ncol(meffil.control.matrix(qc.objects)),
                   length(qc.objects) - ceiling(length(qc.objects)/n.cross))

    stats <- mclapply(1:max.pcs, function(number.pcs) {
        residuals <- list(M=matrix(NA,nrow=n.quantiles,ncol=length(qc.objects)),
                          U=matrix(NA,nrow=n.quantiles,ncol=length(qc.objects)))
        group <- sample(rep(1:n.cross, length.out=length(qc.objects)), length(qc.objects), replace=F)

        for (test.group in unique(group)) {
            msg("pcs", number.pcs, "group", test.group)
            test.idx <- which(group == test.group)
            design.matrix <- predict.design.matrix(qc.objects, number.pcs, test.idx,
                                                   fixed.effects=fixed.effects,
                                                   random.effects=random.effects)

            intensity.R <- sapply(qc.objects, function(object) object$intensity.R)
            intensity.G <- sapply(qc.objects, function(object) object$intensity.G)
            valid.idx <- which(intensity.R + intensity.G > 200)
            if(length(valid.idx) == 0) {
                valid.idx <- 1:length(intensity.R)
                warning("Most or all of the microarrays have very low intensity.")
            }
            reference.idx <- valid.idx[which.min(abs(intensity.R/intensity.G-1)[valid.idx])]
            dye.intensity <- (intensity.R + intensity.G)[reference.idx]/2
            for (target in c("M","U")) {
                original <- sapply(qc.objects[test.idx], function(object) {
                    object$quantiles[[name]][[target]] * dye.intensity/object$dye.intensity
                })
                residuals[[target]][,test.idx] <- (normalize.quantiles(original, design.matrix)
                                                   - rowMeans(original))
            }
        }

        c(n=number.pcs,M=mean((residuals$M[,-1])^2), U=mean((residuals$U[,-1])^2))
    })

    stats <- as.data.frame(do.call(rbind, stats))

    list(data=stats,
         plot=(ggplot(stats, aes(x=n)) +
               geom_line(aes(y=M, colour="M")) +
               geom_line(aes(y=U, colour="U")) +
               ggtitle("Fit residuals for different numbers of PCs") +
               labs(x="number of PCs", y="Mean squared residuals") +
               scale_x_continuous(breaks=seq(0,max(stats$n),by=5 )) +
               theme(legend.title=element_blank())))
}


jmp = c(6, 1.5, 1.5, 0.25, 0.75, 1.5, 3, 0.5, 1.5)
iter = 1e8
out.length = 10000
burn.length = 1e8

resp.f = c(1.21,1.37,1.2,1.47,1.47,1.49,1.47,1.39,1.52)


bigres=matrix(NA,length(dir(pattern="*.rda")),12)

k=1
for(I in dir(pattern="*.rda")) {

load(I)
sa=sapply(1:1000,function(j) {
jnk=res[[j]]$rl
ifelse(!inherits(jnk,"try-error"),
sum(abs(res[[j]]$rl$k-res[[1]]$ktrue)),NA)})
bigres[k,1]=as.numeric(substr(I,4,6))
bigres[k,3]=ifelse(as.numeric(substr(I,2,2))==2,0,1)
    bigres[k,2]=as.numeric(substr(I,9,9))
    Ti=bigres[k,2]
    bigres[k,1:Ti+3]=res[[1]]$ktrue
bigres[k,12]=mean(sa==0,na.rm=TRUE)
k=k+1
}
colnames(bigres)=c("n","T","highlysep","k1","k2","k3","k4","k5","k6","k7","k8","pCorrect")

bigres3=matrix(NA,length(dir(pattern="k4")),14)

k=1
for(I in dir(pattern="k4")) {

load(I)

bigres3[k,1]=as.numeric(substr(I,4,6))
bigres3[k,2]=as.numeric(substr(I,9,9))
bigres3[k,3]=ifelse(as.numeric(substr(I,2,2))==2,0,1)
    Ti=bigres3[k,2]
    bigres3[k,1:Ti+3]=res[[1]]$ktrue
# MSE xi2

xi=array(1,c(4,4,3))
    sigma=xi
    sepp=ifelse(as.numeric(substr(I,2,2))==3,4,2.5)
for(j in 1:4) {
for(u in 1:3) {
xi[j,1:j,u]=seq(0,sepp*j,length=j)}}

bigres3[k,12]=mean(sapply(1:1000, function(j) {
jnk=res[[j]]$rl
ifelse(!is.null(jnk) & !inherits(jnk,"try-error"), ifelse(any(jnk$k==4),
sum((res[[j]]$rl$xi[4,1:4,]-xi[4,1:4,])^2,na.rm=TRUE),NA),NA)}),na.rm=TRUE)

bigres3[k,13]=mean(sapply(1:1000, function(j) {
jnk=res[[j]]$rlmax
ifelse(!is.null(jnk) & !inherits(jnk,"try-error"),
sum((res[[j]]$rlmax$xi[4,1:4,]-xi[4,1:4,])^2,na.rm=TRUE),NA)}),na.rm=TRUE)

    bigres3[k,14]=mean(sapply(1:1000, function(j) {
jnk=res[[j]]$rlfixed
ifelse(!is.null(jnk)  & !inherits(jnk,"try-error"),
sum((res[[j]]$rlfixed$xi[4,1:4,]-xi[4,1:4,])^2,na.rm=TRUE),NA)}),na.rm=TRUE)

k=k+1
}

colnames(bigres3)=c("n","T","highlysep","k1","k2","k3","k4","k5","k6","k7","k8",paste("msexi4",c("est","max","fix")))

rm(res)
save.image(file="resultsPI12.RData")


#Objetivo:  dado un dataset y la funcion de ganancia,  devuelve el corte optimo

#el codigo NO es generico
#se asume que la clase se llama  clase_ternaria  y que los positivos son los BAJA+2

#limpio la memoria
rm(list=ls())
gc()

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

library("data.table")

#aqui cada alumno debe poner SUS PROPIAS SEMILLAS
ksemilla_azar1   <-  7799901
ksemilla_azar2   <-  56008937

#------------------------------------------------------------------------------
#dados un dataset y el nombre de una columna,  calcula el mejor corte para esa columna
#no hace falta modificar esta funcion

columna_mejorcorte  = function(pcolumna, pdataset)
{

  #calculos basicos
  universo     <-  nrow(pdataset )
  pos_total    <-  sum(pdataset$clase01 )
  neg_total    <-  universo -  pos_total
  gan_universo <-  19500*pos_total - 500*neg_total

  #calculo la ganancia de los  na's
  pos_na    <-  sum(  pdataset[ is.na( get(pcolumna) ), clase01 ],  na.rm=TRUE )
  neg_na    <-  sum(  1- pdataset[ is.na( get(pcolumna) ), clase01 ],  na.rm=TRUE  )
  gan_na    <-  19500*pos_na - 500*neg_na

  gan_universo_nonulo <-  gan_universo - gan_na

  #genero el universo de los valores NO NULOS
  univar    <-  pdataset[ !is.na( get(pcolumna) ),  c("clase01", pcolumna, "azar"),  with=FALSE ]
  universo_nonulo <- nrow(univar)

  #este es el caso en que todos los valores de la variable son nulos
  if( universo_nonulo==0 )
  {
    return(  list(  "columna"   = pcolumna,
                    "valor"     = NA ,
                    "gan_left"  = 0 ,
                    "gan_right" = 0,
                    "gan_na"    = gan_na,
                    "gan_total" = gan_na
                 )
        )

  }

  #ordeno creciente por  <pcolumna, azar>
  univar <- univar[ order(get(pcolumna), azar),   c("clase01", pcolumna), with=FALSE]

  gan_acum  <- cumsum( ifelse( univar$clase01, 19500, -500 ) )
  gan_mejor <- pmax( gan_acum, gan_universo_nonulo - gan_acum )

  columna <- as.vector( univar[ , get(pcolumna) ] )
  pos     <-  which.max( gan_mejor )
  val     <-  columna[pos]

  i         <-  match( val,  columna )
  pos_inf   <-  pmax( 1, i-1 )
  valor_inf <- columna[pos_inf]
  gan_inf   <- gan_mejor[ pos_inf ]

  i <-  pos
  while( i<=universo_nonulo  &&  columna[i]== val ) i<- i+1 ;
  pos_sup    <- i-1
  valor_sup  <- columna[pos_sup ]
  gan_sup    <- gan_mejor[ pos_sup ]

  if( gan_inf > gan_sup )
  {
    ganancia    <- gan_inf
    valor       <- valor_inf
    pos         <- pos_inf
  }else{
    ganancia    <- gan_sup
    valor       <- valor_sup
    pos         <- pos_sup
  }

  gan_left  <-  gan_acum[ pos ]
  gan_right <-  gan_universo_nonulo - gan_acum[ pos ]

  return(  list(  "columna"   = pcolumna,
                  "valor"     = valor ,
                  "gan_left"  = gan_left ,
                  "gan_right" = gan_right,
                  "gan_na"    = gan_na,
                  "gan_total" = pmax( gan_left, gan_right, gan_left+gan_na,  gan_right+gan_na)
               )
        )

}
#------------------------------------------------------------------------------
#dado un dataset,  devuelve el mejor corte desde el punto de vista de la ganancia
#no hace falta modificar esta funcion

dataset_mejorcorte  = function(pdataset)
{
  #creo una variable azar que me va a ser util
  #inicializo el generador de numeros aleatorios
  set.seed( ksemilla_azar2 )
  pdataset[ , azar   := runif(nrow(pdataset)) ]

  #busco el mejor corte del dataset
  metricas <- lapply( colnames( pdataset) , columna_mejorcorte,  pdataset )
  metricas <- rbindlist( metricas )

  metricas <- metricas[ order( -gan_total ) ]

  #me quedo con el primero SIN ser clase01 ni clase_ternaria
  m <-  metricas[ columna!="clase01" & columna!="clase_ternaria",  ][1]

  return(  list(  "columna"   = m$columna,
                  "valor"     = m$valor ,
                  "gan_left"  = m$gan_left ,
                  "gan_right" = m$gan_right,
                  "gan_na"    = m$gan_na,
                  "gan_total" = m$gan_total
               )
        )

}

#------------------------------------------------------------------------------
#Aqui comienza el programa principal

#cargo el dataset
dataset <- fread("201902.txt")

#creo una clase que sea 1 cuando es BAJA+2 , y  0 en caso contrario
#esto me simplifica los calculos
dataset[ , clase01:= as.integer(clase_ternaria=="BAJA+2") ]

#-------------------------
#Divido el dataset en training 50% y testing 50%
# training es cuando particion=1,  testing cuando particion=2

set.seed(ksemilla_azar1 )

dataset[, azar :=  runif( nrow(dataset) )]

setorder( dataset,  clase01,  azar )

neg_cant <-  nrow( dataset[ clase01==0 , ] )
pos_cant <-  nrow( dataset[ clase01==1 , ] )

dataset[  , particion:= 1 ]
dataset[  (round(neg_cant/2)+1): neg_cant ,  particion:= 2 ]
dataset[  (neg_cant+1):(neg_cant+1+ round(pos_cant/2)) ,  particion:= 2 ]

nrow( dataset[ particion==1, ] )
nrow( dataset[ particion==2, ] )
#-------------------------

#agrego un campo llamado nodo_arbol
#donde se podra rastear de donde proviene ese nodo
dataset[ , nodo_arbol := "1" ]

#en este momento hay un solo nodo, el "1", que es la raiz

#hago los conteos
hacerConteo  = function()
{

  dataset[ , list(  train_cant = sum(  particion==1 ),
                    test_cant  = sum(  particion==2 ),
                    train_pos  = sum(  particion==1 & clase01==1 ),
                    test_pos   = sum(  particion==2 & clase01==1 ),
                    train_neg  = sum(  particion==1 & clase01==0 ),
                    test_neg   = sum(  particion==2 & clase01==0 ),
                    train_gan  = sum(  ifelse( particion==1, ifelse( clase01, 19500, -500),  NA ), na.rm=TRUE),
                    test_gan   = 2*(sum(  ifelse( particion==2, ifelse( clase01, 19500, -500),  NA ), na.rm=TRUE))
  )
  , by="nodo_arbol" ]
}

#-------------------------

#Empiezo la construccion del primer nivel del arbol

#primero voy a partir la raiz del arbol
#veo cual es el mejor corte en training
#nodo_arbol=="1"  estoy en la raiz
dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1",]  )

#---- ALUMNOS   ATENCION
#---- a partir de aqui DEBEN modificar el codigo
#---- ya que les saldra cortes distintos a los mios !

#aplico el corte que se acaba de imprimir
#este es un caso simple, la columna por la que corto no tiene nulos
#si hubiera nulos,  hay que decidir si van para la derecha o la izquierda

dataset[ nodo_arbol=="1" & ttarjeta_visa<=0,  nodo_arbol:= "11" ]
dataset[ nodo_arbol=="1" & ttarjeta_visa>0 ,  nodo_arbol:= "12" ]

#termine el primer nivel del arbol, hago los conteos
hacerConteo()

#-------------------------

#Empiezo la construccion del segundo nivel del arbol

#la hoja izquierda
#nodo_arbol=="11"  estoy en la hoja izquierda raiz
dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="11", ] )

dataset[ nodo_arbol=="11" & mautoservicio<=230.37,  nodo_arbol:= "111" ]
dataset[ nodo_arbol=="11" & mautoservicio> 230.37,  nodo_arbol:= "112" ]

#la hoja derecha
#nodo_arbol=="12"  estoy en la hoja derecha raiz
dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12", ] )

dataset[ nodo_arbol=="12" & Visa_Finiciomora<=20190211,  nodo_arbol:= "121" ]
dataset[ nodo_arbol=="12" & ( Visa_Finiciomora>20190211 | is.na(Visa_Finiciomora) ) ,  nodo_arbol:= "122" ]

#termine el segundo nivel del arbol, hago los conteos
hacerConteo()

#Pregunta
#Empiezan a notar que en testing
#el oro no es "tan oro" como en lo es training
#y que la piedra no es "tan piedra"  ?
#en este momento cada fibra de su humanidad debe estar resonando con este arbol de decision

#-------------------------

#---- ALUMNOS   ATENCION
#---- a partir de aqui DEBEN seguir cortando las hojas, agregando codigo al script
#---- ya que deben lograr un arbol con 16 hojas
#---- por favor, no actuar como un automata finito,  si a su criterio no vale la pena cortar un nodo del arbo, NO HACERLO

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="111", ] )
#dataset[ nodo_arbol=="111" & ccajeros_propio_transacciones<=1,  nodo_arbol:= "1111" ]
#dataset[ nodo_arbol=="111" & ( ccajeros_propio_transacciones>1 | is.na(ccajeros_propio_transacciones) ) ,  nodo_arbol:= "1112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="112", ] )
#dataset[ nodo_arbol=="112" & mcuenta_corriente_Paquete<=-5031.85,  nodo_arbol:= "1121" ]
#dataset[ nodo_arbol=="112" & ( mcuenta_corriente_Paquete>-5031.85 | is.na(mcuenta_corriente_Paquete) ) ,  nodo_arbol:= "1122" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="121", ] )
dataset[ nodo_arbol=="121" & marketing_coss_selling<=10,  nodo_arbol:= "1211" ]
dataset[ nodo_arbol=="121" & ( marketing_coss_selling>10 | is.na(marketing_coss_selling) ) ,  nodo_arbol:= "1212" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="122", ] )
dataset[ nodo_arbol=="122" & tmovimientos_ultimos90dias<=1,  nodo_arbol:= "1221" ]
dataset[ nodo_arbol=="122" & ( tmovimientos_ultimos90dias>1 | is.na(tmovimientos_ultimos90dias) ) ,  nodo_arbol:= "1222" ]

hacerConteo()

#Resultados
#--------------------------11
#--------------121--------------------122
#---------1211------1212---------1221------1222

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1211", ] )
dataset[ nodo_arbol=="1211" & mcuenta_corriente_Paquete<=1,  nodo_arbol:= "12111" ]
dataset[ nodo_arbol=="1211" & ( mcuenta_corriente_Paquete>1 | is.na(mcuenta_corriente_Paquete) ) ,  nodo_arbol:= "12112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1212", ] )
#Gan = 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1221", ] )
dataset[ nodo_arbol=="1221" & mcaja_ahorro_Paquete<=1,  nodo_arbol:= "12211" ]
dataset[ nodo_arbol=="1221" & ( mcaja_ahorro_Paquete>1 | is.na(mcaja_ahorro_Paquete) ) ,  nodo_arbol:= "12212" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222", ] )
dataset[ nodo_arbol=="1222" & mcheques_emitidos_rechazados<=130162.5,  nodo_arbol:= "12221" ]
dataset[ nodo_arbol=="1222" & ( mcheques_emitidos_rechazados>130162.5 | is.na(mcheques_emitidos_rechazados) ) ,  nodo_arbol:= "12222" ]

hacerConteo()

#Resultados
#------------------------------11
#-----------------121--------------------------------122
#-------1211----------------1212---------1221----------------1222
#--12111---12112---------------------12121--12122-------12221---12222

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12111", ] )
dataset[ nodo_arbol=="12111" & mcuenta_corriente_Paquete<=-1726.58,  nodo_arbol:= "121111" ]
dataset[ nodo_arbol=="121112" & ( mcuenta_corriente_Paquete>-1726.58 | is.na(mcuenta_corriente_Paquete) ) ,  nodo_arbol:= "121112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12112", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12121", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12122", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12221", ] )
dataset[ nodo_arbol=="12221" & marketing_coss_selling<=4,  nodo_arbol:= "122211" ]
dataset[ nodo_arbol=="12221" & ( marketing_coss_selling>4 | is.na(marketing_coss_selling) ) ,  nodo_arbol:= "122212" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="12222", ] )
dataset[ nodo_arbol=="12222" & mcuenta_corriente_Paquete<=-134881,  nodo_arbol:= "122221" ]
dataset[ nodo_arbol=="12222" & ( mcuenta_corriente_Paquete>-134881 | is.na(mcuenta_corriente_Paquete) ) ,  nodo_arbol:= "122222" ]

hacerConteo()

#Resultados
#------------------------------------11
#---------------------121----------------------------------122
#-----------1211----------------1212------------1221-------------------1222
#-----12111------12112---------------------12121-----12122-------12221------12222
#121111-121112----------------------------------------------122211-122212--122221-122222

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="121111", ] )
dataset[ nodo_arbol=="121111" & mpagomiscuentas<=1925.36,  nodo_arbol:= "1211111" ]
dataset[ nodo_arbol=="121111" & ( mpagomiscuentas>1925.36 | is.na(mpagomiscuentas) ) ,  nodo_arbol:= "1211112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="121112", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="122211", ] )
dataset[ nodo_arbol=="122211" & numero_de_cliente<=43832058,  nodo_arbol:= "1222111" ]
dataset[ nodo_arbol=="122211" & ( numero_de_cliente>43832058 | is.na(numero_de_cliente) ) ,  nodo_arbol:= "1222112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="122212", ] )
dataset[ nodo_arbol=="122212" & mcomisiones_mantenimiento<=-4198.8,  nodo_arbol:= "1222121" ]
dataset[ nodo_arbol=="122212" & ( mcomisiones_mantenimiento>-4198.8 | is.na(mcomisiones_mantenimiento) ) ,  nodo_arbol:= "1222122" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="122221", ] )
dataset[ nodo_arbol=="122221" & numero_de_cliente<=50908094,  nodo_arbol:= "1222211" ]
dataset[ nodo_arbol=="122221" & ( numero_de_cliente>50908094 | is.na(numero_de_cliente) ) ,  nodo_arbol:= "1222212" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="122222", ] )
#Ganancia 0

hacerConteo()

#Resultados
#--------------------------------------------------------------11
#---------------------------------------------121-----------------------------------------------------122
#-----------------------------1211--------------------------1212--------------------------------1221------------------------------1222
#------------------12111-------------12112--------------------------------------------12121------------12122------------12221-----------12222
#-----------121111-------121112----------------------------------------------122211------------122212------------122221-------122222
#------1211111-1211112--------------------------------------------------1222111-1222112---1222121-1222122---1222211-1222212

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1211111", ] )
dataset[ nodo_arbol=="1211111" & Master_msaldodolares<=0,  nodo_arbol:= "12111111" ]
dataset[ nodo_arbol=="1211111" & ( Master_msaldodolares>0 | is.na(Master_msaldodolares) ) ,  nodo_arbol:= "12111112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1211112", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222111", ] )
#Ganancia 0

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222112", ] )
dataset[ nodo_arbol=="1222112" & numero_de_cliente<=46822826,  nodo_arbol:= "12221121" ]
dataset[ nodo_arbol=="1222112" & ( numero_de_cliente>46822826 | is.na(numero_de_cliente) ) ,  nodo_arbol:= "12221122" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222121", ] )
dataset[ nodo_arbol=="1222121" & mpasivos_margen<=0,  nodo_arbol:= "12221211" ]
dataset[ nodo_arbol=="1222121" & ( mpasivos_margen>0 | is.na(mpasivos_margen) ) ,  nodo_arbol:= "12221212" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222122", ] )
dataset[ nodo_arbol=="1222122" & Visa_fechaalta<=19910214,  nodo_arbol:= "12221221" ]
dataset[ nodo_arbol=="1222122" & ( Visa_fechaalta>19910214 | is.na(Visa_fechaalta) ) ,  nodo_arbol:= "12221222" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222211", ] )
dataset[ nodo_arbol=="1222211" & numero_de_cliente<=50908094,  nodo_arbol:= "12222111" ]
dataset[ nodo_arbol=="1222211" & ( numero_de_cliente>50908094 | is.na(numero_de_cliente) ) ,  nodo_arbol:= "12222112" ]

dataset_mejorcorte( dataset[ particion==1 & nodo_arbol=="1222212", ] )
#Ganancia 0

hacerConteo()

#Ganancia total +
#6'758.000


# Try different values of k for glrm and find the value with the highest pcc

rm(list = ls())

source("../project_support.r")

# Load data
raw_data <- read_csv("./input/data_transposed.csv")
questions <- read_csv("./input/drh_v6_poll.csv")

# Select only parent questions for coarse analysis
parent_quest <- questions %>% filter(is.na(`Parent Question`))

# Create output directory
make.dir("./k_value")

# initate h2o
h2o.init(nthreads = -1)

# Find optimal value of k for glrm
glrm_k_idx(raw_data, analysis = "a", granularity = "c", var_filter = 0.5, entry_filter = 0.5, seed = 123)
glrm_k_idx(raw_data, analysis = "a", granularity = "c", var_filter = 0.35, entry_filter = 0.3, seed = 123)
glrm_k_idx(raw_data, analysis = "a", granularity = "f", var_filter = 0.5, entry_filter = 0.5, seed = 123)
glrm_k_idx(raw_data, analysis = "a", granularity = "f", var_filter = 0.35, entry_filter = 0.3, seed = 123)
glrm_k_idx(raw_data, analysis = "b", granularity = "c", var_filter = 0.5, entry_filter = 0.5, seed = 123)
glrm_k_idx(raw_data, analysis = "b", granularity = "c", var_filter = 0.35, entry_filter = 0.3, seed = 123)
glrm_k_idx(raw_data, analysis = "b", granularity = "f", var_filter = 0.5, entry_filter = 0.5, seed = 123)
glrm_k_idx(raw_data, analysis = "b", granularity = "f", var_filter = 0.35, entry_filter = 0.3, seed = 123)

# Shutdown H2O
h2o.shutdown(prompt=FALSE)


# Create a new data frame called murders_nw with only the states from the northeast and the west

murders_nw <- filter(murders, region %in% c("Northeast", "West"))

# Number of states (rows) in this category
nrow(murders_nw)


#Fit a hierarchical core/plot/site jags model.
#clearn envirionment, source paths.
rm(list=ls())
source('paths.r')
#source('/home/caverill/NEFI_microbe/data_formatting/formatting_NEON_microbial/core_site_plot_aggregation_May.2018/0. aggregation paths.r')
#source some other functions
source('NEFI_functions/hierarchical_linear_dirlichet_jags.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/mean_center.r')

#load data.
obs.table <- readRDS( obs.table.path)
core.table <- readRDS(core.table.path)
plot.table <- readRDS(plot.table.path)
site.table <- readRDS(site.table.path)

##TESTING
#lets only look at complete cases for 2 sites right now.
obs.table <-  obs.table[obs.table$siteID %in% c('BART','HARV'),]
core.table <- core.table[core.table$geneticSampleID %in% obs.table$geneticSampleID,]
plot.table <- plot.table[plot.table$plotID %in% obs.table$plotID,]
site.table <- site.table[site.table$siteID %in% obs.table$siteID,]

#put everything in correct order.
#Convert all factor vectors to character vectors - this line sucks and is a good argument for data.table/tidyverse
 obs.table[sapply( obs.table, is.factor)] <-  lapply( obs.table[sapply( obs.table, is.factor)], as.character)
core.table[sapply(core.table, is.factor)] <-  lapply(core.table[sapply(core.table, is.factor)], as.character)
plot.table[sapply(plot.table, is.factor)] <-  lapply(plot.table[sapply(plot.table, is.factor)], as.character)
site.table[sapply(site.table, is.factor)] <-  lapply(site.table[sapply(site.table, is.factor)], as.character)

#hierarchically order the rows as site/plot/core.
obs.table <-  obs.table[order( obs.table$siteID, obs.table$plotID, obs.table$geneticSampleID),]
core.table <- core.table[order(core.table$siteID,core.table$plotID,core.table$geneticSampleID),]
plot.table <- plot.table[order(plot.table$siteID,plot.table$plotID),]
site.table <- site.table[order(site.table$siteID),]
core_mu <- core.table
plot_mu <- plot.table
site_mu <- site.table

#setup indexing
core_plot <- as.factor(core.table$plotID)
core_site <- as.factor(core.table$siteID)
plot_plot <- as.factor(plot.table$plotID)
site_site <- as.factor(site.table$siteID)

#setup y, core, plot and site data frames, and associated sd tables where applicable.
y <- obs.table[,3:6]
#dropping soil moisture and soil pH for now because all NA values for two site-dates of interest.
#core <- core.table[,c('siteID','plotID','soilMoisture','soilInWaterpH','soilTemp')]
#colnames(core)[3:5] <- c('moisture','pH','temperature')
core <- core.table[,c('siteID','plotID','soilTemp')]
colnames(core)[3] <- c('temperature')
core_sd <- core.table[,c('siteID','plotID')]
plot <- plot.table[,c('siteID','plotID','organicCPercent','CNratio')]
plot_sd <- plot.table[,c('siteID','plotID','organicCPercent_sd','CNratio_sd')]
site <- site.table[,c('siteID','elevation','map','mat','n.dep')]
site_sd <- site.table[,c('siteID','map_sd','mat_sd')]

#drop plot-site indices from data frames. Those saved in index vectors.
core$intercept <- rep(1,nrow(core))
core <- core[,-c(1:2)]; core <- core[,c('intercept','temperature')]
plot <- plot[,-c(1:2)]
site <- site[,-c(1:2)]
for(i in 1:ncol(core)){
  core[,i] <- mean_center(core[,i])
}
for(i in 1:ncol(plot)){
  plot[,i] <- mean_center(plot[,i])
}
for(i in 1:ncol(site)){
  site[,i] <- mean_center(site[,i])
}

core_sd <- NA
plot_sd <- NA
site_sd <- NA

#transform y values.
y <- data.frame(lapply(y, crib_fun))
#reorder y columns so 'other' is first.
y <- data.frame(y$other, y[,1:3])

core_mu = core; plot_mu = plot; site_mu = site

test <- hierarchical_dirlichet_jags.r(y = y,
                                      core_mu = core, plot_mu = plot, site_mu = site,
                                      core_sd = core_sd, plot_sd = plot_sd, site_sd = site_sd,
                                      core_plot = core_plot, core_site = core_site, plot_plot = plot_plot, site_site = site_site)

testing_development/ddirch_development/testing ddirch hierarchically with NEON data.r


#Remove Characters
remove_char <- function(elements,x){
  for(j in strsplit(elements,'')[[1]]){
    x <- gsub(j,'',x) #Check weather the given character is in the possible x and if so replace it
  }
  return(x)
}

#Search weather LHS exsists in the current Closure
search_attr <- function(x,data){
  condition = TRUE
  for(i in 1:nchar(data)){
    if(x == ''){break}
    if(!grepl(substr(x,1,1),data)){
      condition = FALSE
      break
    }
    x <- substr(x,2,nchar(x))
  }
  if(x != '')
    condition = FALSE
  return(condition)
}

#Check weather one FD is a subset of another FD
check_subset <- function(superset,subset){
  condition = TRUE
  for(i in 1:nrow(subset)){
    temp <- find_closure(subset[i,'V1'],superset)
    if(!search_attr(subset[i,'V2'],temp)){
      condition = FALSE
      break
    }
  }
  return(condition)
}

# Combining FD's with Common LHS
combine_fd <- function(data){
  nofd <- nrow(data)
  loop_condition = TRUE
  i <- 1
  while(loop_condition){
    common <- c()
    for(j in 1:nofd){
      if(data[j,'V1'] == data[i,'V1']){
        common <-append(common,j)
      }
    }
    temp <- strsplit(paste(data[common,'V2'],collapse = ""),'')[[1]]
    temp <- temp[!duplicated(temp)]
    add <- c(data[i,'V1'],paste(temp,collapse = ''))
    data <- data[-common,]
    data <- rbind(data,add)
    nofd <- nrow(data)
    i <- i + 1
    if(i > nofd)
      loop_condition = FALSE
  }
  return(data)
}

#Find all Attributes possible using FD's
find_attr <- function(input){
  temp <- paste(paste(input[,'V1'],collapse = ''),paste(input[,'V2'],collapse = ''),sep = '')
  temp <- strsplit(temp,'')[[1]]
  temp <- temp[!duplicated(temp)]
  attr <- paste(sort(temp),collapse = '')
  return(attr)
}


print(paste0(Sys.time(), " --- Prop species describing <=N species"))

taxonomic_effort$N_real_describers.1.prop <- taxonomic_effort$N_real_describers.1 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.2.prop <- taxonomic_effort$N_real_describers.2 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.3.prop <- taxonomic_effort$N_real_describers.3 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.4.prop <- taxonomic_effort$N_real_describers.4 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.5.prop <- taxonomic_effort$N_real_describers.5 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.6.prop <- taxonomic_effort$N_real_describers.6 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.7.prop <- taxonomic_effort$N_real_describers.7 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.8.prop <- taxonomic_effort$N_real_describers.8 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.9.prop <- taxonomic_effort$N_real_describers.9 / taxonomic_effort$N_real_describers * 100
taxonomic_effort$N_real_describers.10.prop <- taxonomic_effort$N_real_describers.10 / taxonomic_effort$N_real_describers * 100

taxonomic_effort$N_real_describers.1.prop_roll <- rollmean(taxonomic_effort$N_real_describers.1.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.2.prop_roll <- rollmean(taxonomic_effort$N_real_describers.2.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.3.prop_roll <- rollmean(taxonomic_effort$N_real_describers.3.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.4.prop_roll <- rollmean(taxonomic_effort$N_real_describers.4.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.5.prop_roll <- rollmean(taxonomic_effort$N_real_describers.5.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.6.prop_roll <- rollmean(taxonomic_effort$N_real_describers.6.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.7.prop_roll <- rollmean(taxonomic_effort$N_real_describers.7.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.8.prop_roll <- rollmean(taxonomic_effort$N_real_describers.8.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.9.prop_roll <- rollmean(taxonomic_effort$N_real_describers.9.prop, 10, fill = list(NA, NULL, NA))
taxonomic_effort$N_real_describers.10.prop_roll <- rollmean(taxonomic_effort$N_real_describers.10.prop, 10, fill = list(NA, NULL, NA))

cols <- names(taxonomic_effort)[grepl(".prop", names(taxonomic_effort))]
cols <- c("years", cols)
des_y <- melt(taxonomic_effort[, ..cols], id.vars="years")

cols <- names(taxonomic_effort)[grepl(".prop_roll", names(taxonomic_effort))]
cols <- c("years", cols)
des_y_roll <- melt(taxonomic_effort[, ..cols], id.vars="years")
des_y_roll$variable <- gsub("_roll", "", des_y_roll$variable)

des_y <- merge(
    des_y, des_y_roll, by=c("years", "variable"), suffixes=c("", "_roll")
)

# Trend analysis
cols <- names(taxonomic_effort)[grepl(".prop_roll", names(taxonomic_effort))]
cols <- c("years", cols)
te_trend <- taxonomic_effort[, ..cols]

results_p <- c()
results_tau <- c()
for (i in 1:10) {
    name <- paste0("N_real_describers.", i, ".prop_roll")
    trend <- te_trend[, get(name)]
    # plot(trend)
    res <- MannKendall(trend)
    results_p <- c(results_p, round(as.numeric(res$sl), 2))
    results_tau <- c(results_tau, round(as.numeric(res$tau), 2))
}

print(paste0(results_tau, collapse = ", "))
print(paste0(results_p, collapse = ", "))
print(which(results_p > 0.05))
print(sum(results_p <= 0.05))

formatstr <- function(string) {
    string <- gsub("N_real_describers.", "", string)
    string <- gsub(".prop", "", string)
    string <- ifelse(
        string=="1",
        paste0(string, " species"), paste0("<=", string, " species")
    )
    string
}

des_y$variable <- factor(
    des_y$variable, levels = paste0("N_real_describers.", 1:10, ".prop")
)

plot_tax <- ggplot(des_y, aes(x=years, y=value, group=variable)) +
    geom_line(size=.5, colour="grey", linetype='dashed') +
    geom_point(size=.5, color='grey') +
    geom_smooth(size=1, colour="black") +
    geom_line(size=.7, aes(y=value_roll), color='grey50') +
    xlab("\nYear") + ylab("Percentage of PTEs describing <= N species (%)\n") +
    facet_wrap(
        . ~variable, ncol=2,
        labeller=labeller(variable=formatstr), dir="v"
    ) +
    scale_y_continuous(limits=c(0, 50), breaks=seq(0,50,20), minor_breaks=seq(0, 50, 10)) +
    theme + theme_minimal(
        base_size=10
    ) + theme(
        strip.text = element_text(size = 9)
    )

ggsave(
    paste0(dir_plot, 'fig-6.png'), plot_tax, units="cm",
    width=14, height=12, dpi=300
)

des_y_data <- des_y[, c("years", "variable", "value", "value_roll")]

des_y_data$N_species_described <- as.integer(
    gsub("N_real_describers.|.prop", "", des_y_data$variable)
)

des_y_data$variable <- NULL

des_y_data <- des_y_data[order(N_species_described, years)]

wfile <- paste0(v2_dir_data_webapp, "ch1-fig-03-data.csv")
fwrite(des_y_data, wfile, na="")


#' Grab Auxilliary Files
#'
#' This function reads in values from the *.std, *.par, and *.cor files.
#' @param wd directory where ASAP run is located
#' @param asap.name Base name of original dat file (without the .dat extension)
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param index.names names of indices
#' @return list of summary statistics about run (e.g. # parameters, correlation matrix, max gradient)
#' @export

GrabAuxFiles <- function(wd,asap.name,asap,fleet.names,index.names) {

  aux.list <-  list("npar"=-999, "asap.cor.names"=NA, "asap.cor.mat"=NA,
                    "asap.std"=NA, "max.grad"=-999, "F.rep"=NA, "Tot.B"=NA , "SSB"=NA,
                    "Expl.B"=NA, "recr"=NA, "asap.name"=asap.name )

  if (file.exists(paste0(wd,"\\",asap.name,".std"))){
    # Read in std file from admb
    asap.std <- read.table(paste0(wd,"\\",asap.name, ".std"), header = F, skip=1, stringsAsFactors = FALSE)
    names(asap.std) <- c("index", "name", "value", "stdev" )

    years <- seq(asap$parms$styr, asap$parms$endyr)

    # Read in cor file from admb
    ncol.cor <- dim(asap.std) [1]
    asap.cor <- read.table(paste0(wd,"\\",asap.name, ".cor"), header = F, skip=2,
                           col.names=c("index", "name", "value", "stdev", seq(1,ncol.cor)), fill=T)
    asap.cor.mat <- as.matrix(asap.cor[,5:length(asap.cor[1,])])
    asap.cor.names <- as.character(as.vector(asap.cor[,2]) )
    levels.cor.names <- unique(asap.cor.names)
    F.rep <- which(asap.cor.names=="Freport")
    asap.cor.names[F.rep] <- paste(asap.cor.names[F.rep],years, sep=".")
    Tot.B <- which(asap.cor.names=="TotJan1B")
    asap.cor.names[Tot.B] <- paste(asap.cor.names[Tot.B],years, sep=".")
    SSB <- which(asap.cor.names=="SSB")
    asap.cor.names[SSB] <- paste(asap.cor.names[SSB],years, sep=".")
    Expl.B <- which(asap.cor.names=="ExploitableB")
    asap.cor.names[Expl.B] <- paste(asap.cor.names[Expl.B],years, sep=".")
    recr <- which(asap.cor.names=="recruits")
    asap.cor.names[recr] <- paste(asap.cor.names[recr],years, sep=".")

    N.yr1 <- which(asap.cor.names=="log_N_year1_devs")
    asap.cor.names[N.yr1] <- paste(asap.cor.names[N.yr1],"Age",seq(2,asap$parms$nages), sep=".")

    recr.devs <- which(asap.cor.names=="log_recruit_devs")
    asap.cor.names[recr.devs] <- paste(asap.cor.names[recr.devs],years, sep=".")
    Fmult.yr1 <- which(asap.cor.names=="log_Fmult_year1")
    asap.cor.names[Fmult.yr1] <- paste(asap.cor.names[Fmult.yr1],fleet.names, sep=".")
    Fmult.devs <- which(asap.cor.names=="log_Fmult_devs")
    asap.cor.names[Fmult.devs] <- paste(asap.cor.names[Fmult.devs],paste(fleet.names, rep(years[2:length(years)], each=asap$parms$nfleets),  sep="."), sep=".")
    q.yr1 <- which(asap.cor.names=="log_q_year1")
    asap.cor.names[q.yr1] <- paste(asap.cor.names[q.yr1],index.names, sep=".")

    q.devs <- which(asap.cor.names=="log_q_devs")
    #asap.cor.names[q.devs] <- paste(asap.cor.names[q.devs],index.names, sep=".")

    if (length(q.devs)>0) asap.cor.names[q.devs] <- paste(asap.cor.names[q.devs],years, sep=".")

    diag(asap.cor.mat) <- rep(NA, ncol.cor)

    asap.grad <- readLines(paste0(wd, "\\", asap.name, ".par"),n=1)
    par.split<- unlist(strsplit(asap.grad, " "))
    max.grad <- par.split[length(par.split)]
    npar <- as.numeric(par.split[ 6])
    aux.list <-  list("npar"=npar, "asap.cor.names"=asap.cor.names, "asap.cor.mat"=asap.cor.mat,
                      "asap.std"=asap.std, "max.grad"=max.grad, "F.rep"=F.rep[1], "Tot.B"=Tot.B[1],
                      "SSB"=SSB[1], "Expl.B"=Expl.B[1] , "recr"=recr[1], "asap.name"=asap.name )
  }

  return(aux.list)
}


correlator <- function() {
    xVals <- c()
    yVals <- c()

    memo <- function(x, y) {
        xVals <<- union(xVals, x)
        yVals <<- union(yVals, y)
    }

    show <- function() {
        r <- lm(xVals ~ yVals)
        print(r)
    }

    return(list(memo=memo, show=show))
}


get.askhseis <- function(AM) {
    if_else <- c(1:10)
    for_while <- c(11:23)
    if_else_for_while <- c(if_else, for_while)

    vectors <- c(24:39)
    lists <- c(40:56)
    matrices <- c(57:72)
    vectors_lists_matrices <- c(vectors, lists, matrices)

    data_frames <- c(73:88)
    plots <- c(89:100)
    data_frames_plots <- c(data_frames, plots)

    set.seed(AM + 20212)

    askhseis <- c()
    askhseis <- c(askhseis, sample(if_else, 1))
    askhseis <- c(askhseis, sample(for_while, 1))
    askhseis <- c(askhseis, sample(vectors, 1))
    askhseis <- c(askhseis, sample(lists, 1))
    askhseis <- c(askhseis, sample(matrices, 1))
    askhseis <- c(askhseis, sample(data_frames, 1))
    askhseis <- c(askhseis, sample(plots, 1))

    for (extra in list(if_else_for_while, vectors_lists_matrices, data_frames_plots)) {
        while (TRUE) {
            n <- sample(extra, 1)
            if (! n %in% askhseis) {
                break
            }
        }
        askhseis <- c(askhseis, n)
    }

    askhseis <- sort(askhseis)

    return (askhseis)
}


library ('boot')
library ('parallel')
library ('tidyverse')

options (boot.parallel = 'multicore')
options (boot.ncpus = detectCores ())

DATA_PATH <- '.'

REPLICATES <- 33333
CONFIDENCE <- 0.99

OUTLIER_LIMIT <- 0.05
OUTLIER_SLACK <- 0.1

PLOT_ROWS <- 4
PLOT_WIDTH <- 300
PLOT_HEIGHT <- 300

STRIPE_ROWS <- 2
STRIPE_WIDTH <- 400
STRIPE_HEIGHT <- 250

VM_BASELINE <- 'OpenJDK'

# Incrementally load data.
# This is O(n^2) as it should be :-)

master <- tibble ()

vm_dirs <- list.files (DATA_PATH, '^[[:alnum:][:punct:]]+$', include.dirs = TRUE, full.names = TRUE)
for (vm_dir in vm_dirs) {
    vm_name <- basename (vm_dir)

    data_files <- list.files (vm_dir, '^[[:alnum:][:punct:]]+\\.csv\\.xz$', full.names = TRUE)
    for (data_file in data_files) {
        data_name <- basename (data_file)
        data_split <- strsplit (data_name, '\\.csv\\.xz') [[1]]
        benchmark_name <- data_split [1]

        data_read <- suppressMessages (read_csv (data_file, col_types = cols (.default = col_double ())))
        descriptor <- tibble (benchmark = benchmark_name, vm = vm_name)
        master <- bind_rows (master, crossing (descriptor, data_read))
    }
}

# One time post processing.

# We really want time in seconds.
# TODO Eventually the harness should dump nanosecond CSV files.
master <- master %>% mutate (time = time / 1000)

# We want baseline virtual machine to the left.
# TODO Eventually this should be read from platform metadata.
master <- master %>% mutate (vm = factor (
    vm,
    ordered = TRUE,
    levels = c ('OpenJDK', 'OpenJ9', 'GraalVM-CE', 'GraalVM-EE'),
    labels = c ('OpenJDK', 'OpenJ9', 'GraalVM CE', 'GraalVM EE')))

# Annotate data with cold vs warm information.
#
# Right now we use a trivial filter, everything
# in the first half of ten minute execution
# is cold.

BENCHMARK_EXEC_TIME <- 600
WARM_CUTOFF_TIME <- BENCHMARK_EXEC_TIME * 0.5

master <- master %>% group_by (benchmark, vm, run) %>% mutate (total = cumsum (time))
master <- master %>% mutate (warm = (total >= WARM_CUTOFF_TIME))
master <- master %>% ungroup ()

# Helper function for averaging over runs.
get_run_means <- function (data) {
    return (data %>% group_by (run) %>% summarize (avg = mean (time)) %>% pull (avg))
}

# Simple violin plots: Single plot per benchmark

do_flag_outliers <- function (data) {
    limits <- quantile (data, c (OUTLIER_LIMIT, 1 - OUTLIER_LIMIT))
    range <- limits [2] - limits [1]
    limit_lo <- limits [1] - range * OUTLIER_SLACK
    limit_hi <- limits [2] + range * OUTLIER_SLACK
    return (data < limit_lo | data > limit_hi)
}

do_plot_violin <- function (data) {
    # Mild outlier filtering is required to prevent excess scale compression.
    # It would be better to achieve the same with fixed scale
    # but apparently faceting does not support it.
    # Outliers are picked per run to avoid
    # excluding entire run.
    data <- data %>% group_by (benchmark, run, vm) %>% filter (!do_flag_outliers (time)) %>% ungroup ()
    ggplot (data) +
        geom_violin (aes (x = vm, y = time, fill = vm), scale = 'width', width = 1) +
        geom_boxplot (aes (x = vm, y = time), width = 0.2) +
        facet_wrap (vars (benchmark), nrow = PLOT_ROWS, scales = 'free_y') +
        theme (legend.position = 'none', axis.text.x = element_text (angle = 90, vjust = 0.5, hjust = 1)) +
        labs (x = NULL, y = 'Single repetition time [s]') +
        scale_fill_brewer (palette = 'Blues', type = 'qual')
}

# Simple bar plots: Single plot per benchmark

# Compute arithmetic mean with confidence intervals.
# We use standard bootstrap computation for confidence intervals.

do_mean_interval <- function (data, key) {
    # Key not used but supplied by dplyr::group_map.

    # We work on run means for speed.
    runs <- get_run_means (data)

    # Standard bootstrap computation.
    mean_boot <- boot (runs, function (d, i) mean (d [i]), R = REPLICATES)

    # The computations can fail so fall back to something if they do.
    mean_ci <- tryCatch (boot.ci (mean_boot, type = 'bca', conf = CONFIDENCE), error = function (e) NA)
    if (!any (is.na (mean_ci))) return (data.frame (avg = mean_boot $ t0, lo = mean_ci $ bca [1,4], hi = mean_ci $ bca [1,5]))
    mean_ci <- tryCatch (boot.ci (mean_boot, type = 'basic', conf = CONFIDENCE), error = function (e) NA)
    if (!any (is.na (mean_ci))) return (data.frame (avg = mean_boot $ t0, lo = mean_ci $ basic [1,4], hi = mean_ci $ basic [1,5]))
    return (data.frame (avg = mean_boot $ t0, lo = NA, hi = NA))
}

do_plot_mean <- function (data) {
    summary <- data %>%
        group_by (benchmark, vm) %>%
        group_map (do_mean_interval)
    ggplot (summary) +
        geom_col (aes (x = vm, y = avg, fill = vm), color = 'black') +
        geom_errorbar (aes (x = vm, ymin = lo, ymax = hi), width = 0.5) +
        facet_wrap (vars (benchmark), nrow = PLOT_ROWS, scales = 'free_y') +
        theme (legend.position = 'none', axis.text.x = element_text (angle = 90, vjust = 0.5, hjust = 1)) +
        labs (x = NULL, y = 'Mean single repetition time [s]') +
        scale_fill_brewer (palette = 'Blues', type = 'qual')
}

# Simple ratio plots: Single plot per benchmark

# Compute ratio with confidence intervals.
# We use stratified bootstrap computation for confidence intervals.

do_ratio_interval <- function (data, key, orig) {

    # We work on run means for speed.
    runs <- get_run_means (data)

    # Get the baseline from the original data.
    base <- get_run_means (orig %>% filter (benchmark == key $ benchmark, vm == VM_BASELINE))

    # Helper function for stratified bootstrap.
    meanify <- function (data, index) {
        data_top <- data $ value [index [data $ strata]]
        data_bot <- data $ value [index [!data $ strata]]
        return (mean (data_top) / mean (data_bot))
    }

    # Stratified bootstrap computation.
    means_tibble <- bind_rows (tibble (value = runs, strata = FALSE), tibble (value = base, strata = TRUE))
    ratio_boot <- boot (means_tibble, meanify, R = REPLICATES, strata = means_tibble $ strata)

    # The computations can fail so fall back to something if they do.
    ratio_ci <- tryCatch (boot.ci (ratio_boot, type = 'bca', conf = CONFIDENCE), error = function (e) NA)
    if (!any (is.na (ratio_ci))) return (data.frame (avg = ratio_boot $ t0, lo = ratio_ci $ bca [1,4], hi = ratio_ci $ bca [1,5]))
    ratio_ci <- tryCatch (boot.ci (ratio_boot, type = 'basic', conf = CONFIDENCE), error = function (e) NA)
    if (!any (is.na (ratio_ci))) return (data.frame (avg = ratio_boot $ t0, lo = ratio_ci $ basic [1,4], hi = ratio_ci $ basic [1,5]))
    return (data.frame (avg = ratio_boot $ t0, lo = NA, hi = NA))
}

do_plot_ratio <- function (data) {
    summary <- data %>%
        group_by (benchmark, vm) %>%
        group_map (do_ratio_interval, data)
    ggplot (summary, aes (x = vm, y = avg * 100, ymin = lo * 100, ymax = hi * 100, fill = vm)) +
        geom_col () +
        geom_errorbar (width = 0.5, color = '#555555') +
        facet_wrap (vars (benchmark), nrow = STRIPE_ROWS, scales = 'free_y', strip.position = 'bottom') +
        labs (x = NULL, y = 'Average speed up to OpenJDK baseline [%]', fill = 'JVM implementation') +
        theme (
            text = element_text (family = 'Serif', color = '#555555'),
            legend.position = 'bottom',
            axis.text.x = element_blank (),
            axis.ticks.x = element_blank (),
            axis.title.y = element_text (size = 14, margin = margin (r = 10)),
            strip.text.x = element_text (angle = 90, vjust = 0.5, hjust = 1, size = 14, color = '#555555'),
            strip.background = element_blank (),
            legend.text = element_text (size = 14),
            legend.title = element_text (size = 14),
            legend.background = element_rect (fill = 'transparent', color = NA),
            legend.box.background = element_rect (fill = 'transparent', color = NA),
            plot.background = element_rect (fill = 'transparent', color = NA)) +
        scale_fill_manual (
            breaks = c ('OpenJDK', 'OpenJ9', 'GraalVM CE', 'GraalVM EE'),
            values = c ('#ecd5a0', '#60aa52', '#a73607', '#6e8ab1'))
}

# Prepare plots for web.

data <- master %>% filter (warm)

ggsave ('stripe.png', do_plot_ratio (data), width = STRIPE_WIDTH, height = STRIPE_HEIGHT, unit = 'mm', bg = 'transparent')
ggsave ('overview-mean.png', do_plot_mean (data), width = PLOT_WIDTH, height = PLOT_HEIGHT, unit = 'mm')
ggsave ('overview-violin.png', do_plot_violin (data), width = PLOT_WIDTH, height = PLOT_HEIGHT, unit = 'mm')


####
# Tannistha Nandi
# 19th July2018
###Estimated diversity in the mouse gut and found differences between the various groups.
####
#Figure 5C

library(dplyr)
library(Rcpp)
library(tidyr)
library(ggplot2)
library(ggsignif)
library(vegan)
library(gridExtra)
library(plyr)
library(ggpubr)

data=read.csv("../Data/Gavage_adjust_diversityV2.txt", header=T, stringsAsFactors = FALSE, sep="\t", row.names = 1)
metadata=data[,1:3]
data_s=data[,4:887]
data_s=t(data_s)
data_percent= apply(data_s, 2,function(x) x/sum(x))
data_s=t(data_percent)

species = merge(data_s, metadata, by=0)
rownames(species) = species$Row.names
species = species[,-1]

species$Diversity = diversity(species[,1:884], index = "simpson")

# function to compute median summary
summarySE_2 = function (data = NULL, measurevar, groupvars = NULL, na.rm = FALSE,
                        conf.interval = 0.95, .drop = TRUE)
{
  length2 <- function(x, na.rm = FALSE) {
    if (na.rm)
      sum(!is.na(x))
    else length(x)
  }
  datac <- ddply(data, groupvars, .drop = .drop, .fun = function(xx, col, na.rm) {
    c(N = length2(xx[, col], na.rm = na.rm),
      mean = mean(xx[, col], na.rm = na.rm),
      median = median(xx[, col], na.rm = na.rm),
      sd = sd(xx[, col], na.rm = na.rm),
      mad=mad(xx[, col], na.rm = na.rm))
  }, measurevar, na.rm)
  datac <- rename(datac, c(mean = measurevar))
  datac$se <- datac$sd/sqrt(datac$N)
  ciMult <- qt(conf.interval/2 + 0.5, datac$N - 1)
  datac$ci <- datac$se * ciMult
  return(datac)
}

pd <- position_dodge(0.1)
tgc <- summarySE_2(species, measurevar="Diversity", .drop= T,groupvars=c("Treatment", "Days"))
tgc=filter(tgc,Treatment!="BC"&Treatment!="BCBA") #Filter off BC treated mice

p <- ggplot(tgc, aes(x=Days, y=median, colour=Treatment, linetype=Treatment)  ) +
  geom_errorbar(aes(ymin=(median - mad), ymax=(median + mad)),  width=.5, position=pd) +
  geom_line(position=pd,size=1.5)+
  geom_point(position=pd,size=4,shape=16) +
  xlab("Days since start of experiment") +
  ylab("Simpson Diversity") +
  scale_linetype_manual("", values=c("twodash", "twodash", "twodash", "twodash"), guide="none")+
  scale_color_manual(values=c("darkkhaki", "cyan", "darkblue", "grey"))+
  scale_x_continuous(limits=c(-1,23), breaks=c(0,3,6,7,10, 13, 16,19, 22)) +
  theme_bw() +
  theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),legend.justification="center",  legend.box.background = element_rect(), legend.box.margin = margin(6, 6, 6, 6), text=element_text(family="Arial"),
        legend.text=element_text(family="Arial", size=15),legend.title=element_text(family="Arial", size=20),
        axis.text.x = element_text(family="Arial", colour="grey20",size=15,angle=0,hjust=0.5,vjust=0.5,face="plain"),
        axis.text.y = element_text(family="Arial", colour="grey20",size=15,angle=0,hjust=1,vjust=0.5,face="plain"),
        axis.title.x = element_text(family="Arial", colour="grey20",size=15,angle=0,hjust=.5,vjust=0,face="bold"),
        axis.title.y = element_text(family="Arial", colour="grey20",size=15,angle=90,hjust=.5,vjust=.5,face="bold"))              # Position legend in bottom right
p

######### Wilcoxon Test
x=species[which(species$Treatment=="BTBA" & species$Days==16 & species$Cage <3),]
y=species[which(species$Treatment=="BA" & species$Days==16 | species$Treatment=="BT" & species$Days==16 & species$Cage<3 | species$Treatment=="PBS" & species$Days==16) ,]
wilcox.test(x$Diversity, y$Diversity,alternative="g")

x=species[which(species$Treatment=="BTBA" & species$Days==19 & species$Cage <3),]
y=species[which(species$Treatment=="BA" & species$Days==19 | species$Treatment=="BT" & species$Days==19 & species$Cage<3 | species$Treatment=="PBS" & species$Days==19) ,]
wilcox.test(x$Diversity, y$Diversity,alternative="g")

x=species[which(species$Treatment=="BTBA" & species$Days==22 & species$Cage <3),]
y=species[which(species$Treatment=="BA" & species$Days==22 | species$Treatment=="BT" & species$Days==22 & species$Cage<3 | species$Treatment=="PBS" & species$Days==22) ,]
wilcox.test(x$Diversity, y$Diversity,alternative="g")


################################################################################################
# This code uses myExchangeFileH1 from ReadExchangeFileExample_WKRDBEST2 (Author:David Currie) ###
## This data is dummy data for H1 VS, FT, FO, SS, SA, FM and BV.
## This code does not present anything new. It was an opportunity for me to get to use RDBES format and play around with ratio and inclusion probabilities estimation.
## Ana Ribeiro Santos
########################################################################################

library(dplyr)

#load the data
source ("ReadExchangeFileExample_WKRDBEST2.r")
#lst(myExchangeFileH1)

# Because the data did not have sampled weight or total sample weight I had to estimated.
#add species name to FM table
myExchangeFileH1$FM$Species <- myExchangeFileH1$SA$SAspeciesCode[match(myExchangeFileH1$FM$SAid,myExchangeFileH1$SA$SAid)]
#head(myExchangeFileH1$FM)

#dim(myExchangeFileH1$FM)
#For this example we are goin to select just one species = 1015724 = Leuciscus aspius.
myExchangeFileH1$FM <- myExchangeFileH1$FM [myExchangeFileH1$FM$Species =="1015724",]

#calculate the weight per length. a and b paramters from Fisbase
a <- 0.01389
b <- 3

myExchangeFileH1$FM$Wt.at.len_g <- with (myExchangeFileH1$FM, ((as.numeric(FMclass)/10)^ b) * a) # this gives in grams, equation expected CM not MM hence divide by 10

#calculate the weight for each SAid (Sample ID)
sample_wght_SAid <- myExchangeFileH1$FM %>%
  group_by(SAid) %>%
  summarise (., SAsampleWeightLive_est = round (sum (Wt.at.len_g), 0)) %>% as.data.frame()

# merge it with SA table
myExchangeFileH1$SA <- merge (myExchangeFileH1$SA, sample_wght_SAid)
#head(myExchangeFileH1$SA)

#Calculate the totalweightlive based on the ratio_SA
myExchangeFileH1$SA$ratio_SA <- ifelse (is.na (myExchangeFileH1$SA$SAsampleWeightLive), with (myExchangeFileH1$SA, as.numeric (SAnumberTotal) / as.numeric (SAnumberSampled)),
                                        with (myExchangeFileH1$SA, as.numeric (SAtotalWeightLive) / as.numeric (SAsampleWeightLive)))

myExchangeFileH1$SA$SAtotalWeightLive_est <- with (myExchangeFileH1$SA, SAsampleWeightLive_est * ratio_SA)

##########################################################################################################################################################
# uses myExchnageFileH1 data and assumes simple random sampling within stages
# trips within domains (quarter, area and gear) and ages within lengths.
# In the code below, the hierarchy is as follows in order: VS, FT, "FO","SS","SA","FM","BV"

# set up the population totals
popDat <- as.data.frame(matrix(c(16,39,86,54, 32, 29, 1464760,3937180,6831707, 2876490, 3487500, 2345431),byrow=F,nrow=6,ncol=2))
names(popDat) <- c("tripNum","liveWt")
rownames(popDat) <-  c("Q2 27 GND", "Q3 27 DRB", "Q3 27 FPO", "Q4 27 FPO", "Q4 27 FYK", "Q4 27 GNS")

# calculate inclusion probabilities assuming SRS within strata
myExchangeFileH1$VS$VSincProb <- as.numeric (myExchangeFileH1$VS$VSnumberSampled)/ as.numeric (myExchangeFileH1$VS$VSnumberTotal)
myExchangeFileH1$BV$BVincProb <- as.numeric (myExchangeFileH1$BV$BVnumberSampled)/ as.numeric (myExchangeFileH1$BV$BVnumberTotal)
myExchangeFileH1$FM$FMincProb <- 1
myExchangeFileH1$SA$SAincProb <- as.numeric (myExchangeFileH1$SA$SAnumberSampled)/as.numeric (myExchangeFileH1$SA$SAnumberTotal)
myExchangeFileH1$SS$SSincProb <- as.numeric (myExchangeFileH1$SS$SSnumberSampled)/as.numeric (myExchangeFileH1$SS$SSnumberTotal)
myExchangeFileH1$FO$FOincProb <- as.numeric (myExchangeFileH1$FO$FOnumberSampled)/as.numeric (myExchangeFileH1$FO$FOnumberTotal)
myExchangeFileH1$FT$FTincProb <- as.numeric (myExchangeFileH1$FT$FTnumberSampled)/as.numeric (myExchangeFileH1$FT$FTnumberTotal)

# caclulate quarter from date, and then make a domain of quarter combined with area
# allocate domains to FM & BV as well
myExchangeFileH1$SA$FTid <- myExchangeFileH1$SS$FTid[match(myExchangeFileH1$SA$SSid,myExchangeFileH1$SS$SSid)]
myExchangeFileH1$SS$date <- myExchangeFileH1$FO$FOendDate[match(myExchangeFileH1$SS$FOid,myExchangeFileH1$FO$FOid)]
myExchangeFileH1$SA$date <- myExchangeFileH1$SS$date[match(myExchangeFileH1$SA$SSid,myExchangeFileH1$SS$SSid)]
myExchangeFileH1$SA$quarter <- paste("Q",(as.numeric(substr(myExchangeFileH1$SA$date,6,7))-1) %/% 3 + 1,sep="")
myExchangeFileH1$SA$domain <- paste(myExchangeFileH1$SA$quarter,myExchangeFileH1$SA$SAarea, myExchangeFileH1$SA$SAgear)
myExchangeFileH1$FM$domain <- myExchangeFileH1$SA$domain[match(myExchangeFileH1$FM$SAid,myExchangeFileH1$SA$SAid)]
myExchangeFileH1$BV$domain <- myExchangeFileH1$FM$domain[match(myExchangeFileH1$BV$FMid,myExchangeFileH1$FM$FMid)]
myExchangeFileH1$BV$numAtUnit <- 1

# add spp to FM
myExchangeFileH1$FM$spp <- myExchangeFileH1$SA$SAspeciesCode[match(myExchangeFileH1$FM$SAid,myExchangeFileH1$SA$SAid)]

# -----------------------------------------------------------------------
# a function to calculate inclusion probabilities for the units at the final stage
# of sampling given all the inclusion probabilities for the other stages
# -----------------------------------------------------------------------
getIncProb <- function(RDB,stages){
  nStages <- length(stages)
  if (any(stages %in% c("FM"))) {
    RDB[["FM"]][["FMincProb"]] <- 1
  }
  RDB[[stages[[1]]]][["incProb"]] <- RDB[[stages[[1]]]][[paste(stages[[1]],"incProb",sep="")]]
  for (i in 2:(nStages)) {
    indx <- RDB[[stages[[i]]]][[paste(stages[[i-1]],"id",sep="")]]
    indxPrev <- RDB[[stages[[i-1]]]][[paste(stages[[i-1]],"id",sep="")]]
    RDB[[stages[[i]]]][["incProbPrev"]] <- RDB[[stages[[i-1]]]][[paste("incProb",sep="")]][match(indx,indxPrev)]
    RDB[[stages[[i]]]][["incProb"]] <- RDB[[stages[[i]]]][["incProbPrev"]]*RDB[[stages[[i]]]][[paste(stages[[i]],"incProb",sep="")]]
  }
  return(RDB)
}

# -----------------------------------------------------------------------
# Number-at-Length
# -----------------------------------------------------------------------
# set up the stages in the sampling design used in the estimation
#stages <- list("FT","FO", "SS","SA","FM")
stages <- list("VS", "FT","FO", "SS","SA","FM")
#stages <- list("LE","SS","SA","FM")

# calculate the inclusion probabilities by length class given the other inclusion probabilities
# in the higher stages
test <- getIncProb(myExchangeFileH1,stages)

# calculate a Horvitz Thompson estimate for total numbers at length by domain
# assuming srs within the domain - this is valid for the RDBshare data
estL <- tapply(as.numeric(test$FM$FMnumberAtUnit)/test$FM$incProb,list(test$FM$FMclass,test$FM$domain),sum)

#estL <- test$FM %>%
#  group_by(FMclass, domain, spp) %>%
#  summarise (., est.L = sum (as.numeric (FMnumberAtUnit)/incProb))

# calculate a HT estimate for total landed weight using the sampled landed weights
# assuming srs etc as before
estX <- tapply(test$SA$SAtotalWeightLive_est/test$SA$incProbPrev,list(test$SA$domain),sum)/1e3

# get the relevant population totals
popX <- popDat[match(names(estX),rownames(popDat)),"liveWt"]

# calculate the ratio estimates for numbers at length
estLR <- estL*matrix(rep(popX/estX,dim(estL)[1]),byrow=T,ncol=dim(estL)[2])

# compare the estLR with the ratio estimation using the ratio between the sum total sampled weight and the landings in the domain
test <- myExchangeFileH1
sumX <- tapply(myExchangeFileH1$SA$SAtotalWeightLive_est,list(myExchangeFileH1$SA$domain),sum) # sum te total sampled weight for each domain
testLR <- estL*matrix(rep(popX/sumX,dim(estL)[1]),byrow=T,ncol=dim(estL)[2]) # multiply the number at length by the ratio between landings and sampled weight

testLR
estLR
## They are super different!!! So im wondering if Im doing something wrong here!! The fact that Im working with made up data does not help at all!!

########################################################################################################################################
# JUST to test if using a different approach from Liz's code and function we would get the same number at length up to Vessel selection'
#############################################################################################################################################
VSinfo <- myExchangeFileH1$VS %>% transmute(VSid,SDid,
                                            VSincProb)%>%distinct()

FTinfo <-myExchangeFileH1$FT%>%transmute(FTid, VSid,  FTincProb )%>%distinct()

FOinfo<-myExchangeFileH1$FO%>%transmute(FOid,FTid, time=paste("Q",(as.numeric(substr(myExchangeFileH1$FO$FOendDate,6,7))-1) %/% 3 + 1,sep=""),
                                        metier=FOgear, space=FOarea, FOincProb)%>%distinct()
FOinfo$domain <- paste (FOinfo$time, FOinfo$space, FOinfo$metier)

SSinfo<-myExchangeFileH1$SS%>%transmute(SSid, FOid, SSincProb)%>%distinct()
#SAinfo<-myExchangeFileH1$SA%>%transmute(SAid,SSid,spp=SAspeciesCode,
#                              wsamp=SAsampleWeightMeasured,wsamptot=SAtotalWeightMeasured)%>%distinct()

SAinfo<- myExchangeFileH1$SA%>%transmute(SAid,SSid,spp=SAspeciesCode,SAincProb)%>%distinct()

FMinfo<-myExchangeFileH1$FM%>%transmute(FMid,SAid,len=FMclass,n=as.numeric(FMnumberAtUnit), FMincProb)

samp_est_stratum_incPro <-FMinfo%>% left_join (SAinfo)%>%left_join(SSinfo)%>%left_join(FOinfo)%>%left_join(FTinfo)%>% left_join(VSinfo) %>%
  group_by(domain, spp, len, n) %>%
  summarise (., final_prob = FMincProb * SAincProb * SSincProb * FOincProb * FTincProb * VSincProb) %>%
  ungroup() %>%
  group_by(domain, spp, len) %>%
  summarise (., est.n = sum(n / final_prob))


# 3. faza: Vizualizacija podatkov

graf.bdp <- ggplot(data = bdp) +
            geom_point(aes(x = dohodek, y = rast), color = "blue")+
            labs(title ="Povezava med rastjo in velikostjo dohodka")+
            geom_text(aes(x = dohodek, y = rast, label=leto),
                      hjust = 0, vjust = -0.3)+
            scale_y_continuous(limits = c(130, 170))+
            scale_x_continuous(limits = c(4700, 8900))+
            xlab("Dohodek") + ylab("Gospodarska rast")

graf.rast.doba <- ggplot(data = prva) +
              geom_point(aes(x = rast, y = st_let), stat = 'identity')+
              geom_smooth(aes(x = rast, y = st_let), method = lm)+
              geom_text(aes(x = rast, y = st_let, label=leto),hjust=0, vjust=-0.3)+
              labs(title ="Povezava gospodarske rasti in življenjske dobe")+
              ylab("Življenjska doba") + xlab("Gospodarska rast")

graf.izdatki <- ggplot(data = izdatki, aes(x=leto, y=meritev, fill = vrsta)) +
         geom_bar(position="dodge", stat="identity", colour="black")+
          labs(title ="Odstotek dohodka za različne vrste izdatkov")+
          scale_x_continuous(breaks=seq(2005,2014,1))+
          scale_fill_brewer(name = "Vrsta izdatkov",
                            labels = c("Drugo", "Izdatki za bolezen",
                            "Izdatki za brezposelnost", "Izdatki za družino in otroke",
                            "Izdatki za invalidnost", "Izdatki za nastanitev",
                            "Izdatki za smrt hranitelja družine", "Izdatki za starost"),
                            palette = "Paired") +
          ylab("Delež dohodka za različne izdatke (v %)")+xlab("Leto")

graf.leta <- ggplot(tabela3) +
                    geom_line(aes(x=leto, y=meritev, color = Vrsta)) +
                    geom_point(aes(x=leto, y=meritev, color = Vrsta))+
                    scale_x_continuous(breaks=seq(2005,2015,1))+
                    labs(title = "Primerjava celotne življenjske dobe in zdravih let")+
                    scale_fill_brewer(palette = "Paired", name = "Vrsta dobe")+
                    ylab("Število let")+xlab("Leto")

#Primerjava številov avtomobilov in količini odpadkov
graf.avto.odpadki <- ggplot(data = left_join(odpadki1, avto)) +
  geom_point(aes(x = avtomobili, y = odpadki), stat = 'identity')+
  geom_text(aes(x = avtomobili, y = odpadki, label=regija),hjust=0, vjust=0)+
  labs(title ="Primerjava številov avtomobilov in količini odpadkov")+
  xlab("Število avtomobilov") + ylab("Količina odpadkov")

graf.brezp.obsojeni <- ggplot(data = left_join(povprecna_stopnja, povprecno_delez_obsojenih)) +
  geom_point(aes(x = Meritev, y = meritev), stat = 'identity')+
  geom_text(aes(x = Meritev, y = meritev, label=regija),hjust=0, vjust=0)+
  labs(title ="Primerjava povprečne stopnje brezposelnosti in deleža obsojenih ljudi")+
  ylab("Povprečen delež obsojenih") + xlab("Povprečna stopnja brezposelnosti")

# Uvozimo zemljevid.
gpclibPermit()
zemljevid <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding = "UTF-8") %>% pretvori.zemljevid()
levels(zemljevid$NAME_1)[levels(zemljevid$NAME_1) %in%
                           c("Notranjsko-kraška",
                             "Spodnjeposavska")] <- c("Primorsko-notranjska",
                                                      "Posavska")
imena.pokrajin <- aggregate(cbind(long, lat) ~ regija, data = (avto %>% right_join(zemljevid, by = c("regija" = "NAME_1"))), FUN=function(x)mean(range(x)))

zemljevid.stopnje <- ggplot() +
  geom_polygon(data = povprecna_stopnja %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
              aes(x = long, y = lat, group = group, fill =Meritev), color = "black")+
              xlab("") + ylab("")+
              geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija)) +
              ggtitle("Povprečna stopnja brezposelnosti po regijah")

zemljevid.zdravniki <- ggplot() +
  geom_polygon(data = povprecno_pnz %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
               aes(x = long, y = lat, group = group, fill =Meritev), color = "black")+
              xlab("") + ylab("") +
              geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija))+
              ggtitle("Povprečna število prebivalcev na enega zdravnika")

zemljevid.obsojenih <- ggplot() +
  geom_polygon(data = povprecno_delez_obsojenih %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
               aes(x = long, y = lat, group = group, fill = Meritev), color = "black")+
              xlab("") + ylab("")+
              geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija)) +
              ggtitle("Povprečen delež obsojenih po regijah")

zemljevid.vode <- ggplot() +
  geom_polygon(data = voda %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
              aes(x = long, y = lat, group = group, fill = Meritev), color = "black")+
              xlab("") + ylab("")+
              geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija)) +
              ggtitle("Poraba vode po regijah",
              subtitle = "Poraba vode, dobavljene iz javnega vodovoda, v gospodinjstvih na prebivalca (m3/prebivalca)")

zemljevid.odpadki <- ggplot() +
  geom_polygon(data = odpadki1 %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
               aes(x = long, y = lat, group = group, fill = Meritev), color = "black")+
                xlab("") + ylab("")+
                geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija)) +
                ggtitle("Količina odpadkov po regijah",
                subtitle = "Komunalni odpadki, zbrani z javnim odvozom odpadkov na prebivalca (kilogram/prebivalca)")

zemljevid.avto <- ggplot() +
                geom_polygon(data = avto %>% right_join(zemljevid, by = c("regija" = "NAME_1")),
                aes(x = long, y = lat, group = group, fill = Meritev), color = "black")+
                xlab("") + ylab("")+
                geom_text(data=imena.pokrajin, aes(x =long, y=lat, label = regija))+
                ggtitle("Število avtomobilov",
                subtitle = "Število vseh osebnih avtomobilov na 1.000 prebivalcev (število/1.000 prebivalcev)")


#!/usr/bin/env Rscript

# Copyright (C) 2017 by
# Thomas E. Gorochowski <tom@chofski.co.uk>, Voigt Lab, MIT
# All rights reserved
# Released under MIT license (see LICENSE.txt)

# Arguments:
# 1. count_matrix_filename
# 3. library_size_matrix
# 4. gene_length_matrix
# 5. output_file_prefix
args <- commandArgs(TRUE)
arg_count_matrix <- args[1]
arg_library_size_matrix <- args[2]
arg_gene_length_matrix <- args[3]
arg_output_file_prefix <- args[4]

# We use edgeR for between sample normalisation factors
library(edgeR)

# Load the data file
count_matrix <- read.table(arg_count_matrix, header=T, row.names=1, com='')

# Load the gene lengths (for RPKM calculation) - reorder
gene_length_matrix <- read.table(arg_gene_length_matrix, header=T, row.names=1, com='')
gene_lengths <- gene_length_matrix[order(match(rownames(gene_length_matrix),rownames(count_matrix))),1]

# Load the actual mapped reads
library_size_matrix <- read.table(arg_library_size_matrix, header=T, row.names=1, com='')

# Get the library sizes (total counts in annotated genes)
print(library_size_matrix)
print(library_size_matrix$total_mapped_reads)
print(colSums(count_matrix))
lib_sizes <- as.vector(library_size_matrix$total_mapped_reads)

# Calculate normalisation factors using TMM
expr <- DGEList(counts=count_matrix, lib.size=lib_sizes)
expr <- calcNormFactors(expr)

# Calculate RPKM value (normalisation factors are included by default) log=FALSE
expr_norm <- rpkm(expr, gene.length=gene_lengths)

# Write the RPKM values to a text file
write.table(expr_norm, col.names=NA, quote=FALSE, file=paste0(arg_output_file_prefix, "/fpkm.normed.matrix.txt"), sep="\t")

# Write normalisation factors used
write.table(data.frame("design"=colnames(count_matrix), "factor"=expr$samples$norm.factors, "lib_size"=expr$samples$lib.size), file=paste0(arg_output_file_prefix, "/norm.factors.matrix.txt"), sep='\t', quote=FALSE, row.names=FALSE)


# 3. faza: Vizualizacija podatkov

#graf1 prikazuje države, ločene po kontinentih, in njihovo stopnjo veselja
# graf1 <- ggplot(tabela_2017, aes(x=Continent, y=Happiness.Score, color=Continent)) + geom_point(show.legend = FALSE) + theme_bw() +
#   ggtitle("Stopnja sreče po celinah") + theme(axis.title = element_text(size = (9)), plot.title = element_text(size=14)) +
#   xlab("Kontinent") + ylab("Stopnja sreče")

#graf2 prikazuje države, ločene po kontinentih, in njihovo stopnjo veselja - "violin plot". Avstralija je izločena iz grafa, ker imamo podatke
#samo za 2 državi - graf se ne izriše.
graf2 <- ggplot(tabela_2017[!(tabela_2017$Continent=="Australia"),], aes(x=Continent, y=Happiness.Score)) + geom_violin(aes(fill=Continent), show.legend = FALSE) +
  theme_bw() + theme(axis.title = element_text(size = (9)), plot.title = element_text(size=14, hjust = 0.5)) +
  ggtitle("Stopnja sreče po kontinentih") + xlab("Kontinent") + ylab("Stopnja sreče [1-10]")

#graf3 prikazuje stopnjo korelacije med stopnjo sreče in posameznimi dejavniki
#Prevod v slovenščino
tabela_2017_slo <- tabela_2017
names(tabela_2017_slo)[5] <- "Stopnja sreče"
names(tabela_2017_slo)[6] <- "BDP države"
names(tabela_2017_slo)[7] <- "Družina"
names(tabela_2017_slo)[8] <- "Pričak. živ. doba"
names(tabela_2017_slo)[9] <- "Svoboda"
names(tabela_2017_slo)[10] <- "Radodarnost"
names(tabela_2017_slo)[11] <- "Odsotnost korupcije"
names(tabela_2017_slo)[12] <- "Dystopia in ostanek"

data3 = cor(tabela_2017_slo[c(5:12)])
#corrplot(data3, method = "number", title = "Korelacija med stopnjo srečo in dejavniki")

#Za naslednji graf bomo potrebovali ujemanje imen držav v tabeli "tabela_2017" in "tabela_preb", saj bomo dodajali stolpce iz ene tabele v drugo.
#Ročno je potrebno spremeniti imena petih držav (Problem: Kosovo in Severni Ciper - podatka bom izpustil)

tabela_preb[56,1] <- "Taiwan Province of China" #Prej "Taiwan"
tabela_preb[147,1] <- "Macedonia" #Prej "North Macedonia"
tabela_preb[121,1] <- "Palestinian Territories" #Prej "Palestine"
tabela_preb[17,1] <- "Congo (Kinshasa)" #Prej "Democratic Republic of the Congo"
tabela_preb[119,1] <- "Congo (Brazzaville)" #Prej "Congo"

#Dodamo stolpec "Population" k tabeli "tabela_2017"
tabela_2017$"Št. prebivalcev (2016)" <- tabela_preb$`Population(2016)`[match(tabela_2017$Country, tabela_preb$Country)]

#Dodan stolpec za prirast prebivalstva k tabeli "tabela_2017"
tabela_2017$"Prirast (2016/2017)" <- tabela_preb$`Change(2016/2017)`[match(tabela_2017$Country, tabela_preb$Country)]

#Iz tabele odstranimo 2 državi, za katere nimamo podatkov (Severni Ciper in Kosovo)
tabela_2017_sprem <- tabela_2017[-c(60,77),]

#Preimenujemo še en stolpec
tabela_2017_sprem1 <- tabela_2017_sprem
names(tabela_2017_sprem1)[5] <- "Stopnja sreče"

#Izrišemo graf korelacije med stopnjo sreče in številom prebivalstva ter prirastom ljudi
data4 = cor(tabela_2017_sprem1[c(5,13,14)])
#corrplot(data4, method = "number", title = "Korelacija med stopnjo sreče in številom prebivalstva ter prirastom ljudi")

#Za naslednjo vizualizacijo nas bo zanimalo pri katerih državah je bilo gibanje stopnje sreče tekom treh let (2015 - 2017) največje, kje pa najmanjše
#Uredimo tabele za vsa tri leta po abecedi
tabela_2015_abc <- tabela_2015[order(tabela_2015$Country),]
tabela_2016_abc <- tabela_2016[order(tabela_2016$Country),]
tabela_2017_abc <- tabela_2017[order(tabela_2017$Country),]

#V tabelo s podatki za leto 2017 bomo dodali stolpec, ki predstavlja absolutno vrednost spremembe stopnje sreče v letih 2015 - 2017
tabela_2017_abc$Happiness.Change <- abs(tabela_2015_abc$Happiness.Score - tabela_2016_abc$Happiness.Score) + abs(tabela_2016_abc$Happiness.Score - tabela_2017_abc$Happiness.Score)

#Naredimo tabelo s podatki relevantnimi za to vizualizacijo
hap_change <- tabela_2017_abc
hap_change[2:14] <- list(NULL)
hap_change$Happiness.Score.2015 <- tabela_2015_abc$Happiness.Score
hap_change$Happiness.Score.2016 <- tabela_2016_abc$Happiness.Score
hap_change$Happiness.Score.2017 <- tabela_2017_abc$Happiness.Score

#Razvrstimo države naraščajoče glede na velikost spremembe stopnje sreče
hap_change <- hap_change[order(hap_change$Happiness.Change),]

#Izberemo samo 3 države z največjim gibanjem in 3 z najmanjšim
hap_change_tb <- hap_change[c(1,2,3,146,147,148),]

hap_change_tb$Happiness.Change <- NULL
hap_change_tb <- melt(hap_change_tb, id.vars = "Country", measure.vars = colnames(hap_change_tb)[-1])
hap_change_tb$variable <- as.integer(gsub("\\D", "", hap_change_tb$variable))

#Preimenujemo stolpce
names(hap_change_tb)[1] <- "Država"
names(hap_change_tb)[2] <- "Leto"
names(hap_change_tb)[3] <- "Sprememba"

graf3 <- ggplot(hap_change_tb, aes(x=factor(Leto), y=Sprememba)) + geom_line(aes(group = Država), colour = "Black") +
  geom_point(aes(colour = Država), size = 3) + ggtitle("Sprememba stopnje sreče v letih 2015 - 2017 (3 max & 3 min)") +
  theme(plot.title = element_text(size = 14)) + xlab("Leto") + ylab("Stopnja sreče [1-10]") + guides(colour = guide_legend("Država"))

# #ZEMLJEVID
#Uvozi potrebne knjižnice
source("https://raw.githubusercontent.com/jaanos/APPR-2018-19/master/lib/uvozi.zemljevid.r")

zemljevid <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
                             "ne_50m_admin_0_countries", mapa = "zemljevidi", pot.zemljevida = "", encoding = "UTF-8") %>%
  fortify() %>% filter(CONTINENT == "Europe" | SOVEREIGNT %in% c("Turkey", "Cyprus"),
         long < 45 & long > -45 & lat > 30 & lat < 75)

#ggplot() + geom_polygon(data=zemljevid, aes(x=long, y=lat, group=group, fill=id)) +
#  guides(fill=FALSE)

#Tabela, v kateri so samo evropske države in njihova vrednost stonje sreče
tabela_evropske <- tabela_2017_sprem[tabela_2017_sprem[, 2] == "Europe",]
tabela_evropske[6:14] <- NULL
tabela_evropske[2:4] <- NULL

drzave <- unique(as.character(zemljevid$NAME))
drzave <- as.data.frame(drzave, stringsAsFactors=FALSE)
names(drzave) <- "Country"

#Spremenimo tips tolpca v tabeli "zemljevid" (factor->character)
zemljevid$NAME <- as.character(zemljevid$NAME)
tabela_evropske[14,1] <- "Czechia"
tabela_evropske[36,1] <- "Bosnia and Herz."

k <- kmeans(tabela_evropske[-1], 6)
tabela_evropske$center <- k$centers[k$cluster, ]

ujemanje <- left_join(drzave, tabela_evropske, by="Country")

zem <- ggplot() + geom_polygon(data=left_join(zemljevid, ujemanje, by=c("NAME"="Country")), aes(x=long, y=lat, group=group, fill=center)) +
  ggtitle("Stopnja sreče po evropskih državah (2017)") + xlab("") + ylab("") + scale_fill_gradient(low='#66FF66', high='#006600') +
  guides(fill=guide_colorbar(title="Stopnja sreče [1-10]")) + theme(plot.title = element_text(size=14, hjust=0.5))

#Dodane oznake za državi z najvišjo in najnižjo vrednostjo + vrednost za Slovenijo
zem1 <- zem + geom_point(aes(x=30, y=50)) + geom_text(aes(x=30, y=49), label = "4.096")
zem1 <- zem1 + geom_point(aes(x=9, y=62)) + geom_text(aes(x=9, y=61), label = "7.537")
zem1 <- zem1 + geom_point(aes(x=14.4, y=46)) + geom_text(aes(x=14, y=45), label = "5.758")

#Tabela s podatki za Evropo za leto 2017
tabela_evropa <- tabela_2017_sprem[tabela_2017_sprem[, 2] == "Europe",]
tabela_evropa[14,1] <- "Czechia"
tabela_evropa[36,1] <- "Bosnia and Herz."

#Dodamo stolpce s procentualnimi deleži posameznih dejavnikov
tabela_evropa$Economy.Procent <- with(tabela_evropa, Economy / Happiness.Score *100)
k1 <- kmeans(tabela_evropa[,"Economy.Procent"], 6)
tabela_evropa$center_economy <- k1$centers[k1$cluster, ]

tabela_evropa$Family.Procent <- with(tabela_evropa, Family / Happiness.Score *100)
k2 <- kmeans(tabela_evropa[,"Family.Procent"], 6)
tabela_evropa$center_family <- k2$centers[k2$cluster, ]

tabela_evropa$Life.Expectancy.Procent <- with(tabela_evropa, Life.Expectancy / Happiness.Score *100)
k3 <- kmeans(tabela_evropa[,"Life.Expectancy.Procent"], 6)
tabela_evropa$center_life_e <- k3$centers[k3$cluster, ]

tabela_evropa$Freedom.Procent <- with(tabela_evropa, Freedom / Happiness.Score *100)
k4 <- kmeans(tabela_evropa[,"Freedom.Procent"], 6)
tabela_evropa$center_freedom <- k4$centers[k4$cluster, ]

tabela_evropa$Generosity.Procent <- with(tabela_evropa, Generosity / Happiness.Score *100)
k5 <- kmeans(tabela_evropa[,"Generosity.Procent"], 6)
tabela_evropa$center_generosity <- k5$centers[k5$cluster, ]

tabela_evropa$Trust.Procent <- with(tabela_evropa, Trust / Happiness.Score *100)
k6 <- kmeans(tabela_evropa[,"Trust.Procent"], 6)
tabela_evropa$center_trust <- k6$centers[k6$cluster, ]

#tabela_evropa$Dystopia.Residual.Procent <- with(tabela_evropa, Dystopia.Residual / Happiness.Score *100)

#Zbrišemo stolpca s podatki o letu in kontinentu
tabela_evropa[2:3] <- NULL

#Tabela, ki jo bomo potrebovali pri risanju zemljevidov v shiny-ju
ujemanjes1 <- left_join(drzave, tabela_evropa, by="Country")

#Potrebujemo samo podatke iz prvih treh stolpec tabele "tabela_skupna"
tabela_shiny <- tabela_skupna[,c(1,2,3)]
tabela_shiny$Year <- as.integer(tabela_shiny$Year)

#Prevodi iz angleščine v slovenščino
names(tabela_shiny)[1]<-"Država"
names(tabela_shiny)[2]<-"Leto"
names(tabela_shiny)[3]<-"Razvrstitev [od 148]"


#!/usr/local/bin/Rscript --vanilla

# Alternative shebang for local Mac OS X: "#!/usr/local/bin/Rscript --vanilla"
# Linux version for HPC: #!/hpc/local/CentOS7/dhl_ec/software/R-3.4.0/bin/Rscript --vanilla
cat("++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    R STATISTICS UPDATER: ADVANCED PACKAGES
    \n
    * Name:        RStats_ADVANCED
    * Version:     v1.6.2
    * Last edit:   2019-03-19
    * Created by:  Sander W. van der Laan | s.w.vanderlaan-2@umcutrecht.nl
    \n
    * Description: This script can be used to update R-3+ via the commandline.

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")

# CLEAR THE BOARD
rm(list = ls())

#--------------------------------------------------------------------------
### GENERAL SETUP
Today=format(as.Date(as.POSIXlt(Sys.time())), "%Y%m%d")
cat(paste("\nToday's date is: ", Today, ".\n", sep = ''))

cat("\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
                              INSTALLATION OF USEFUL PACKAGES
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n
* Loading install function for packages. It will check whether the packages is already installed,
if not it will update.\n")

#--------------------------------------------------------------------------
### FUNCTION TO INSTALL PACKAGES, VERSION A -- This is a function found by
### Sander W. van der Laan online from @Samir:
### http://stackoverflow.com/questions/4090169/elegant-way-to-check-for-missing-packages-and-install-them
### Compared to VERSION 1 the advantage is that it will automatically check in both CRAN and Bioconductor

install.packages.auto <- function(x) {
  x <- as.character(substitute(x))
  if(isTRUE(x %in% .packages(all.available = TRUE))) {
    eval(parse(text = sprintf("require(\"%s\")", x)))
  } else {
    # Update installed packages - this may mean a full upgrade of R, which in turn
    # may not be warrented.
    #update.install.packages.auto(ask = FALSE)
    eval(parse(text = sprintf("install.packages(\"%s\", dependencies = TRUE, repos = \"https://cloud.r-project.org/\")", x)))
  }
  if(isTRUE(x %in% .packages(all.available = TRUE))) {
    eval(parse(text = sprintf("require(\"%s\")", x)))
  } else {
    if (!requireNamespace("BiocManager"))
      install.packages("BiocManager")
    BiocManager::install() # this would entail updating installed packages, which in turned may not be warrented

    # Code for older versions of R (<3.5.0)
    # source("http://bioconductor.org/biocLite.R")
    # Update installed packages - this may mean a full upgrade of R, which in turn
    # may not be warrented.
    # biocLite(character(), ask = FALSE)
    eval(parse(text = sprintf("BiocManager::install(\"%s\")", x)))
    eval(parse(text = sprintf("require(\"%s\")", x)))
  }
}

cat("\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")
cat("\n* Determining R version used...\n")

version

cat("\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")
cat("\n* Library paths used...\n")

.libPaths()

cat("\n\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")
cat("\n* Updating installed packages...\n")

chooseCRANmirror(ind=1)

cat("\n* Let's update if necessary...\n")
update.packages(checkBuilt = TRUE, ask = FALSE)

cat("\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
                          Install GENERAL install.packages
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")

cat("\n* For VEGAS to work...\n")
install.packages.auto("corpcor")
install.packages.auto("mvtnorm")

cat("\n* For clustering and correlation...\n")
install.packages.auto("spatstat")
install.packages.auto("pvclust")
install.packages.auto("mclust")
install.packages.auto("cluster")
install.packages.auto("corrgram")
install.packages.auto("heatmap.plus")
install.packages.auto("heatmap3")
install.packages.auto("pheatmap")
install.packages.auto("ComplexHeatmap")
install.packages.auto("ape")
install.packages.auto("circlize")
install.packages.auto("SAM")
install.packages.auto("irlba")
install.packages.auto("Matrix")
install.packages.auto("DBI")

cat("\n* Proteomics-specific clustering tools...\n")
install.packages.auto("randomForestSRC")

cat("\n* Install packages to load in foreign data, such as SAS or STATA...\n")
install.packages.auto("foreign")
cat("\n* Packages to load in \"foreign\" data, for new STATA v13 files...\n")
devtools::install_github("sjewo/readstata13", ref="0.4")

cat("\n* Some meta-analysis/forest plots install.packages. Also refer to http://cran.r-project.org/web/views/MetaAnalysis.html...\n")
install.packages.auto("Gmisc")
install.packages.auto("rmeta")
install.packages.auto("diagram")
install.packages.auto("metafor")
install.packages.auto("meta")
install.packages.auto("RISmed")
install.packages.auto("epiR")

cat("\n* Some additional useful packages...\n")
install.packages.auto("AICcmodavg")
install.packages.auto("car")
install.packages.auto("rms")
install.packages.auto("survival")
install.packages.auto("survminer")
install.packages.auto("tableone")
install.packages.auto("forestplot")
install.packages.auto("haven") # for loading SPSS files!

cat("\n* Some additional packages needed for 'powsimR'...\n")
install.packages.auto("methods")
install.packages.auto("stats")
install.packages.auto("Rtsne")
install.packages.auto("moments")
install.packages.auto("minpack.lm")
install.packages.auto("glmnet")
install.packages.auto("MASS")
install.packages.auto("reshape2")
install.packages.auto("tibble")
install.packages.auto("cowplot")
install.packages.auto("scales")
install.packages.auto("cobs")
install.packages.auto("msir")
install.packages.auto("drc")
install.packages.auto("DrImpute")
install.packages.auto("VGAM")

cat("\n\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")
#--------------------------------------------------------------------------
### CLOSING MESSAGE
cat("All done updating R on the HPC or your Mac.\n")
cat(paste("\nToday's: ",Today, "\n"))
cat("++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")


if(!require(ggplot2)){install.packages('ggplot2')}
library(ggplot2)

dat2014 <- read.table('jcr_recs_2014.txt', header = TRUE, dec = '.', sep = ';')
dat2013 <- read.table('jcr_recs_2013.txt', header = TRUE, dec = '.', sep = ';')
dat2012 <- read.table('jcr_recs_2012.txt', header = TRUE, dec = '.', sep = ';')
dat2011 <- read.table('jcr_recs_2011.txt', header = TRUE, dec = '.', sep = ';')
dat2010 <- read.table('jcr_recs_2010.txt', header = TRUE, dec = '.', sep = ';')

dat <- data.frame(Impact.Factor = c(dat2014$Impact.Factor,
                                    # dat2012$Impact.Factor,
                                    # dat2012$Impact.Factor,
                                    # dat2011$Impact.Factor,
                                    dat2010$Impact.Factor),
                  Year = as.factor(c(rep(2014, dim(dat2014)[1]),
                           # rep(2013, dim(dat2013)[1]),
                           # rep(2012, dim(dat2012)[1]),
                           # rep(2011, dim(dat2011)[1]),
                           rep(2010, dim(dat2010)[1]))))

pdf('impact.pdf', width = 16, height = 9)
ggplot(dat, aes(x = Impact.Factor)) +
  geom_density(aes(group = Year, col = Year, fill = Year), alpha = .5) +
  theme(axis.text=element_text(size=15),
        axis.title=element_text(size=14,face="bold"))
dev.off()

2015_2016/20151020 The impact of daily practices/some analyses.r


Employees = data.frame(Name=c("Yash Verma","Neha Charak","Vikrant Nagyal","Arnab goswami","Keya Singh"),
                       Gender=c("M","F","M","M","F"),
                       Age=c(21,20,25,26,32),
                       Designation=c("CEO","Exective","Manager","Clerk","Assistant"),
                       SSN=c("123-34-2346","123-44-779","556-24-433","123-98-987","679-77-576"),
                       salary=c(50000,6000,5000,4000,3000),
                       exp_yrs=c(5,4,3,2,1),
                       doj=c("04-05-15","04-05-16","04-05-17","04-05-18","04-05-19"),
                       cont=c(1345,12453,12445,124123,56343),
                       perf=c(5,4,3,2,1),
                       dep=c("head","office","office","home","home")
)
print("Performed by Yash Verma 18BCS1814")
print("Details of the employees:")
print(Employees)
summary(Employees)


#' @title
#' Multi-omics data sets and clusters.
#'
#' @description
#' This dataset was taken from Yang \emph{et al.} 2019 Cell Syst ( 8, 427-445.e10). It is a multiomics data set, comprising transciptomics, proteomics and phosphoproteomics measurements at multiple time points. The clustering of these time series data is also made available. The phosphoproteomics and proteomics data were clustered using Mfuzz, and the transcriptomics data were clustered using STEM (The STEM clustering details can be found in Kaur \emph{et al.} 2020 npj Sys. Bio.).
#'
#'
#' @name multiomics
#' @docType data
#' @references Yang \emph{et al.} 2019. Available at: \url{http://doi.org/10.1016/j.cels.2019.03.012}
#' @keywords data
NULL

#'
#' @rdname multiomics
"phosTsData.stand"

#' @rdname multiomics
"protTsData.stand"

#' @rdname multiomics
"rnaSeqTsData.stand"

#' @rdname multiomics
"phosClusVec"

#' @rdname multiomics
"protClusVec"

#' @rdname multiomics
"rnaSeqClusVec"