##Raster= raster
##Output=output vector
##Carpeta= folder
##Nombre = string Lote prueba 1
##Unidad_de_Cosecha = string kg/ha
##Comentarios= string Establecimiento "El calabozo", cosecha: 13/01/2020
##Version_simplificada= string no

##output_plots_to_html
##showplots

nombre<-Nombre
detalleslote <-Comentarios
unidad_de_cosecha<-Unidad_de_Cosecha
version_simplificada<-Version_simplificada

library(sp)
library(spdep)
library(gstat)
library(raster)
library(rgdal)

print(Carpeta)
setwd(Carpeta)
Kg_wls<-as(Raster, "SpatialPixelsDataFrame")
valores<-na.omit(Kg_wls@data[,1])
print(str(Kg_wls))
print(paste("Los archvos seran guardados en:", getwd()))
r<-Raster

if (version_simplificada == "no"){
                cols <- c("#AA0014","#d73027","#fc8d59","#fee08b","#d9ef8b","#91cf60","#1a9850")
                cortes<-quantile(valores, probs = c(0.10,0.20,0.40,0.50,0.60,0.80,1))
                #reclasifico los valores continuos de raster por la calsificación de tomas.
                values_tg<-unname(cortes)

                lamatrix<-matrix(nrow=8,ncol=3)
                lamatrix[1,1]<--Inf
                lamatrix[1,2]<-values_tg[1]
                lamatrix[1,3]<-values_tg[1]
                lamatrix[8,1]<-values_tg[7]
                lamatrix[8,2]<-Inf
                lamatrix[8,3]<-values_tg[7]

                for (i in 2:7){
                a<-i-1
                lamatrix[i,1]<-values_tg[a]
                b<-i
                lamatrix[i,2]<-values_tg[b]
                a<-i
                lamatrix[i,3]<-values_tg[a]
                }
          }

          if (version_simplificada == "si"){
             cols <- c("#d73027","#fee08b","#d9ef8b","#1a9850")
             cortes<-quantile(valores, probs =c(0.2,0.5,0.8,1))
             #son 5
              #reclasifico los valores continuos de raster por la calsificación de tomas.
              values_tg<-unname(cortes)

              lamatrix<-matrix(nrow=4,ncol=3)
              lamatrix[1,1]<--Inf
              lamatrix[1,2]<-values_tg[1]
              lamatrix[1,3]<-values_tg[1]
              lamatrix[4,1]<-values_tg[3]
              lamatrix[4,2]<-Inf
              lamatrix[4,3]<-values_tg[4]

              for (i in 2:4){
              a<-i-1
              lamatrix[i,1]<-values_tg[a]
              b<-i
              lamatrix[i,2]<-values_tg[b]
              a<-i
              lamatrix[i,3]<-values_tg[a]
              }

          }

          rc <- reclassify(r, lamatrix,include.lowest=TRUE)
          print("ACA ESTA LA VECTORIZACION")
          vectorizado<-rasterToPolygons(rc,na.rm=TRUE,dissolve=TRUE)
	  #Este error me lo marco el Juani Orcellet.
	  colnames(vectorizado@data)<-c("output")

          vectorizado@data$colores<-as.factor(unname(cortes))
          plot(vectorizado["output"],col=cols,border="NA")
          writeOGR(vectorizado, layer = paste(nombre," vectorizado",sep=""), dsn="vectorizado R", driver="ESRI Shapefile",overwrite_layer=TRUE)
          print("ACA ARMO EL PDF")
          valores<-na.omit(Kg_wls@data[,1])
          #cortes<-quantile(valores, probs = c(0,0.10,0.25,0.50,0.75,0.90,1))
          h <- hist(valores, breaks=20, plot=F) # h$breaks and h$mids
          #cols <- c("#AA0014","#d73027","#fc8d59","#fee08b","#d9ef8b","#91cf60","#1a9850")
          k <- cols[findInterval(h$breaks, unname(cortes), rightmost.closed=T, all.inside=F) + 1]
          #plot(h, col=k,main=paste("Distribucion de rendimiento, Lote:", Lote),xlab= paste("Rendimiento",unidad_de_cosecha),ylab="Frecuencia")

          ruta<-getwd()
          nombre1<-paste("Mapa de rendimiento-",nombre,".pdf",sep= "")
          pdf(file= paste(ruta,"/",nombre1,sep=""))
          #par(mar = c(2,2,2,2)
           par(mfrow=c(1,1))

          plot(vectorizado["output"], col=cols, border="NA",main=paste("Mapa de Rendimiento",nombre,sep=" "))
          max<-length(cortes)
          legend("topleft",as.character(round(unname(cortes[1:max]),digits=2)),fill=cols,cex = 0.8,bty="n",title=unidad_de_cosecha)
          mtext(detalleslote,side=1,cex=1)
          mtext("Desarrollodo en INTA Bordenave - @FrancoFrolla",side=4,cex=0.5)

          plot(h, col=k,main=paste("Histograma rendimiento"),xlab=paste("Rendimiento", unidad_de_cosecha),ylab="Frecuencia")
          mtext("Desarrollodo en INTA Bordenave - @FrancoFrolla",side=4,cex=0.5)

          dev.off()
          print("ACA ARMO EL KML")
          hacerkml<-function(){

            obj <- spTransform(vectorizado, CRS("+init=epsg:4326"))
            inners<-c("")
            outers<-c("")
            union<-c("")
            superkml<-c("")
            stack<-c("")
	    print(str(obj))
            if (version_simplificada == "no"){
            cabezera<-c('<?xml version="1.0"?>
                        <kml xmlns:xsd="http://schemas.opengis.net/kml/2.2.0/ogckml22.xsd" version="1.0">
                        <Document><Style id="1"><LineStyle><width>2.0</width><color>ff1400aa</color></LineStyle><PolyStyle><color>ff1400aa</color></PolyStyle></Style><Style id="2"><LineStyle><width>2.0</width><color>ff2730d7</color></LineStyle><PolyStyle><color>ff2730d7</color></PolyStyle></Style><Style id="3"><LineStyle><width>2.0</width><color>ff598dfc</color></LineStyle><PolyStyle><color>ff598dfc</color></PolyStyle></Style><Style id="4"><LineStyle><width>2.0</width><color>ff8be0fe</color></LineStyle><PolyStyle><color>ff8be0fe</color></PolyStyle></Style><Style id="5"><LineStyle><width>2.0</width><color>ff8befd9</color></LineStyle><PolyStyle><color>ff8befd9</color></PolyStyle></Style><Style id="6"><LineStyle><width>2.0</width><color>ff60cf91</color></LineStyle><PolyStyle><color>ff60cf91</color></PolyStyle></Style><Style id="7"><LineStyle><width>2.0</width><color>ff50981a</color></LineStyle><PolyStyle><color>ff50981a</color></PolyStyle></Style><Style id="8"><LineStyle><width>2.0</width><color>ff882754</color></LineStyle><PolyStyle><color>ff882754</color></PolyStyle></Style>
                        <ScreenOverlay><name>Legend: Logo</name><Icon> <href>http://lmingenieria.com.ar/images/logo.png</href> </Icon> <overlayXY x="0" y="0" xunits="fraction" yunits="fraction"/>
                         <screenXY x="25" y="40" xunits="pixels" yunits="pixels"/>
                        <rotationXY x="0.5" y="0.5" xunits="fraction" yunits="fraction"/>
                        <size x="0" y="0" xunits="pixels" yunits="pixels"/>
                          </ScreenOverlay>')}
             if (version_simplificada == "si"){
            cabezera<-c('<?xml version="1.0"?>
                        <kml xmlns:xsd="http://schemas.opengis.net/kml/2.2.0/ogckml22.xsd" version="1.0">
                        <Document><Style id="1"><LineStyle><width>0</width><color>ff2730d7</color></LineStyle><PolyStyle><color>ff2730d7</color></PolyStyle></Style><Style id="2"><LineStyle><width>0</width><color>ff8be0fe</color></LineStyle><PolyStyle><color>ff8be0fe</color></PolyStyle></Style><Style id="3"><LineStyle><width>0</width><color>ff8befd9</color></LineStyle><PolyStyle><color>ff8befd9</color></PolyStyle></Style><Style id="4"><LineStyle><width>0</width><color>ff50981a</color></LineStyle><PolyStyle><color>ff50981a</color></PolyStyle></Style><Style id="5"><LineStyle><width>2.0</width><color>ff8befd9</color></LineStyle><PolyStyle><color>ff8befd9</color></PolyStyle></Style><Style id="6"><LineStyle><width>2.0</width><color>ff60cf91</color></LineStyle><PolyStyle><color>ff60cf91</color></PolyStyle></Style><Style id="7"><LineStyle><width>2.0</width><color>ff50981a</color></LineStyle><PolyStyle><color>ff50981a</color></PolyStyle></Style><Style id="8"><LineStyle><width>2.0</width><color>ff882754</color></LineStyle><PolyStyle><color>ff882754</color></PolyStyle></Style>
                        <ScreenOverlay><name>Legend: Logo</name><Icon> <href>http://lmingenieria.com.ar/images/logo.png</href> </Icon> <overlayXY x="0" y="0" xunits="fraction" yunits="fraction"/>
                         <screenXY x="25" y="40" xunits="pixels" yunits="pixels"/>
                        <rotationXY x="0.5" y="0.5" xunits="fraction" yunits="fraction"/>
                        <size x="0" y="0" xunits="pixels" yunits="pixels"/>
                          </ScreenOverlay>')}
            #ACTIVAR PARA SACAR LOS MULTYPOLYGON Y SILENCIAR LOS DE ABAJO
            #prefijo<-c('<Placemark><name>30</name><styleUrl>#1</styleUrl><Polygon>')
            #sufijo<-c('</Polygon></Placemark>')
            fin<-c('</Document></kml>')

            #prefijo<-c('<Placemark><name>1</name><styleUrl>#1</styleUrl><MultiGeometry>')
            sufijo<-c('</MultiGeometry></Placemark>')
            prefijo.poligono<-c('<Polygon>')
            sufijo.poligono<-c('</Polygon>')

            for (a in 1:length(obj@polygons)){

              if (version_simplificada == "no"){

              if (obj$output[a] == unname(cortes[7])){estilo.id = 7}
              if (obj$output[a] == unname(cortes[6])){estilo.id = 6}
              if (obj$output[a] == unname(cortes[5])){estilo.id = 5}
              if (obj$output[a] == unname(cortes[4])){estilo.id = 4}
              if (obj$output[a] == unname(cortes[3])){estilo.id = 3}
              if (obj$output[a] == unname(cortes[2])){estilo.id = 2}
              if (obj$output[a] == unname(cortes[1])){estilo.id = 1}
              }

              if (version_simplificada == "si"){

              if (obj$output[a] == unname(cortes[4])){estilo.id = 4}
              if (obj$output[a] == unname(cortes[3])){estilo.id = 3}
              if (obj$output[a] == unname(cortes[2])){estilo.id = 2}
              if (obj$output[a] == unname(cortes[1])){estilo.id = 1}
              }

              prefijo<-sprintf('<Placemark><name>%s</name><styleUrl>#%s</styleUrl><MultiGeometry>',obj$output[a],estilo.id)

              #print(paste("corrida numero",a))
              agujeros<-c()
              superkml<-c("")
              for (i in 1:length(obj@polygons[[a]]@Polygons)){
                agujero<-obj@polygons[[a]]@Polygons[[i]]@hole
                agujeros<-c(agujeros,agujero)
              }
              #print(agujeros)

              for (i in 1:length(agujeros)){
                if(agujeros[i] == FALSE){
                  #obtengo el outboundary
                  xyz<-obj@polygons[[a]]@Polygons[[i]]@coords
                  coords.out <- paste(xyz[,1], ',', xyz[,2], ',', 0, collapse='\n ', sep = "")
                  outers<-sprintf('<outerBoundaryIs><LinearRing><coordinates>%s</coordinates></LinearRing></outerBoundaryIs>', coords.out)
                  if(is.na(agujeros[i+1])){
                    union<-paste(prefijo.poligono,outers,sufijo.poligono)
                    #union<-paste(prefijo,outers,sufijo)
                    superkml<-paste(superkml,union)
                    #stop("Se termino la ejecución porque no habia mas poligonos")
                  } else {
                    repeat {
                      if(agujeros[i+1] == TRUE){
                        xyz<-obj@polygons[[a]]@Polygons[[i+1]]@coords
                        coords.int <- paste(xyz[,1], ',', xyz[,2], ',', 0, collapse='\n ', sep = "")
                        xt<-sprintf('<innerBoundaryIs><LinearRing><coordinates>%s</coordinates></LinearRing></innerBoundaryIs>',coords.int)
                        inners<-paste(inners,xt)
                        i<-i+1
                      }
                      if (agujeros[i+1] == FALSE  | is.na(agujeros[i+1])){
                        union<-paste(prefijo.poligono,outers,inners,sufijo.poligono)
                        #activar para sacar los multypolygons
                        #union<-paste(prefijo,outers,inners,sufijo)
                        inners<-c("")
                        outers<-c("")
                        #print("era false")
                        #print(i+1)
                        break
                      }
                    }
                  }
                  superkml<-paste(superkml,union)
                  #superkml<-paste(prefijo.poligono,superkml,union,sufijo.poligono)
                  #stack<-paste(stack,superkml)
                } else {#print("era verdadero")
                }
              }
              stack<-paste(stack,prefijo,superkml,sufijo)

            }

            write(paste(cabezera,stack,fin), paste(nombre,".kml",sep=""))

          }
   hacerkml()

Output <- sf::st_as_sf(vectorizado)


\name{extreme_deconvolution}
\alias{extreme_deconvolution}

\title{Density estimation using Gaussian mixtures in the presence of
  noisy, heterogeneous and incomplete data}

\description{We present a general algorithm to infer a d-dimensional
distribution function given a set of heterogeneous, noisy observations
or samples. This algorithm reconstructs the error-deconvolved or
'underlying' distribution function common to all samples, even when the
individual samples have unique error and missing-data properties. The
underlying distribution is modeled as a mixture of Gaussians, which is
completely general. Model parameters are chosen to optimize a justified,
scalar objective function: the logarithm of the probability of the data
under the error-convolved model, where the error convolution is
different for each data point. Optimization is performed by an
Expectation Maximization (EM) algorithm, extended by a regularization
technique and 'split-and-merge' procedure. These extensions mitigate
problems with singularities and local maxima, which are often
encountered when using the EM algorithm to estimate Gaussian density
mixtures.}

\usage{
extreme_deconvolution(ydata,ycovar,xamp,xmean,xcovar,
                      projection=NULL,weight=NULL,
                      fixamp=NULL,fixmean=NULL,fixcovar=NULL,
                      tol=1.e-6,maxiter=1e9,w=0,logfile=NULL,
                      splitnmerge=0,maxsnm=FALSE,likeonly=FALSE,
                      logweight=FALSE)
}

\arguments{
  \item{ydata}{[ndata,dy] matrix of observed quantities}
  \item{ycovar}{[ndata,dy] / [ndata,dy,dy] / [dy,dy,ndata] matrix, list or 3D array
    of observational error covariances
    (if [ndata,dy] then the error correlations are assumed to vanish)}
  \item{xamp}{[ngauss] array of initial amplitudes (*not* [1,ngauss])}
  \item{xmean}{[ngauss,dx] matrix of initial means}
  \item{xcovar}{[ngauss,dx,dx] list of matrices of initial covariances}
  \item{projection}{[ndata,dy,dx] list of projection matrices}
  \item{weight}{[ndata] array of weights to be applied to the data points}
  \item{logweight}{(bool, default=False) if True, weight is actually
                   log(weight)}
  \item{fixamp}{(default=None) None, True/False, or list of bools}
  \item{fixmean}{(default=None) None, True/False, or list of bools}
  \item{fixcovar}{(default=None) None, True/False, or list of bools}
  \item{tol}{(double, default=1.e-6) tolerance for convergence}
  \item{maxiter}{(long, default= 10**9) maximum number of iterations to perform}
  \item{w}{(double, default=0.) covariance regularization parameter
            (of the conjugate prior)}
  \item{logfile}{basename for several logfiles (_c.log has output from
                 the c-routine; _loglike.log has the log likelihood path of
                 all the accepted routes, i.e. only parts which increase
                 the likelihood are included, during splitnmerge)}
  \item{splitnmerge}{(int, default=0) depth to go down the splitnmerge path}
  \item{maxsnm}{(Bool, default=False) use the maximum number of split 'n'
                 merge steps, K*(K-1)*(K-2)/2}
  \item{likeonly}{(Bool, default=False) only compute the total log
                   likelihood of the data}
}

\value{
  \item{avgloglikedata}{avgloglikedata after convergence}
  \item{xamp}{updated xamp}
  \item{xmean}{updated xmean}
  \item{xcovar}{updated xcovar}
}

\details{
  ...
}

\author{Jo Bovy, David W. Hogg, & Sam T. Roweis}

\references{
Inferring complete distribution functions from
noisy, heterogeneous and incomplete observations Jo Bovy, David
W. Hogg, & Sam T. Roweis, Submitted to AOAS (2009) [arXiv/0905.2979]
}

\examples{
library(ExtremeDeconvolution)

ydata <-
c(2.62434536, 0.38824359, 0.47182825, -0.07296862, 1.86540763,
-1.30153870, 2.74481176, 0.23879310, 1.31903910, 0.75062962,
2.46210794, -1.06014071, 0.67758280, 0.61594565, 2.13376944,
-0.09989127, 0.82757179, 0.12214158, 1.04221375, 1.58281521,
-0.10061918, 2.14472371, 1.90159072, 1.50249434, 1.90085595,
0.31627214, 0.87710977, 0.06423057, 0.73211192, 1.53035547,
0.30833925, 0.60324647, 0.31282730, 0.15479436, 0.32875387,
0.98733540, -0.11731035, 1.23441570, 2.65980218, 1.74204416,
0.80816445, 0.11237104, 0.25284171, 2.69245460, 1.05080775,
0.36300435, 1.19091548, 3.10025514, 1.12015895, 1.61720311,
1.30017032, 0.64775015, -0.14251820, 0.65065728, 0.79110577,
1.58662319, 1.83898341, 1.93110208, 1.28558733, 1.88514116,
0.24560206, 2.25286816, 1.51292982, 0.70190717, 1.48851815,
0.92442829, 2.13162939, 2.51981682, 3.18557541, -0.39649633,
-0.44411380, 0.49553414, 1.16003707, 1.87616892, 1.31563495,
-1.02220122, 0.69379599, 1.82797464, 1.23009474, 1.76201118,
0.77767186, 0.79924193, 1.18656139, 1.41005165, 1.19829972,
1.11900865, 0.32933771, 1.37756379, 1.12182127, 2.12948391,
2.19891788, 1.18515642, 0.62471505, 0.36126959, 1.42349435,
1.07734007, 0.65614632, 1.04359686, 0.37999916, 1.69803203,
0.55287144, 2.22450770, 1.40349164, 1.59357852, -0.09491185,
1.16938243, 1.74055645, 0.04629940, 0.73378149, 1.03261455,
-0.37311732, 1.31515939, 1.84616065, 0.14048406, 1.35054598,
-0.31228341, 0.96130449, -0.61577236, 2.12141771, 1.40890054,
0.97538304, 0.22483838, 2.27375593, 2.96710175, -0.85798186,
2.23616403, 2.62765075, 1.33801170, -0.19926803, 1.86334532,
0.81907970, 0.39607937, -0.23005814, 1.55053750, 1.79280687,
0.37646927, 1.52057634, -0.14434139, 1.80186103, 1.04656730,
0.81343023, 0.89825413, 1.86888616, 1.75041164, 1.52946532,
1.13770121, 1.07782113, 1.61838026, 1.23249456, 1.68255141,
0.68988323, -1.43483776, 2.03882460, 3.18697965, 1.44136444,
0.89984477, 0.86355526, 0.88094581, 1.01740941, -0.12201873,
0.48290554, 0.00297317, 1.24879916, 0.70335885, 1.49521132,
0.82529684, 1.98633519, 1.21353390, 3.19069973, -0.89636092,
0.35308331, 1.90148689, 3.52832571, 0.75136522, 1.04366899,
0.77368576, 2.33145711, 0.71269214, 1.68006984, 0.68019840,
-0.27255875, 1.31354772, 1.50318481, 2.29322588, 0.88955297,
0.38263794, 1.56276110, 1.24073709, 1.28066508, 0.92688730,
2.16033857, 1.36949272, 2.90465871, 2.11105670, 1.65904980,
-0.62743834, 1.60231928, 1.42028220, 1.81095167, 2.04444209)

ydata  <- matrix(ydata,length(ydata),1)
N      <- dim(ydata)[1]
ycovar <- ydata*0 + 0.01
xamp   <- c(0.5,0.5)
xmean  <- matrix(c(0.86447943, 0.67078879, 0.322681, 0.45087394),2,2)
xcovar <-
  list(matrix(c(0.03821028, 0.04014796, 0.04108113, 0.03173839),2,2),
       matrix(c(0.06219194, 0.09738021, 0.04302473, 0.06778009),2,2))
projection <- list()
for (i in 1:N)
  projection[[i]] = matrix(c(i\%\%2,(i+1)\%\%2),1,2)
res <- extreme_deconvolution(ydata, ycovar, xamp, xmean, xcovar,
         projection=projection, logfile="ExDeconDemo")
print(res)
stopifnot((res$avgloglikedata - (-1.3114744655258121)) **2. < 10.**-8)
stopifnot((res$xmean[1,1]-2.30368235)**2. < 10.**-5)
stopifnot((res$xmean[1,2]-1.70701517)**2. < 10.**-5)
stopifnot((res$xmean[2,1]-1.08009397)**2. < 10.**-5)
stopifnot((res$xmean[2,2]-0.8888667)**2. < 10.**-5)
stopifnot((res$xcovar[[1]][1,1]-0.445645987259)**2. < 10.**-5.)
stopifnot((res$xamp[1]-0.11968415)**2. < 10.**-5)
stopifnot((res$xamp[2]-0.880315852981)**2. < 10.**-5)
}


LISP Interpreter Run

[[[[[

 Show that a formal axiomatic system (fas) can only prove
 that finitely many LISP expressions are elegant.
 (An expression is elegant if no smaller expression has
 the same value.)

 More precisely, show that a fas of LISP complexity N can't
 prove that a LISP expression X is elegant if X's size is
 greater than N + 356.

 (fas N) returns the theorem proved by the Nth proof
 (Nth S-expression) in the fas, or nil if the proof is
 invalid, or stop to stop everything.

]]]]]

[
 This expression searches for an elegant expression
 that is larger than it is and returns the value of
 that expression as its own value.
]

define expression  [Formal Axiomatic System #1]
       let (fas n) if = n 1 '(is-elegant x)
                   if = n 2  nil
                   if = n 3 '(is-elegant yyy)
                   [else]    stop

       let (loop n)
           let theorem [be] display (fas n)
           if = nil theorem [then] (loop + n 1)
           if = stop theorem [then] fas-has-stopped
           if = is-elegant car theorem
              if > display size cadr theorem
                   display + 356 size fas
                 [return] eval cadr theorem
              [else] (loop + n 1)
           [else] (loop + n 1)

       (loop 1)

define      expression
value       ((' (lambda (fas) ((' (lambda (loop) (loop 1))) ('
             (lambda (n) ((' (lambda (theorem) (if (= nil theo
            rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s
            topped (if (= is-elegant (car theorem)) (if (> (di
            splay (size (car (cdr theorem)))) (display (+ 356
            (size fas)))) (eval (car (cdr theorem))) (loop (+
            n 1))) (loop (+ n 1))))))) (display (fas n))))))))
             (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if
             (= n 2) nil (if (= n 3) (' (is-elegant yyy)) stop
            ))))))

