options("warn"=-1)

#from http://selection.med.yale.edu/baseline/Archive/Baseline%20Version%201.3/Baseline_Functions_Version1.3.r
# Compute p-value of two distributions
compareTwoDistsFaster <-function(sigma_S=seq(-20,20,length.out=4001), N=10000, dens1=runif(4001,0,1), dens2=runif(4001,0,1)){
#print(c(length(dens1),length(dens2)))
if(length(dens1)>1 & length(dens2)>1 ){
	dens1<-dens1/sum(dens1)
	dens2<-dens2/sum(dens2)
	cum2 <- cumsum(dens2)-dens2/2
	tmp<- sum(sapply(1:length(dens1),function(i)return(dens1[i]*cum2[i])))
	#print(tmp)
	if(tmp>0.5)tmp<-tmp-1
	return( tmp )
	}
	else {
	return(NA)
	}
	#return (sum(sapply(1:N,function(i)(sample(sigma_S,1,prob=dens1)>sample(sigma_S,1,prob=dens2))))/N)
}

require("grid")
arg <- commandArgs(TRUE)
#arg <- c("300143","4","5")
arg[!arg=="clonal"]
input <- arg[1]
output <- arg[2]
rowIDs <- as.numeric(  sapply(arg[3:(max(3,length(arg)))],function(x){ gsub("chkbx","",x) } )  )

numbSeqs = length(rowIDs)

if ( is.na(rowIDs[1]) | numbSeqs>10 ) {
  stop( paste("Error: Please select between one and 10 seqeunces to compare.") )
}

#load( paste("output/",sessionID,".RData",sep="") )
load( input )
#input

xMarks = seq(-20,20,length.out=4001)

plot_grid_s<-function(pdf1,pdf2,Sample=100,cex=1,xlim=NULL,xMarks = seq(-20,20,length.out=4001)){
  yMax = max(c(abs(as.numeric(unlist(listPDFs[pdf1]))),abs(as.numeric(unlist(listPDFs[pdf2]))),0),na.rm=T) * 1.1

  if(length(xlim==2)){
    xMin=xlim[1]
    xMax=xlim[2]
  } else {
    xMin_CDR = xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001][1]
    xMin_FWR = xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001][1]
    xMax_CDR = xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001][length(xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001])]
    xMax_FWR = xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001][length(xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001])]

    xMin_CDR2 = xMarks[listPDFs[pdf2][[1]][["CDR"]]>0.001][1]
    xMin_FWR2 = xMarks[listPDFs[pdf2][[1]][["FWR"]]>0.001][1]
    xMax_CDR2 = xMarks[listPDFs[pdf2][[1]][["CDR"]]>0.001][length(xMarks[listPDFs[pdf2][[1]][["CDR"]]>0.001])]
    xMax_FWR2 = xMarks[listPDFs[pdf2][[1]][["FWR"]]>0.001][length(xMarks[listPDFs[pdf2][[1]][["FWR"]]>0.001])]

    xMin=min(c(xMin_CDR,xMin_FWR,xMin_CDR2,xMin_FWR2,0),na.rm=TRUE)
    xMax=max(c(xMax_CDR,xMax_FWR,xMax_CDR2,xMax_FWR2,0),na.rm=TRUE)
  }

  sigma<-approx(xMarks,xout=seq(xMin,xMax,length.out=Sample))$x
  grid.rect(gp = gpar(col=gray(0.6),fill="white",cex=cex))
  x <- sigma
  pushViewport(viewport(x=0.175,y=0.175,width=0.825,height=0.825,just=c("left","bottom"),default.units="npc"))
  #pushViewport(plotViewport(c(1.8, 1.8, 0.25, 0.25)*cex))
  pushViewport(dataViewport(x, c(yMax,-yMax),gp = gpar(cex=cex),extension=c(0.05)))
  grid.polygon(c(0,0,1,1),c(0,0.5,0.5,0),gp=gpar(col=grey(0.95),fill=grey(0.95)),default.units="npc")
  grid.polygon(c(0,0,1,1),c(1,0.5,0.5,1),gp=gpar(col=grey(0.9),fill=grey(0.9)),default.units="npc")
  grid.rect()
  grid.xaxis(gp = gpar(cex=cex/1.1))
  yticks = pretty(c(-yMax,yMax),8)
  yticks = yticks[yticks>(-yMax) & yticks<(yMax)]
  grid.yaxis(at=yticks,label=abs(yticks),gp = gpar(cex=cex/1.1))
  if(length(listPDFs[pdf1][[1]][["CDR"]])>1){
    ycdr<-approx(xMarks,listPDFs[pdf1][[1]][["CDR"]],xout=seq(xMin,xMax,length.out=Sample),yleft=0,yright=0)$y
    grid.lines(unit(x,"native"), unit(ycdr,"native"),gp=gpar(col=2,lwd=2))
  }
  if(length(listPDFs[pdf1][[1]][["FWR"]])>1){
    yfwr<-approx(xMarks,listPDFs[pdf1][[1]][["FWR"]],xout=seq(xMin,xMax,length.out=Sample),yleft=0,yright=0)$y
    grid.lines(unit(x,"native"), unit(-yfwr,"native"),gp=gpar(col=4,lwd=2))
   }

  if(length(listPDFs[pdf2][[1]][["CDR"]])>1){
    ycdr2<-approx(xMarks,listPDFs[pdf2][[1]][["CDR"]],xout=seq(xMin,xMax,length.out=Sample),yleft=0,yright=0)$y
    grid.lines(unit(x,"native"), unit(ycdr2,"native"),gp=gpar(col=2,lwd=2,lty=2))
  }
  if(length(listPDFs[pdf2][[1]][["FWR"]])>1){
    yfwr2<-approx(xMarks,listPDFs[pdf2][[1]][["FWR"]],xout=seq(xMin,xMax,length.out=Sample),yleft=0,yright=0)$y
    grid.lines(unit(x,"native"), unit(-yfwr2,"native"),gp=gpar(col=4,lwd=2,lty=2))
   }

  grid.lines(unit(c(0,1),"npc"), unit(c(0.5,0.5),"npc"),gp=gpar(col=1))
  grid.lines(unit(c(0,0),"native"), unit(c(0,1),"npc"),gp=gpar(col=1,lwd=1,lty=3))

  grid.text("All", x = unit(-2.5, "lines"), rot = 90,gp = gpar(cex=cex))
  grid.text( expression(paste("Selection Strength (", Sigma, ")", sep="")) , y = unit(-2.5, "lines"),gp = gpar(cex=cex))

  if(pdf1==pdf2 & length(listPDFs[pdf2][[1]][["FWR"]])>1 & length(listPDFs[pdf2][[1]][["CDR"]])>1 ){
    pCDRFWR = compareTwoDistsFaster(sigma_S=xMarks, N=10000, dens1=listPDFs[[pdf1]][["CDR"]], dens2=listPDFs[[pdf1]][["FWR"]])
    pval = formatC(as.numeric(pCDRFWR),digits=3)
    grid.text( substitute(expression(paste(P[CDR/FWR], "=", x, sep="")),list(x=pval))[[2]] , x = unit(0.02, "npc"),y = unit(0.98, "npc"),just=c("left", "top"),gp = gpar(cex=cex*1.2))
  }
  grid.text(paste("CDR"), x = unit(0.98, "npc"),y = unit(0.98, "npc"),just=c("right", "top"),gp = gpar(cex=cex*1.5))
  grid.text(paste("FWR"), x = unit(0.98, "npc"),y = unit(0.02, "npc"),just=c("right", "bottom"),gp = gpar(cex=cex*1.5))
  popViewport(2)
}
#plot_grid_s(1)

p2col<-function(p=0.01){
  breaks=c(-.51,-0.1,-.05,-0.01,-0.005,0,0.005,0.01,0.05,0.1,0.51)
  i<-findInterval(p,breaks)
  cols = c( rgb(0.8,1,0.8), rgb(0.6,1,0.6), rgb(0.4,1,0.4), rgb(0.2,1,0.2) , rgb(0,1,0),
            rgb(1,0,0), rgb(1,.2,.2), rgb(1,.4,.4), rgb(1,.6,.6) , rgb(1,.8,.8) )
  return(cols[i])
}

plot_pvals<-function(pdf1,pdf2,cex=1,upper=TRUE){
  if(upper){
    pCDR1FWR2 = compareTwoDistsFaster(sigma_S=xMarks, N=10000, dens1=listPDFs[[pdf1]][["CDR"]], dens2=listPDFs[[pdf2]][["FWR"]])
    pFWR1FWR2 = compareTwoDistsFaster(sigma_S=xMarks, N=10000, dens1=listPDFs[[pdf1]][["FWR"]], dens2=listPDFs[[pdf2]][["FWR"]])
    pFWR1CDR2 = compareTwoDistsFaster(sigma_S=xMarks, N=10000, dens2=listPDFs[[pdf2]][["CDR"]], dens1=listPDFs[[pdf1]][["FWR"]])
    pCDR1CDR2 = compareTwoDistsFaster(sigma_S=xMarks, N=10000, dens2=listPDFs[[pdf2]][["CDR"]], dens1=listPDFs[[pdf1]][["CDR"]])
    grid.polygon(c(0.5,0.5,1,1),c(0,0.5,0.5,0),gp=gpar(col=p2col(pFWR1FWR2),fill=p2col(pFWR1FWR2)),default.units="npc")
    grid.polygon(c(0.5,0.5,1,1),c(1,0.5,0.5,1),gp=gpar(col=p2col(pCDR1FWR2),fill=p2col(pCDR1FWR2)),default.units="npc")
    grid.polygon(c(0.5,0.5,0,0),c(1,0.5,0.5,1),gp=gpar(col=p2col(pCDR1CDR2),fill=p2col(pCDR1CDR2)),default.units="npc")
    grid.polygon(c(0.5,0.5,0,0),c(0,0.5,0.5,0),gp=gpar(col=p2col(pFWR1CDR2),fill=p2col(pFWR1CDR2)),default.units="npc")

    grid.lines(c(0,1),0.5,gp=gpar(lty=2,col=gray(0.925)))
    grid.lines(0.5,c(0,1),gp=gpar(lty=2,col=gray(0.925)))

    grid.text(formatC(as.numeric(pFWR1FWR2),digits=3), x = unit(0.75, "npc"),y = unit(0.25, "npc"),just=c("center", "center"),gp = gpar(cex=cex))
    grid.text(formatC(as.numeric(pCDR1FWR2),digits=3), x = unit(0.75, "npc"),y = unit(0.75, "npc"),just=c("center", "center"),gp = gpar(cex=cex))
    grid.text(formatC(as.numeric(pCDR1CDR2),digits=3), x = unit(0.25, "npc"),y = unit(0.75, "npc"),just=c("center", "center"),gp = gpar(cex=cex))
    grid.text(formatC(as.numeric(pFWR1CDR2),digits=3), x = unit(0.25, "npc"),y = unit(0.25, "npc"),just=c("center", "center"),gp = gpar(cex=cex))

 #   grid.text(paste("P = ",formatC(pCDRFWR,digits=3)), x = unit(0.5, "npc"),y = unit(0.98, "npc"),just=c("center", "top"),gp = gpar(cex=cex))
 #   grid.text(paste("P = ",formatC(pFWRFWR,digits=3)), x = unit(0.5, "npc"),y = unit(0.02, "npc"),just=c("center", "bottom"),gp = gpar(cex=cex))
  }
  else{
  }
}

##################################################################################
################## The whole OCD's matrix ########################################
##################################################################################

#pdf(width=4*numbSeqs+1/3,height=4*numbSeqs+1/3)
pdf( output ,width=4*numbSeqs+1/3,height=4*numbSeqs+1/3)

pushViewport(viewport(x=0.02,y=0.02,just = c("left", "bottom"),w =0.96,height=0.96,layout = grid.layout(numbSeqs+1,numbSeqs+1,widths=unit.c(unit(rep(1,numbSeqs),"null"),unit(4,"lines")),heights=unit.c(unit(4,"lines"),unit(rep(1,numbSeqs),"null")))))

for( seqOne in 1:numbSeqs+1){
  pushViewport(viewport(layout.pos.col = seqOne-1, layout.pos.row = 1))
  if(seqOne>2){
    grid.polygon(c(0,0,0.5,0.5),c(0,0.5,0.5,0),gp=gpar(col=grey(0.5),fill=grey(0.9)),default.units="npc")
    grid.polygon(c(1,1,0.5,0.5),c(0,0.5,0.5,0),gp=gpar(col=grey(0.5),fill=grey(0.95)),default.units="npc")
    grid.polygon(c(0,0,1,1),c(1,0.5,0.5,1),gp=gpar(col=grey(0.5)),default.units="npc")

    grid.text(y=.25,x=0.75,"FWR",gp = gpar(cex=1.5),just="center")
    grid.text(y=.25,x=0.25,"CDR",gp = gpar(cex=1.5),just="center")
  }
  grid.rect(gp = gpar(col=grey(0.9)))
  grid.text(y=.75,substr(paste(names(listPDFs)[rowIDs[seqOne-1]]),1,16),gp = gpar(cex=2),just="center")
  popViewport(1)
}

for( seqOne in 1:numbSeqs+1){
  pushViewport(viewport(layout.pos.row = seqOne, layout.pos.col = numbSeqs+1))
  if(seqOne<=numbSeqs){
    grid.polygon(c(0,0.5,0.5,0),c(0,0,0.5,0.5),gp=gpar(col=grey(0.5),fill=grey(0.95)),default.units="npc")
    grid.polygon(c(0,0.5,0.5,0),c(1,1,0.5,0.5),gp=gpar(col=grey(0.5),fill=grey(0.9)),default.units="npc")
    grid.polygon(c(1,0.5,0.5,1),c(0,0,1,1),gp=gpar(col=grey(0.5)),default.units="npc")
    grid.text(x=.25,y=0.75,"CDR",gp = gpar(cex=1.5),just="center",rot=270)
    grid.text(x=.25,y=0.25,"FWR",gp = gpar(cex=1.5),just="center",rot=270)
  }
  grid.rect(gp = gpar(col=grey(0.9)))
  grid.text(x=0.75,substr(paste(names(listPDFs)[rowIDs[seqOne-1]]),1,16),gp = gpar(cex=2),rot=270,just="center")
  popViewport(1)
}

for( seqOne in 1:numbSeqs+1){
  for(seqTwo in 1:numbSeqs+1){
    pushViewport(viewport(layout.pos.col = seqTwo-1, layout.pos.row = seqOne))
    if(seqTwo>seqOne){
      plot_pvals(rowIDs[seqOne-1],rowIDs[seqTwo-1],cex=2)
      grid.rect()
    }
    popViewport(1)
  }
}

xMin=0
xMax=0.01
for(pdf1 in rowIDs){
  xMin_CDR = xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001][1]
  xMin_FWR = xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001][1]
  xMax_CDR = xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001][length(xMarks[listPDFs[pdf1][[1]][["CDR"]]>0.001])]
  xMax_FWR = xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001][length(xMarks[listPDFs[pdf1][[1]][["FWR"]]>0.001])]
  xMin=min(c(xMin_CDR,xMin_FWR,xMin),na.rm=TRUE)
  xMax=max(c(xMax_CDR,xMax_FWR,xMax),na.rm=TRUE)
}

for(i in 1:numbSeqs+1){
  for(j in (i-1):numbSeqs){
    pushViewport(viewport(layout.pos.col = i-1, layout.pos.row = j+1))
    grid.rect()
    plot_grid_s(rowIDs[i-1],rowIDs[j],cex=1)
    popViewport(1)
  }
}

dev.off()

cat("Success", paste(rowIDs,collapse="_"),sep=":")


# Imposto la working directory, definisco i nomi dei campi e leggo i dati e
# li attaccho.

setwd('/home/niccolove/Documents/Scuola/SD/')

campi = c('age', 'workclass', 'fnlwgt', 'education', 'education-num',
          'marital-status', 'occupation', 'relationship', 'race', 'sex',
          'capital-gain', 'capital-loss', 'hours-per-week', 'native-country',
          'income')

data = read.table('adult.txt', sep=',', na.strings='?', skip=1, col.names=campi)
attach(data)

# Dei dati visualizzo dimensione, struttura e i primi dieci

dim(data); str(data)
first-ten = data[1:10,]
View(first-ten)

# Creo un nuovo campo ordinato per l'educazione in base ai campi dati

levels(education)

educazioni = c('Preschool', '1st-4th', '5th-6th', '7th-8th', '9th', '10th',
               '11th', '12th', 'HS-grad', 'Prof-school', 'Assoc-acdm',
               'Assoc-voc', 'Some-college', 'Bachelors', 'Masters', 'Doctorate')

education_rec = ordered(education, levels=0:15, labels=educazioni)

# Prendiamo le prime dieci righe delle colonne numeriche

numeric_only = data[,c(1, 3, 5, 11, 12, 13)]
numeric_only[1:10,]

# Disegnamo i grafici per tutte le variabili qualitative

levels(workclass)
# Iteriamo su tutte le colonne e accettiamo solo quelle non numeriche
for (i in 1:ncol(data)){
    if(!is.numeric(data[1,i])) {

        # Prendiamo la table e calcoliamo freq, aggiungiamo i valori relativi e
        # assoluti, e disegnamo il grafico
        my_table = table(data[,i])
        str(my_table)
        freq = prop.table(my_table)
        binded = cbind(my_table, round(freq, 4), round(freq*100, 2))
        barplot(freq, cex.names=0.5, cex.axis=1.3, legend.text=colnames(data[i]))
        abline(h=0)
    }
}

# Prendiamo i valori assoluti e relativi della frequenza di ogni combinazione di
# workclass ed education

absolute_table = round(prop.table(table(workclass, education)), 4)
relative_table = absolute_table*100

# Ordiniamo i dati per workclass e education discendente e visualizziamo le
# prime e le ultime 5 righe

data_per_workclass = data[with(data, order(workclass, -education)),]
head(data_per_workclass, 5)
tail(data_per_workclass, 5)

# Creiamo i data frame di maschietti e femminucce, ne mostriamo la dimensione e
# li riuniamo in un singolo dataframe

maschietti = subset(data_per_workclass, sex=="Male")
dim(maschietti)
femminucce = subset(data_per_workclass, sex=="Female")
dim(femminucce)
entrambi = rbind(maschietti, femminucce)


"
Написать формулу получения 20 случайных действительных чисел из диапазона
(min = -7, max = -2) с помощью функции sample(),
не используя при ее вызове задания минимального и максимального значений.
"
w <- sample(10000) * -0.1000
result=c()
for (number in w)
  if (number >= -7 & number <= -2)
    result <- append(result, number)
result <- sample(result,20)
print(result)


# armar plot ranking anual

# definicion parametros
cant_n=5;
metrica_s='betweeness';

# tomar caracter dinamico
metrica_sym <-rlang::sym(metrica_s)

# pryueba concepto top N
temporal_acumulado_nodos_grafos %>%
    arrange(.data = .,desc(!!metrica_sym)) %>%
    head(cant_n)

# armar para cada periodo segun parametros en top N
resu <- temporal_acumulado_nodos_grafos %>%
nest(-periodo) %>%
    mutate(top_n_periodo=purrr::map(data,
                                    cant=cant_n,
                                    metrica=metrica_s,
                                    .f=function(d,metrica,cant){
        metrica_sym <-rlang::sym(metrica_s)
        ranking <- seq(from=1,to = cant,by = 1)
        ret <- d %>% arrange(desc(!!metrica_sym)) %>% head(cant) %>%
            mutate(posicion=ranking) %>%
            mutate(valor_seleccion= !!metrica_sym)
        ret
    }))
metrica_sym <-rlang::sym(metrica_s)
# plot con ranking
plot_out <- resu %>%
    # filter(periodo==1996) %>%
    unnest(top_n_periodo) %>%
    mutate(autor=fct_reorder(autor,posicion,.desc = TRUE)) %>%
    mutate(posicion=as.factor(posicion)) %>%
    ggplot(aes(x=periodo,y=autor,color=posicion,group=posicion,label=valor_seleccion))+
    geom_point()+
    geom_line(show.legend = FALSE)+
    theme_light()+
    theme(axis.text.x = element_text(angle = 90, hjust = 1),
          axis.text.y = element_text(size = 6))+
    labs(x="",y="")

plotly::ggplotly(plot_out)


rm(list=ls())
library(DEploid)
library(dplyr)

common_plot <- function(){
    plot(myfit$df, main = "df", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, col = points_col)
    abline(v = dev.ratio.rate.cut, col = "blue" )

    plot.glmnet(myfit, xvar="norm", col = useColor, main = "norm", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5)
    plot(myfit$a0, main = "a0", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, col = points_col)
    abline(v = dev.ratio.rate.cut, col = "blue" )

    plot.glmnet(myfit, xvar="lambda", col = useColor, main = "lambda", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5)
    plot(myfit$lambda, main = "lambda", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, col = points_col)
    abline(v = dev.ratio.rate.cut, col = "blue" )

    plot.glmnet(myfit, xvar="dev", col = useColor, main = "dev.ratio", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, xlim = c(0,1))
    plot(myfit$dev.ratio, main = "dev.ratio", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, col = points_col, ylim=c(0,1))
    abline(v = dev.ratio.rate.cut, col = "blue" )

    plot(c(0,0), c(1,1), type = "n", xlab = "", ylab = "", axes=F, main = "", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5)
    plot(c(1:n_lambda), c(dev.ratio.rate,0), main = "dev.ratio change", cex.main = 3, cex.lab = 1.5, cex.axis = 1.5, ylim=c(0,0.02), col = points_col)
    abline(v = dev.ratio.rate.cut, col = "blue" )
}

panel = read.table("panel_from_crosses.txt", header=T, comment.char="", check.names=F)
panelCol = names(panel)
panel = panel[, -which(panelCol %in% c("PG0051-C", "PG0052-C", "7G8", "GB4", "PG0004-CW", "PG0008-CW"))]

strainColors = rep("grey", length(names(panel)))
strainColors[names(panel) %in% read.table("cross_3D7xHB3", header=F)$V1] = "red"
strainColors[names(panel) %in% read.table("cross_7G8xGB4", header=F)$V1] = "blue"
strainColors[names(panel) %in% read.table("cross_HB3xDD2", header=F)$V1] = "green"

i_arr = c(389:415)
correct_df = c(rep(1,6),
               rep(3,3),
               1,
               rep(2,16),
               1)

#n_lambda = 100
dev.explained = c()
for ( idx_i in 1:27 ){
    i = i_arr[idx_i]
    sample_i = paste("PG0", i, "-C", sep="")
#    sample_i = "PG0396-C"
    coverage = extractCoverageFromVcf(paste("jasonMixed/", sample_i, ".vcf.gz", sep = ""))
dev.explained.sample = c()
    for ( chrom in unique(coverage$CHROM) ){
        chrom_idx = which(coverage$CHROM == chrom)
        panelName = paste("crossProgenyOnlyPanel_", chrom, ".txt", sep="")
        if (idx_i == 1){
            write.table(panel[chrom_idx,], file = panelName, sep = "\t", row.names=F, col.names=F)
        }

        wsaf = computeObsWSAF(alt = coverage$altCount[chrom_idx], ref = coverage$refCount[chrom_idx])
        wsafName = paste("tmp/", sample_i, "_", chrom, ".wsaf", sep="")
        write.table(wsaf, file = wsafName, row.names=F, col.names=F)

        outFile = paste("tmp/", sample_i, "_", chrom, ".lasso", sep="")
        system (paste("lasso", panelName, wsafName, ">", outFile))
#print(paste("lasso", panelName, wsafName, ">", outFile))
#        inFileName = args[1]

        system(paste("grep TABLE ", outFile, " > ", outFile, ".TABLE", sep=""))
        system(paste("grep BETA ", outFile, " > ", outFile, ".BETA", sep=""))

        mytable = read.table(paste(outFile, ".TABLE", sep=""), header=T, stringsAsFactors = F)[,-1]
        mybeta = read.table(paste(outFile, ".BETA", sep=""), header=T, stringsAsFactors = F)[,-1]

        dev.ratio.rate = diff(mytable$rsq) / mytable$rsq[-1]
        dev.ratio.rate.cut = min(which(dev.ratio.rate<0.001)[1], length(dev.ratio.rate), na.rm = T)

        png( paste(sample_i, "_", chrom, ".png", sep=""), width = 1000, height = 1000)
        par(mar=c(5,5,2,2))
        par(mfrow = c(4,1))
        plot(mytable$df, ylab = "# of predictor variable", cex.lab = 2, cex.axis = 2)
        abline(v = dev.ratio.rate.cut, col = "blue" )

        plot(mytable$rsq, ylab = "Deviance ratio", cex.lab = 2, cex.axis = 2)
        abline(v = dev.ratio.rate.cut, col = "blue" )

        plot(diff(mytable$rsq), ylab = "Deviance ratio differences", cex.lab = 2, cex.axis = 2 )
        abline(v = dev.ratio.rate.cut, col = "blue" )

        v_idx = c()
        plot(c(0, max(mytable$L1norm)),
             c(min(mybeta[,-1]), max(mybeta[,-1])), type="n", xlab = "L1 Norm", ylab = "Coefficient", cex.lab = 2, cex.axis = 2)
        for (i in 1:dim(mybeta)[1]){
             lines(c(0, mytable$L1norm), c(0,mybeta[i,-1]), col = strainColors[mybeta[i,1]])
        }
        abline(v = mytable$L1norm[dev.ratio.rate.cut], col = "blue" )

        legend("left", legend=c("3D7xHB3", "7G8xGB4", "HB3xDD2"), col = c("red", "blue", "green"), lty=1, bty="n", cex = 2)
        dev.off()

        CHROM = coverage$CHROM[chrom_idx]
        POS = coverage$POS[chrom_idx]
        new_tmp_panel = cbind(CHROM, POS, panel[chrom_idx,mybeta[which(mybeta[,1+dev.ratio.rate.cut] > 0),1]] )
        write.table(new_tmp_panel, file = paste("panels/", sample_i, "_", chrom, ".panel.txt", sep =""), quote = F, row.names=F, sep = "\t")

    }
}


# The usual Scheme way : build a function that takes commands as parameters (it's like message passing oriented programming)
queue <- function() {
    v <- list()
    f <- function(cmd, val=NULL) {
        if(cmd == "push") {
            v <<- c(v, val)
            invisible()
        } else if(cmd == "pop") {
            if(length(v) == 0) {
                stop("empty queue")
            } else {
                x <- v[[1]]
                v[[1]] <<- NULL
                x
            }
        } else if(cmd == "length") {
            length(v)
        } else if(cmd == "empty") {
            length(v) == 0
        } else {
            stop("unknown command")
        }
    }
    f
}

# Create two queues
a <- queue()
b <- queue()
a("push", 1)
a("push", 2)
b("push", 3)
a("push", 4)
b("push", 5)

a("pop")
# [1] 1
b("pop")
# [1] 3


import('./functional', attach = TRUE)

#' Create a logical vector from a numeric index vector
#'
#' Compute the inverse of \code{\link{base::which}}: given an index vector and
#' the output length, create a logical vector of the output length, with the
#' specified elements set to \code{TRUE}.
#'
#' @param indices numeric vector of selected indices
#' @param length of the output vecotr
#' @return A logical vector of length \code{length} with the elements specified
#'  by \code{indices} set to \code{TRUE}.
#' @seealso \code{\link{base::which}}
# TODO: Handle negative indices?
# TODO: handle factors, equivalent to unname(apply(model.matrix(~0 + factor), 2, as.logical))
index_mask = function (indices, length)
    is.element(1 : length, indices)