[Show that this expression knows its own size.]

size expression

expression  (size expression)
value       456

[
 Run #1.

 Here it doesn't find an elegant expression
 larger than it is:
]

eval expression

expression  (eval expression)
display     (is-elegant x)
display     1
display     456
display     ()
display     (is-elegant yyy)
display     3
display     456
display     stop
value       fas-has-stopped

define expression  [Formal Axiomatic System #2]
       let (fas n) if = n 1 '(is-elegant x)
                   if = n 2  nil
                   if = n 3 '(is-elegant yyy)
                   if = n 4  cons is-elegant
                             cons ^ 10 509     [<=====]
                                  nil
                   [else]    stop

       let (loop n)
           let theorem [be] display (fas n)
           if = nil theorem [then] (loop + n 1)
           if = stop theorem [then] fas-has-stopped
           if = is-elegant car theorem
              if > display size cadr theorem
                   display + 356 size fas
                 [return] eval cadr theorem
              [else] (loop + n 1)
           [else] (loop + n 1)

       (loop 1)

define      expression
value       ((' (lambda (fas) ((' (lambda (loop) (loop 1))) ('
             (lambda (n) ((' (lambda (theorem) (if (= nil theo
            rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s
            topped (if (= is-elegant (car theorem)) (if (> (di
            splay (size (car (cdr theorem)))) (display (+ 356
            (size fas)))) (eval (car (cdr theorem))) (loop (+
            n 1))) (loop (+ n 1))))))) (display (fas n))))))))
             (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if
             (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if
            (= n 4) (cons is-elegant (cons (^ 10 509) nil)) st
            op)))))))