#' Like \code{table}, but allows specifying a vector of labels
#'
#' \code{table} does not know what values to expect; as a consequence, it does
#' not tabulate non-existent values (see Examples). \code{full_table} amends
#' this, and yields complete count tables, which are sometimes more useful.
#' @param data vector to tabulate, which is internally passed to \code{table}
#' @param labels complete vector of all possible values being counted
#' @return A complete count table of the \code{data}, where the possible values
#' are in the order specified by \code{labels}. Values which do not occur in
#' \code{data} are set to \code{0}.
#' @examples
#' a = c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE)
#' b = rep(TRUE, 4)
#' table(a)
#' # a
#' # FALSE  TRUE
#' #     4     2
#' table(b)
#' # b
#' # TRUE
#' #    4
#' full_table(a, c(TRUE, FALSE))
#' # TRUE FALSE
#' #    2     4
#' full_table(b, c(TRUE, FALSE))
#' # TRUE FALSE
#' #    4     0
full_table = function (data, labels)
    table(factor(data, labels))

#' Sort by a one or more given keys
#'
#' Apply an \code{order} directly to a target.
#'
#' @param data a vector or \code{data.frame} to sort
#' @param ... one or more keys to sort by; if missing, use the values themselves
#'  (for a vector), or the values of the first column
#' @param decreasing logical value indicating whether to invert the sort order
#'  (default: \code{FALSE})
#' @return The sorted data in the same format (preserving names, etc).
sort_by = function (data, ..., decreasing = FALSE)
    UseMethod('sort_by')

sort_by.data.frame = function (data, ..., decreasing = FALSE)
    let(key = if (length(list(...)) == 0) list(data[, 1]) else list(...),
        data[do.call(order, c(key, decreasing = decreasing)), ])

sort_by.default = function (data, ..., decreasing = FALSE)
    let(key = if (length(list(...)) == 0) list(data) else list(...),
        data[do.call(order, c(key, decreasing = decreasing))])


with(dfr, tapply(Salary, Department, max))


# Load the rjags library
library('rjags')

# Convert to a list
make_list <- function(draw)
{
	results = list()
	for(name in names(draw))
	{
		# Extract "chain 1"
		results[[name]] = as.array(draw[[name]][,,1])

		# Transpose 2D arrays
		if(length(dim(results[[name]])) == 2)
			results[[name]] = t(results[[name]])
	}
	return(results)
}

# Load data from file
source('data.txt')