[Show that this expression knows its own size.]

size expression

expression  (size expression)
value       509

[
 Run #2.

 Here it finds an elegant expression
 exactly one character larger than it is:
]

eval expression

expression  (eval expression)
display     (is-elegant x)
display     1
display     509
display     ()
display     (is-elegant yyy)
display     3
display     509
display     (is-elegant 10000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            0000000000000000000000)
display     510
display     509
value       10000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            0000000000

define expression  [Formal Axiomatic System #3]
       let (fas n) if = n 1 '(is-elegant x)
                   if = n 2  nil
                   if = n 3 '(is-elegant yyy)
                   if = n 4  cons is-elegant
                             cons ^ 10 508     [<=====]
                                  nil
                   [else]    stop

       let (loop n)
           let theorem [be] display (fas n)
           if = nil theorem [then] (loop + n 1)
           if = stop theorem [then] fas-has-stopped
           if = is-elegant car theorem
              if > display size cadr theorem
                   display + 356 size fas
                 [return] eval cadr theorem
              [else] (loop + n 1)
           [else] (loop + n 1)

       (loop 1)

define      expression
value       ((' (lambda (fas) ((' (lambda (loop) (loop 1))) ('
             (lambda (n) ((' (lambda (theorem) (if (= nil theo
            rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s
            topped (if (= is-elegant (car theorem)) (if (> (di
            splay (size (car (cdr theorem)))) (display (+ 356
            (size fas)))) (eval (car (cdr theorem))) (loop (+
            n 1))) (loop (+ n 1))))))) (display (fas n))))))))
             (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if
             (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if
            (= n 4) (cons is-elegant (cons (^ 10 508) nil)) st
            op)))))))

[Show that this expression knows its own size.]

size expression

expression  (size expression)
value       509

[
 Run #3.

 Here it finds an elegant expression
 exactly the same size as it is:
]

eval expression

expression  (eval expression)
display     (is-elegant x)
display     1
display     509
display     ()
display     (is-elegant yyy)
display     3
display     509
display     (is-elegant 10000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            000000000000000000000)
display     509
display     509
display     stop
value       fas-has-stopped

define expression  [Formal Axiomatic System #4]
       let (fas n) if = n 1 '(is-elegant x)
                   if = n 2  nil
                   if = n 3 '(is-elegant yyy)
                   if = n 4  cons is-elegant
                             cons cons "-
                                  cons ^ 10 600  [<=====]
                                  cons 1
                                       nil
                                  nil
                   [else]    stop

       let (loop n)
           let theorem [be] display (fas n)
           if = nil theorem [then] (loop + n 1)
           if = stop theorem [then] fas-has-stopped
           if = is-elegant car theorem
              if > display size cadr theorem
                   display + 356 size fas
                 [return] eval cadr theorem
              [else] (loop + n 1)
           [else] (loop + n 1)

       (loop 1)

define      expression
value       ((' (lambda (fas) ((' (lambda (loop) (loop 1))) ('
             (lambda (n) ((' (lambda (theorem) (if (= nil theo
            rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s
            topped (if (= is-elegant (car theorem)) (if (> (di
            splay (size (car (cdr theorem)))) (display (+ 356
            (size fas)))) (eval (car (cdr theorem))) (loop (+
            n 1))) (loop (+ n 1))))))) (display (fas n))))))))
             (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if
             (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if
            (= n 4) (cons is-elegant (cons (cons - (cons (^ 10
             600) (cons 1 nil))) nil)) stop)))))))

[Show that this expression knows its own size.]

size expression

expression  (size expression)
value       538

[
 Run #4.

 Here it finds an elegant expression
 much larger than it is, and evaluates it:
]

eval expression

expression  (eval expression)
display     (is-elegant x)
display     1
display     538
display     ()
display     (is-elegant yyy)
display     3
display     538
display     (is-elegant (- 10000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            00000000000000000000000000000000000000000000000000
            0000000000000000 1))
display     607
display     538
value       99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999
            99999999999999999999999999999999999999999999999999

End of LISP Run

Elapsed time is 0 seconds.


setwd("/projectnb/talbot-lab-data/NEFI_data/metagenomes/sunbeam-stable/extensions/sbx_report")
install.packages("rmarkdown")
rmarkdown::render("example.html")
download.file("example.html")
library(reshape2)
library(ggplot2)

#bart sample <- 769473 reads
#DSNY sample <- 5796356 reads
#OSBS sample <- 2764342 reads
#SCBI sample <- 2169130 reads
#WOOD sample <- 725509 reads

i <- 1
genes.norm <- trans2

while (i < 69) {
  #SCBI
  genes.norm[1,i] <- (genes.norm[1,i]/2169130)*1000000
  #DSNY
  genes.norm[2,i] <- (genes.norm[1,i]/5796356)*1000000
  #BART
  genes.norm[3,i] <- (genes.norm[1,i]/769473)*1000000
  #OSBS
  genes.norm[4,i] <- (genes.norm[1,i]/5796356)*1000000
  #WOOD
  genes.norm[5,i] <- (genes.norm[1,i]/725509)*1000000
  i <- i + 1
}

df <- as.data.frame(genes.norm)
library(dplyr)
df <- tibble::rownames_to_column(df, "Sample")
df[1,1] <- "SCBI"
df[2,1] <- "DSNY"
df[3,1] <- "BART"
df[4,1] <- "OSBS"
df[5,1] <- "WOOD"
df_long <- melt(df, id.vars = "Sample", variable.name = "Gene")

plot1 <- ggplot(df_long, aes(x = Sample, y = value, fill = Gene)) +
  geom_bar(stat = "identity", position="stack", colour = "black")


library(tidyverse)
library(lubridate)

reported_cases <- read_csv("E:\\Pythonfiles\\Github_Programs\\EstmatingRtDeepL\\Rt_Methods_Comparision\\ontario_cases.csv")
reported_cases$date <- ymd(reported_cases$date)
head(reported_cases)

home_path = "E:\\Pythonfiles\\Github_Programs\\EstmatingRtDeepL\\Rt_Methods_Comparision"
epinow2_Rt_data <- read_csv(file.path(home_path,"ontario_epinow2_Rt.csv"))
epinow2_It_data <- read_csv(file.path(home_path,"ontario_epinow2_It.csv"))
epiestime_Rt_data <- read_csv(file.path(home_path,"ontario_epiestim_Rt.csv"))
epiestime_It_data <- read_csv(file.path(home_path,"ontario_epiestim_It.csv"))
kalman_Rt_data <- read_csv(file.path(home_path,"ontario_kalmanfilter_Rt.csv"))
dl_data <- read_csv(file.path(home_path,"ontario_DL_export.csv"))

ontario <- tibble(date = reported_cases[7:143,"date"]$date)
ontario$case <- dl_data[7:143,"case"]$case
ontario$DeepLearningRt <- dl_data[7:143,"DLRt"]$DLRt
ontario$EpiEstimRt <- epiestime_Rt_data[7:143,]$`Mean(R)`
ontario$EpiNow2Rt <- epinow2_Rt_data[7:143,]$mean
ontario$KalmanRt <- kalman_Rt_data[7:143,]$Rt
ontario$DeepLearningIt <- dl_data[7:143,]$DLdaily
ontario$EpiEstimIt <- epiestime_It_data[7:143,]$`epiestim_res_lit$I_local`
ontario$EpiNow2It <- epinow2_It_data[7:143,]$mean
ontario$EmsembleRt <- (dl_data[7:143,"DLRt"]$DLRt + epiestime_Rt_data[7:143,]$`Mean(R)`+ epinow2_Rt_data[7:143,]$mean)/3
ontario$EmsembleIt <- (dl_data[7:143,]$DLdaily + epiestime_It_data[7:143,]$`epiestim_res_lit$I_local`+ epinow2_It_data[7:143,]$mean)/3
head(ontario)
write.csv(ontario,"DataSum.csv")

ggplot(ontario, aes(x = 1:length(date), y = case)) + geom_point()+labs(x = "Days after March 1", y = "Daily Cases")


 DSPSV Example Program Results

 Solution
       -5.0000    -2.0000     1.0000     4.0000

 Details of the factorization
             1          2          3          4
 1      0.4074     0.3031    -0.5960     0.6537
 2                -2.5907     0.8115     0.2230
 3                            1.1500     4.2000
 4                                       2.0700

 Pivot indices
           1          2         -2         -2


#install.packages("dplyr")
library(ggplot2)
library(dplyr)

dataframe <- read.csv(file="variability.dat" ,head=TRUE,sep="\t")
initial_deployment <- tbl_df(dataframe) %>%
  #filter(dam_updated_0 < 10000000 ) %>%
  group_by(variability, bundles_count) %>%
  summarise(avg_time = mean( ( dam_updated_3 )/1000000),  std=sd(( dam_updated_3 )/1000000))

#data <- read.csv(file="plan_size_vs_time.dat" ,head=TRUE,sep="\t")
setEPS()
postscript("exp3.eps")
ggplot(data = initial_deployment, aes(x=bundles_count, y=avg_time, group=factor(variability),color=factor(variability))) + geom_line() + scale_colour_hue(l=20) +  labs(x = "Size", y="Time(ms)", group="a") + guides(col = guide_legend(title="Variability", reverse = TRUE))
dev.off()


##########################################
# simple demo of building sequence rules
##########################################

library(arulesSequences)
library("readr")

##load training data and modify
train_clicks <- read_csv("RecSys/data_cleaned/train.csv",
                         col_types = cols(X1 = col_skip(), cat = col_character(),
                                          itemID = col_character(), sessionID = col_character(),
                                          status = col_logical(), ts = col_datetime(format = "%Y-%m-%dT%H:%M:%OS%Z")))

data <- read_baskets(con = "./"RecSys/data_cleaned/train.csv", info = c("sequenceID","eventID","SIZE"))

as(head(data), "data.frame") # view first few rows of the data

seqs <- cspade(data, parameter = list(support = 0.1), control = list(verbose = TRUE))
as(seqs,"data.frame")  # view the sequences

rules <- ruleInduction(seqs, confidence = 0.5,control = list(verbose = TRUE))
as(rules,"data.frame")  # view the rules


library("testthat")
source("../equalSizedBins.r")
varlogfile <- "test.log"

# q1 == minX and q2 == minXX
x1Binned <- equalSizedBins(rbind(1,1,1,1,1,2,2,2,3,3), varlogfile)
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,1,2,2))

# q1 == minX and q2 == maxXX
x1Binned <- equalSizedBins(rbind(1,1,1,1,1,2,2,3,3,3), varlogfile)
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,2,2,2))

# q1 == minX and normal split
x1Binned <- equalSizedBins(rbind(1,1,1,1,1,2,3,4,5,6), varlogfile)
expect_equal(x1Binned, rbind(0,0,0,0,0,1,1,2,2,2))

# q3 == maxX and q1 == minXX
x1Binned <- equalSizedBins(rbind(1,1,1,2,2,3,3,3,3,3), varlogfile)
expect_equal(x1Binned, rbind(0,0,0,1,1,2,2,2,2,2))

# q3 == maxX and q1 == maxXX
x1Binned <- equalSizedBins(rbind(1,1,2,2,2,3,3,3,3,3), varlogfile)
expect_equal(x1Binned, rbind(0,0,1,1,1,2,2,2,2,2))

# q3 == maxX and q1 == maxXX
x1Binned <- equalSizedBins(rbind(1,2,3,4,5,6,6,6,6,6), varlogfile)
expect_equal(x1Binned, rbind(0,0,1,1,1,2,2,2,2,2))

# q1==q2
x1Binned <- equalSizedBins(rbind(1,2,2,2,2,2,2,2,2,3), varlogfile)
expect_equal(x1Binned, rbind(0,1,1,1,1,1,1,1,1,2))

# main case - nicely separates into 3 bins
x1Binned <- equalSizedBins(rbind(1,2,3,4,5,6,7,8,9,10), varlogfile)
expect_equal(x1Binned, rbind(0,0,0,1,1,1,2,2,2,2))


context("icount iterator: Infinite sequence")

test_that("icount's default values generate the sequence 0, 1, 2, ..", {
  it <- icount()

  i <- nextElem(it)
  expect_equal(i, 0)

  i <- nextElem(it)
  expect_equal(i, 1)

  i <- nextElem(it)
  expect_equal(i, 2)

  i <- nextElem(it)
  expect_equal(i, 3)
})