# Run model 1 and save results
m = jags.model(file='model1.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=list(N1=data$N1, N2=data$N2))
update(m, 10000)
draw = jags.samples(m, 50000, thin=10,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(5000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='prior1.txt', row.names=FALSE, col.names=FALSE)

# Run model 2 and save results
m = jags.model(file='model2.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=list(N1=data$N1, N2=data$N2))
update(m, 10000)
draw = jags.samples(m, 50000, thin=10,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(5000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='prior2.txt', row.names=FALSE, col.names=FALSE)

# Run model 3 and save results
m = jags.model(file='model3.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=list(N1=data$N1, N2=data$N2))
update(m, 10000)
draw = jags.samples(m, 50000, thin=10,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(5000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='prior3.txt', row.names=FALSE, col.names=FALSE)

# Run model 1 and save results
m = jags.model(file='model1.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=data)
update(m, 10000)
draw = jags.samples(m, 100000, thin=100,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(1000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='chains1.txt', row.names=FALSE, col.names=FALSE)
print(mean(results$mu1 < results$mu2))
print(mean(results$mu1 == results$mu2))
print(mean(results$mu1 > results$mu2))

# Run model 2 and save results
m = jags.model(file='model2.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=data)
update(m, 10000)
draw = jags.samples(m, 100000, thin=100,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(1000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='chains2.txt', row.names=FALSE, col.names=FALSE)
print(mean(results$mu1 < results$mu2))
print(mean(results$mu1 == results$mu2))
print(mean(results$mu1 > results$mu2))

# Run model 3 and save results
m = jags.model(file='model3.txt', inits=list(.RNG.seed=42, .RNG.name="base::Mersenne-Twister"), data=data)
update(m, 10000)
draw = jags.samples(m, 100000, thin=100,
		variable.names = c('mu1', 'mu2', 'sigma'))
results = make_list(draw)
chains = array(NA, dim=c(1000, 3))
chains[,1] = results$mu1
chains[,2] = results$mu2
chains[,3] = results$sigma
write.table(chains, file='chains3.txt', row.names=FALSE, col.names=FALSE)
print(mean(results$mu1 < results$mu2))
print(mean(results$mu1 == results$mu2))
print(mean(results$mu1 > results$mu2))


name.getter <- function(full.name)
{
  gsub(x=full.name, pattern="TOP500_", replacement="")
}

top500.rank <- function(flops, type="theoretical")
{
  # TODO swap to GFLOPS
  files <- .__TOP500_datafiles

  ret <- integer(length(files))

  type <- match.arg(tolower(type), c("theoretical", "linpack"))
  if (type == "theoretical")
    col <- "r.peak"
  else if (type == "linpack")
    col <- "r.max"

  for (i in 1L:length(files))
  {
    file <- files[i]

    top <- eval(parse(text=file))[, col]
    if (any(flops >= top))
      ret[i] <- which(flops >= top)[1L]
    else
      ret[i] <- NA_integer_
  }

  return( ret )
}

top500.summary <- function(type="theoretical")
{
  files <- .__TOP500_datafiles
  len <- length(files)
  ret <- data.frame(date=character(len), Min=numeric(len), Mean=numeric(len), Max=numeric(len), Sum=numeric(len), Median=numeric(len), stringsAsFactors=FALSE)

  type <- match.arg(tolower(type), c("theoretical", "linpack", "ncores"))
  if (type == "theoretical")
    col <- "r.peak"
  else if (type == "linpack")
    col <- "r.max"
  else if (type == "ncores")
    col <- "number.of.processors"

  for (i in 1L:length(files))
  {
    file <- files[i]
    top <- eval(parse(text=file))[, col]

    ret[i, 1L] <- name.getter(file)
    ret[i, 2L] <- min(top)
    ret[i, 3L] <- mean(top)
    ret[i, 4L] <- max(top)
    ret[i, 5L] <- sum(top)
    ret[i, 6L] <- median(top)
  }

  ret$date <- as.Date(paste0(ret$date, "01"), format="%Y%m%d")

  return( ret )
}

top500.diff <- function()
{
  files <- .__TOP500_datafiles
  len <- length(files)
  ret <- data.frame(date=character(len), Min=numeric(len), Mean=numeric(len), Max=numeric(len), stringsAsFactors=FALSE)

  for (i in 1L:length(files))
  {
    file <- files[i]
    top.theoretical <- eval(parse(text=file))[, "r.peak"]
    top.linpack <- eval(parse(text=file))[, "r.max"]

    top <- top.theoretical - top.linpack
    top <- sapply(top, function(x) max(0.000001, x))

    ret[i, 1L] <- name.getter(file)
    ret[i, 2L] <- min(top)
    ret[i, 3L] <- mean(top)
    ret[i, 4L] <- max(top)
  }

  ret$date <- as.Date(paste0(ret$date, "01"), format="%Y%m%d")

  return( ret )
}


## R CODE FOR ANALYSIS OF RESULTING ASSEMBLY COVERAGE FILES ##

library(hexbin)
library(data.table)
library(doBy)
library(lattice)
library(gridExtra)
#load appropriate libraries.

temp_data <- function(file) {
  temp_dataset <- read.table(file, header=F, sep=" ")
  #Imports the data
  temp_dataset <- temp_dataset[ which(temp_dataset$V1!='genome'), ]
  #remove anything in the file where 'genome' is in column V1
  temp_dataset$loc = as.character(lapply(strsplit(as.character(temp_dataset$V1), split="_"), "[", 1))
  #split each line using '_' as the split variable. assign the second part of the split to loc (locus)
  temp_dataset$A <- basename(file)
  temp_dataset$taxon = as.character(lapply(strsplit(as.character(temp_dataset$A), split="-"), "[", 1))
  #split each line using '_' as the split variable. assign the second part of the split to taxon
  return(temp_dataset)
  #return the dataset
}
#The above is a function that opens each file sent to it and cleans up the data a bit.

make_dataset <- function(working_dir) {
  #a function to generate the dataset.
  setwd(working_dir)
  files <- list.files(pattern = '.per.contig.summary')
  #set working directory and get files.

  for (file in files){
  #simple for loop traversing all files the loop picked up earlier.
    if (exists("dataset")){
      #if the dataset already exists, this will start the append process.
      Sys.sleep(0.1)
      print(file)
      flush.console()
      #provides a way to see what files are being worked on.

      temp_dataset <- temp_data(file)
      #run the function setup above on the file.

      dataset<-rbind(dataset, temp_dataset)
      #join the new data to the old dataset.

      rm(temp_dataset)
      #as a precaution, remove the temp_dataset from memory.

    } else {
      #if dataset does not exist, we need to make it.
      Sys.sleep(0.1)
      print(file)
      flush.console()
      #provides a way to see what files are being worked on.

      dataset <- temp_data(file)
      #this runs the function on the file and generates 'dataset'
    }
  }
new_data <- dataset
rm(dataset)
#this is a precaution against if you run the function twice. It will remove 'dataset' so that if the loop is run again, a new dataset will be made.
return(new_data)
}
#The above is a function loops over files in the directory provided to the function.

new_data <- make_dataset("/directory/path/to/your/files")
#make the dataset using the functions 'make_dataset' and 'temp_data'.
#to get this statement to work properly, you will need to execute the code for the functions into active memory (similar to loading a pacakge)

#########
# now that you have the data, the statements below, summarize that data in various ways.

summary_avg <- summaryBy(V2 ~ taxon, data = new_data, FUN = function(x) { c(n = length(x), m = mean(x), sd = sd(x), min=min(x), max=max(x)) } )


#### DONNES QUALI : ON VA REPRESENTER LA PROPORTION DE 1.

#Création d'un vecteur avec toutes les commbinaisons dans l'ordre)
name= c("DD","with himself","with DC","with Silur" ,"DC","with himself","with DD","with Silur" ,"Silur","with himself","with DD","with DC" )
average= sample(seq(1,10) , 12 , replace=T)
number= sample(seq(4,39) , 12 , replace=T)
data=data.frame(name,average,number)

png("#26_add_number_of_value_onto_a_boxplot.png" , width = 480, height = 480)

#Gestion des marges)
par(mar=c(7,2,2,2))

#Représentation du tableau bil :
my_bar=barplot(data$average , border=F , names.arg=data$name , las=2 , col=c(rgb(0.3,0.1,0.4,0.6) , rgb(0.3,0.5,0.4,0.6) , rgb(0.3,0.9,0.4,0.6) ,  rgb(0.3,0.9,0.4,0.6)) , ylim=c(0,11) , main="" )
abline(v=c(4.9 , 9.7) , col="grey")

#Ajout du texte
text(my_bar, data$average+0.4 , paste("n = ",data$number,sep="") ,cex=1)

#Legende
legend("topleft", legend = c("Alone","with Himself","With other genotype" ) , col = c(rgb(0.3,0.1,0.4,0.6) , rgb(0.3,0.5,0.4,0.6) , rgb(0.3,0.9,0.4,0.6) ,  rgb(0.3,0.9,0.4,0.6)) , bty = "n", pch=20 , pt.cex = 2, cex = 0.8, horiz = FALSE, inset = c(0.05, 0.05))

dev.off()


#
# Learning to use network and network plotting functions for VIVO data
#
# Copyright (c) 2015 Mike Conlon
# See LICENSE file for terms of use
#
#  To Do
#  Add grant dollars as an attribute.  Derive attribute for People, Department, College
#  Size of node is log of attribute
#
#  Experiment with "large" sizes in PDF (poster size plots with labeling)
#
# start with a root node
net <-network.initialize(1,directed=F)
net %v% "type" <- "Root"
net %v% "vertex.names" <- "COM"
net %v% "amt" <-0
#
# create some departments
#
add.vertices(net,1,list(list(type="Department",vertex.names="Radiology",amt=0)))
net["COM","Radiology"]<-1
add.vertices(net,1,list(list(type="Department",vertex.names="Pathology",amt=0)))
net["COM","Pathology"]<-1
add.vertices(net,1,list(list(type="Department",vertex.names="Pediatrics",amt=0)))
net["COM","Pediatrics"]<-1
#
# create some people in the departments
#
add.vertices(net,1,list(list(type="Person",vertex.names="Mancuso",amt=0)))
net["Radiology","Mancuso"]<-1
add.vertices(net,1,list(list(type="Person",vertex.names="Sistrom",amt=0)))
net["Radiology","Sistrom"]<-1
add.vertices(net,1,list(list(type="Person",vertex.names="Rathe",amt=0)))
net["Radiology","Rathe"]<-1

for (i in 1:15) {
  name <- paste("P",i,sep="")
  add.vertices(net,1,list(list(type="Person",vertex.names=name,amt=0)))
  net["Pathology",name]<-1
}
for (i in 1:30) {
  name <- paste("M",i,sep="")
  add.vertices(net,1,list(list(type="Person",vertex.names=name,amt=0)))
  net["Pediatrics",name]<-1
}
#
# Add grants as another level
#
vt<-get.vertex.attribute(net,"type")
vn<-get.vertex.attribute(net,"vertex.names")
va<-get.vertex.attribute(net,"amt")
for (i in 1:network.size(net)) {
  if (vt[i] == "Person") {
    di<-get.neighborhood(net,i)[1]  # get department index for this person
    ng <- floor(10*runif(1))
    if (ng > 0) {
      for (j in 1:ng) {
        gname <- paste(vn[i],".G",j,sep="")
        gamt=floor(50000*rexp(1)*rexp(1))
        add.vertices(net,1,list(list(type="Grant",vertex.names=gname,amt=gamt)))
        net[vn[i],gname]<-1
#
# Add the grant amounts to the corresponding person grant total
#
        va<-get.vertex.attribute(net,"amt")
        va[i]<-va[i]+gamt
        set.vertex.attribute(net,"amt",va)
#
# Add the grant amounts to the corresponding department total
#
        va<-get.vertex.attribute(net,"amt")
        va[di]<-va[di]+gamt
        set.vertex.attribute(net,"amt",va)
#
# Add the grant amount to the root total
#
        va<-get.vertex.attribute(net,"amt")
        va[1]<-va[1]+gamt
        set.vertex.attribute(net,"amt",va)
      }
    }
  }
}

#
#   Default plot
#
plot(net)
#
#   Color nodes by type
#
plot(net,vertex.col="type")
#
#   Color nodes by type and size them by grant dollars
#
palette(rev(rainbow(6)))
plot(net,vertex.col="type",
  vertex.cex=0.5*(1+floor(log10(1+get.vertex.attribute(net,"amt")))))


pdf_file<-"pdf/lorenzcurves_barcharts_10.pdf"
cairo_pdf(bg="grey98", pdf_file,width=12,height=9)

library(fBasics) # for seqPalette
library(gdata)

layout(matrix(c(1,2,1,2),2,2),heights=c(6,1))
par(omi=c(1,0.5,1.25,0.25),mai=c(0,2.65,0.75,0.25),cex=1.5,family="Lato Light",las=1)

# Read data

myData<-read.xls("myData/income_ten_classes.xlsx",head=T,skip=1,dec=".", encoding="latin1")

# Create chart and other elements

bp1<-barplot(as.matrix(myData),ylim=c(0,3),width=c(0.45),axes=F,horiz=T,col=c("grey",seqPalette(10,"OrRd")[2:10]),border=par("bg"),names.arg=c("2000","1986","2000","1984","2004","1984"))
arrows(0,-0.01,0,3.25,lwd=1.5,length=0,xpd=T,col="grey")
text(100-(myData[10,]/2),bp1,col="white",cex=1.1,family="Lato Black",labels=paste(round(myData[10,],digits=0),"%",sep=" "),xpd=T)
text(-15,bp1[2],"USA",family="Lato Black",adj=1,xpd=T)
text(-15,bp1[4],"Mexico",family="Lato Black",adj=1,xpd=T)
text(-15,bp1[6],"Germany",family="Lato Black",adj=1,xpd=T)

# Create chart and other elements

par(mai=c(0,2.65,0.1,0.25))
bp2<-barplot(as.matrix(rep(10,10)),ylim=c(0,0.5),width=c(0.25),axes=F,horiz=T,col=seqPalette(10,"Greys"),border=par("bg"),names.arg=c("Uniform distribution"))
arrows(0,-0.01,0,0.35,lwd=1.5,length=0,xpd=T,col="grey")
text(95,bp2,labels="10 %",col="white",xpd=T)
mtext(seq(0,100,by=20),at=seq(0,100,by=20),3,line=0,cex=1.15)

# Titling

mtext("Income Distribution over ten Classes in three Countries",line=2,adj=0,cex=2.25,family="Lato Black",outer=T)
myBreak<-strsplit( strwrap("In Mexico the richest 10% of income recipients held over 45% of the overall income in 2000, in the USA
                           it was 29%, in Germany 24. Compared to 1984 the share did increase.",width=110),"\n")
for(i in seq(along=myBreak))
{
mtext(myBreak[[i]],line=1.8-i,adj=0,side=3,cex=1.25,outer=T)
}
mtext("Source: World Income Inequality Database V2.Oc 2008",1,line=1.5,adj=1,cex=0.95,font=3,outer=T)
dev.off()


# take input from the user
num = as.integer(readline(prompt = "Enter a number: "))
if(num < 0) {
print("Enter a positive number")
} else {
sum = (num * (num + 1)) / 2;
print(paste("The sum is", sum))
}


  #  extract summary information for ONE variable at the time

   extract.summary.data.for.one.variable = function( x, y ) {
    # extract various (unadjusted) summary stats: medians, quantiles, etc
      d0 = tapply(X=x, INDEX=y, FUN=mean, na.rm=T, simplify=T)
      d1 = tapply(X=x, INDEX=y, FUN=sd, na.rm=T, simplify=T)
      d2 = tapply(X=x, INDEX=y, FUN=function(x) length(x[is.finite(x)]), simplify=T)
      d3 = tapply(X=x, INDEX=y, FUN=median, na.rm=T, simplify=T)
      d4 = tapply(X=x, INDEX=y, FUN=function(x) quantile(x, probs=0.25, na.rm=T), simplify=T)
      d5 = tapply(X=x, INDEX=y, FUN=function(x) quantile(x, probs=0.75, na.rm=T), simplify=T)
      out = rbind( mean=exp(d0)-1, sd=exp(d1), n=d2, median=exp(d3)-1, q25=exp(d4)-1, q75=exp(d5)-1 )
      print (out)
    return (out)
  }


a<-read.table(file.path(data.path,"short-term-input.out"),skip=3,header=F,sep=',')
names(a)<-list("Age","west","weca","PM","FF","Ninp")

Catch<-read.table(file.path(data.path,"mcout_C.out"),header=T)

N<-read.table(file.path(data.path,"mcout_N.out"),header=T)
CN<-merge(Catch,N)

all<-merge(CN,a)
all<-subset(all,select=c(Age, Year, C,N,west,weca,PM),Year<=2012)
all$SSB<-all$N*all$west*all$PM
all$Yield<-all$C*all$weca
all$Ages<-paste("Age",all$Age)
head(all)
write.table(all,file=file.path(data.path,'Yield_SSB_at_age.csv'),row.names=F,col.names=T,sep=',')

cleanup()
 newplot(dev='screen',2,2)

by(all,list(all$Year),function(x)
 pie(x$SSB,labels=x$Ages,main=paste('SSB',x[1,'Year']),radius = 1)
)

by(all,list(all$Year),function(x)
 pie(x$Yield,labels=x$Ages,main=paste('Yield',x[1,'Year']),radius = 1)
)


# -------------------------------------------------------------------------------
# Geostats model via R-INLA
#
# Rscript --vanilla model.R -i perc_hh_no_water_supply -a bogot_dc
#
# input: satellite features tif files, cropped prediction area tif file
# output: tif file of predictions on out of sample area
# ran on Windows 10, R v4.0.2, 8cpu GCE VM
# takes 10 minutes in predicting over a 66x67 pixel grid
# -------------------------------------------------------------------------------

# install.packages('rgdal')
# install.packages('geoR')
# install.packages('sp')
# install.packages('foreach')
# install.packages('shiny')
# install.packages("INLA", repos = "https://inla.r-inla-download.org/R/stable", dep = TRUE)
# install.packages('optparse')
# install.packages('tidyverse')
# install.packages('raster')

library(optparse)
library(tidyverse)
library(dplyr)
library(geoR)
library(sp)
library(rgdal)
library(raster)
library(INLA)
library(purrr)

work_dir = 'C:/Users/cholo/Downloads/'
setwd(work_dir)
data_dir = paste0(work_dir, 'geoai-immap-wash/data/')#'../data/'
feats_dir = paste0(data_dir, 'features/')

# gsutil cp gs://immap-wash-training/20200811_dataset.csv .
# gsutil cp gs://immap-wash-training/features/2018_colombia_*.tif data/features/

# parser
option_list = list(
  make_option(c("-i", "--indicator"), type="character", default="perc_hh_no_water_supply",
              help="indicator to model", metavar="character"),
	make_option(c("-a", "--area"), type="character", default="bogot_dc",
              help="area to hold out", metavar="character")
);
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
indicator = opt$indicator;
area = opt$area;

merged = paste0(area,'.tif');#'2018_colombia_merged_satellite_features_v2.tif';
inds_file = '20200811_dataset.csv'
features = c(
  'vegetation',
  'aridity_cgiarv2',
  'temperature',
  'nighttime_lights',
  'population',
  'elevation',
  'urban_index'
)
test_areas = c(
  'bogot_dc',
  'norte_de_santander',
  'la_guajira',
  'nario'
)
count_vars = c(
  perc_hh_no_toilet = 'd_c_sanita',
  perc_hh_no_water_supply = 'd_c_acuedu',
  perc_hh_no_sewage = 'd_c_alcant'
)

robustscaler_sklearn <- function(df){
    for (f in features){
        row = filter(stats, feature == f)
        df[[f]] = (df[[f]] - row$median)/(row$p75 - row$p25)
    }
    return(df)
}

now <- function(){
  return(format(Sys.time(), "%Y-%m-%d %H:%M:%S"))
}

read_ <- function(){
    print(paste0(now(),' Reading data'))
    # read indicators df, excluding test area
    count_var = count_vars[[indicator]]
    cols = c('x', 'y', count_var, 'd_hogares')
    d = read.csv(paste0(data_dir,inds_file), stringsAsFactors = F) %>%
        filter(adm1_name != area) %>%
        dplyr::select(all_of(cols)) %>%
        dplyr::rename(positive = all_of(count_var), total = 'd_hogares') %>%
        dplyr::mutate(prev = positive / total) %>%
        dplyr::arrange(x)

    print(dim(d))

    # read feature raster values of indicator labelled grid
    for (f in features){
        fname = paste0(feats_dir,'2018_colombia_',f,'.tif')
        r <- raster(fname)
        d[[f]] <- raster::extract(r, d[, c("x", "y")])
    }
    d = d[complete.cases(d),]
    print(dim(d))

    # get stats from training data
    df = data.frame()
    for (f in features){
        qs = quantile(d[[f]],c(0.25, 0.75))
        df_ = data.frame(
            feature = f,
            median = median(d[[f]]),
            p25 = qs[1],
            p75 = qs[2],
            mad = mad(d[[f]])
        )
        df = rbind(df, df_)
    }
    stats <<- df

    # read data to predict on
    fname = paste0(feats_dir,merged)
    r <- stack(fname)
    dp = data.frame(rasterToPoints(r))
    dp = dp[complete.cases(dp),]
    colnames(dp) = append(c('x', 'y'), features) # rename columns

    d <<- robustscaler_sklearn(d)
    dp <<- robustscaler_sklearn(dp)
    return(r)
}

stack_ <- function(d, dp) {
    print(paste0(now(),' Stacking and making meshes'))
    # affects how many traingles are made inside the mesh, increased by x10 to reduce triangles
    coo <<- cbind(d$x, d$y)
    mesh <<- inla.mesh.2d(
        loc = coo, max.edge = c(1, 50),
        cutoff = 0.1
        #   loc = coo, max.edge = c(0.1, 5),
        #   cutoff = 0.01
    )

    # sense checks
    # mesh$n
    # plot(mesh)
    # points(coo, col = "red")

    spde <<- inla.spde2.matern(mesh = mesh, alpha = 2, constr = TRUE)

    indexs <<- inla.spde.make.index("s", spde$n.spde)
    lengths(indexs)

    A <<- inla.spde.make.A(mesh = mesh, loc = coo)

    coop <<- cbind(dp$x, dp$y)

    Ap <<- inla.spde.make.A(mesh = mesh, loc = coop)

    df_e = data.frame(
        b0 = 1,
        vegetation = d$vegetation,
        aridity_cgiarv2 = d$aridity_cgiarv2,
        temperature = d$temperature,
        nighttime_lights = d$nighttime_lights,
        population = d$population,
        elevation = d$elevation,
        urban_index = d$urban_index
    )
    df_p = data.frame(
        b0 = 1,
        vegetation = dp$vegetation,
        aridity_cgiarv2 = dp$aridity_cgiarv2,
        temperature = dp$temperature,
        nighttime_lights = dp$nighttime_lights,
        population = dp$population,
        elevation = dp$elevation,
        urban_index = dp$urban_index
    )

    stk.e <- inla.stack(
    tag = "est",
    data = list(y = d$positive, numtrials = d$total),
    A = list(1, A),
    effects = list(df_e, s = indexs)
    )

    stk.p <- inla.stack(
    tag = "pred",
    data = list(y = NA, numtrials = NA),
    A = list(1, Ap),
    effects = list(df_p, s = indexs)
    )

    stk.full <<- inla.stack(stk.e, stk.p)

}

fit_ <- function(
    subset = FALSE,
    theta0 = NULL,
    x0 = NULL
){
    print(paste0(now(),' Fitting INLA model'))
    if (subset == TRUE) {
        control_mode_list = list();
        control_compute_list = list();
    } else {
        control_mode_list = list(theta = theta0, x = x0);
        control_compute_list = list(openmp.strategy="huge");
        # control_compute_list = list();
    }

    formula <- (
    y ~ 0 + b0 +
        vegetation +
        aridity_cgiarv2 +
        temperature +
        nighttime_lights +
        population +
        elevation +
        urban_index +
        f(s, model = spde)
    )

    # 17 minutes predicting on bogota
    res <- inla(formula,
                family = "binomial", Ntrials = numtrials,
                control.family = list(link = "logit"),
                data = inla.stack.data(stk.full),
                control.predictor = list(
                compute = TRUE, link = 1,
                A = inla.stack.A(stk.full)
                )
                , control.mode = control_mode_list
                , control.compute = control_compute_list
                # , verbose = TRUE
    )
    return(res)
}

predict_ <- function(res, r){
    print(paste0(now(),' Predicting using fitted INLA model'))

    ## 9.4 Mapping malaria prevalence

    index <- inla.stack.index(stack = stk.full, tag = "pred")$data

    prev_mean <- res$summary.fitted.values[index, "mean"]
    prev_ll <- res$summary.fitted.values[index, "0.025quant"]
    prev_ul <- res$summary.fitted.values[index, "0.975quant"]

    r_prev_mean <- rasterize(
        x = coop, y = r, field = prev_mean,
        fun = mean
    )

    rf <- writeRaster(r_prev_mean, filename=paste0("preds_", indicator, "_", area, ".tif"), format="GTiff", overwrite=TRUE)

    # output coefficients to a text file
    out <- capture.output(summary(res))
    cat("Model results", out, file=paste0("model_summary_",indicator,"_",area,".txt"), sep="\n", append=TRUE)
}

main_ <- function() {
    print(paste0('Processing ',indicator,' for ',area))
    r = read_()

    # subset to get initial params
    set.seed(42)
    n_samples = round(dim(d)[1]*0.1)
    sub = d[sample(nrow(d), n_samples), ]
    subp = dp[0:5,]

    stack_(sub, subp)
    res0 = fit_(subset = TRUE)
    theta0 = res0$mode$theta
    x0 = res0$mode$x
    print(paste0(now(),' Fitting to subset done.'))

    stack_(d, dp)
    res = fit_(subset = FALSE)
    predict_(res, r)
}

main_()


plot.correlogI <- function(x, expected = TRUE, label.dist = FALSE, significance = TRUE, line.alpha = TRUE, line.alpha.bonf = TRUE, ci = TRUE, ...){

  dots <- list(...)

  if(!"main" %in% names(dots)) dots$main <- "Correlogram"
  if(!"xlab" %in% names(dots)) dots$xlab <- "Distance class"

  if(label.dist == TRUE) dcl <- round(x$result$distMax, 2)
  else dcl <- x$result$class

  do.call(plot, c(list(x = dcl, y = x$result$I,
                       ylim = c(-1, 1), xlim = c(-0.2, 0.2) + range(dcl),
                       type = "n", bty = "n", xaxt = "n",
                       ylab = "Moran's I"), dots))
  axis(side = 1, at = dcl, labels = dcl)

  if(expected == TRUE) abline(h = x$EI, col = "black", lty = 2)

  if(x$tail == "two" | x$tail == "upper"){
    if(line.alpha == TRUE) lines(x = dcl, y = x$result$Ia.up, col = "red")
    if(x$seq.bonferroni == TRUE & line.alpha.bonf == TRUE) lines(x = dcl, y = x$result$Ia.up.bonf, col = "red", lty = 2)
  }

  if(x$tail == "two" | x$tail == "lower"){
    if(line.alpha == TRUE) lines(x = dcl, y = x$result$Ia.lo, col = "red")
    if(x$seq.bonferroni == TRUE & line.alpha.bonf == TRUE) lines(x = dcl, y = x$result$Ia.lo.bonf, col = "red", lty = 2)
  }

  if(significance == TRUE) points(x = dcl, y = x$result$I, pch=(15 * as.numeric(x$result["."] == "*")))
  else points(x = dcl, y = x$result$I, pch=0)

  if(ci == TRUE){
    arrows(x0 = dcl,
           x1 = dcl,
           y0 = x$result$I,
           y1 = x$result$I + qnorm(x$alpha) * sqrt(x$result$varI),
           length = 0.07, angle = 90)
    arrows(x0 = dcl,
           x1 = dcl,
           y0 = x$result$I,
           y1 = x$result$I - qnorm(x$alpha) * sqrt(x$result$varI),
           length = 0.07, angle = 90)
  }
}


\name{plot_contribution}
\alias{plot_contribution}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Plotting contributions calculated from the observed data and contributions calculated from simulated data
}
\description{
  This function extracts from a \code{Simulated_Data_From_Fitted_Model} object contributions of rich-get-richer and fit-get-richer effects calculated using simulated networks and plots these contributions versus the contributions calculated from the original observed network. See \code{\link{joint_estimate}} for a description of how the contributions are calculated.
}
\usage{
plot_contribution(simulated_object,
                  original_result,
                  which_plot = "PA",
                  y_label = ifelse("PA" == which_plot,
                  "Contribution of the rich-get-richer effect",
                  "Contribution of the fit-get-richer effect"),
                  legend_pos_x = 0.75,
                  legend_pos_y = 0.9)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{simulated_object}{
    an object of class \code{Simulated_Data_From_Fitted_Model} that contains simulated data.
  }
   \item{original_result}{
    an object of class \code{Full_PAFit_result} that contains the estimation results from the original observed data.
  }
  \item{which_plot}{
    String. ``PA": plots contributions of rich-get-richer effect, ``fit": plots contribution of fit-get-richer effect. Default is ``PA".
  }
   \item{y_label}{
   String. The label for y-axis. Default is "Contribution of rich-get-richer effect".
  }
\item{legend_pos_x}{Numeric. The horizontal position, between (0,1), of the legend. Default value is \code{0.75}.}
\item{legend_pos_y}{Numeric. The vertical position, between (0,1), of the legend. Default value is \code{0.9}.}
}

\value{
 Output a plot.
}

\author{
  Thong Pham \email{thongphamthe@gmail.com}
}
\references{
  1. Pham, T., Sheridan, P. & Shimodaira, H. (2015). PAFit: A Statistical Method for Measuring Preferential Attachment in Temporal Complex Networks. PLoS ONE 10(9): e0137796. (\doi{10.1371/journal.pone.0137796}).

  2. Pham, T., Sheridan, P. & Shimodaira, H. (2016). Joint Estimation of Preferential Attachment and Node Fitness in Growing Complex Networks. Scientific Reports 6, Article number: 32558. (\doi{10.1038/srep32558}).

 3. Pham, T., Sheridan, P. & Shimodaira, H. (2020). PAFit: An R Package for the Non-Parametric Estimation of Preferential Attachment and Node Fitness in Temporal Complex Networks. Journal of Statistical Software 92 (3). (\doi{10.18637/jss.v092.i03}).

4. Inoue, M., Pham, T. & Shimodaira, H. (2020). Joint Estimation of Non-parametric Transitivity and Preferential Attachment Functions in Scientific Co-authorship Networks. Journal of Informetrics 14(3). (\doi{10.1016/j.joi.2020.101042}).
}
\seealso{
 \code{\link{joint_estimate}}, \code{\link{plot_contribution}}
}

\examples{
\dontrun{

  library("PAFit")
  net_object     <- generate_net(N = 500, m = 10, s = 10, alpha = 0.5)
  net_stat       <- get_statistics(net_object)
  result         <- joint_estimate(net_object, net_stat)
  simulated_data <- generate_simulated_data_from_estimated_model(net_object, net_stat, result)
  plot_contribution(simulated_data, result, which_plot = "PA")
  plot_contribution(simulated_data, result, which_plot = "fit")
  }
}

\concept{preferential attachment}
\concept{attachment function}
\concept{fitness}


REBOL
[
    title: "Code to implement printf natively"
]

dbg: [ here: ( print here ) ]

format: func [
    fmt [string!] {Format to print}
    data [ block!] {Block of data to put into fmt}
    /local
	;o
][
    o: context [
	str: copy ""
	char: none

	val: fills: none

	fillchar: #" "
	align-char: none
	n-space: 0
	n-fracts: 6
	fmt-char: none

	digit: charset [ #"0" - #"9" ]

	data-pattern: [
	    ( align-char: fillchar: signchar: none )
	    #"%"
	    opt [
		[ copy align-char #"-" ]
		|
		[ copy fillchar #"0"   ]
		| copy signchar #"+"
	    ]
	    copy n-space any digit
	    opt [
		#"." copy n-fracts any digit
		]
	    copy fmt-char [
		#"f"
		| #"g"
		| #"e"
		| #"E"
		| #"d"
		| #"i"
		| #"s"
	    ]
	    (
		n-space: to-integer any [ n-space 0 ]
		n-fracts: to-integer any [ n-fracts 6 ]

		val: first+ data
		unless val [
		    make error! "Not enough data to print, number of specifiers larger than data"
		]

		val: switch fmt-char [
		    "s"		[ to-string val ]
		    "d" "i"	[ num-to-string-d abs val ]
		    "f"		[ num-to-string-f abs val n-fracts ]
		    "e" "E"	[ num-to-string-e abs val n-fracts fmt-char  ]
		]

		fills: max 0 n-space - length? val
		either align-char == #"+" [
		    insert/dup tail str fillchar  fills
		    append str val
		][
		    append str val
		    insert/dup tail str fillchar  fills
		]
	    )
	]

	pattern: [
	    any [ data-pattern | copy char skip ( append str char ) ]
	]

	num-to-string-d: func [ num [ integer! ] /local str ] [
	    str: copy ""

	    unless num >= 0 [
		append str "-"
		str: next str
		num: negate num
	    ]
	    until [
		frac: mod num 10
		insert str  round/floor frac
		num: num - frac
		num: num / 10
		num < 1.0
	    ]
	    head str
	]

	num-to-string-f: func [ num n-fracts /local str ][
	    str: copy ""

	    unless num >= 0 [
		append str "-"
		str: next str
		num: negate num
	    ]

	    num: num * ( 10.0 ** n-fracts )
	    loop n-fracts [
		frac: mod num 10
		insert str  round/half-ceiling frac
		num: num - frac
		num: num / 10
	    ]
	    insert str #"."
	    until [
		frac: mod num 10
		insert str  round/floor frac
		num: num - frac
		num: num / 10
		num < 1.0
	    ]
	    head str
	]
	num-to-string-e: func [
	    num n-fracts modifier
	    /local str  n
	] [
	    str: copy ""
	    n: round/floor log-10 abs num
	    num: num / (10.0 ** n )
	    str: num-to-string-f num  n-fracts
	    append str modifier
	    append str n-fracts
	]

	parse/all/case fmt pattern
    ]

    return o/str
]

test-base: func [ fmt dta] [
    prin my: format fmt dta
    prin std: sprintf join [ fmt ] dta
    either my == std [
	print "-- OK"
    ][
	print "--  Fault"
    ]
]
test-string: does [
    fmt: "<%s> <%10s>  <%-10s>  <%010s> ---"
    dta: ["a" "b" "c" "d"]
    test-base fmt dta
]

test-f: does [
    fmt: "%f %10f %-10f %4.2f %-10.3f %3.8f ---"
    dta: reduce [ pi pi pi pi pi  pi]
    test-base fmt dta
]
test-e: does [
    fmt: "%E %10e %-10E %4.2E %-10.3e %3.8E ---"
    dta: reduce [ pi pi pi pi pi  pi]
    test-base fmt dta
]

test-d: does [
    fmt: "%d  %10d  %-10d %2d^/"
    dta: reduce [ random 1000 random 1000 random 10000  3 ]
    test-base fmt dta
]

test-string
test-f
test-e
test-d


# Load EISMINT1 data
load_eismint1_moving = function(fldr)
{
    xHt1 = read.table(file.path(fldr,"EISMINT1-moving_x-H_type1.txt"),header=TRUE)
    xHt2 = read.table(file.path(fldr,"EISMINT1-moving_x-H_type2.txt"),header=TRUE)
    xHe  = read.table(file.path(fldr,"EISMINT1-moving_x-H_exactmargin.txt"),header=TRUE)

    xuxy      = read.table(file.path(fldr,"EISMINT1-moving_x-uxy_mean.txt"),header=TRUE)
    xtprime   = read.table(file.path(fldr,"EISMINT1-moving_x-T_prime_base.txt"),header=TRUE)
    tprime    = read.table(file.path(fldr,"EISMINT1-moving_divide_T_prime.txt"),header=TRUE)
    uz        = read.table(file.path(fldr,"EISMINT1-moving_divide_uz.txt"),header=TRUE)

    eis1 = list(x=seq(0,750,by=10),s=seq(0,1,by=0.05))

    # Variables versus distance from divide x
    eis1$Ht1          = approx(x=xHt1$x,y=xHt1$H,       xout=eis1$x,rule=2)$y
    eis1$Ht2          = approx(x=xHt2$x,y=xHt2$H,       xout=eis1$x,rule=2)$y
    eis1$He           = approx(x=xHe$x, y=xHe$H,        xout=eis1$x,rule=2)$y
    eis1$uxy_mean     = approx(x=xuxy$x,y=xuxy$uxy_mean,xout=eis1$x,rule=2)$y
    eis1$T_prime_base = approx(x=xtprime$x,y=xtprime$T_prime_base,xout=eis1$x,rule=2)$y

    # Variables at divide versus normalized ice thickness sigma
    eis1$T_prime      = approx(x=tprime$sigma,y=tprime$T_prime,xout=eis1$s,rule=2)$y
    eis1$uz           = approx(x=uz$sigma,    y=uz$uz,         xout=eis1$s,rule=2)$y

    return(eis1)
}

load_eismint1_fixed = function(fldr)
{
    xHt1 = read.table(file.path(fldr,"EISMINT1-fixed_x-H_type1.txt"),header=TRUE)
    xHt2 = read.table(file.path(fldr,"EISMINT1-fixed_x-H_type2.txt"),header=TRUE)

    xuxy    = read.table(file.path(fldr,"EISMINT1-fixed_x-uxy_mean_3D.txt"),header=TRUE)
    # xtprime = read.table(file.path(fldr,"EISMINT1-fixed_x-T_prime_base.txt"),header=TRUE)

    eis1 = data.frame(x=seq(0,750,by=10))
    eis1$Ht1          = approx(x=xHt1$x,y=xHt1$H,       xout=eis1$x,rule=2)$y
    eis1$Ht2          = approx(x=xHt2$x,y=xHt2$H,       xout=eis1$x,rule=2)$y
    eis1$uxy_mean     = approx(x=xuxy$x,y=xuxy$uxy_mean,xout=eis1$x,rule=2)$y
    # eis1$T_prime_base = approx(x=xtprime$x,y=xtprime$T_prime_base,xout=eis1$x,rule=2)$y

    return(eis1)
}

# Check data
if (FALSE) {

    eis1m = load_eismint1_moving("./EISMINT1-moving/")
    eis1f = load_eismint1_fixed("./EISMINT1-fixed/")

    eis1 = eis1f

    xlim = c(0,750)
    ylim = c(0,4000)

    plot(xlim,ylim,type="n",ann=FALSE,axes=FALSE)
    axis(1)
    axis(2)
    mtext(side=1,line=2.5,las=0,"Distance from divide [km]")
    mtext(side=2,line=2.5,las=0,"Ice thickness [m]")
    grid()

    lines(eis1$x,eis1$Ht1,col=1,lwd=2,lty=1)
    lines(eis1$x,eis1$Ht2,col=1,lwd=2,lty=2)
    # lines(eis1$x,eis1$He, col=1,lwd=2,lty=3)

    legend("bottomleft",inset=0.02,bty="n",col=c(1,1,1),lwd=c(2,2,2),lty=c(1,2,3),c("type I","type II","exact"))

    box()

}


a <- as.double(readline(prompt = "Enter a:"))

i <- 1

while (i <= 10) {
  print(i * a)
  i <- i + 1
}


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(pracma)
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)

dat = read_csv('./data/dataset.csv') %>%
  group_by(subset, label, id, person, dimension) %>%
  mutate(
    velocity = cumtrapz(time, acceleration),
    position = cumtrapz(time, velocity)
  )

dat.plot = dat %>%
  gather("metric", "value", acceleration, velocity, position)

p = ggplot(dat.plot, aes(y = value, x = time, group = as.factor(id), colour=person)) +
  geom_hline(yintercept=0) +
  geom_line(alpha=0.1) +
  facet_grid(metric + dimension ~ label) +
  xlim(0, 2) +
  ylim(-100, 100) +
  guides(colour = guide_legend(override.aes = list(alpha = 1)))
print(p)


model_shootnumber <- function (canopyShootNumber_t1 = 288.0,
         leafNumber = 3.34,
         sowingDensity = 288.0,
         targetFertileShoot = 600.0,
         tilleringProfile_t1 = c(288.0),
         leafTillerNumberArray_t1 = c(1, 1, 1),
         numberTillerCohort_t1 = 1){
    #'- Name: ShootNumber -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: CalculateShootNumber Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: calculate the shoot number and update the related variables if needed
    #'- inputs:
    #'            * name: canopyShootNumber_t1
    #'                          ** description : shoot number for the whole canopy
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 288.0
    #'                          ** unit : shoot m-2
    #'                          ** inputtype : variable
    #'            * name: leafNumber
    #'                          ** description : Leaf number
    #'                          ** variablecategory : state
    #'                          ** inputtype : variable
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 3.34
    #'                          ** unit : leaf
    #'            * name: sowingDensity
    #'                          ** description : number of plant /m²
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 500
    #'                          ** default : 288.0
    #'                          ** unit : plant m-2
    #'                          ** inputtype : parameter
    #'            * name: targetFertileShoot
    #'                          ** description : max value of shoot number for the canopy
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 280
    #'                          ** max : 1000
    #'                          ** default : 600.0
    #'                          ** unit : shoot
    #'                          ** inputtype : variable
    #'            * name: tilleringProfile_t1
    #'                          ** description :  store the amount of new tiller created at each time a new tiller appears
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [288.0]
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: leafTillerNumberArray_t1
    #'                          ** description : store the number of tiller for each leaf layer
    #'                          ** variablecategory : state
    #'                          ** datatype : INTLIST
    #'                          ** unit : leaf
    #'                          ** default : [1, 1, 1]
    #'                          ** inputtype : variable
    #'            * name: numberTillerCohort_t1
    #'                          ** description :  Number of tiller which appears
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: averageShootNumberPerPlant
    #'                          ** description : average shoot number per plant in the canopy
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : shoot m-2
    #'            * name: canopyShootNumber
    #'                          ** description : shoot number for the whole canopy
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : shoot m-2
    #'            * name: leafTillerNumberArray
    #'                          ** description : store the number of tiller for each leaf layer
    #'                          ** variablecategory : state
    #'                          ** datatype : INTLIST
    #'                          ** unit : leaf
    #'            * name: tilleringProfile
    #'                          ** description :  store the amount of new tiller created at each time a new tiller appears
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit : dimensionless
    #'            * name: numberTillerCohort
    #'                          ** description : Number of tiller which appears
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : dimensionless
    leafTillerNumberArray <- vector()
    tilleringProfile <- vector()
    lNumberArray_rate <- vector()
    emergedLeaves <- max(1, ceiling(leafNumber - 1.0))
    shoots <- fibonacci(emergedLeaves)
    canopyShootNumber <- min(shoots * sowingDensity, targetFertileShoot)
    averageShootNumberPerPlant <- canopyShootNumber / sowingDensity
    if (canopyShootNumber != canopyShootNumber_t1)
    {
        tilleringProfile <- c(tilleringProfile_t1, canopyShootNumber - canopyShootNumber_t1)
    }
    numberTillerCohort <- length(tilleringProfile)
    for( i in seq(length(leafTillerNumberArray_t1), ceiling(leafNumber)-1, 1)){
        lNumberArray_rate <- c(lNumberArray_rate, numberTillerCohort)
    }
    leafTillerNumberArray <- c(leafTillerNumberArray_t1, lNumberArray_rate)
    return (list ("averageShootNumberPerPlant" = averageShootNumberPerPlant,"canopyShootNumber" = canopyShootNumber,"leafTillerNumberArray" = leafTillerNumberArray,"tilleringProfile" = tilleringProfile,"numberTillerCohort" = numberTillerCohort))
}

fibonacci <- function (n){
    if (n <= 1)
    {
        return( n)
    }
    else
    {
        return( fibonacci(n - 1) + fibonacci(n - 2))
    }
}

init_shootnumber <- function (sowingDensity = 288.0,
         targetFertileShoot = 600.0){
    tilleringProfile_t1 <- vector()
    leafTillerNumberArray_t1 <- vector()
    leafTillerNumberArray <- vector()
    tilleringProfile <- vector()
    canopyShootNumber <- sowingDensity
    averageShootNumberPerPlant <- 1.0
    tilleringProfile <- c(tilleringProfile, sowingDensity)
    numberTillerCohort <- 1
    leafTillerNumberArray <- vector()
    return (list ("averageShootNumberPerPlant" = averageShootNumberPerPlant,"canopyShootNumber" = canopyShootNumber,"leafTillerNumberArray" = leafTillerNumberArray,"tilleringProfile" = tilleringProfile,"numberTillerCohort" = numberTillerCohort))
}


#' @export
define_longitudinal_measurement_invariance_model = function(df, model_strength = "CONFIGURAL", unconstrained_parcel_indices = c()){
  is_weak <- model_strength == "WEAK"
  is_strong <- model_strength == "STRONG" || model_strength == "PARTIAL_STRONG"
  is_strict <- model_strength == "STRICT"
  constrain_all_means_to_zero <- model_strength == "CONFIGURAL"
  paste0(
    "# Define factors\n\n",
    define_factors(df, is_weak || is_strong || is_strict),
    "\n\n# Intercepts\n",
    define_intercepts(df, is_strong || is_strict, unconstrained_parcel_indices),
    "\n\n# Unique variances and covariances\n",
    define_variances(df, is_strict),
    "\n\n",
    define_covariances(df),
    "\n\n# Latent variable means\n",
    define_latent_variable_means(df, constrain_all_means_to_zero),
    "\n\n# Latent variable variances and covariances\n",
    define_latent_variable_variances(df),
    "\n\n",
    define_latent_variable_covariances(df)
  )
}


## Generate Raster Riles

slippyRaster=function(rst,zoom=c(3,9),output,col=rev(terrain.colors(255)),browse=TRUE){

  if(is.na(proj4string(rst))){
    proj4string(rst)=crs.geo
  }
  rst=projectRaster(rst,crs=CRS(proj_fos))

  ee=extent(rst)
  xmin=ee@xmin
  xmax=ee@xmax
  ymin=ee@ymin
  ymax=ee@ymax

  tile_list=bounding_tiles(xmin,xmax,ymin,ymax,zoom)

  zs=unique(tile_list$z)

  if(!file.exists(output)){
    dir.create(output)
  }

  if(!file.exists(paste0(output,"/tiles"))){
    dir.create(paste0(output,"/tiles"))
  }

  for(idx in zoom[1]:zoom[2]){
    this_root=paste0(output,"/tiles/",idx)
    if(!file.exists(this_root)){
      dir.create(this_root)
    }
    ux=unique(subset(tile_list,tile_list$z==idx)$x)
    for(udx in ux){
      this_node=paste0(this_root,"/",udx)
      if(!file.exists(this_node)){
        dir.create(this_node)
      }
    }
  }

  for(idx in seq_along(tile_list$x)){

    tlen=length(tile_list$x)
    pb=txtProgressBar(min=1,max=tlen,initial=1,style=3)
    setTxtProgressBar(pb,idx)
    eo=tile_square(tile_list$x[idx],tile_list$y[idx],tile_list$z[idx])

    png(paste0(output,"/tiles/",tile_list$z[idx],"/",tile_list$x[idx],"/",tile_list$y[idx],".png"),width=256,height=256,bg="#FFFFFF00")
    par(mai=c(0,0,0,0),mar=c(0,0,0,0),bty="n",xaxt="n",yaxt="n")
    image(rst,xlim=c(eo[3],eo[4]),ylim=c(eo[1],eo[2]),bg="#FFFFFF88",col=col)
    dev.off()
  }

    h_tem=file("data/template.html")
    h_lines=readLines(h_tem)
    midpt_x=mean(xmin,xmax)
    midpt_y=mean(ymin,ymax)
    minzm=min(zoom)
    maxzm=max(zoom)
    c_line=paste0("      var mytile =L.tileLayer('file:tiles/{z}/{x}/{y}.png',{")
    h_lines[63]=c_line
    m_line=paste0("        maxZoom: ",maxzm,",")
    h_lines[64]=m_line
    p_line=paste0("      var map = L.map('map').setView([",midpt_y,",",midpt_x,"], ",minzm,");")
    h_lines[57]=p_line
    o_file=paste0(output,"/index.html")
    o_file=file(o_file)
    writeLines(h_lines,o_file)
    close(o_file)
    close(h_tem)

  if(browse==TRUE){
    browseURL(paste0(output,"/index.html"))
  }
  paste0(output,"/index.html")
}


# function to plot estimation results  2015-3-12 Thong Pham
plot.PAFit_result <-
function(x                       ,
         net_stat                ,
         true_f         = NULL   , plot             = "A"              , plot_bin     = TRUE  ,
         line           = FALSE  , confidence       = TRUE             , high_deg_A   = 1     ,
         high_deg_f     = 5      ,
         shade_point    = 0.5    , col_point        = "grey25"         , pch          = 16    ,
         shade_interval = 0.5    , col_interval     = "lightsteelblue" ,
         label_x        = NULL   , label_y          = NULL             ,
         max_A          = NULL   , min_A            = NULL             , f_min        = NULL  ,
         f_max          = NULL   , plot_true_degree = FALSE            ,
         ...) {
  if (plot_bin == TRUE) {
      x$k       <- x$center_k
      x$A       <- x$theta
      x$upper_A <- x$upper_bin
      x$lower_A <- x$lower_bin
      x$var_logA <- x$var_logbin
  }
  dots <- function(...) {
      list(...)
  }

  additional_para <- dots(...)
  #print(additional_para)

  gg_color_hue = function( n ) {
    hues = seq( 15 , 375 , length = n + 1 )
    hcl( h = hues , l = 65 , c = 100 )[ 1 : n ]
  }
  cols = c( "grey25" , gg_color_hue( n = 3 ) )
  gray25 = cols[ 1 ]; red = cols[ 2 ]; green = cols[ 3 ]; blue = cols[ 4 ]

  if ("A" == plot[1]) {
      if (!is.null(high_deg_A))
          non_zero <- which(x$A > 10^-20 & x$k >= high_deg_A & x$k > 0)
      else
          non_zero <- which(x$A > 10^-20 & x$k >= x$deg_threshold & x$k > 0)

      if (!is.null(high_deg_A)) {
          v                   <- which(x$k[non_zero] == high_deg_A)
          if (length(v) > 0) {
              new_var_log         <- x$var_logA[non_zero] #* (x$A[non_zero][v[1]]) ^ 2;
              x$A[non_zero]       <- x$A[non_zero] / x$A[non_zero][v[1]];
              #print(x$var_logA[non_zero])
              #print(non_zero)
              #print(v)
              x$lower_A[non_zero] <- exp(log(x$A[non_zero]) - 2 * sqrt(new_var_log));
              x$upper_A[non_zero] <- exp(log(x$A[non_zero]) + 2 * sqrt(new_var_log));
              non_zero            <- x$A > 10^-20 & x$k >= high_deg_A &
                                   (!is.na(x$upper_A)) & (!is.infinite(x$upper_A))
          }
      }
     if ((!is.null(max_A)) && (!is.null(min_A)))
          limit <- c(min(min_A,x$lower_A[non_zero]) , max(max_A,x$upper_A[non_zero]))
      else if (!is.null(min_A)) {
          limit <- c(min(min_A,x$lower_A[non_zero]) , max(x$upper_A[non_zero]))
      }
      else if (!is.null(max_A)) {
          limit <- c(min(x$lower_A[non_zero]) , max(max_A,x$upper_A[non_zero]))
      }
      else {
          limit <- c(min(x$lower_A[non_zero]) , max(x$upper_A[non_zero]))
      }

      if (is.null(additional_para$ylim))
        ylim <- limit
      else ylim <- additional_para$ylim

      if (is.null(additional_para$xlim))
          xlim <- c(min(x$k[non_zero]) , max(x$k[non_zero]))
      else xlim <- additional_para$xlim
      #print(xlim)

      temp   <- names(additional_para)
      ok_vec <- which(temp != "xlim" & temp != "ylim")
      #print(additional_para)
      additional_para_list <- ""
      for (i in ok_vec) {
          if (!is.character(additional_para[[i]]))  {
              additional_para_list <- paste0(additional_para_list ,temp[i]," = ",additional_para[[i]],",");
          } else  additional_para_list <- paste0(additional_para_list ,temp[i]," = '",additional_para[[i]],"',")
      }
      final_para <- substr(additional_para_list,1,nchar(additional_para_list) - 1)
      #print(final_para)
      col_pa <- as.vector(col2rgb(col_point)) / 255

      eval(parse(text = paste('plot(x$k[non_zero][1], x$A[non_zero][1] , xlab = ifelse(!is.null(label_x),label_x, "Degree k"),
           ylab = ifelse(!is.null(label_y) , label_y,"Attachment function"),
           xlim = xlim , ylim = ylim , axes = FALSE, log = "xy" ,
           col = rgb(col_pa[1],col_pa[2],col_pa[3], shade_point),
           mgp = c( 2.5 , 1 , 0 ),
           type = "n",', final_para, ')')))
      #magaxis(grid = TRUE, frame.plot = TRUE)
      eval(parse(text = paste('magaxis(grid = FALSE, frame.plot = TRUE,',final_para,')')));
      #xtick = seq(from = xlim[1], to = xlim[2],5)
      #axis(side = 1, at = xtick, labels = NULL, xlim = xlim, log = "x")
      if (TRUE == confidence) {
        order    <- order(x$k[non_zero])
        upper_f  <- x$upper_A[non_zero][order]
        lower_f  <- x$lower_A[non_zero][order]
        unique_x <- unique((x$k[non_zero])[order])
        upper_u  <- rep(0,length(unique_x))
        lower_u  <- upper_u
        for (jjj in 1:length(unique_x)) {
          uu           <- which((x$k[non_zero])[order] == unique_x[jjj])
          #print(uu)
          upper_u[jjj] <- max(upper_f[uu])
          lower_u[jjj] <- min(lower_f[uu])
        }
        my_col <- as.vector(col2rgb(col_interval))
        my_col <- my_col / 255
        polygon(c(unique_x,rev(unique_x)) , c(upper_u,rev(lower_u)) , col = rgb(my_col[1],my_col[2],my_col[3],shade_interval),border = NA)
        #arrows(x0 = x$k[non_zero] + 1, y0 = x$lower_A[non_zero],
        #       x1 = x$k[non_zero] + 1, y1 = x$upper_A[non_zero], code = 3,angle = 90,
        #       length = 0,
        #       col = rgb(0,0,0,shade_interval))
      }
      points(x$k[non_zero], x$A[non_zero] , pch = pch, col = rgb(col_pa[1],col_pa[2],col_pa[3], shade_point),...)
      if (TRUE == line) {
          alpha <- x$alpha
          #if (!is.null(names(x$loglinear_fit)))
          #    beta <-  x$loglinear_fit$coefficients[1]
          #else {
              index_one <- which(x$A[non_zero] == 1 & x$k[non_zero] != 0)[1]
              beta      <- -alpha* log(x$k[non_zero][index_one])
              #print(beta)
          #}
          lines(x$k[non_zero], exp(beta) * (x$k[non_zero]) ^ alpha, lwd = 2, col = blue)

          #lines(c(1,x$k[non_zero] + 1),c(x$PA_offset , exp(beta) * (x$k[non_zero]) ^ alpha), lwd = 2, col = green)
      }

  }
  else if ("f" == plot[1]) {

      non_zero <- x$lower_f > 10^-20 & net_stat$increase > 0
      if (length(non_zero) <= 0)
        stop("There is no data. Please decrease high_deg")
      # Plot the density of node fitnesses

      f_non <- x$f[non_zero]
      d     <- density(f_non)
      ok_d  <- d$x > 0
      max_x <- max(d$x[ok_d])
      min_x <- min(d$x[ok_d])

      #layout(cbind(1,2), width = c(4,1))
      plot(d$x[ok_d] , d$y[ok_d], col  = 2 , log = "x", lwd = 0, main = "",
           xlab = "Fitness", ylab = "Density",xlim = c(min_x,max_x),
           mgp = c( 2.5 , 1 , 0 ),
           axes = FALSE,
           pch = "",...)
      axis(side = 1, at=c(format(round(min_x, 2), nsmall = 2),
                          format(round(1, 2), nsmall = 2),
                          format(round(max_x, 2), nsmall = 2)),
           tcl = 0.5, ...)
      magaxis(side = 2,grid = FALSE, frame.plot = TRUE,
              logpretty = FALSE,...)

      #x <- c(format(min(f_non),digits = 1),1,5,10,15,format(max(f_non),digits = 4))
      u    <- smooth.spline(d$x, d$y, spar = 0.01)
      #polygon(d$x, d$y, col = red_fade, border=NA)
      ok_u <- u$x > 0 & u$y > 0
      lines(u$x[ok_u], u$y[ok_u], col = "grey50",lwd = 2.5);
      #axis(3, at = 1,labels = "Mean = 1", las = 0,cex.axis = 2)
      gray <- rgb(0,0,0,1)
      #abline(v = median(f_non), lty = 5, lwd = 1.5,col = green)
      #abline(v = quantile(f_non,0.99), lty = 4, lwd = 1.5, col = blue)
      #mtext(at = median(f_non), side = 3,
      #      format(round(median(f_non), 2), nsmall = 2), cex = 1)
      #mtext(at = quantile(f_non,0.99), side = 3,
      #      format(round(quantile(f_non,0.99), 2), nsmall = 2),
      #      cex = 1)

      #plot.new()
      #par(mar=c(0, 0, 0, 0))
      #legend(legend = c("99th percentile" , "Median"),
      #       text.col = c(gray),
      #       x = "left", col = c(green,blue),lwd = 1.5,
      #       lty = c(5,4),cex = 1, bty = "n")
  }
  else if ("true_f" == plot[1]) {
          #names(true_f) <- net_stat$node_id
          #true_f        <-  true_f[names(x$f)]
          true_f1   <- length(true_f[net_stat$node_id][net_stat$f_position]) * true_f[net_stat$node_id][net_stat$f_position]/
                       sum(true_f[net_stat$node_id][net_stat$f_position])
          if (FALSE == is.null(high_deg_f)) {
              non_zero <- x$lower_f[net_stat$f_position] > 10^-20 & true_f1 > 10^-20 & net_stat$increase[net_stat$f_position] > high_deg_f
          } else
              non_zero <- x$lower_f[net_stat$f_position] > 10^-20 & true_f1 > 10^-20
          if (length(non_zero) <= 0)
             stop("There is no net_stat. Please decrease high_deg")
          #print(non_zero)
          b        <- lm(true_f1[non_zero] ~ 0 + x$f[net_stat$f_position][non_zero])$coefficients[1]
          upper_f  <-  exp(log(b*x$f[net_stat$f_position][non_zero]) + 2 * sqrt(x$var_f[net_stat$f_position][non_zero] / x$f[net_stat$f_position][non_zero] ^ 2))
          lower_f  <-  exp(log(b*x$f[net_stat$f_position][non_zero]) - 2 * sqrt(x$var_f[net_stat$f_position][non_zero] / x$f[net_stat$f_position][non_zero] ^ 2))

          #print(lower_f)
          #print("---")
          #print(upper_f)

          if (is.null(additional_para$xlim)) {
              if ((!is.null(f_min)) && (!is.null(f_max))) {
                  if (TRUE == confidence)
                      xlim <- c(min(c(f_min,lower_f,true_f1[non_zero])) , max(c(f_max,upper_f,true_f1)))
                  else xlim <- c(min(c(f_min,true_f1[non_zero])) , max(c(f_max,true_f1)))
              }
              else  if (!is.null(f_max)) {
                  if (TRUE == confidence)
                      xlim <- c(min(c(lower_f,true_f1[non_zero])) , max(c(f_max,upper_f,true_f1)))
                  else xlim <- c(min(c(true_f1[non_zero])) , max(c(f_max,true_f1)))
              }
              else if (!is.null(f_min)) {
                  if (TRUE == confidence)
                      xlim <- c(min(c(f_min,lower_f,true_f1[non_zero])) , max(c(upper_f,true_f1)))
                  else xlim <- c(min(c(f_min,true_f1[non_zero])) , max(c(true_f1)))
              }
              else {
                  if (TRUE == confidence)
                      xlim <- c(min(c(lower_f,true_f1[non_zero])) , max(c(upper_f,true_f1)))
                  else  xlim <- c(min(c(true_f1[non_zero])) , max(c(true_f1)))
              }
          }
          else {
              xlim <- additional_para$xlim
          }
          #print(xlim)
          if (is.null(additional_para$ylim))
              ylim <- xlim
          else ylim <- additional_para$ylim
          temp   <- names(additional_para)
          ok_vec <- which(temp != "xlim" & temp != "ylim")
          #print(additional_para)
          additional_para_list <- ""
          for (i in ok_vec) {
            if (!is.character(additional_para[[i]]))  {
              additional_para_list <- paste0(additional_para_list ,temp[i]," = ",additional_para[[i]],",");
            } else  additional_para_list <- paste0(additional_para_list ,temp[i]," = '",additional_para[[i]],"',")
          }
          final_para <- substr(additional_para_list,1,nchar(additional_para_list) - 1)

          #print(final_para)

          eval(parse(text = paste('plot(true_f1[non_zero][1], b * x$f[net_stat$f_position][non_zero][1] , xlim= xlim ,
                                   ylim = ylim,
                ylab = "Estimated fitness" , xlab = "True fitness" , log = "xy" , type = "n", axes = FALSE,
                                  ,
                 	mgp = c( 2.5 , 1 , 0 ) ,',
                                  final_para, ')')))
          #magaxis(grid = TRUE, frame.plot = TRUE)
          eval(parse(text = paste('magaxis(grid = FALSE, frame.plot = TRUE,',final_para,')')));

          if (TRUE == confidence) {
              #x_point <- c(true_f1[non_zero],rev(true_f1[non_zero]))
              #y_point <- c(upper_f, rev(lower_f))
              order    <- order(true_f1[non_zero])
              upper_f  <- upper_f[order]
              lower_f  <- lower_f[order]
              unique_x <- unique(true_f1[non_zero][order])
              upper_u  <- rep(0,length(unique_x))
              lower_u  <- upper_u
              for (jjj in 1:length(unique_x)) {
                  uu           <- which(true_f1[non_zero][order] == unique_x[jjj])
                  #print(uu)
                  upper_u[jjj] <- max(upper_f[uu])
                  lower_u[jjj] <- min(lower_f[uu])
              }
              my_col <- as.vector(col2rgb(col_interval))
              my_col <- my_col / 255
              polygon(c(unique_x , rev(unique_x)) , c(upper_u , rev(lower_u)) , col = rgb(my_col[1] , my_col[2] , my_col[3] , alpha = shade_interval) , border = NA)
              #arrows(y0 = lower_f, x0 = true_f1[non_zero], y1 = upper_f, x1 = true_f1[non_zero], code = 3,angle = 90, length = 0,
              #       col = rgb(0,0,0,shade_interval))
          }
          abline(a=0,b = 1)
          if (FALSE == plot_true_degree) {
              col_fit <- as.vector(col2rgb(col_point)) / 255
              points(true_f1[non_zero],b * x$f[net_stat$f_position][non_zero] , pch = pch , col = rgb(col_fit[1],col_fit[2],
                                                                                col_fit[3],
                                                                                shade_point),...)
          }
          else {
              points(b * x$f[net_stat$f_position][non_zero],true_f1[non_zero] , pch = "" , ...)
              col         <- brewer.pal(9 , "Greens")
              order       <- order(net_stat$increase[net_stat$f_position][non_zero])
              col_seq     <- seq(min(net_stat$increase[net_stat$f_position][non_zero]) ,
                                 max(net_stat$increase[net_stat$f_position][non_zero]) , 9)
              a           <- sapply(net_stat$increase[net_stat$f_position][non_zero] , function(x)which(col_seq >= x)[1])
              a[is.na(a)] <- 9
              text(b * x$f[net_stat$f_position][non_zero] , true_f1[non_zero] , net_stat$increase[net_stat$f_position][non_zero] , col = col[a] , ...)
          }
      }
}


#' Generators
#'
#' Random float vector/matrix generators. \code{flrunif()} produces uniform
#' random values. \code{flrnorm()} produces random normal values.
#' \code{flrand()} will accept an arbitrary generator. See the details section
#' for more information.
#'
#' @details
#' For \code{flrunif()} and \code{flrnorm()}, the data is produced without a
#' double precision copy.  That is, it is not (computationally) equivalent to
#' \code{fl(matrix(runif(...)))}, though the operations are conceptually the
#' same.  For these, To produce a vector instead of a matrix, leave argument
#' \code{n} blank. Setting \code{n=1} will produce an mx1 matrix.
#'
#' For \code{flrand()}, the data is generated in double precision in 4KiB
#' batches and copied over to a pre-allocated vector.  This will be slower than
#' generating all of the data up front and copying it, although it uses far less
#' memory most of the time.  So you can think of \code{flrunif()} and
#' \code{flrnorm()} as highly optimized versions of \code{flrand()} for uniform
#' and normal generators specifically.
#'
#' @param m,n
#' The dimensions of the matrix/vector. \code{m} must be specified.  If \code{n}
#' is not, then the return is a vector.
#' @param min,max
#' Minimum and maximum values for the uniform generator.
#' @param mean,sd
#' Mean and standard deviation values for the normal generator.
#' @param generator
#' A generating function, such as \code{rnorm}, or even something custom
#' defined.
#' @param ...
#' Additional arguments passed to the generator. For example, if \code{runif} is
#' passed as \code{generator}, then you might additionally pass \code{max=10}.
#'
#' @examples
#' library(float)
#'
#' flrunif(10) # length 10 vector
#' flrunif(10, 1) # 10x1 matrix
#' flrunif(10, min=10, max=20)
#'
#' flrand(runif, 10) # conceptually the same as flrunif(10)
#'
#' mygen = function(n) sample(1:5, n, replace=TRUE)
#' flrand(mygen, 30)
#'
#' @useDynLib float R_flrunif_spm R_flrnorm_spm R_flrand_spm
#' @name rand
#' @rdname rand
NULL

#' @rdname rand
#' @export
flrunif = function(m, n, min=0, max=1)
{
  m = as.integer(m)
  if (missing(n))
  {
    n = 1L
    isavec = TRUE
  }
  else
  {
    n = as.integer(n)
    isavec = FALSE
  }

  if (m < 0)
    stop("invalid 'm' value (< 0)")
  if (n < 0)
    stop("invalid 'n' value (< 0)")

  ret = .Call(R_flrunif_spm, m, n, as.double(min), as.double(max), isavec)
  float32(ret)
}

#' @rdname rand
#' @export
flrnorm = function(m, n, mean=0, sd=1)
{
  m = as.integer(m)
  if (missing(n))
  {
    n = 1L
    isavec = TRUE
  }
  else
  {
    n = as.integer(n)
    isavec = FALSE
  }

  if (m < 0)
    stop("invalid 'm' value (< 0)")
  if (n < 0)
    stop("invalid 'n' value (< 0)")

  ret = .Call(R_flrnorm_spm, m, n, as.double(mean), as.double(sd), isavec)
  float32(ret)
}

flrand_batch = function(start, data, generator, len, ...)
{
  gen = generator(len, ...)
  if (!is.integer(gen) && !is.double(gen))
    storage.mode(gen) = "double"

  .Call(R_flrand_spm, data, start, len, gen)
  start + len
}

#' @rdname rand
#' @export
flrand = function(generator, m, n, ...)
{
  m = as.integer(m)
  if (missing(n))
  {
    n = 1L
    isavec = TRUE
  }
  else
  {
    n = as.integer(n)
    isavec = FALSE
  }

  n = m*n

  MAX = 512L # 4k chunks of doubles
  fullruns = as.integer(n/MAX)
  rem = as.integer(n - fullruns*MAX)

  data = integer(n)
  start = 1L
  for (i in seq_len(fullruns))
    start = flrand_batch(start, data, generator, MAX, ...)

  if (rem)
    start = flrand_batch(start, data, generator, rem, ...)

  float32(data)
}


install.packages("plotrix")
library(plotrix)
sales = read.csv("waterfall.csv")
names(sales)[1] = "lbl"
staircase.plot( sales$value, totals = sales$logic, labels = sales$lbl, total.col = c("lightgreen"), inc.col = c("blue","red"))

R Community/Create Charts in R-Assignment/waterfall.r


library(testthat)
library(digest)

test_1 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(answer1), "be07d96682ac055deedd3faddf6cf1f0")
  })
  print("Success!")
}

test_2 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(abs(answer2)), "f3481c09ab4181d4cd15f79869589215")
  })
  print("Success!")
}

test_2.5 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(answer2.5), "3a5505c06543876fe45598b5e5e5195d")
  })
  print("Success!")
}

test_3 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(regm$coefficients,2)), "39ed4f5524c9502fe419c723bae8e028")
  })
  print("Success!")
}