test_that("icount works with a given initial value", {
  it <- icount(start=42)

  i <- nextElem(it)
  expect_equal(i, 42)

  i <- nextElem(it)
  expect_equal(i, 43)

  i <- nextElem(it)
  expect_equal(i, 44)

  i <- nextElem(it)
  expect_equal(i, 45)
})

test_that("icount works with a decimal step size", {
  it <- icount(start=42, step=1.5)

  i <- nextElem(it)
  expect_equal(i, 42)

  i <- nextElem(it)
  expect_equal(i, 43.5)

  i <- nextElem(it)
  expect_equal(i, 45)

  i <- nextElem(it)
  expect_equal(i, 46.5)
})

test_that("icount works with the optional stop", {
  it <- icount(stop=5)
  expect_equal(0:5, unlist(as.list(it)))
})

test_that("icount works with a given initial value and a stop", {
  it <- icount(start=42, stop=50)
  expect_equal(42:50, unlist(as.list(it)))
})

test_that("icount works with a stop and decimal step size", {
  it <- icount(start=42, step=1.5, stop=50)
  expect_equal(seq(42, 50, by=1.5), unlist(as.list(it)))
})


# Getting started with dplyr within R

# 1. Glimpse at a dataset: provides the details of what the overall dataset looks like
glimpse(counties)

# 2. Select the columns from a dataset using the pipe operator and the select() verb
counties %>%
  # Select the columns
  select(state, county, population, poverty)

# 3. Arranging rows
counties_selected <- counties %>%
  select(state, county, population, private_work, public_work, self_employed)

counties_selected %>%
  # Add a verb to sort in descending order of public_work
  arrange(desc(public_work))

# 4. Filtering for conditions
counties_selected <- counties %>%
  select(state, county, population)

counties_selected %>%
  # Filter for counties with a population above 1000000
  filter(state == 'California' & population > 1000000)

# 5. Filtering and arranging
counties_selected <- counties %>%
  select(state, county, population, private_work, public_work, self_employed)

# Filter for Texas and more than 10000 people; sort in descending order of private_work
counties_selected %>%
  # Filter for Texas and more than 10000 people
  filter(state == 'Texas' & population > 10000) %>%
  # Sort in descending order of private_work
  arrange(desc(private_work))

# 6. Mutate and arranging
counties_selected <- counties %>%
  select(state, county, population, public_work)

# Mutate is used to create a new column
counties_selected %>%
  mutate(public_workers = public_work * population / 100) %>%
  # Sort in descending order of the public_workers column
  arrange(desc(public_workers))

# 7. Mutate a new variable
counties_selected <- counties %>%
  # Select the columns state, county, population, men, and women
  select(state, county, population, men, women)

counties_selected %>%
  # Calculate proportion_women as the fraction of the population made up of women
  mutate(proportion_women = women / population)

# 8. All together, select, filter, mutate and arrange
counties %>%
  # Select the five columns
  select(state, county, population, men, women) %>%
  # Add the proportion_men variable
  mutate(proportion_men = men / population) %>%
  # Filter for population of at least 10,000
  filter(population >= 10000) %>%
  # Arrange proportion of men in descending order
  arrange(desc(proportion_men))


# Test binary steiger

devtools::install_github("MRCIEU/TwoSampleMR")
library(TwoSampleMR)

# Extract data for BMI vs CHD
bmi <- extract_instruments(2)
chd <- extract_outcome_data(bmi$SNP, 7)
dat <- harmonise_data(bmi, chd)

# Calculate variance explained in BMI (using pvals and sample size)
dat$r.exposure <- get_r_from_pn(dat$pval.exposure, dat$samplesize.exposure)

# Calculate variance explained in CHD (using log OR and allele frequencies)
dat$r.outcome <- get_r_from_lor(dat$beta.outcome, dat$eaf.outcome, dat$ncase.outcome, dat$ncontrol.outcome, prevalence=0.4)

# Test causal direction
mr_steiger2(dat$r.exposure, dat$r.outcome, dat$samplesize.exposure, dat$samplesize.outcome)


setwd("~/Google_Drive/L1_Project/Analysis/IWTomics/low_resolution/")
require(IWTomics)

# function to create IWTomicsData object with low resolution features
source('IWTomicsData_low_resolution.r')
# function to perform IWTomics test on low resolution scalar features
test_scalar <- function(data1,data2,mu=0,statistics='mean',probs=0.5,paired=FALSE,B=1000){
  # data1 and data2 matrices with 1 row

  if(statistics=='median'){
    statistics='quantile'
    probs=0.5
  }
  n1=ncol(data1)
  n2=ncol(data2)
  n=n1+n2
  data1=data1-mu
  if(paired){
    exact=(B>=(2^n1))
  }else{
    exact=(B>=choose(n,n1))
  }

  p=nrow(data1)
  result=list(test='2pop',mu=mu)
  data=cbind(data1,data2)

  # Univariate permutations
  message('    Point-wise tests...')
  if(statistics=='mean'){
    T0_plot=rowMeans(data1,na.rm=TRUE)-rowMeans(data2,na.rm=TRUE)
    T0=(T0_plot)^2
  }
  if(statistics=='quantile'){
    T0_plot=apply(data1,1,quantile,probs=probs,na.rm=TRUE)-apply(data2,1,quantile,probs=probs,na.rm=TRUE)
    T0=(T0_plot)^2
    if(is.matrix(T0_plot)){
      T0_plot=colSums(T0_plot)
      T0=colSums(T0)
    }
  }
  if(statistics=='variance'){
    T0_plot=apply(data1,1,var,na.rm=TRUE)/apply(data2,1,var,na.rm=TRUE)
    T0=(T0_plot)^2
  }
  if(exact){
    if(paired){
      T_perm=do.call(cbind,lapply(seq_len(n1+1)-1,
                                  function(m){
                                    group_change=combn(n1,m)
                                    T_perm=apply(group_change,2,
                                                 function(change){
                                                   data_perm=data
                                                   data_perm[,c(change,n1+change)]=matrix(data_perm[,c(n1+change,change)],nrow=1)
                                                   if(statistics=='mean')
                                                     return((rowMeans(matrix(data_perm[,seq.int(n1)],nrow=1),na.rm=TRUE)-rowMeans(matrix(data_perm[,n1+seq.int(n2)],nrow=1),na.rm=TRUE))^2)
                                                   if(statistics=='quantile'){
                                                     T_perm=(apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,quantile,probs=probs,na.rm=TRUE)-apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,quantile,probs=probs,na.rm=TRUE))^2
                                                     if(is.matrix(T_perm))
                                                       return(colSums(T_perm))
                                                     return(T_perm)
                                                   }
                                                   if(statistics=='variance')
                                                     return((apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,var,na.rm=TRUE)/apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,var,na.rm=TRUE))^2)
                                                 })
                                    return(T_perm)
                                  }))
    }else{
      first_group=combn(n,n1)
      T_perm=apply(first_group,2,
                   function(group){
                     data_perm=matrix(data[,c(group,setdiff(seq_len(n1+n2),group))],nrow=1)
                     if(statistics=='mean')
                       return((rowMeans(matrix(data_perm[,seq.int(n1)],nrow=1),na.rm=TRUE)-rowMeans(matrix(data_perm[,n1+seq.int(n2)],nrow=1),na.rm=TRUE))^2)
                     if(statistics=='quantile'){
                       T_perm=(apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,quantile,probs=probs,na.rm=TRUE)-apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,quantile,probs=probs,na.rm=TRUE))^2
                       if(is.matrix(T_perm))
                         return(colSums(T_perm))
                       return(T_perm)
                     }
                     if(statistics=='variance')
                       return((apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,var,na.rm=TRUE)/apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,var,na.rm=TRUE))^2)
                   })
    }
  }else{
    T_perm=do.call(cbind,lapply(seq.int(B-1),
                                function(perm){
                                  if(paired){
                                    couple.perm=rbinom(n1,1,0.5)
                                    data_perm=matrix(data[,c(n1*couple.perm,-n1*couple.perm)+seq.int(2*n1)],nrow=1)
                                  }else{
                                    permutation=sample(n,n1)
                                    data_perm=matrix(data[,c(permutation,setdiff(seq_len(n),permutation))],nrow=1)
                                  }
                                  if(statistics=='mean')
                                    return((rowMeans(matrix(data_perm[,seq.int(n1)],nrow=1),na.rm=TRUE)-rowMeans(matrix(data_perm[,n1+seq.int(n2)],nrow=1),na.rm=TRUE))^2)
                                  if(statistics=='quantile'){
                                    T_perm=(apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,quantile,probs=probs,na.rm=TRUE)-apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,quantile,probs=probs,na.rm=TRUE))^2
                                    if(is.matrix(T_perm))
                                      return(colSums(T_perm))
                                    return(T_perm)
                                  }
                                  if(statistics=='variance')
                                    return((apply(matrix(data_perm[,seq.int(n1)],nrow=1),1,var,na.rm=TRUE)/apply(matrix(data_perm[,n1+seq.int(n2)],nrow=1),1,var,na.rm=TRUE))^2)
                                }))
    T_perm=cbind(T_perm,T0)
  }

  # Not fully computable p-values (some permutations do not produce any test statistics because of the NAs)
  if(statistics=='variance'){
    no.pval=rowSums(is.na(data))>=(min(n1,n2)-1)
  }else{
    no.pval=rowSums(is.na(data))>=min(n1,n2)
  }
  #T_perm[no.pval,]=NaN # do not compute any p-value when it is not fully computable
  # do not compute any p-value if NaN is in T_perm
  #if(statistics!='variance'){
  #  pval=rowSums(T_perm>=T0)/B
  #}else{
  #  pval=pmin(2*rowSums(T_perm>=T0)/B,2*rowSums(T_perm<=T0)/B)
  #}
  # compute p-value omitting NaN
  if(statistics!='variance'){
    pval=rowSums(T_perm>=T0,na.rm=TRUE)/rowSums(!is.nan(T_perm))
  }else{
    pval=pmin(2*rowSums(T_perm>=T0,na.rm=TRUE)/rowSums(!is.nan(T_perm)),2*rowSums(T_perm<=T0,na.rm=TRUE)/rowSums(!is.nan(T_perm)))
  }

  result$T0_plot=T0_plot
  result$unadjusted_pval=pval
  result$exact=exact
  class(result)='ITWomics.2pop'
  return(list(result=result,no.pval=no.pval))
}

# files with datasets and features
datasets=read.table("~/Google_Drive/L1_Project/Analysis/IWTomics/low_resolution/datasets.txt",sep="\t",header=TRUE,stringsAsFactors=FALSE)
features_datasets=read.table("~/Google_Drive/L1_Project/Analysis/IWTomics/low_resolution/features_datasets.txt",sep="\t",header=TRUE,stringsAsFactors=FALSE)

# select low-resoution features
features_datasets=features_datasets[56:62,]

regionsFeatures_new=IWTomicsData(datasets$file,features_datasets[,datasets$id],'center',
                                 datasets$id,datasets$name,features_datasets$id,features_datasets$name,
                                 path='~/Downloads/IWT_lowres/files')
rm(list=setdiff(ls(),c('regionsFeatures_new','test_scalar')))
require(IWTomics)
regionsFeatures=IWTomicsData(regions(regionsFeatures_new),features(regionsFeatures_new),alignment='center',
                             id_regions=idRegions(regionsFeatures_new),name_regions=nameRegions(regionsFeatures_new),
                             id_features=idFeatures(regionsFeatures_new),name_features=nameFeatures(regionsFeatures_new),
                             length_features=lengthFeatures(regionsFeatures_new))
regionsFeatures@metadata=regionsFeatures_new@metadata
save(regionsFeatures,file='L1_low_resolution_complete.RData')

# select only autosomes
load('L1_low_resolution_complete.RData')
index=lapply(regionsFeatures@regions,function(region) seqnames(region)!='chrX')
regionsFeatures@metadata$region_datasets$size=unlist(lapply(index,sum))
regionsFeatures@regions=GRangesList(mapply(function(region,ind) region[ind,],regionsFeatures@regions,index,SIMPLIFY=FALSE))
regionsFeatures@features=lapply(regionsFeatures@features,function(feature) mapply(function(feat,ind) t(as.matrix(feat[,which(ind)])),feature,index,SIMPLIFY=FALSE))
regionsFeatures@length_features=lapply(regionsFeatures@length_features,function(feature) mapply(function(feat,ind) feat[which(ind)],feature,index,SIMPLIFY=FALSE))
validObject(regionsFeatures)
# number of windows in each dataset
lengthRegions(regionsFeatures)
save(regionsFeatures,file='L1_low_resolution_autosomes.RData')

######################
### ONLY AUTOSOMES ###
######################

load('L1_low_resolution_autosomes.RData')
idFeatures_select=c("Dis_Telo","Dis_Cent","Rep_Timing","Average_Recom_Rate","Telomere_Hexamer")
regionsFeatures=regionsFeatures[,idFeatures_select]
regionsFeatures@features=lapply(regionsFeatures@features,function(feat) lapply(feat,function(fe) t(fe)))

pdf('boxplot_low_resolution.pdf',width=10,height=7)
for(idFeature in idFeatures(regionsFeatures)){
  means=unlist(lapply(features(regionsFeatures)[[idFeature]],mean,na.rm=TRUE))
  boxplot(features(regionsFeatures)[[idFeature]],outline=FALSE,range=0.0000001,
          col=c('red','blue','green','gray'),names=nameRegions(regionsFeatures),main=nameFeatures(regionsFeatures)[idFeature])
  points(1:4,means)
}
dev.off()

# clustering using spearman correlation
clustering_spearman <- function(data,file_name,h,labels){
  correlation <- cor(data,method="spearman",use="pairwise.complete.obs");
  abs.corr=as.dist(1-abs(correlation))
  fit <- hclust(abs.corr)
  pdf(paste0("clustering_spearman",file_name,".pdf"),width=12,height=12)
  par(mar=c(4,1,1,14)+0.1)
  library("dendextend")
  dend=as.dendrogram(fit,hang=0.05)
  dend_cut=cutree(dend,h=h)[order.dendrogram(dend)]
  dend_col=rep(1,length(dend_cut))
  cluster=which(table(dend_cut)>1)
  for(k in seq_along(cluster)){
    dend_col[dend_cut==cluster[k]]=k+2
  }
  labels_colors(dend)=dend_col
  labels(dend)=labels[labels(dend)]
  plot(dend,xlab= "1-|Spearman's correlation|", ylab="",main=NULL,cex=0.7,cex.lab=1.5,horiz=TRUE,xlim=c(1,0))
  lines(c(h,h),c(-2,nrow(correlation)+1),col='red',lty='dashed',lwd=2)
  dev.off()
}