test_4 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(regf$coefficients,2)), "75de71587b69493dbccb55da24780133")
  })
  print("Success!")
}

test_5 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(lnreg$coefficients,2)), "0d6321ce24f7863ac3aacff0855b328f")
  })
  print("Success!")
}

test_6 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(lnregf), "aa8ca5ff5de0776fb598f5945315ed51")
  })
  print("Success!")
}

test_7 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg2A$coefficients,2)), "e2c2f7f8174ef76ed82c27f77636b62e")
  })
  print("Success!")
}

test_8 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg2B$coefficients[1],2)), "dc866355624fa98af7f3af50cec3c7ff")
  })
  print("Success!")
}

test_10 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg_race$coefficients,2)), "e4c85e58f1688fc79bc7f0f8e329318f")
  })
  print("Success!")
}

test_11 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(reg4), "b725a136eb98459cf499ef0e3f245c3c")
  })
  print("Success!")
}

test_12 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg5_20$coefficients,2)), "e5dbfaaca5da98db52ab38de583975af")
  })
  print("Success!")
}

test_16 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg5_50$coefficients,2)), "eca7a47a1caf78bd2fc48dd00168330c")
  })
  print("Success!")
}


# x-axis values
x <- c("A", "B", "C", "D")

# y-axis values
y <- c(2, 4, 6, 8)

barplot(y, names.arg = x, col = "red", density = 10, width = c(1, 2, 3, 4))


p <- c("8", "30", "20", "8", "20", NA, "30")
names(p) <- c("3", "8", "10", "20", "29", "30", "52")

cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), function(s) {
  while (!is.na(s[1])) {
    if (s[1] == s[2]) {
      break
    }
    i <- s[2]
    while (!is.na(i)) {
      if (s[1] == i) {
        return(i)
      }
      i <- p[i]
    }
    s[1] <- p[s[1]]
  }
  s[1]
}), sep="\n")


library(tm)
library(wordcloud)
library(SnowballC)
library(caret)
library(e1071)
library(rminer)
library(party)
library(kernlab)

install.packages("e1071")
install.packages("rminer")
install.packages("kernlab")
install.packages("party")
install.packages("caret")

# reove all list
rm(list=ls(all=T))

setwd("C:/03-MyProjects/Sentiment-classification/")
FileName="Movie1.csv"
movie_t_messages = read.csv(FileName, header= T, stringsAsFactors = F)
View(movie_t_messages)

movie_t_messages$Label <-factor(movie_t_messages$Label)
#movie_t_messages$t_message <- lapply(movie_t_messages$t_message, iconv, from="ISO-8859-15", to="UTF-8")