# all
features_plot=matrix(unlist(lapply(regionsFeatures@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_spearman(features_plot,"_low_resolution_all",h=0.2,labels=nameFeatures(regionsFeatures))
# de novo
features_plot=matrix(unlist(lapply(regionsFeatures["L1denovo",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_spearman(features_plot,"_low_resolution_denovo",h=0.2,labels=nameFeatures(regionsFeatures))
# polymorphic
features_plot=matrix(unlist(lapply(regionsFeatures["L1Pol",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_spearman(features_plot,"_low_resolution_pol",h=0.2,labels=nameFeatures(regionsFeatures))
# human specific
features_plot=matrix(unlist(lapply(regionsFeatures["L1HS",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_spearman(features_plot,"_low_resolution_hs",h=0.2,labels=nameFeatures(regionsFeatures))
# control
features_plot=matrix(unlist(lapply(regionsFeatures["Control",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_spearman(features_plot,"_low_resolution_controls",h=0.2,labels=nameFeatures(regionsFeatures))

# clustering using pearson correlation
clustering_pearson <- function(data,file_name,h,labels){
  correlation <- cor(data,method="pearson",use="pairwise.complete.obs");
  abs.corr=as.dist(1-abs(correlation))
  fit <- hclust(abs.corr)
  pdf(paste0("clustering_pearson",file_name,".pdf"),width=12,height=12)
  par(mar=c(4,1,1,14)+0.1)
  library("dendextend")
  dend=as.dendrogram(fit,hang=0.05)
  dend_cut=cutree(dend,h=h)[order.dendrogram(dend)]
  dend_col=rep(1,length(dend_cut))
  cluster=which(table(dend_cut)>1)
  for(k in seq_along(cluster)){
    dend_col[dend_cut==cluster[k]]=k+2
  }
  labels_colors(dend)=dend_col
  labels(dend)=labels[labels(dend)]
  plot(dend,xlab= "1-|Pearson's correlation|", ylab="",main=NULL,cex=0.7,cex.lab=1.5,horiz=TRUE,xlim=c(1,0))
  lines(c(h,h),c(-2,nrow(correlation)+1),col='red',lty='dashed',lwd=2)
  dev.off()
}

# all
features_plot=matrix(unlist(lapply(regionsFeatures@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_pearson(features_plot,"_low_resolution_all",h=0.2,labels=nameFeatures(regionsFeatures))
# de novo
features_plot=matrix(unlist(lapply(regionsFeatures["L1denovo",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_pearson(features_plot,"_low_resolution_denovo",h=0.2,labels=nameFeatures(regionsFeatures))
# polymorphic
features_plot=matrix(unlist(lapply(regionsFeatures["L1Pol",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_pearson(features_plot,"_low_resolution_pol",h=0.2,labels=nameFeatures(regionsFeatures))
# human specific
features_plot=matrix(unlist(lapply(regionsFeatures["L1HS",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_pearson(features_plot,"_low_resolution_hs",h=0.2,labels=nameFeatures(regionsFeatures))
# control
features_plot=matrix(unlist(lapply(regionsFeatures["Control",]@features,unlist)),ncol=nFeatures(regionsFeatures))
colnames(features_plot)=idFeatures(regionsFeatures)
clustering_pearson(features_plot,"_low_resolution_controls",h=0.2,labels=nameFeatures(regionsFeatures))

#################### IWTomics test ####################
M=matrix(NA,nrow=nRegions(regionsFeatures),ncol=nRegions(regionsFeatures))
rownames(M)=idRegions(regionsFeatures)
colnames(M)=idRegions(regionsFeatures)
M=list(M=M)

result_mean=rep(M,nFeatures(regionsFeatures))
names(result_mean)=idFeatures(regionsFeatures)
for(idFeature in idFeatures(regionsFeatures)){
  message(nameFeatures(regionsFeatures)[idFeature])
  message('De novo vs Control')
  result_mean[[idFeature]][1,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$Control,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][1,4])
  message('Polymorphic vs Control')
  result_mean[[idFeature]][2,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$Control,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][2,4])
  message('Human specific vs Control')
  result_mean[[idFeature]][3,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1HS,features(regionsFeatures)[[idFeature]]$Control,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][3,4])
  message('De novo vs Polymorphic')
  result_mean[[idFeature]][1,2]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1Pol,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][1,2])
  message('De novo vs Human specific')
  result_mean[[idFeature]][1,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1HS,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][1,3])
  message('Polymorphic vs Human specific')
  result_mean[[idFeature]][2,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$L1HS,B=10000)$result$unadjusted_pval
  message(result_mean[[idFeature]][2,3])
}
save(result_mean,file='L1_low_resolution_results_mean.RData')

result_mean$Dis_Telo
result_mean$Dis_Cent
result_mean$Rep_Timing
result_mean$Average_Recom_Rate
result_mean$Telomere_Hexamer

### IWTomics tests for median and quantiles (not shown in the current study)
# result_median=rep(M,nFeatures(regionsFeatures))
# names(result_median)=idFeatures(regionsFeatures)
# for(idFeature in idFeatures(regionsFeatures)){
#   message(nameFeatures(regionsFeatures)[idFeature])
#   message('De novo vs Control')
#   result_median[[idFeature]][1,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$Control,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][1,4])
#   message('Polymorphic vs Control')
#   result_median[[idFeature]][2,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$Control,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][2,4])
#   message('Human specific vs Control')
#   result_median[[idFeature]][3,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1HS,features(regionsFeatures)[[idFeature]]$Control,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][3,4])
#   message('De novo vs Polymorphic')
#   result_median[[idFeature]][1,2]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1Pol,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][1,2])
#   message('De novo vs Human specific')
#   result_median[[idFeature]][1,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1HS,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][1,3])
#   message('Polymorphic vs Human specific')
#   result_median[[idFeature]][2,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$L1HS,statistics="median",B=10000)$result$unadjusted_pval
#   message(result_median[[idFeature]][2,3])
# }
# save(result_median,file='L1_low_resolution_results_median.RData')
#
# result_variance=rep(M,nFeatures(regionsFeatures))
# names(result_variance)=idFeatures(regionsFeatures)
# for(idFeature in idFeatures(regionsFeatures)){
#   message(nameFeatures(regionsFeatures)[idFeature])
#   message('De novo vs Control')
#   result_variance[[idFeature]][1,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$Control,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][1,4])
#   message('Polymorphic vs Control')
#   result_variance[[idFeature]][2,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$Control,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][2,4])
#   message('Human specific vs Control')
#   result_variance[[idFeature]][3,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1HS,features(regionsFeatures)[[idFeature]]$Control,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][3,4])
#   message('De novo vs Polymorphic')
#   result_variance[[idFeature]][1,2]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1Pol,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][1,2])
#   message('De novo vs Human specific')
#   result_variance[[idFeature]][1,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1HS,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][1,3])
#   message('Polymorphic vs Human specific')
#   result_variance[[idFeature]][2,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$L1HS,statistics="variance",B=10000)$result$unadjusted_pval
#   message(result_variance[[idFeature]][2,3])
# }
# save(result_variance,file='L1_low_resolution_results_variance.RData')
#
# result_quantile=rep(M,nFeatures(regionsFeatures))
# names(result_quantile)=idFeatures(regionsFeatures)
# for(idFeature in idFeatures(regionsFeatures)){
#   message(nameFeatures(regionsFeatures)[idFeature])
#   message('De novo vs Control')
#   result_quantile[[idFeature]][1,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$Control,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][1,4])
#   message('Polymorphic vs Control')
#   result_quantile[[idFeature]][2,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$Control,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][2,4])
#   message('Human specific vs Control')
#   result_quantile[[idFeature]][3,4]=test_scalar(features(regionsFeatures)[[idFeature]]$L1HS,features(regionsFeatures)[[idFeature]]$Control,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][3,4])
#   message('De novo vs Polymorphic')
#   result_quantile[[idFeature]][1,2]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1Pol,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][1,2])
#   message('De novo vs Human specific')
#   result_quantile[[idFeature]][1,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1denovo,features(regionsFeatures)[[idFeature]]$L1HS,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][1,3])
#   message('Polymorphic vs Human specific')
#   result_quantile[[idFeature]][2,3]=test_scalar(features(regionsFeatures)[[idFeature]]$L1Pol,features(regionsFeatures)[[idFeature]]$L1HS,statistics="quantile",probs=0.9,B=10000)$result$unadjusted_pval
#   message(result_quantile[[idFeature]][2,3])
# }
# save(result_quantile,file='L1_low_resolution_results_quantile_90.RData')
#


# Packages ----------------------------------------------------------------
library(EpiNow2)
library(data.table)
library(future)
library(here)

# Save incubation period and generation time ------------------------------
# generation time from: https://www.medrxiv.org/content/10.1101/2020.09.04.20188516v2.full.pdf
# gamma distribution in SI: https://www.medrxiv.org/content/medrxiv/suppl/2020/09/16/2020.09.04.20188516.DC2/2020.09.04.20188516-1.pdf
shape <- 6.8004
rate <- 1.2344
generation_time <- list(mean = shape / rate,
                        mean_sd = 0.5,
                        sd = sqrt(shape) / rate,
                        sd_sd = 0.25,
                        max = 15)
print("Generation time parameters (gamma)")
print(generation_time)
saveRDS(generation_time , here::here("data-raw", "data", "generation_time.rds"))

incubation_period <- get_incubation_period(disease = "SARS-CoV-2", source = "lauer")
print("Incubation period parameters (log normal)")
print(incubation_period)
saveRDS(incubation_period, here::here("data-raw", "data", "incubation_period.rds"))

# Fit Report distribution -------------------------------------------------
# use an approximate delay distribution based on local knowledge
# truncate the distribution at 30 days
reporting_delay <- list(mean = 1.25,
                        means_sd = 0.05,
                        sd = 1,
                        sd_sd = 0.05)
saveRDS(reporting_delay, here::here("data-raw", "data", "reporting_delay.rds"))

print("Reporting delay parameters (log normal)")
print(reporting_delay)


library(WGCNA)
options(stringsAsFactors = FALSE)
enableWGCNAThreads()

args = commandArgs(trailingOnly=TRUE)

#***********************************step1 cluster Sample*************************************
prefix = strsplit(args[1], '.', fixed=TRUE)[[1]][1]
d=read.table(args[1],sep="\t",header=T,check.names=F, row.names=1)
#d=d[1:10000,]
datExpr = t(d)

gsg = goodSamplesGenes(datExpr, verbose = 3)
if (!gsg$allOK)
{
if (sum(!gsg$goodGenes)>0)
	printFlush(paste("Removing genes:", paste(names(datExpr)[!gsg$goodGenes], collapse = ", ")))
if (sum(!gsg$goodSamples)>0)
	printFlush(paste("Removing samples:", paste(rownames(datExpr)[!gsg$goodSamples], collapse = ", ")))
	datExpr = datExpr[gsg$goodSamples, gsg$goodGenes]
}
#write.table(names(datExpr)[!gsg$goodGenes], file="removeGene.xls", row.names=FALSE, col.names=FALSE, quote=FALSE)
#write.table(names(datExpr)[!gsg$goodSamples], file="removeSample.xls", row.names=FALSE, col.names=FALSE, quote=FALSE)

sampleTree = hclust(dist(datExpr), method = "average")
pdf(file = paste(prefix,"sampleClustering.pdf", sep='_'), width = 12, height = 9)
par(cex = 0.6)
par(mar = c(0,4,2,0))
plot(sampleTree, main = "Sample clustering", sub="", xlab="", cex.lab = 1.5, cex.axis = 1.5, cex.main = 2)
dev.off()

#***********************************step2  Choosing the soft threshold beta via scale free topology*************************************

powers = c(c(1:10), seq(from = 12, to=20, by=2))
#sft = pickSoftThreshold(datExpr, powerVector = powers, verbose = 5)
sft=pickSoftThreshold(datExpr,dataIsExpr = TRUE,powerVector = powers,corFnc = cor,corOptions = list(use = 'p'),networkType = "unsigned")

pdf(file=paste(prefix,'pickSoftThreshold.pdf', sep='_'), wi=12, he=9)
par(mfrow = c(1,2))
cex1 = 0.9
# Plot the results:
par(mfrow = c(1, 2))
# SFT index as a function of different powers
plot(sft$fitIndices[,1], -sign(sft$fitIndices[, 3])*sft$fitIndices[, 2], xlab = "Soft Threshold (power)", ylab = "Scale Free Topology Model Fit, signed R^2", type = "n", main = paste("Scale independence"))
text(sft$fitIndices[, 1], -sign(sft$fitIndices[, 3]) * sft$fitIndices[, 2], labels = powers, col = "red")
# this line corresponds to using an R^2 cut-off of h
abline(h = 0.9, col = "red")
# Mean connectivity as a function of different powers
plot(sft$fitIndices[, 1], sft$fitIndices[, 5], type = "n", xlab = "Soft Threshold (power)", ylab = "Mean Connectivity", main = paste("Mean connectivity"))
text(sft$fitIndices[, 1], sft$fitIndices[, 5], labels = powers, col = "red")

dev.off()
save(datExpr, file='datExpr.RData')


getPower=function(wx,nodes,wf)
{
  # sum contributions
  power=0;
  l=length(nodes)

  for (j in 2:l)
  {

      # index for wavelets coefficients returned by waveslim::modwt
      depth=nodes[[j]][1]
      numberNode=nodes[[j]][2]
      index=sum(2^(1:depth-1))+numberNode;
      power=align(wx[[index]]^2,depth,numberNode,wf)+power;

  }

  return(power);
}


hoge <- read.csv("synthesized_info.csv")
dead <- subset(hoge, status == "dead")
arrive <- subset(hoge, status == "arrive")
library(ggplot2)
ggplot(data=hoge, aes(x=hoge$lifetime, y=hoge$co.evolution.rate, colour=hoge$status), xlab("lifetime")) + geom_point(aes(size=hoge$average.bug, alpha=.5)) + scale_size_continuous(range = c(2, 10)) + labs(size="size", x="lifetime", y="degree of co-evolution", alpha="alpha", colour="status")

ggplot(data=hoge, aes(x=hoge$lifetime, y=hoge$co.evolution.rate, colour=hoge$status), xlab("lifetime")) + geom_point(aes(size=hoge$average.bug, alpha=.5)) + scale_size_continuous(range = c(2, 10)) + labs(size="size", x="lifetime", y="degree of co-evolution", alpha="alpha", colour="status") + geom_vline(xintercept = median(hoge$lifetime)) + geom_hline(yintercept = median(hoge$co.evolution.rate))


# depends on TP-FP-yeast-setup.r

#https://www.andifugard.info/cohens-u1-u2-and-u3/
eff <- c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1, 1.2, 1.4, 1.6, 1.8, 2, 2.5, 3, 4)

prob <- c(0.50,0.54,0.58,0.62,0.66,0.69,0.73,0.76,0.79,0.82,0.84,0.88,0.92,0.945,0.964,0.977,0.99,0.999,0.99997)

pdf('null-effect.pdf', height=4.5, width=8.5)
par(mfrow=c(1,2))

plot(x.e$effect, x.t$wi.eBH, pch=19, col=rgb(0,0,1,0.2), log='y', xlim=c(-1.5,1.5),
   ylim=c(1e-10, 1), xlab="Effect size", ylab="Adjusted p-value", main='A')
points(x.e$effect, x.t$we.eBH, pch=19, col=rgb(1,0,0,0.2))
abline(h=0.1, lty=2, lwd=2, col='grey')
legend(-0.5, 1e-7,legend=c('Wilcoxon',"Welch's t"),pch=19, col=c("blue", "red"))

plot(abs(x.e$effect), x.e$overlap, pch=19, cex=0.2, col=rgb(0,0.5,1,0.2), xlim=c(0,4), xlab="Effect size", ylab="Overlap", main='B')
points(abs(t.e$effect), t.e$overlap, pch=19, cex=0.4, col=rgb(1,.6,0,0.2))
points(eff, 1-prob, col="red", pch=1, type='b', lwd=1.5)

dev.off()


library(tidyverse)
library(readxl)
library(lme4)
library(mosaic)
library(rstanarm)

dat0 <- read_excel('data/ASSISTment_merge_2021_04_12_N=1,587_ver.02.xlsx')
dat <- read_csv('data/IES_assessment_final_2021_06_03_N=4284 - Sheet1.csv')
dat0$student_number <- gsub("\\.0",'',dat0$student_number)

dat <- filter(dat,student_number%in%dat0$student_number)%>%
    rename(condition=condition_assignment)

dat$race <- dat$student_raceEthnicityFed%>%
    factor()%>%
    fct_lump_min(200)%>%
    fct_recode(`Hispanic/Latino`="1",Asian="3",White="6")%>%
    fct_relevel('White') ## make White (the biggest category) the reference

### check that prob level sums to total
all.equal(rowSums(select(dat,starts_with("correct.01_"))),dat$pre.total_math_score)
all.equal(rowSums(select(dat,starts_with("correct.06_"))),dat$mid.total_math_score)

datLongPre <- smallDat%>%
    select(student_number,starts_with("correct.01_"))%>%
    pivot_longer(cols=-student_number,names_to='prob',values_to='pre',names_prefix='correct.01_')%>%
    mutate(prob=substr(prob,1,2))

datLongMid <- smallDat%>%
    select(student_number,starts_with("correct.06_"))%>%
    pivot_longer(cols=-student_number,names_to='prob',values_to='mid',names_prefix='correct.06_')%>%
    mutate(prob=substr(prob,1,2))

datLong <-
    smallDat%>%
    select(student_number,initial_teacher_class,condition,ScaleScore,EIP,ESOL,IEP,FEMALE,GIFTED,race,ScaleScoreMISS,ESOLMISS,raceMISS)%>%
    right_join(datLongPre,by='student_number')%>%
    full_join(datLongMid,by=c('student_number','prob'))

datLong%>%
    group_by(prob,condition)%>%
    summarize(gain=mean(mid)-mean(pre))%>%
    ggplot(aes(condition,gain,fill=condition))+
    geom_hline(yintercept=0)+
    geom_col()+
    facet_wrap(~prob)
ggsave('gainByProb.jpg')

mod0 <- glmer(mid~condition+pre+(1|student_number/initial_teacher_class)+(1|prob),data=datLong,family=binomial)
mod1 <- update(mod0,.~.+ScaleScore)
mod2 <- update(mod1,.~.-(1|prob)+(pre|prob))
an12 <- anova(mod1,mod2)
mod3 <- update(mod2,.~.-(pre|prob)+(pre+condition|prob))
an23 <- anova(mod1,mod2,mod3)
mod4 <- update(mod3,.~.-(pre+condition|prob)+(pre+ScaleScore+condition|prob))
an14 <- anova(mod1,mod2,mod3,mod4)

library(broom.mixed)
sepMods <- datLong%>%
    nest(-prob)%>%
    mutate(
        mod=map(data, ~glmer(mid~condition+pre+ScaleScore+(1|initial_teacher_class),data=.x,family=binomial)),
        mod=map(mod,~tidy(.)%>%filter(term=='conditionInstant'))
    )%>%
    unnest(mod)

library(estimatr)
sepOLS <-  datLong%>%
    nest(-prob)%>%
    mutate(
        mod=map(data, ~lm_robust(mid~condition+pre+ScaleScore,data=.x,fixed_effects=~initial_teacher_class)),
        mod=map(mod,~tidy(.)%>%filter(term=='conditionInstant'))
    )%>%
    unnest(mod)

re3 <- ranef(mod3,condVar=TRUE)
effByProb <- fixef(mod3)['conditionInstant']+re3$prob$condition
pv <- attr(re3$prob,'postVar')
seByProb <- sqrt(summary(mod3)$coef['conditionInstant',2]^2+pv[3,3,])

effs3 <- data.frame(item=rownames(re3$prob),effect=effByProb,seEff=seByProb)%>%
    mutate(signif=ifelse(effect-2*seEff>0,'Positive',ifelse(effect+2*seEff<0,'Negative','Undetermined')))

effs3%>%
    ggplot(aes(item, effect,ymin=effect-2*seEff,ymax=effect+2*seEff))+
    geom_point()+
    geom_errorbar(width=0)+geom_hline(yintercept=0)+
    labs(x='Item',y='Treatment Effect (Logit Scale)',color='Year')
ggsave('effectByProblem.jpg')

re4 <- ranef(mod4,condVar=TRUE)
effByProb <- fixef(mod4)['conditionInstant']+re4$prob$condition
pv <- attr(re4$prob,'postVar')
seByProb <- sqrt(summary(mod4)$coef['conditionInstant',2]^2+pv[4,4,])

data.frame(item=rownames(re4$prob),effect=effByProb,seEff=seByProb)%>%
    mutate(signif=ifelse(effect-2*seEff>0,'Positive',ifelse(effect+2*seEff<0,'Negative','Undetermined')))%>%
    ggplot(aes(item, effect,ymin=effect-2*seEff,ymax=effect+2*seEff))+
    geom_point()+
    geom_errorbar(width=0)+geom_hline(yintercept=0)+
    labs(x='Item',y='Treatment Effect (Logit Scale)',color='Year')
ggsave('effectByProblem4.jpg')

mod3a <- stan_glmer(mid ~ condition + pre  + ScaleScore + (1 | student_number/initial_teacher_class) + (pre + condition | prob),
                   data=datLong,family=binomial(logit))
samp <- as.matrix(mod3a$stanfit)[,grep('condition',rownames(mod3a$stan_summary))]

effsStan <- samp[,rep('conditionInstant',10)]+samp[,paste0('b[conditionInstant prob:',rownames(re3$prob),']')]
colnames(effsStan) <- rownames(re3$prob)

effsStan2 <- apply(effsStan,2,function(x) c(effect=mean(x), seEff=sd(x),quantile(x,c(.025,.975))))%>%
    t()%>%
    as.data.frame()%>%
    rownames_to_column('item')

effStan2%>%
    ggplot(aes(item, effect,ymin=effect-2*seEff,ymax=effect+2*seEff))+
    geom_point()+
    geom_errorbar(width=0)+geom_hline(yintercept=0)+
    labs(x='Item',y='Treatment Effect (Logit Scale)',color='Year')

diffs <- matrix(nrow=10,ncol=10)
for(i in 1:10) for(j in 1:10) diffs[i,j] <- mean(effsStan[,i]>effsStan[,j])
rownames(diffs) <- colnames(diffs) <- effsStan2$item

### is there item-level missingness?
datLong%>%
    group_by(student_number)%>%
    summarize(preNA=mean(is.na(pre)),midNA=mean(is.na(mid)))%>%
    ungroup()%>%
    distinct(preNA,midNA)
## no

mean(is.na(dat0$mid.total_math_score))
mean(is.na(datLong$mid))
mean(is.na(dat0$pre.total_math_score))
mean(is.na(datLong$pre)

datLong%>%

y <- mod3a$y  # matrix of "success" and "failure" counts
trials <- rowSums(y)
y_prop <- y[, 1] / trials  # proportions

# get predicted success proportions
yrep <- posterior_predict(mod3a)
yrep_prop <- sweep(yrep, 2, trials, "/")

ppc_error_binned(y, yrep[1:6, ])


library(a5udes)
library(dplyr)
library(sf)
library(tidygraph)
library(igraph)
library(progress)
library(furrr)

CE=osmdata::getbb(place_name='Ceará', format_out = "sf_polygon") %>% slice(1)

catch=st_read('./data/hybas_sa_lev12_v1c')
catch_ce=catch %>% st_filter(CE)
rm(catch)

catchment_geometry = catch_ce %>% dplyr::select(HYBAS_ID,NEXT_DOWN,SUB_AREA,UP_AREA) %>% st_transform(32724)
save(catchment_geometry,file='data/catchment_geometry.RData')

catchment_graph=catch2graph(catchment_geometry)
save(catchment_graph,file='data/catchment_graph.RData')


# [Contoh Code Market Basket Analysis di R](https://academy.dqlab.id/main/livecode/11/20/625)
# Menggunakan library arules
library(arules)
# Membaca transaksi dari file data_transaksi.txt
transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menampilkan data transaksi dengan print dan inspect
inspect(transaksi)
# Menghasilkan model Market Basket Analysis
mba <- apriori(transaksi,parameter = list(supp = 0.1, confidence = 0.5))
# Menampilkan paket produk
inspect(subset(mba, lift>1))

# [Menampilkan Kombinasi dari Contoh Transaksi "Kecil"](https://academy.dqlab.id/main/livecode/11/21/626)
# Menggunakan library arules
library(arules)
#Membaca transaksi dari file data_transaksi.txt
transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menampilkan jumlah kombinasi dari produk yang terdapat pada daftar transaksi yang ada
inspect(apriori(transaksi, parameter = list(support=.1, minlen=2, target='frequent itemsets')))

# [Menampilkan Kombinasi dari Transaksi "Besar"](https://academy.dqlab.id/main/livecode/11/21/627)
# Menggunakan library arules
library(arules)
# Membaca transaksi dari file data_transaksi2.txt
transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi2.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menampilkan jumlah kombinasi dari produk yang terdapat pada daftar transaksi yang ada
inspect(apriori(transaksi, parameter = list(support=.03, minlen=2, target='frequent itemsets')))

# [Membaca File sebagai Data Frame](https://academy.dqlab.id/main/livecode/11/24/111)
# Membaca file yang berlokasi di https://academy.dqlab.id/dataset/data_transaksi.txt
# dengan fungsi read.csv, dan kemudian disimpan pada variable transaksi_tabular
transaksi_tabular <- read.csv("https://academy.dqlab.id/dataset/data_transaksi.txt", sep="\t")
# Menampilkan variable transaksi_tabular dengan fungsi print
print(transaksi_tabular)

# [Membaca File sebagai Transaction](https://academy.dqlab.id/main/livecode/11/24/115)
library(arules)

read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                  format="single", sep="\t", cols=c(1,2), skip=1)

# [Menampilkan Daftar Item Transaksi](https://academy.dqlab.id/main/livecode/11/24/116)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
transaksi@itemInfo

# [Menampilkan Daftar Kode Transaksi](https://academy.dqlab.id/main/livecode/11/24/117)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
transaksi@itemsetInfo

# [Tampilan Transaksi dalam bentuk Matrix](https://academy.dqlab.id/main/livecode/11/24/119)
library(arules)
transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
transaksi@data

# [Item Frequency](https://academy.dqlab.id/main/livecode/11/24/678)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
itemFrequency(transaksi, type="absolute")

# [Statistik Top 3](https://academy.dqlab.id/main/livecode/11/24/679)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
data_item <- itemFrequency(transaksi, type="absolute")
# Melakukan sorting pada data_item
data_item <- sort(data_item, decreasing = TRUE)
# Mengambil 3 item pertama
data_item <- data_item[1:3]
# Konversi data_item menjadi data frame dengan kolom Nama_Produk dan Jumlah
data_item <- data.frame("Nama Produk"=names(data_item), "Jumlah"=data_item, row.names=NULL)
print(data_item)

# [Output Statistik Top 3 Sebagai File](https://academy.dqlab.id/main/livecode/11/24/680)
library(arules)
transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
data_item <- itemFrequency(transaksi, type="absolute")
# Melakukan sorting pada data_item
data_item <- sort(data_item, decreasing = TRUE)
# Mengambil 3 item pertama
data_item <- data_item[1:3]
# Konversi data_item menjadi data frame dengan kolom Nama_Produk dan Jumlah
data_item <- data.frame("Nama Produk"=names(data_item), "Jumlah"=data_item, row.names=NULL)
# Menulis File Statistik Top 3
write.csv(data_item, file="top3_item_retail.txt", eol = "\r\n")

# [Grafik Item Frequency](https://academy.dqlab.id/main/livecode/11/24/120)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Tampilan item frequency plot
itemFrequencyPlot(transaksi)

# [Melihat Itemset per Transaksi dengan Inspect](https://academy.dqlab.id/main/livecode/11/25/123)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menggunakan inspect terhadap transaksi
inspect(transaksi)

# [Menghasilkan Rules dengan Apriori](https://academy.dqlab.id/main/livecode/11/25/124)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menghasilkan associaton rules
apriori(transaksi)

# [Melihat Rules dengan fungsi inspect](https://academy.dqlab.id/main/livecode/11/25/125)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menghasilkan association rules dan disimpan sebagai variable mba
mba <- apriori(transaksi)
# Melihat isi dari rules dengan menggunakan fungsi inspect
inspect(mba)

# [Filter RHS](https://academy.dqlab.id/main/livecode/11/25/126)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
# Menghasilkan association rules dan disimpan sebagai variable mba
mba <- apriori(transaksi)
# Filter rhs dengan item "Sirup" dan tampilkan
inspect(subset(mba, rhs %in% "Sirup"))

# [Filter LHS](https://academy.dqlab.id/main/livecode/11/25/127)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi)
inspect(subset(mba, lhs %in% "Gula"))

# [Filter LHS dan RHS](https://academy.dqlab.id/main/livecode/11/25/128)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi)
inspect(subset(mba, lhs %in% "Pet Food" & rhs %in% "Sirup"))

# [Menghasilkan Rules dengan Parameter Support dan Confidence](https://academy.dqlab.id/main/livecode/11/26/133)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
apriori(transaksi, parameter = list(supp = 0.1, confidence = 0.5))

# [Inspeksi Rules Yang Dihasilkan](https://academy.dqlab.id/main/livecode/11/26/134)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
apriori(transaksi ,parameter = list(supp = 0.1, confidence = 0.5))
inspect(mba)

# [Filter LHS dan RHS (2)](https://academy.dqlab.id/main/livecode/11/26/135)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi,parameter = list(supp = 0.1, confidence = 0.5))
inspect(subset(mba, lhs %in% "Teh Celup" | rhs %in% "Teh Celup"))

# [Filter berdasarkan Lift](https://academy.dqlab.id/main/livecode/11/26/146)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi,parameter = list(supp = 0.1, confidence = 0.5))
inspect(subset(mba, (lhs %in% "Teh Celup" | rhs %in% "Teh Celup") & lift>1))

# [Rekomendasi - Filter dengan %ain%](https://academy.dqlab.id/main/livecode/11/26/147)
library(arules)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi,parameter = list(supp = 0.1, confidence = 0.5))
inspect(subset(mba, (lhs %ain% c("Pet Food", "Gula" ))))

# [Visualisasi Rules dengan Graph](https://academy.dqlab.id/main/livecode/11/26/148)
library(arules)
library(arulesViz)

transaksi <- read.transactions(file="https://academy.dqlab.id/dataset/data_transaksi.txt",
                               format="single", sep="\t", cols=c(1,2), skip=1)
mba <- apriori(transaksi,parameter = list(supp = 0.1, confidence = 0.5))
plot(subset(mba, lift>1.1), method="graph")

R/Kelas Penerapan/Data Science in Retail Market Basket Analysis/Data Science in Retail Market Basket Analysis.r


# <-- encoding UTF-8 -->
# Empirical study on NHSS dataset (county level)
# -------------------------------------
## DOC STRING
#
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------

# -------------------------------------
## SECTION 0: ENVIRONMENT
library(car)  # qqplots
library(plm)  # panel data models & Hausman test
library(nlme)  # gls estimation
library(nortest)  # normality tests
library(openxlsx)  # easy xlsx IO
source("./src/plottools.r")  # easy plotting tools
source("./src/paneltools.r")  # extra tools for plm package, e.g. formatted summary for MS WORD

# environment par dict
envNHSS$Output <- "./output/proc_3_NHSS/"  # alter output directory

# -------------------------------------
## SECTION 1: (ROBUST) POOL DATA MODEL WITH FGLS & OLS
cat("\nSECTION 1: (ROBUST) POOL DATA MODELS ON NHSS DATASET, ALL FINAL SPECIFICATIONS")
# NOTE: in this section, we seen the panel data set "dfp_NHSS" as a pool dataset,
#       use OLS & GLS to estimate every final specification in li_Eq_NHSS;
# NOTE: if extra normality tests on residuals required, please use the library nortest:: & shapiro.test()

# 1.0 prepare a collection of estimated models
li_ModPoolOLS_NHSS <- list()
li_ModPoolGLS_NHSS <- list()

# 1.1 estimation & print summaries
for(tmpYname in envNHSS$Ynames){
    # slice a temp dataset
    tmpdf <- li_Dat_NHSS[[tmpYname]]
    # 1.1.1 estimation
    li_ModPoolOLS_NHSS[[tmpYname]] <- lm( li_Eq_NHSS[[tmpYname]], tmpdf )
    li_ModPoolGLS_NHSS[[tmpYname]] <- nlme::gls( li_Eq_NHSS[[tmpYname]], tmpdf )
    # 1.1.2 run-time log
    cat("\n---------------------------------------------------------------\n***** FORMULA *****:\n")
    print( li_Eq_NHSS[[tmpYname]] ); print("\n")
    # 1.1.3 print summary
    print( summary( li_ModPoolOLS_NHSS[[tmpYname]] ) )
    print( summary( li_ModPoolGLS_NHSS[[tmpYname]] ) )

}

# -------------------------------------
## SECTION 2: FIXED INDIVIDUAL EFFECT & RANDOM INDIVIDUAL EFFECT MODEL & HAUSSMAN
cat("\nSECTION 2: FIXED INDIVIDUAL EFFECT & RANDOM INDIVIDUAL EFFECT MODEL")
# NOTE: in this section, we estimate fixed INDIVIDUAL effect models & random individual effect models for every health outcome
#
#       using OLS+robustSE for the individual effect models, FGLS estimator for the random effect models;
#
#       then, we performed Haussman test, using both original & robust/auxiliary-regression-based test (Wooldridge (2010));
#       the robust Haussman test can cook possible heterosketasticity (well ... we have used FGLS estimators);
#
# NOTE: based on dfp_NHSS dataset

# 2.0 prepare collections
li_ModFix_NHSS <- list()  # for fixed individual effect models
li_ModRan_NHSS <- list()  # for random individual effect models
df_Haussman_NHSS <- data.frame(
    Equation = envNHSS$Ynames,  # dependents
    Chisq = 0,  # Haussman Statistics (X2)
    pVal_Chisq = 0,  # p-value
    ChisqRobust = 0,  # robust Haussman Statistics (through an auxiliary regression)
    pVal_ChisqRobust = 0  # p-value
)

# 2.1 loop on health outcomes, estimate & perform Haussman test
for(tmpYname in envNHSS$Ynames){
    # slice a temp dataset
    tmpdf <- li_DatPlm_NHSS[[tmpYname]]
    # 2.1.1 fixed effect model (OLS estimator, the robustSE is computed when summary(mod) )
    li_ModFix_NHSS[[tmpYname]] <- plm::plm( li_Eq_NHSS[[tmpYname]], data = tmpdf,
                                              effect = "individual", model = "within" )
    # 2.1.2 random effect model (FGLS estimator)
    li_ModRan_NHSS[[tmpYname]] <- plm::pggls( li_Eq_NHSS[[tmpYname]], data = tmpdf,
                                              effect = "individual", model = "random" )

    # 2.1.3 Haussman test (H0: random effect, if phtest(fixed, random))
    tmp <- plm::phtest( li_ModFix_NHSS[[tmpYname]], li_ModRan_NHSS[[tmpYname]], method = "chisq" )
    df_Haussman_NHSS$Chisq[df_Haussman_NHSS$Equation == tmpYname] <- tmp$statistic
    df_Haussman_NHSS$pVal_Chisq[df_Haussman_NHSS$Equation == tmpYname] <- tmp$p.value
    # 2.1.4 robust Haussman test (H0: random effect)
    tmp <- plm::phtest( li_ModFix_NHSS[[tmpYname]], li_ModRan_NHSS[[tmpYname]], method = "aux",
                        vcov = function(x) plm::vcovHC(x, method="white2",type="HC3")   )
    df_Haussman_NHSS$ChisqRobust[df_Haussman_NHSS$Equation == tmpYname] <- tmp$statistic
    df_Haussman_NHSS$pVal_ChisqRobust[df_Haussman_NHSS$Equation == tmpYname] <- tmp$p.value

    # 2.1.4 summary, print the effect models
    cat("\n---------------------------\n")
    cat("FIXED INDIVIDUAL EFFECT MODEL: ",tmpYname,"\n")
    print(        summary(  li_ModFix_NHSS[[tmpYname]], vcov = vcovHC( li_ModFix_NHSS[[tmpYname]] )  )          )  # using robust SE
}

# 2.2 print & output the results of Haussman tests
cat("\n---------------------------\n")
cat("HAUSSMAN TEST RESULT; H0: SHOULD USE RANDOM INDIVIDUAL EFFECT","\n")
print(df_Haussman_NHSS)
write.csv(df_Haussman_NHSS, file = paste(sep="",envNHSS$Output,"HaussmanTest_NHSS.csv"))

# -------------------------------------
## SECTION 3: NOTMALITY OF THE BENCHMARK MODEL (FIXED INDIVIDUAL EFFECT MODEL)
cat("\nSECTION 3: NOTMALITY OF THE BENCHMARK MODEL (FIXED INDIVIDUAL EFFECT MODEL)")
# NOTE: in this section, we test the normality of our benchmark model,
#       the fixed individual effect model.
#       using & output QQplot & common normality tests (depend on library nortest)
#
#       H0: normal distribution
#
df_NormTest_NHSS <- list(
    Test = c( "Shapiro-Wilk", "Pearson Chi-square", "Lilliefor",
              "Anderson-Darling", "Cramer-von Mises" )  # test names
)  # saves p-values; converted to a df later

for(tmpYname in envNHSS$Ynames){
    # 3.1 qqplots: plotting & output
    pdf(file = paste(sep="",envNHSS$Output,"ResidQQ_FixIndi_NHSS_",tmpYname,".pdf"), width = 12, height = 10)
        func_easyQQnorm( residuals(li_ModFix_NHSS[[tmpYname]]), ylab = paste(sep="","resid(",tmpYname,")"), alpha = 0.05 )
    dev.off()
    # 3.2 normality tests
    tmp <- residuals(li_ModFix_NHSS[[tmpYname]])
    df_NormTest_NHSS[[tmpYname]] <- c(
        shapiro.test( tmp )$p.value,  # Shapiro-Wilk test
        nortest::pearson.test( tmp )$p.value,  # Peason chi-sqaure test
        nortest::lillie.test( tmp )$p.value,  # Kolmogorov-Smirnov test
        nortest::ad.test( tmp )$p.value,  # Anderson-Darling test
        nortest::cvm.test( tmp )$p.value  # Cramer-von Mises test
    )
}

# 3.3 convert to a dataframe then output
df_NormTest_NHSS <- data.frame(df_NormTest_NHSS)
write.csv(df_NormTest_NHSS,file = paste(sep="",envNHSS$Output,"NormTest_NHSS.csv"))

# -------------------------------------
## SECTION 4: (ROBUST) TWO-WAYS FIXED EFFECT MODEL & CONSISTENCY WITH ONE-WAY FIXED INDIVIDUAL EFFECT MODEL
cat("\nSECTION 4: (ROBUST) TWO-WAYS FIXED EFFECT MODEL & CONSISTENCY WITH ONE-WAY FIXED INDIVIDUAL EFFECT MODEL")
# NOTE: in this section, we estimate a two-ways fixed effect model (OLS estimator + robustSE),
#       then perform Haussman test on it & the fixed individual effect model
#       (H0: the two are consistent, and we have learnt the one-way fixed effect model's estimate is consistent)
#       to see if the estimates of the two models are consistent
li_ModTwo_NHSS <- list()
df_exHaussman_NHSS <- df_Haussman_NHSS  # use the same structure

# 4.1 estimate & Haussman
for(tmpYname in envNHSS$Ynames){
    # slice a temp data
    tmpdf <- li_DatPlm_NHSS[[tmpYname]]
    # 4.1.1 estimate a two-way model
    li_ModTwo_NHSS[[tmpYname]] <- plm::plm( li_Eq_NHSS[[tmpYname]], tmpdf, effect = "twoways", model = "within" )
    # 4.1.2 Haussman test (original)
    tmp <- df_exHaussman_NHSS$Equation == tmpYname
    tmp2 <- plm::phtest( li_ModFix_NHSS[[tmpYname]], li_ModTwo_NHSS[[tmpYname]] )
    df_exHaussman_NHSS$Chisq <- tmp2$statistic
    df_exHaussman_NHSS$pVal_Chisq <- tmp2$p.value
    # 4.1.2 Robust Haussman test (auxiliary regression based)
    tmp2 <- plm::phtest( li_ModFix_NHSS[[tmpYname]], li_ModTwo_NHSS[[tmpYname]], method = "aux" )
    df_exHaussman_NHSS$ChisqRobust <- tmp2$statistic
    df_exHaussman_NHSS$pVal_ChisqRobust <- tmp2$p.value
    # print the two-way model
    print( summary( li_ModTwo_NHSS[[tmpYname]], vcov = vcovHC(li_ModTwo_NHSS[[tmpYname]])   ) )  # summary, using robust cov-mat estimates
}

# 4.2 convert the results of Haussman test to a df, then output
df_exHaussman_NHSS <- data.frame(df_exHaussman_NHSS)
write.csv(df_exHaussman_NHSS, file=paste(sep="",envNHSS$Output,"exHaussman_2Wayor1Way_NHSS.csv"))

# -------------------------------------
## SECTION 5: (ROBUST) ADD AN EXTRA CANDIDATE VARIABLE ()
# NOTE: in this section, we add another variable into the final specifications to do robustness check;
#       1st, we check whether the new variable is significant on the three health outcomes?
#       2nd, we add it to the final specifications and regress (benchmark effect, FGLS estimator)

# -------------------------------------
## SECTION 6: FORMATTED OUTPUT (FOR MS WORD)
# NOTE: in this section, we formatted the results for MS WORD software,
#       then output as excel file (because .csv may lead strings to be recognized as numbers )
# -----------
li_Report_NHSS <- list()  # a list to save formatted reports
for(tmpYname in envNHSS$Ynames){
    # 6.1 temp df
    tmpdf1 <- format_plm( summary(li_ModFix_NHSS[[tmpYname]] , vcov = vcovHC(li_ModFix_NHSS[[tmpYname]])  ) ,
                            Yname = paste(sep="",tmpYname,"_FixIndi_OLS_HCse") )  # fixed  individual effect, OLS estimator + robustSE
    tmpdf2 <- format_pggls( summary(li_ModRan_NHSS[[tmpYname]]) ,
                            Yname = paste(sep="",tmpYname,"_RanIndi_FGLS") )  # random individual effect, FGLS estimator
    tmpdf3 <- format_plm(   summary(li_ModTwo_NHSS[[tmpYname]] ,  vcov = vcovHC(li_ModTwo_NHSS[[tmpYname]]) ) ,
                            Yname = paste(sep="",tmpYname,"_TwoWays_OLS_HCse") )  # two-ways fixed effect model + robustSE
    tmpdf4 <- format_gls(   summary(li_ModPoolGLS_NHSS[[tmpYname]])  ,
                            Yname = paste(sep="",tmpYname,"_Pooling_GLS") )  # Pooling, GLS estimator
    tmpdf5 <- format_lm(    summary(li_ModPoolOLS_NHSS[[tmpYname]])  ,
                            Yname = paste(sep="",tmpYname,"_Pooling_OLS") )  # Pooling, OLS estimator
    # 6.2 merging
    li_Report_NHSS[[tmpYname]] <- plyr::join(
        tmpdf1, tmpdf2,
        by = "Variable", type = "full"
    )
    li_Report_NHSS[[tmpYname]] <- plyr::join(
        li_Report_NHSS[[tmpYname]], tmpdf3,
        by = "Variable", type = "full"
    )
    li_Report_NHSS[[tmpYname]] <- plyr::join(
        li_Report_NHSS[[tmpYname]], tmpdf4,
        by = "Variable", type = "full"
    )
    li_Report_NHSS[[tmpYname]] <- plyr::join(
        li_Report_NHSS[[tmpYname]], tmpdf5,
        by = "Variable", type = "full"
    )

}
# 6.3 garbage collection
rm( tmpdf1, tmpdf2, tmpdf3, tmpdf4, tmpdf5 )

# print info
print(li_Report_NHSS)

# output to excel
openxlsx::write.xlsx(li_Report_NHSS, file = paste(sep="",envNHSS$Output,"RegReport_NHSS.xlsx") )


library(ggvis)
#simple summary brush tooltip
x_bar <- "x̄"
sigma_hat <- "σ̂"

brushed_summary <- function(items, session, page_loc, ...) {
  if (nrow(items) == 0) return()

  items$key__ <- NULL
  lines <- Map(function(name, vals) {
    paste0(name, ": ",
      x_bar, " = ", round(mean(vals), 2), " ",
      sigma_hat, " = ", round(sd(vals), 2)
    )
  }, names(items), items)
  html <- paste(unlist(lines), collapse = "<br />\n")

  show_tooltip(session, page_loc$r + 5, page_loc$t, html)
}

# Scatter plot with brushing
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points(size.brush := 400) %>%
  handle_brush(brushed_summary)

# Bar graph with brushing
pressure %>% ggvis(x = ~temperature, y = ~pressure) %>%
  scale_nominal("x", range = "width", padding = 0, points = FALSE) %>%
  layer_rects(y2 = 0, width = band(), fill.brush := "red") %>%
  handle_brush(brushed_summary)

# Brushing with 10000 points
data("diamonds", package="ggplot2")
d <- diamonds[sample(nrow(diamonds), 10000), ]
d %>% ggvis(x = ~carat, y = ~price) %>%
  layer_points(size := 40, fillOpacity := 0.02, fillOpacity.brush := 0.4) %>%
  handle_brush(brushed_summary)


suppressMessages(library(tidyverse))
suppressMessages(library(patchwork))

args <- commandArgs(trailingOnly=TRUE)

if (length(args) != 2)
    stop("Expected two arguments")

input_file <- args[1]
output_file <- args[2]

df <- read.csv(input_file)

df$strategy_type <- gsub("Default", "Original", df$strategy_type)

plot <-
    ggplot(df, aes(x=phi, y=certificate, col=ifelse(certificate >= phi, 'Correct', 'Incorrect'))) +
    geom_point() +
    geom_abline(intercept=0, slope=1) +
    labs(x=expression(phi),
         y=expression("Certificate" ~ phi[c]),
         col="Satisfies requirement") +
    facet_grid(graph ~ strategy_type, label="label_parsed") +
    scale_x_continuous(breaks=c(0.0001, 0.0025, 0.005, 0.0075, 0.01), limits = c(0.0001, NA)) +
    scale_y_continuous(limits = c(0.0, NA)) +
    theme(panel.spacing = unit(2, "lines")) +
    scale_color_manual(values = c('Correct' = "blue", 'Incorrect' = "red"))

ggsave(output_file, plot)


# create data :
sample=paste(rep("sample_",40) , seq(1,40) , sep="")
specie=c(rep("carot" , 10) , rep("cumcumber" , 10) , rep("wheat" , 10) , rep("Potatoe" , 10) )
gene1=rep(seq(5,14),4)
gene2=c( seq(1,5.5,0.5)+rnorm(10 , 4 , 2) , seq(1,20,2)+rnorm(10 , 6 , 0.5) , seq(2,11)+rnorm(10 , 5 , 2) , seq(3,12)+rnorm(10 , 4 , 10) )
data=data.frame(sample,specie,gene1,gene2)
colors=c(rgb(0.2,0.2,0.1,0.5) , rgb(0.1,0.4,0.1,0.6) , rgb(0.7,0.3,0.1,0.5) , rgb(0.2,0.2,0.9,0.5) )

# Make the graph
library(lattice)
png("#36_xyplot_one_screen.png" , width = 480, height = 480)
xyplot(gene2 ~ gene1 , data, groups = specie , type = "a", auto.key = list(corner=c(0.1,0.9) , points = FALSE, lines = FALSE, col=colors , cex=1.3) , 	lwd=5 , col=colors )
dev.off()