movie_t_messages$t_message[1]
nrow(movie_t_messages)
prop.table(table(movie_t_messages$Label))
set.seed(100)
inTrain <-createDataPartition(y=movie_t_messages$Label,p=0.5, list=FALSE)
train <- movie_t_messages[inTrain,]
testdata <- movie_t_messages[-inTrain,]

inTest <- createDataPartition(y=testdata$Label,p=0.5, list=FALSE)
test1 <-testdata[inTest,]
test2 <-testdata[-inTest,]

prop.table(table(test1$Label))
prop.table(table(test2$Label))
prop.table(table(testdata$Label))

View(test1)

options(mc.cores=1)
train_corpus <- Corpus(VectorSource(train$Label))
length(train_corpus)

cleanCorpus <- function(corpus)
  {
  corpus.tmp <- tm_map(corpus, removePunctuation)
  corpus.tmp <- tm_map(corpus.tmp,stripWhitespace)
  corpus.tmp <- tm_map(corpus.tmp,tolower)
  corpus.tmp <- tm_map(corpus.tmp, PlainTextDocument)
  corpus.tmp <- tm_map(corpus.tmp, removeNumbers)
  corpus.tmp <- tm_map(corpus.tmp, stemDocument)
  corpus.tmp <- tm_map(corpus.tmp,removeWords, stopwords("english"))
  return(corpus.tmp)
}
  step6  <- cleanCorpus(train_corpus)
   inspect(step6[1:5])

   train_dtm_bin <- DocumentTermMatrix(step6, control=list(weighting = weightBin))
   dim(train_dtm_bin)
 str(train_dtm_bin)
inspect(train_dtm_bin[1,1:8])

dtm.as.matrix <- as.matrix(train_dtm_bin)
View(dtm.as.matrix)

train_rmsp_bin_95 = removeSparseTerms(train_dtm_bin, 0.97)
dim(train_rmsp_bin_95)

train_BOW_95 <- as.matrix(train_rmsp_bin_95)
View(train_BOW_95)

mean_train_95 = sort(colMeans(train_BOW_95), decreasing=T)
average_top20_train <- mean(mean_train_95[1:20])
average_top20_train
mean_train_95[1]
barplot(mean_train_95[1:10], border=NA,las= 3,xlab="Top 20",ylab="Av Binary Weightd", ylim= c(0,1.5))

train_data_bin_95 = data.frame(y=train$Label, train_BOW_95)
View(train_data_bin_95)

###### TEST 1
test1_corpus <- Corpus(DataframeSource(as.matrix(test1$Label)))

test1_step6  <- cleanCorpus(test1_corpus)
inspect(test1_step6[1:5])

#create weight
#test1_dtm_bin_95 <- DocumentTermMatrix(test1_step6, list(weighting = weightBin, dictionary = train_BOW_95))

test1_dtm_bin_95 <- DocumentTermMatrix(test1_step6, list(weighting = weightBin))
 test1_m_bin_95 <-as.matrix(test1_dtm_bin_95)
View(test1_m_bin_95)

#combine LABEL
test1_data_bin_95 = data.frame(y=test1$Label,test1_m_bin_95)

#plot
mean_test1_95 = sort(colMeans(test1_m_bin_95), decreasing=T)
average_top20_test1 <- mean(mean_test1_95[1:20])
average_top20_test1
mean_test1_95[1]
barplot(mean_test1_95[1:20], border=NA,las= 3,xlab="Top 20",ylab="Test1 Av Binary Weightd", ylim= c(0,1.5))

###### TEST 2
#Adding Interest  data$size      <- 0

test2_corpus <- Corpus(DataframeSource(as.matrix(test2$Label)))
test2_step6  <- cleanCorpus(test2_corpus)
inspect(test2_step6[1:5])

#create weight
# error
# test2_dtm_bin_95 <- DocumentTermMatrix(test2_step6, list(weighting = weightBin, dictionary = train_BOW_95))

test2_dtm_bin_95 <- DocumentTermMatrix(test2_step6, list(weighting = weightBin))
test2_m_bin_95 <-as.matrix(test2_dtm_bin_95)
#add int
View(test2_m_bin_95)

#
#combine LABEL and new column for "interest"
#drop column -- test2_m_bin_95<-test2_m_bin_95[,-8]
#test2_m_bin_95<-cbind(test2_m_bin_95, test2_m_bin_95[,"ola"])

test2_m_bin_95<-cbind(test2_m_bin_95, "0")
colnames(test2_m_bin_95)[7:7]<-c("interest")
View(test2_m_bin_95)

test2_data_bin_95 = data.frame(y=test2$Label,test2_m_bin_95)

#plot
mean_test2_95 = sort(colMeans(test2_m_bin_95), decreasing=T)
average_top20_test2 <- mean(mean_test2_95[1:20])
average_top20_test2
mean_test2_95[1]
barplot(mean_test2_95[1:20], border=NA,las= 3,xlab="Top 20",ylab="test2 Av Binary Weightd", ylim= c(0,1.5))

View(train_data_bin_95)
#ctree
BOW_ctree <- ctree(y ~ ., data=train_data_bin_95)

#test1
test1Pred = predict(BOW_ctree, newdata = test1_data_bin_95)
# error
# confusionMatrix(test1Pred, test1_data_bin_95[,1], positive = "Positive", dnn=c("Prediction", "True"))

# Accuracy
conf.mat <- table("Predictions" =test1Pred, Actual= test1_data_bin_95[,1])
conf.mat
(accuracy <- sum(diag(conf.mat)) / length(inTest)* 100)

mmetric(test1Pred, test1_data_bin_95[,1],c("ACC","TPR","PRECISION","F1"))

################test2
#add interest column
#View(test2_data_bin_95)
# droping columns to match train
# test2_data_bin_95<-test2_data_bin_95[,-4]
# test2Pred = predict(BOW_ctree, newdata = test2_data_bin_95)
# confusionMatrix(test2Pred, test2_data_bin_95[,1], positive = "Positive", dnn=c("Prediction", "True"))
# Accuracy  conf.mat <- table("Predictions" =test2Pred, Actual= test2_data_bin_95[,1])
# conf.mat
#(accuracy <- sum(diag(conf.mat)) / length(-inTest)* 100)

#############        naive

BOW_nB <-naiveBayes(y ~., data=train_data_bin_95)

#test1
test1Pred = predict(BOW_nB, newdata = test1_data_bin_95)
# error
# confusionMatrix(test1Pred, test1_data_bin_95[,1], positive = "Positive", dnn=c("Prediction", "True"))

# Accuracy
conf.mat <- table("Predictions" =test1Pred, Actual= test1_data_bin_95[,1])
conf.mat
(accuracy <- sum(diag(conf.mat)) / length(inTest)* 100)

mmetric(test1Pred, test1_data_bin_95[,1],c("ACC","TPR","PRECISION","F1"))

#test2
test2Pred = predict(BOW_nB, newdata = test2_data_bin_95)
# Accuracy
conf.mat <- table("Predictions" =test2Pred, Actual= test2_data_bin_95[,1])
conf.mat
(accuracy <- sum(diag(conf.mat)) / length(inTest)* 100)

mmetric(test2Pred, test2_data_bin_95[,1],c("ACC","TPR","PRECISION","F1"))

################### SVM

BOW_ksvm <- ksvm(y~., data=train_data_bin_95)

#test1
test1Pred = predict(BOW_ksvm, newdata = test1_data_bin_95)
# error
# confusionMatrix(test1Pred, test1_data_bin_95[,1], positive = "Positive", dnn=c("Prediction", "True"))

# Accuracy
conf.mat <- table("Predictions" =test1Pred, Actual= test1_data_bin_95[,1])
conf.mat
(accuracy <- sum(diag(conf.mat)) / length(inTest)* 100)

mmetric(test1Pred, test1_data_bin_95[,1],c("ACC","TPR","PRECISION","F1"))

#test2
test2Pred = predict(BOW_ksvm, newdata = test2_data_bin_95)
# Accuracy
conf.mat <- table("Predictions" =test2Pred, Actual= test2_data_bin_95[,1])
conf.mat
(accuracy <- sum(diag(conf.mat)) / length(inTest)* 100)

mmetric(test2Pred, test2_data_bin_95[,1],c("ACC","TPR","PRECISION","F1"))

RedRabbit ES-R/R - ETL  Score - ES endpoin/Sentiment-classification/movie review - 4 models.r