## LOOP FOR:

# Los "loops" ("lazos" o "bucles" en español) son comandos especiales que
# sirven para hacer ejecutar una tarea una cantidad arbitraria de veces; se
# llama iteración a cada una de estas repeticiones. Sirven para hacer en
# segundos lo que manualmente llevaría horas, días o sería simplemente demasiado.

# Los comandos más universales para hacer loops en programación son "for" y
# "while", y en R esto no es distinto.

# Se puede acceder a la ayuda de R con varios comandos, por ejemplo (no correr):
?Control
?"for"

## SINTAXIS

# Empecemos con un ejemplo muy sencillo:

for (i in 1:4) {
  print(i)
}

# Analicemos lo que ocurre:
# En la consola vemos que se imprimen los números 1, 2, 3 y 4. Esto ocurre
# porque dentro del loop se puso el comando print(i). En este caso i es un
# objeto, al cual llamaremos la "variable" o "variable de iteración". Cuando
# miramos en el paréntesis del for, vemos que dice "i in 1:4". Esto quiere
# decir que la variable i va a tomar los valores contenidos en el vector 1:4,
# es decir que en la primer iteración i vale 1, luego 2 y así. En suma, es
# equivalente a escribir:
i <- 1
print(i)
i <- 2
print(i)
i <- 3
print(i)
i <- 4
print(i)
# ... pero por supuesto que es mucho más económico y elegante.

# Nota: debido a que hay una sola expresión dentro del loop (print(i)), no es
# necesario usar las llaves para delimitar el loop; son equivalentes estas dos
# opciones:
for (i in 1:4)
  print(i)
# ó
for (i in 1:4) print(i)

# Nota: puede verificar que i es además un objeto que existe en su sesión y
# cuyo valor es el último asignado por el loop for. En este caso i == 4:
i

# Por supuesto que este es uno de los ejemplos más elementales que se pueden
# imaginar de un loop for, pero hay un par de detalles que por costumbre o
# convención se repiten casi siempre:
# - El usar el nombre "i" para la variable de iteración. No es necesario que
#   tenga este nombre, eso es un valor arbitrario (puede llamarse, j, k o carlos
#   sin problemas), pero es aconsejable mantener este criterio para facilitar la
#   comprensión del código.
# - El utilizar números naturales para el vector de valores que va a tomar i,
#   en este caso 1:4. Aquí tampoco hay límites en cuanto a los valores o clase
#   de vector que se elige. A continuación veremos porqué es más común y
#   conveniente utilizar estos tipos de vectores.

# Un ejemplo un poco más ilustrativo: consideremos que existe un vector v
# definido así:
v <- c(5, 2, -2, 3)
# Ahora, supongamos que queremos imprimirlo en la consola, un valor a la vez.
# Podemos recurrir a este código:
for (i in v)
  print(i)

# Como puede ver, ahora la variable i va tomando los valores del vector v y
# print(i) los va imprimiendo en la consola. Es equivalente a:
i <- v[1]
print(i)
i <- v[2]
print(i)
i <- v[3]
print(i)
i <- v[4]
print(i)

# De todas formas, este ejemplo *no refleja el uso más frecuente* de la
# variable i. Usualmente lo que se hace es utilizar i para indizar al vector v,
# así:
for (i in 1:4)
  print(v[i])

# A través de los corchetes estamos usando i para imprimir el iésimo elemento
# de v en cada iteración. Parece un camino más largo y por lo tanto
# inconveniente. Sin embargo en la práctica rara vez se va a utilizar la
# variable i para indizar solamente un vector, si no que suele usarse
# repetidamente para indizar diferentes objetos, incluyendo matrices,
# data.frames o listas. Veamos un ejemplo:

# Preparación:
m <- matrix(rpois(12, 8), 4, 3) # Una matriz de 4x3
s <- numeric(4) # Un vector de longitud 4, valores == 0
# Loop:
for (i in 1:4)
  s[i] <- sum(m[i,])
s
# Aquí se creo un vector s, inicialmente todos sus valores 0, cuyo objetivo
# era contener los valores de las sumas por fila de la matriz m. Adentro del
# loop se utilizó i en dos ocasiones:
# (1) para indicar el número de fila de m al cual se debía aplicar la
#     función sum ("sum(m[i,])") y
# (2) para indicar el iésimo valor de s, en donde se almacenó el resultado de
#     la operación anterior ("s[i] <- ...").

# Nota: el vector s es idéntico al obtenido con el comando:
rowSums(m)

# Nota 2: es un error muy común definir s *adentro* del loop, en lugar de
# *afuera*. Al cometer este error le estamos indicando a R que s se debe
# *reiniciar* en cada iteración, de forma que borra todo lo hecho en
# iteraciones anteriores. Veamos esto en un ejemplo:
m <- matrix(rpois(12, 8), 4, 3) # Una matriz de 4x3
# Loop:
for (i in 1:4) {
  s <- numeric(4) # Un vector de longitud 4, valores == 0
  s[i] <- sum(m[i,])
} # Se agregan las llaves porque hay más de 1 comando
s

# Como se muestra en la observación anterior (s == rowSums(m) para el loop
# correcto), no siempre es necesario hacer un loop para hacer estas operaciones
# (aquí rowSums puede hacer lo mismo). En general en R es conveniente saber
# cuándo podemos evitar hacer un loop, no sólo para "simplificar" la sintaxis,
# si no porque puede haber una pérdida de eficiencia que, en caso de hacer
# cálculos pesados, se paga con mucho tiempo perdido. En general el término que
# refiere a optar por alternativas a los loops es "vectorización" (ver lección
# 6.2-loop-for-extra.r por más detalles relativos a la vectorización a la
# eficiencia del uso de recursos). Nótese que la vectorización no es posible en
# todos los lenguajes de programación y que en lenguajes más tradicionales (como
# pueden ser C o FORTRAN) es necesario usar loops para las operaciones más
# simples (como, por ejemplo, sumar dos vectores de igual longitud).

# Hay casos en los que usar loops en R es sencillamente inevitable. Vamos a ver
# ahora uno de estos casos.

## EJEMPLO: SERIE DE FIBONACCI

# La serie de Fibonacci se puede definir de la siguiente manera: se trata de una
# secuencia de valores que cumplen la regla general:
# F_{i} == F_{i - 1} + F_{i - 2}

# (Aquí F_{n} es el enésimo elemento de la serie F.)

# Esto implica que es necesario definir de manera arbitraria los dos primeros
# valores (F_{1} y F_{2}) para poder definir el resto de la serie. Si los
# primeros valores son 0 y 1 entonces la serie es (hasta el octavo valor):
# F = [0, 1, 1, 2, 3, 5, 8, 13]

# Vamos entonces a crear un loop en R que permita calcular la serie de Fibonacci
# hasta el enésimo valor. Crearemos la función fibo para este objetivo:
fibo <- function(n = 20, inicio = 0:1) {
  # n e inicio tienen valores por defecto, por comodidad

}
# ... por ahora la función no hace nada, veamos cómo debemos completarla ...

# Traduciendo la regla general a R, nos quedaría algo así:
out[i] <- out[i - 1] + out[i - 2]
# donde out es un vector en el cual vamos a almacenar todos los valores de la
# serie. Nótese que esto implica que i no puede ser menor que 3; si i fuera 2,
# por ejemplo, entonces out[i - 2] sería out[0], lo cual es un valor no definido
# en R. A su vez, esto implica que out tiene al menos i elementos y que out[1] y
# out[2] están definidos de antemano.

# Estas condicionantes nos llevan a definir lo que llamamos la Preparación del
# loop. Por un lado, out tiene que existir y tener al menos 3 elementos, pero de
# hecho ya decidimos que tendrá n elementos. El valor n está definido como uno
# de los argumentos de la función, así que no lo definiremos de vuelta. Por
# otro lado, los dos primeros valores de out se definen con el otro argumento:
# inicio. De esta forma la preparación sería algo así (no ejecutar):
out <- numeric(n)
out[1:2] <- inicio

# Como puede confirmar, si asigna valores a n y a inicio (inicio debe ser un
# vector de 2 elementos), out ya es un vector viable para aplicar la fórmula
# general. Pero para eso tenemos que agregar el loop en sí (no ejecutar):
for (i in 3:n) {
  out[i] <- out[i - 1] + out[i - 2]
}

# Es imporante notar que el rango de valores de i es 3:n; 3 porque ya vimos que
# i no puede ser menor y n porque es la cantidad de elementos de out.

# Tenemos entonces todo para definir correctamente la función fibo:
fibo <- function(n = 20, inicio = 0:1) {
  # Preparación:
  out <- numeric(n)
  out[1:2] <- inicio
  # Loop:
  for (i in 3:n) {
    out[i] <- out[i - 1] + out[i - 2]
  }
  out # La salida de la función
}

# Podemos comprobar de que fibo hace correctamente su tarea:
fibo()
fibo(22)

# Es importante destacar los puntos claves a tener en cuenta en el proceso de
# crear fibo:
# 1. El vector out debe estar correctamente definido antes de empezar el loop.
#    Generalmente la Preparación es necesaria para aprontar vectores como out,
#    en el cual se almacenan los valores que nos interesan.
# 2. La variable i debe estar contenida en el rango correcto de valores, en
#    este caso 3:n. Este es un punto en el cual es frecuente comenter errores.

# Pero ¿por qué es que es inevitable usar un loop para este problema?
# Se puede responder con un ejemplo: ¿qué ocurre al tratar de calcular el
# cuarto elemento de out? Para obtener este valor es necesario primero definir
# el tercer elemento de out, ya que out[4] = out[3] + out[2]. El mismo problema
# surgirá cuando se trate de obtener out[5] y los demás valores, por lo que no
# queda opción que "ir calculando de a uno" los valores de la serie de
# Fibonacci. En general es fácil ver que siempre que los valores de una
# secuencia dependen de los anteriores es necesario hacer un loop para poder
# calcularlos. Dicho de otra forma, los loops son inevitables para calcular
# secuencias definidas por Relaciones de Recurrencia
# (https://es.wikipedia.org/wiki/Relaci%C3%B3n_de_recurrencia).
# Nota: muchas veces estas relaciones de recurrencia también tienen soluciones
# cerradas, lo que implica que en esos casos tampoco es estrictamente necesario
# usar un loop (en R) para calcular los valores de la sucesión.

## LOOPS FOR ANIDADOS:

# Nada impide que adentro de un for (o un while) se escriba otro loop. Esto es
# lo que llamamos un loop anidado. Las reglas que siguen son las mismas que antes,
# pero hay que tener la precaución de utilizar diferentes nombres para las
# variables de iteración. En el siguiente ejemplo se usan i y j como variables:

m <- matrix(rpois(4, 8), 2, 2) # Una matriz de 2x2
for (i in 1:nrow(m)) {
  for (j in 1:ncol(m)) {
    print(m[i, j])
  }
}

# Como fácilmente se puede comprobar, este código simplemente imprime todos los
# elementos de la matriz m. Nótese: que la variable i se usa para las filas y
# la variable j para las columnas.

## RESUMEN
# Hemos visto el tipo de loop más comunmente utilizado en programación. El loop
# 'for' se utiliza cuando "sabemos" de antemano el número de iteraciones que
# necesitamos.
# Dado que la sintaxis es relativamente elaborada, hay que tener especial
# atención a los errores, particularmente los más comunes: omisión de una llave,
# escribir mál la secuencia de números (1:n) o confundir el nombre de las
# variables (i, j, k, etc ...).
# En general siempre va a ser necesario tener una Preparación, es decir líneas
# de código anteriores al loop en las que se definen correctamente uno o varios
# objetos que serán utilizados dentro del mismo. Un error común es definir
# alguno de estos objetos (como el out en la función fibo) *adentro* del loop,
# cuando es necesario que esto se haga **afuera**, en la preparación.
# Los ejemplos empleados dan cuenta de situaciones comunes en que podemos
# utilizar esta herramienta, pero no está limitada a éstas. Siendo particular-
# mente útil al realizar simulaciones con modelos o aplicar análisis a grandes
# series de datos, su combinación dentro de funciones y con otras estructuras
# de control (ej: condicionales) se hace más importante, y resulta fundamental
# como herramienta para cualquier programador.


# this should use data_frame infrastructure to calculate NMF clustering, optionally in cluster jobs
.b = import('../base')
.io = import('../io')
.df = import('../data_frame')

#' Wrapper function that takes k, num.clusterings and performs max_iter iterations
#'
#' @param A          data matrix [genes x samples]
#' @param k          the number of clusters (matrix rows)
#' @param max_iter   number of NMF iterations to perform
#' @param seed       the random seed
#' @param nsame      number of iterations the class assignments need to stay the same
#' @param num_clusterings  The number of clusterings to perform to compute consensus
#' @return a list of the results matrices W and H, with iterations performed
.nmf = function(A, k, max_iter, seed=1234, nsame=200, num_clusterings=10) {
    one_iter = function(seed) {
        # initialise matrices
        set.seed(seed)
        m = nrow(A)
        n = ncol(A)
        W = as.double(runif(m*k, 0, 1)) # standard random init in (0,1)
        H = as.double(runif(k*n, 0 ,1)) # could use libnmf's generatematrix for it

        # calls to add: nmf_als, mu, neals, alspg, pg
        dyn.load(.io$file_path(module_file(), "nmf_mu.so"))
        re = .C("nmf_mu", a=as.double(A), w0=as.double(W), h0=as.double(H),
                 pm=as.integer(m), pn=as.integer(n), pk=as.integer(k),
                 maxiter=as.integer(max_iter), nsame=as.integer(nsame),
                 DUP=FALSE, PACKAGE='nmf_mu')

        # return decomposed matrices
        list(W = matrix(re$w0, nrow=m, ncol=k, dimnames=list(rownames(A), NULL)),
             H = matrix(re$h0, nrow=k, ncol=n, dimnames=list(NULL, colnames(A))),
             iter = re$maxiter)
    }

    # run nmf for given k and reps
    stopifnot(length(k) == 1)
    A = as.matrix(A)
    sample_names = .b$descriptive_index(A, along=2)
    seed = rep(seed, num_clusterings) + 1:num_clusterings
    result = lapply(seed, one_iter)

    # get consensus clusters and sample similarity
    clusters = lapply(result, function(x) apply(x$H, 2, order)[1,])
    connect.matrix = Reduce('+', lapply(clusters, function(l)
            outer(l,l, function(x,y) as.integer(x==y)))) / length(clusters)

    # compute cophenetic coefficient TODO: how to decide if 2 clusters are better than one?
    dist.matrix = as.dist(1 - connect.matrix)
    HC = hclust(dist.matrix, method="average")
    dist.coph = cophenetic(HC)

    # return sample membership
    data.frame(sample = sample_names[HC$order],
               cluster = cutree(HC, k = k)[HC$order],
               rho = cor(dist.matrix, dist.coph))
}

#' Wrapper function that takes k, num.clusterings and performs max_iter iterations
#'
#' @param A          data matrix [genes x samples]
#' @param k          the number of clusters (matrix rows)
#' @param max_iter   number of NMF iterations to perform
#' @param seed       the random seed
#' @param nsame      number of iterations the class assignments need to stay the same
#' @param rep        The number of clusterings to perform to compute consensus
#' @param hpc_args   Optional arguments to pass to hpc module
#' @return           A data frame with sample names, cluster membership, and score
nmf = function(A, k, max_iter=1000, seed=1234, nsame=200, rep=10, hpc_args=NULL) {
    const = list(num_clusterings=rep, A=A, max_iter=max_iter, seed=seed, nsame=nsame)
    .df$call(data.frame(k=k), fun=.nmf, const=const, hpc_args=hpc_args)
}

if (is.null(module_name())) {
    library(testthat)

    #TODO: write proper tests here
    #  this is just testing that the clustering runs without error
    data = data.matrix(iris[1:4])
    result = nmf(data, 2:4)
}


# Goal: To make a panel of pictures.

par(mfrow=c(3,2))                       # 3 rows, 2 columns.

# Now the next 6 pictures will be placed on these 6 regions. :-)

# Let me take some pains on the 1st
plot(density(runif(100)), lwd=2)
text(x=0, y=0.2, "100 uniforms")        # Showing you how to place text at will
abline(h=0, v=0)
              # All these statements effect the 1st plot.

x=seq(0.01,1,0.01)
par(col="blue")                         # default colour to blue.

# 2 --
plot(x, sin(x), type="l")
lines(x, cos(x), type="l", col="red")

# 3 --
plot(x, exp(x), type="l", col="green")
lines(x, log(x), type="l", col="orange")

# 4 --
plot(x, tan(x), type="l", lwd=3, col="yellow")

# 5 --
plot(x, exp(-x), lwd=2)
lines(x, exp(x), col="green", lwd=3)

# 6 --
plot(x, sin(x*x), type="l")
lines(x, sin(1/x), col="pink")

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


read.in.files<-function(years,quarters,areas,species,ages,filename) {

a<-expand.grid(Area=areas,Species.n=species,Year=years,Quarter=quarters,Age=ages)
a<-a[order(a$Area,a$Species.n,a$Year,a$Quarter,a$Age),]
a$variable<-scan(file.path(data.path,filename),comment.char='#')
a
}

west<-read.in.files(years=SMS.control@first.year:SMS.control@last.year,
              quarters=1:SMS.control@last.season,
              areas=1:SMS.control@no.areas,
              species=1:nsp,
              ages=SMS.control@first.age:SMS.control@max.age.all,
              filename="west.in")

names(west)<-c("Area","Species.n","Year","Quarter","Age","west")

consum<-read.in.files(years=SMS.control@first.year:SMS.control@last.year,
              quarters=1:SMS.control@last.season,
              areas=1:SMS.control@no.areas,
              species=1:npr,
              ages=SMS.control@first.age:SMS.control@max.age.all,
              filename="consum.in")

names(consum)<-c("Area","Species.n","Year","Quarter","Age","consum")

a<-merge(consum,west)
a<-subset(a,consum>0 & west>0)

a$log.consum<-log(a$consum)
a$log.west<-log(a$west)
a$Species<-sp.names[a$Species.n]
a$spQ<-paste(a$Species," Q:",a$Quarter,sep='')

trellis.device()
xyplot(log.consum~log.west|spQ,data=a,layout = c(2, 2),subset=(Year<=2000),
  scales = "free",
  panel=function(x,y) {
    panel.xyplot(x,y,col=1 ,pch=1,type='p')
    panel.loess(x,y, span=1)
    panel.lmline(x,y,col=2)
  }
)

b<-by(a,list(a$Species.n,a$Quarter),function(x) {
    a<-(lm(log.consum~log.west,data=x))
    list(Species.n=x[1,'Species.n'],Quarter=x[1,'Quarter'],a=exp(coef(a)[[1]]),b=coef(a)[[2]])
})

matrix(unlist(b),ncol=4,byrow=T)


#==============================================================================
#	Test for gamm in mgcv package.
#==============================================================================

source("tests.r")

test <- glm.type.test.runner$new(
	"gamm",
	families = c(
		"gaussian", "Gamma", "inverse.gaussian", "poisson", "binomial"
	),
	object.has.call = FALSE
)

test$test.info$formulae <- list(
	gaussian = Sepal.Length ~ s(Petal.Length),
	Gamma = Sepal.Length ~ s(Petal.Length),
	inverse.gaussian = Sepal.Length ~ s(Petal.Length),
	poisson = n ~ s(Petal.Length),
	quasipoisson = bin ~ s(Petal.Length),
	binomial = bin ~ s(Petal.Length),
	quasibinomial = bin ~ s(Petal.Length),
	quasi = Sepal.Length ~ s(Petal.Length)
)

test$run()
rm(test)


S <- scan(n=11)

f <- function(x) sqrt(abs(x)) + 5*x^3

for (i in rev(S)) {
  res <- f(i)
  if (res > 400)
    print("Too large!")
  else
    print(res)
}


library(tidyverse)
library(Seurat)

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_filtered.rds"
h1 = readRDS(fn)

dn.fig = "figures/TSNE"
dir.create("figures", showWarnings = F)
dir.create(dn.fig, showWarnings = F)

# Run PCA on protein expression
protein = rownames(h1@assay$CITE@raw.data)
protein = protein[-grep("Mouse|Rat",protein)]
h1 <- ScaleData(h1, assay.type = "CITE", display.progress = FALSE, do.par = TRUE, num.cores = 8)
h1 <- RunPCA(h1, assay.type = "CITE",
             seed.use = 0, pc.genes = protein,
             pcs.print = 0, reduction.name = "protpca")

fn.new = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_PCA.rds"
saveRDS(h1, fn.new)

# elbow plot for PC inclusion in clustering
y = h1@dr$protpca@sdev
x = 1:20
df = cbind(x,y) %>% base::as.data.frame()
ggplot(df, mapping = aes(x = x , y = y)) +
  geom_point() + xlab("PC") + ylab("SD of PC") +
  ggtitle("H1N1 protein day0") + theme_light()

ggsave(file.path(dn.fig, "PCA_elbow.png"))


#devtools::test("asremlPlus")
context("model_selection")

cat("#### Test estimateV for chick pea example with asreml4\n")
test_that("chickpea_estimateV_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)

  data(chkpeadat)
  asreml.options(design = TRUE)
  asreml.obj <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                       random = ~Smarthouse:Zone + Smarthouse:spl(vLanes),
                       residual = ~Smarthouse:ar1(Lane):ar1(Position),
                       data = chkpeadat, trace = FALSE)

  #'## estimate with fixed spline - no G terms in V matrix
  Vnospl <- estimateV(asreml.obj, fixed.spline.terms = "Smarthouse:spl(vLanes)")

  # Form variance matrix based on estimated variance parameters
  V <- kronecker(mat.ar1(asreml.obj$vparameters[4], length(levels(chkpeadat$Lane))),
                 mat.ar1(asreml.obj$vparameters[5], length(levels(chkpeadat$Position))))
  V <- asreml.obj$sigma2 * kronecker(diag(1,2), V)
  testthat::expect_false(any(abs(Vnospl - V) > 1e-08))

  #Estimate G and R separately
  Gnospl <- estimateV(asreml.obj, which.matrix = "G",
                      fixed.spline.terms = "Smarthouse:spl(vLanes)")
  Rnospl <- estimateV(asreml.obj, which.matrix = "R",
                      fixed.spline.terms = "Smarthouse:spl(vLanes)")
  testthat::expect_false(any(abs(Gnospl + Rnospl - V) > 1e-08))

  #'## estimate with random spline
  Vranspl <- estimateV(asreml.obj)
  Zspl <- as.matrix(asreml.obj$design[ , grepl("Smarthouse:spl(vLanes)",
                                     colnames(asreml.obj$design), fixed = TRUE)])
  V <- V + asreml.obj$sigma2 * asreml.obj$vparameters[2] * (Zspl %*% t(Zspl))
  testthat::expect_false(any(abs(Vranspl - V) > 1e-08))

  #Estimate G and R separately
  Granspl <- estimateV(asreml.obj, which.matrix = "G")
  Rranspl <- estimateV(asreml.obj, which.matrix = "R")
  testthat::expect_false(any(abs(Rranspl - Rnospl) > 1e-06))
  testthat::expect_false(any(abs(Granspl + Rranspl - Vranspl) > 1e-06))
  testthat::expect_false(any(abs(Granspl + Rranspl - V) > 1e-06))

  #Estimate with random spline and k = 6
  asreml.obj <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                       random = ~ Smarthouse:spl(vLanes, k = 6),
                       residual = ~Smarthouse:ar1(Lane):ar1(Position),
                       data = chkpeadat, trace = FALSE)
  summary(asreml.obj)$varcomp
  V <- kronecker(mat.ar1(asreml.obj$vparameters[3], length(levels(chkpeadat$Lane))),
                 mat.ar1(asreml.obj$vparameters[4], length(levels(chkpeadat$Position))))
  V <- kronecker(diag(1,2), V)
  Vranspl6 <- estimateV(asreml.obj)
  Zspl6 <- as.matrix(asreml.obj$design[ , grepl("Smarthouse:spl(vLanes, k = 6)",
                                                colnames(asreml.obj$design), fixed = TRUE)])
  V <- asreml.obj$sigma2 * (V + asreml.obj$vparameters[1] * (Zspl6 %*% t(Zspl6)))
  testthat::expect_false(any(abs(Vranspl6 - V) > 1e-08))

  #Estimate G and R separately
  Granspl <- estimateV(asreml.obj, which.matrix = "G")
  Rranspl <- estimateV(asreml.obj, which.matrix = "R")
  testthat::expect_false(any(abs(Granspl + Rranspl - V) > 1e-06))

  asreml.options(design = FALSE)
  #no residual
  asreml.obj <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                       random = ~ Smarthouse:spl(vLanes),
                       data = chkpeadat, trace = FALSE)
  Vnospl <- estimateV(asreml.obj, fixed.spline.terms = "Smarthouse:spl(vLanes)")
  V <- diag(asreml.obj$sigma2, nrow = nrow(chkpeadat))
  testthat::expect_false(any(abs(Vnospl - V) > 1e-08))

  #Estimate G and R separately
  Gnospl <- estimateV(asreml.obj, which.matrix = "G",
                      fixed.spline.terms = "Smarthouse:spl(vLanes)")
  Rnospl <- estimateV(asreml.obj, which.matrix = "R",
                      fixed.spline.terms = "Smarthouse:spl(vLanes)")
  testthat::expect_false(any(abs(Gnospl + Rnospl - V) > 1e-08))

  asreml.obj <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                       random = ~ Smarthouse:spl(vLanes),
                       residual = ~ idv(units),
                       data = chkpeadat, trace = FALSE)
  Vnospl <- estimateV(asreml.obj, fixed.spline.terms = "Smarthouse:spl(vLanes)")
  V <- diag(asreml.obj$vparameters[2], nrow = nrow(chkpeadat))
  testthat::expect_false(any(abs(Vnospl - V) > 1e-08))

  #single dsum
  asreml.obj <- asreml(fixed = Biomass.plant ~ Smarthouse + Lines * TRT,
                       random = ~Smarthouse:Lane,
                       residual = ~dsum(~ ar1(Lane):ar1(Position) + Lane:ar1(Position) |
                                          Smarthouse, levels = list(c(1), c(2))),
                       data = chkpeadat, trace = FALSE)
  Vdsum <- estimateV(asreml.obj)
  gamma.Lane <- asreml.obj$vparameters[1]
  s2.SW <- asreml.obj$vparameters[2]
  rho.lSW <- asreml.obj$vparameters[3]
  rho.pSW <- asreml.obj$vparameters[4]
  lane.ar1SW <- mat.ar1(order=24, rho=rho.lSW)
  pos.ar1SW <- mat.ar1(order=22, rho=rho.pSW)
  RSW <- s2.SW * mat.dirprod(lane.ar1SW, pos.ar1SW)
  s2.SE <- asreml.obj$vparameters[5]
  rho.pSE <- asreml.obj$vparameters[6]
  pos.ar1SE <- mat.ar1(order=22, rho=rho.pSE)
  RSE <- s2.SE * mat.dirprod(mat.I(24), pos.ar1SE)
  V <- mat.dirsum(list(RSW, RSE))
  #2 Smarthouses = 1056
  V <- gamma.Lane * with(chkpeadat, fac.sumop(fac.combine(list(Smarthouse,Lane)))) + V
  testthat::expect_false(any(abs(Vdsum - V) > 1e-08))

  #Estimate G and R separately
  Gdsum <- estimateV(asreml.obj, which.matrix = "G")
  Rdsum <- estimateV(asreml.obj, which.matrix = "R")
  testthat::expect_false(any(abs(Gdsum + Rdsum - V) > 1e-08))

  #multiple dsum - same as single dsum
  asreml.obj <- asreml(fixed = Biomass.plant ~ Smarthouse + Lines * TRT,
                       random = ~Smarthouse:Lane,
                       residual = ~ dsum(~ ar1(Lane):ar1(Position) | Smarthouse, levels = c(1)) +
                         + dsum(~ Lane:ar1(Position) | Smarthouse, levels = c(2)),
                       data = chkpeadat, trace = FALSE)
  Vdsum <- estimateV(asreml.obj)
  testthat::expect_false(any(abs(Vdsum - V) > 1e-08))

  #Estimate G and R separately
  Gdsum <- estimateV(asreml.obj, which.matrix = "G")
  Rdsum <- estimateV(asreml.obj, which.matrix = "R")
  testthat::expect_false(any(abs(Gdsum + Rdsum - V) > 1e-08))
})

cat("#### Test estimateV for Wheat example with asreml4\n")
test_that("Wheat_estimateV_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)

  data(Wheat.dat)

  #No residual
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       data = Wheat.dat, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    diag(1, nrow=150, ncol=150)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #units residual
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~ units,
                       data = Wheat.dat, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    diag(1, nrow=150, ncol=150)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #units residual
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~ idv(units),
                       data = Wheat.dat, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    diag(asreml.obj$vparameters[2], nrow=150, ncol=150)
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #named residual
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~ Row:Column,
                       data = Wheat.dat, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    diag(1, nrow=150, ncol=150)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #residual with specials
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row + units,
                       residual = ~ar1(Row):ar1(Column),
                       data = Wheat.dat, maxiter = 25, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  gamma.unit <- asreml.obj$vparameters[2]
  rho.r <- asreml.obj$vparameters[4]
  rho.c <- asreml.obj$vparameters[5]
  row.ar1 <- mat.ar1(order=10, rho=rho.r)
  col.ar1 <- mat.ar1(order=15, rho=rho.c)
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    gamma.unit * diag(1, nrow=150, ncol=150) +
    mat.dirprod(row.ar1, col.ar1)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #residual with Row corb
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~corb(Row, b = 1):ar1(Column),
                       data = Wheat.dat, maxiter = 25, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  rho.r <- asreml.obj$vparameters[3]
  rho.c <- c(asreml.obj$vparameters[4])
  row.corb <- mat.banded(x = c(1,rho.r), nrow=10, ncol=10)
  col.ar1 <- mat.ar1(order=15, rho=rho.c)
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    mat.dirprod(row.corb, col.ar1)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #residual with Col corb
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~ar1(Row):corb(Column, b = 4),
                       data = Wheat.dat, maxiter = 25, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  rho.r <- asreml.obj$vparameters[3]
  rho.c <- c(asreml.obj$vparameters[4:7])
  row.ar1 <- mat.ar1(order=10, rho=rho.r)
  col.corb <- mat.banded(x = c(1,rho.c), nrow=15, ncol=15)
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    mat.dirprod(row.ar1, col.corb)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))

  #residual with two corb
  asreml.obj <- asreml(fixed = yield ~ Rep + Variety,
                       random = ~Row,
                       residual = ~corb(Row, b = 1):corb(Column, b = 4),
                       data = Wheat.dat, maxiter = 25, trace = FALSE)
  VWheat <- estimateV(asreml.obj)
  s2 <- asreml.obj$sigma2
  gamma.Row <- asreml.obj$vparameters[1]
  rho.r <- asreml.obj$vparameters[3]
  rho.c <- c(asreml.obj$vparameters[c(4:7)])
  row.corb <- mat.banded(x=c(1,rho.r), nrow=10, ncol=10)
  col.corb <- mat.banded(x = c(1,rho.c), nrow=15, ncol=15)
  V <- fac.vcmat(Wheat.dat$Row, gamma.Row) +
    mat.dirprod(row.corb, col.corb)
  V <- s2*V
  testthat::expect_false(any(abs(VWheat - V) > 1e-08))
  RWheat <- estimateV(asreml.obj, which.matrix = "R")
  R <- s2*mat.dirprod(row.corb, col.corb)
  testthat::expect_false(any(abs(RWheat - R) > 1e-08))

})


# load libraries first
library("psych")
library("tidyverse")
library("stringr")
library("gridExtra")
library("scales")
library("edgeR")
library("limma")

# load the data file into a data tibble
raw_data <- read_tsv(file = "R-input.txt")

# separate row identifiers from the data
accession <- raw_data$Accession
tmt_raw <- raw_data %>% select(-c(Accession))

# let's use more descriptive column names
colnames(tmt_raw) <- c("gal-1", "gal-2", "gal-3",
                        "glu-1", "glu-2", "glu-3",
                        "raf-1", "raf-2", "raf-3")
nrow(tmt_raw)

# let's see what the starting data look like
# set a 3 by 3 color vector
color_vector <- rep(c("red", "blue", "green"), each = 3)

# boxplots of RAW log intensities
boxplot(log10(tmt_raw), col = color_vector,
        notch = TRUE, main = "RAW data: Gal (red), Glu (blue), and Raf(green)",
        xlab = "TMT Samples", ylab = "log of Intensity")

SL_Norm <- function(df) {
    # This makes each channel sum to the average grand total
        # df - data frame of TMT intensities
        # returns a new data frame with normalized values
    norm_facs <- mean(c(colSums(df))) / colSums(df)
    cat("SL Factors:\n", sprintf("%-5s -> %f\n", colnames(df), norm_facs))
    df_sl  <- sweep(df, 2, norm_facs, FUN = "*")
}

# normalize the raw data
tmt_sl <- SL_Norm(tmt_raw)

# let's see what the SL normalized data look like
boxplot(log10(tmt_sl), col = color_vector,
        notch = TRUE, main = "SL Norm data: Gal (red), Glu (blue), and Raf(green)",
        xlab = "TMT Samples", ylab = "log2 of Intensity")

# and check clustering
plotMDS(log10(tmt_sl), col = color_vector, main = "Clustering of SL Norm data")

# load data, study design, and row labels into edgeR object
group <- rep(c("gal", "glu", "raf"), each = 3)
y <- DGEList(counts = tmt_raw, group = group, genes = accession)

# run TMM normalization
y <- calcNormFactors(y)
y$samples

apply_tmm_factors <- function(y) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute grand total (library size) scalings
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors

    # compute the normalized data as a new data frame
    tmt_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(tmt_tmm) <- str_c(colnames(y$counts), "_tmm")

    # return the data frame
    tmt_tmm
}
tmt_tmm <- apply_tmm_factors(y)

# look at intensity distributions across samples after TMM
boxplot(log10(tmt_tmm),
        col = color_vector,
        xlab = "Samples", ylab = "Reporter Intensity",
        main = "After TMM Normalization", notch = TRUE)

# check clustering after TMM with MDS plot
plotMDS(y, col = color_vector, main = "Clustering after TMM normalization")

# compare all samples to each other
pairs.panels(log10(tmt_tmm), method = "spearman",
             lm = TRUE, main = "All versus all (normalized)")

# save the indexes of each condition
gal <- 1:3
glu <- 4:6
raf <- 7:9

CV <- function(df) {
    # Computes CVs of data frame rows
        # df - data frame,
        # returns vector of CVs (%)
    ave <- rowMeans(df)    # compute averages
    sd <- apply(df, 1, sd) # compute standard deviations
    cv <- 100 * sd / ave   # compute CVs in percent (last thing gets returned)
}

labeled_boxplot <- function(df, ylim, title) {
    # Makes a box plot with the median value labeled
        # df - data frame with data to compute CVs of
        # ylim - upper limit for y-axis
        # title - plot title
    cv = CV(df)
    boxplot(cv, ylim = c(0, ylim), notch = TRUE, main = title)
    text(x = 0.65, y = boxplot.stats(cv)$stats[3],
         labels = round(boxplot.stats(cv)$stats[3], 1))
}

# make CV distributions for each condition before and after normalization
par(mfrow = c(2, 3))

labeled_boxplot(tmt_raw[gal], 30, "Galactose RAW")
labeled_boxplot(tmt_raw[glu], 30, "Glucose RAW")
labeled_boxplot(tmt_raw[raf], 30, "Raffinose RAW")
labeled_boxplot(tmt_tmm[gal], 30, "Galactose TMM")
labeled_boxplot(tmt_tmm[glu], 30, "Glucose TMM")
labeled_boxplot(tmt_tmm[raf], 30, "Raffinose TMM")

par(mfrow = c(1, 1))

# print CV cutoffs that cature 90% of the proteins
cat("Gal - 90% of CVs less than:", round(quantile(CV(tmt_tmm[gal]), probs = 0.9), 2), "%\n")
cat("Glu - 90% of CVs less than:", round(quantile(CV(tmt_tmm[glu]), probs = 0.9), 2), "%\n")
cat("Raf - 90% of CVs less than:", round(quantile(CV(tmt_tmm[raf]), probs = 0.9), 2), "%\n")

# make a tidy data frame for plotting
cv_gal <- data.frame(cv = CV(tmt_tmm[gal]), sugar = "gal", stringsAsFactors = FALSE)
cv_glu <- data.frame(cv = CV(tmt_tmm[glu]), sugar = "glu", stringsAsFactors = FALSE)
cv_raf <- data.frame(cv = CV(tmt_tmm[raf]), sugar = "raf", stringsAsFactors = FALSE)
cv_long <- rbind(cv_gal, cv_glu, cv_raf)

# density plots
ggplot(cv_long, aes(x = cv, fill = sugar)) +
  geom_density(alpha = 0.3) +
  coord_cartesian(xlim = c(0, 25)) +
  ggtitle("CV distributions (TMM Norm)")

# compute the shared variance estimates and plot variance trends
y <- estimateDisp(y)
plotBCV(y, main = "Carbon Sources")

collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate = cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                    labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# compute the exact test models, p-values, FC, etc.
et <- exactTest(y, pair = c("gal", "glu"))

# see which proteins have the smallest p-values
topTags(et)$table

# make the results table
tt <- topTags(et, n = Inf, sort.by = "none")$table
gal_glu <- collect_results(tmt_tmm, tt, gal, "gal", glu, "glu")

pvalue_plots <- function(results, ylim, title) {
    # Makes p-value distribution plots
        # results - results data frame
        # ylim - ymax for expanded view
        # title - plot title
    p_plot <- ggplot(results, aes(PValue)) +
        geom_histogram(bins = 100, fill = "white", color = "black") +
        geom_hline(yintercept = mean(hist(results$PValue, breaks = 100,
                                     plot = FALSE)$counts[26:100]))

    # we will need an expanded plot
    p1 <- p_plot + ggtitle(str_c(title, " p-value distribution"))
    p2 <- p_plot + coord_cartesian(xlim = c(0, 1.0), ylim = c(0, 50)) + ggtitle("p-values expanded")
    grid.arrange(p1, p2, nrow = 2) # from gridExtra package
}

# check the p-value distribution
pvalue_plots(gal_glu, 50, "Gal vs Glu")

# see how many up and down candidates (10% FDR)
summary(decideTests(et, p.value = 0.10))

# use function from limma for MD plot
plotMD(et, main = "Gal vs Glu TMM Normalized", p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# see how many candidates are in each category
gal_glu %>% count(candidate)

log2FC_plots <- function(results, range, title) {
    # Makes faceted log2FC plots by candidate
        # results - results data frame
        # range - plus/minus log2 x-axis limits
        # title - plot title
    ggplot(results, aes(x = logFC, fill = candidate)) +
        geom_histogram(binwidth=0.1, color = "black") +
        facet_wrap(~candidate) +
        ggtitle(title) +
        coord_cartesian(xlim = c(-range, range))
}

# can also look at log2FC distributions
log2FC_plots(gal_glu, 3, "LogFC by candidate for Gal vs Glu")

transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")

    df # return the data frame
}

MA_plots <- function(results, x, y, title) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    ma_facet <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
        scale_x_continuous("log10 Ave_intensity") +
        ma_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(ma)
    print(ma_facet)
}

scatter_plots <- function(results, x, y, title) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    scatter_facet <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scatter_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(scatter)
    print(scatter_facet)
}

volcano_plot <- function(results, x, y, title) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # title - plot title string

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        ggtitle(str_c(title, " Volcano Plot"))
}

# do the gal vs glu MA visualizations
MA_plots(gal_glu, "ave_gal", "ave_glu", "Galactose vs Glucose")

# same comparison with scatter plots
scatter_plots(gal_glu, "ave_gal", "ave_glu", "Galactose vs Glucose")

# the ubiquitous volcano plot
volcano_plot(gal_glu, "ave_gal", "ave_glu", "Galactose vs Glucose")

# compare the conditions to each other
pairs.panels(log10(tmt_tmm[c(gal, glu)]), method = "spearman",
             lm = TRUE, main = "Galactose versus Glucose")

# compute the exact test models, p-values, FC, etc.
et <- exactTest(y, pair = c("gal", "raf"))

# see which proteins have the smallest p-values
topTags(et)$table

# get the results table
tt <- topTags(et, n = Inf, sort.by = "none")$table
gal_raf <- collect_results(tmt_tmm, tt, gal, "gal", raf, "raf")

# check the p-value distribution
pvalue_plots(gal_raf, 50, "Gal vs Raf")

# see how many up and down candidates (10% FDR)
summary(decideTests(et, p.value = 0.10))

# use function from limma for MD plot
plotMD(et, main = "Gal vs Raf TMM Normalized", p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# see how many candidates are in each category
gal_raf %>% count(candidate)

# can also look at log2FC distributions
log2FC_plots(gal_raf, 3, "LogFC by candidate for Gal vs Raf")

# make the MA plots
MA_plots(gal_raf, "ave_gal", "ave_raf", "Galactose vs Raffinose")

# scatter plots
scatter_plots(gal_raf, "ave_gal", "ave_raf", "Galactose vs Raffinose")

volcano_plot(gal_raf, "ave_gal", "ave_raf", "Galactose vs Raffinose")

# compare the conditions to each other
pairs.panels(log10(tmt_tmm[c(gal, raf)]), method = "spearman",
             lm = TRUE, main = "Galactose versus Raffinose")

# compute the exact test models, p-values, FC, etc.
et <- exactTest(y, pair = c("glu", "raf"))

# see which proteins have the smallest p-values
topTags(et)$table

# get the results table
tt <- topTags(et, n = Inf, sort.by = "none")$table
glu_raf <- collect_results(tmt_tmm, tt, glu, "glu", raf, "raf")

# check the p-value distribution
pvalue_plots(glu_raf, 50, "Glu vs Raf")

# see how many up and down candidates (10% FDR)
summary(decideTests(et, p.value = 0.10))

# use function from limma for MD plot
plotMD(et, main = "Glu vs Raf TMM Normalized", p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# see how many candidates are in each category
glu_raf %>% count(candidate)

# can also look at log2FC distributions
log2FC_plots(glu_raf, 3, "LogFC by candidate for Glu vs Raf")

# MA plots for glu vs raf
MA_plots(glu_raf, "ave_glu", "ave_raf", "Glucose vs Raffinose")

# scatter plots
scatter_plots(glu_raf, "ave_glu", "ave_raf", "Glucose vs Raffinose")

volcano_plot(glu_raf, "ave_glu", "ave_raf", "Glucose vs Raffinose")

# compare the conditions to each other
pairs.panels(log10(tmt_tmm[c(glu, raf)]), method = "spearman",
             lm = TRUE, main = "Glucose versus Raffinose")

# save the results file to add back to the main spreadsheet
results <- cbind(gal_glu, gal_raf, glu_raf)
write.table(results, "CarbonSources_results.txt", sep = "\t", row.names = FALSE, na = " ")

# log the session information
sessionInfo()


#' @export
accel.est <- function (data) {
	#for BCa conf.intervals
    no.strata <- length(unique(data$Strata))
    accel <- matrix(NA, 2, no.strata)
    for (j in 1:no.strata) {
        u <- rep(NA, data$nh[j])
        for (i in 1:data$nh[j]) {
            u[i] <- mean(data$yhi[[j]][-i])
        }
        accel[1, j] <- sum((mean(u) - u)^3)
        accel[2, j] <- sum((mean(u) - u)^2)
    }
    return(accel)
}


model_gaimean <- function (gAI = 0.0,
         tTWindowForPTQ = 0.0,
         deltaTT = 0.0,
         pastMaxAI_t1 = 0.0,
         listTTShootWindowForPTQ1_t1 = c(0.0),
         listGAITTWindowForPTQ_t1 = c(0.0)){
    #'- Name: GAImean -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Average GAI on a specific thermal time window
    #'            * Author: Loïc Manceau
    #'            * Reference: -
    #'            * Institution: INRA
    #'            * Abstract: -
    #'- inputs:
    #'            * name: gAI
    #'                          ** description : Green Area Index of the day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    #'            * name: tTWindowForPTQ
    #'                          ** description : Thermal Time window for average
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : °C d
    #'                          ** uri :
    #'            * name: deltaTT
    #'                          ** description : Thermal time increase of the day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : °C d
    #'                          ** uri :
    #'            * name: pastMaxAI_t1
    #'                          ** description : Maximum Leaf Area Index reached the current day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    #'            * name: listTTShootWindowForPTQ1_t1
    #'                          ** description : List of daily shoot thermal time in the window dedicated to average
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : °C d
    #'                          ** uri :
    #'            * name: listGAITTWindowForPTQ_t1
    #'                          ** description : List of daily Green Area Index in the window dedicated to average
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    #'- outputs:
    #'            * name: gAImean
    #'                          ** description : Mean Green Area Index
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    #'            * name: pastMaxAI
    #'                          ** description : Maximum Leaf Area Index reached the current day
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    #'            * name: listTTShootWindowForPTQ1
    #'                          ** description : List of daily shoot thermal time in the window dedicated to average
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : °C d
    #'                          ** uri :
    #'            * name: listGAITTWindowForPTQ
    #'                          ** description : List of daily Green Area Index in the window dedicated to average
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : m2 leaf m-2 ground
    #'                          ** uri :
    listTTShootWindowForPTQ1 <- vector()
    listGAITTWindowForPTQ <- vector()
    TTList <- vector()
    GAIList <- vector()
    count <- 0
    gai_ <- 0.0
    gaiMean_ <- 0.0
    countGaiMean <- 0
    for( i in seq(0, length(listTTShootWindowForPTQ1_t1)-1, 1)){
        TTList <- c(TTList, listTTShootWindowForPTQ1_t1[i+1])
        GAIList <- c(GAIList, listGAITTWindowForPTQ_t1[i+1])
    }
    TTList <- c(TTList, deltaTT)
    GAIList <- c(GAIList, gAI)
    SumTT <- sum(TTList)
    while( SumTT > tTWindowForPTQ){
        SumTT <- SumTT - TTList[count+1]
        count <- count + 1}
    for( i in seq(count, length(TTList)-1, 1)){
        listTTShootWindowForPTQ1 <- c(listTTShootWindowForPTQ1, TTList[i+1])
        listGAITTWindowForPTQ <- c(listGAITTWindowForPTQ, GAIList[i+1])
    }
    for( i in seq(0, length(listGAITTWindowForPTQ)-1, 1)){
        gaiMean_ <- gaiMean_ + listGAITTWindowForPTQ[i+1]
        countGaiMean <- countGaiMean + 1
    }
    gaiMean_ <- gaiMean_ / countGaiMean
    gai_ <- max(pastMaxAI_t1, gaiMean_)
    pastMaxAI <- gai_
    gAImean <- gai_
    return (list ("gAImean" = gAImean,"pastMaxAI" = pastMaxAI,"listTTShootWindowForPTQ1" = listTTShootWindowForPTQ1,"listGAITTWindowForPTQ" = listGAITTWindowForPTQ))
}


suppressMessages(library(clustrgame))

if (comm.rank() == 0){
  x = as.matrix(iris[, 1:4])
  y = as.numeric(iris[, 5])
} else {
  x = NULL
  y = NULL
}

dx = expand(x)
dy = expand(y)

dl = km_game(dx, k=3)$labels
l = collapse(dl)

if (comm.rank() == 0){
  rm = rand_measure(y, l[, 1, drop=TRUE])
  print(rm)
}

finalize()


reversalGame <- function(){
  cat("Welcome to the Number Reversal Game! \n")
  cat("Sort the numbers into ascending order by repeatedly \n",
      "reversing the first n digits, where you specify n. \n \n", sep="")

  # Generate a list that's definitely not in ascending order, per instuctions
  data <- sample(1:9, 9)
  while (all(data == 1:9)){
    cat("What were the chances...? \n")
    data <- sample(1:9, 9)
  }
  trials <- 0

  # Play the game
  while (any(data != 1:9)){
    trials <- trials + 1
    cat("Trial", sprintf("%02d", trials), " # ", data, " #  ")
    answer <- readline(paste("Flip how many? "))
    data[1:answer] <- data[answer:1]
  }

  # Victory!
  cat("Well done.  You needed", trials, "flips. \n")
}


source("meta.r")

# The norms
norms <- read.csv(paste0(data_dir, "FINAL_sensorimotor_norms_for_39707_words.csv"), header = TRUE)
norms$Word = norms$Word %>% tolower %>% str_squish

# List of all words in the norms
all_words <- norms$Word

# Relevant columns for norms data
sensory_columns <- c("Auditory.mean", "Gustatory.mean", "Haptic.mean", "Interoceptive.mean", "Olfactory.mean", "Visual.mean")
motor_columns <- c("Foot_leg.mean", "Hand_arm.mean", "Head.mean", "Mouth.mean", "Torso.mean")
all_columns <- c(sensory_columns, motor_columns)

# Dominance
dominance_column_sensorimotor <- "Dominant.sensorimotor"
dominance_column_perceptual <- "Dominant.perceptual"
dominance_column_action <- "Dominant.action"

# Return n random norms
random_norms <- function(n) {
  return(sample(norms$Word, n))
}

# Return a single random norm
random_norm <- function() {
  return(random_norms(1)[1])
}

# Return n random norm pairs
random_norm_pairs <- function(n) {
  pairs <- random_norms(2*n)
  dim(pairs) <- c(n, 2)
  # Convert matrix to list of rows
  return(split(pairs, rep(1:nrow(pairs), each = ncol(pairs))) %>% array)
}

# Returns a 11-dim vector for the supplied word
vector_for_word <- function(word) {
  v <- norms[norms$Word == word, all_columns]
  return(v)
}

# Returns a n x 11 matrix for the supplied words
matrix_for_words <- function(words) {
  # Use match to preserve the order from `words`
  mx <- as.matrix(norms[match(words, norms$Word), all_columns])
  return(mx)
}


fact <- function(n) {
  if ( n <= 1 ) 1
  else n * fact(n-1)
}

executeTask <- function(i) {
	return(fact(i))
}

r = 1

for(i in 0:100000) {
	r = executeTask(i)
}


# SPACE incorporating information of potential hub nodes

espace <- function(X,hub_indx, alpha, lambda,maxit_in=1000,maxit_out=5,tol=1e-6)
{
  n = nrow(X)
  p = ncol(X)
  nh = length(hub_indx)
  rho = matrix(0,p,p)
  rsd = matrix(0,n,p)
  sigma = rep(0,p)

  out <- .C('espace',n = as.integer(n), p = as.integer(p), nh = as.integer(nh),
             X = as.double(X), hub_indx = as.integer(hub_indx), alpha = as.double(alpha),
             lam = as.double(lambda), niter_in = as.integer(maxit_in), niter_out=as.integer(maxit_out),
             tol = as.double(tol), rho = as.double(rho), residual = as.double(rsd), sigma=as.double(sigma),PACKAGE='espace')

  out$rho <- matrix(out$rho,p,p)

  output <- list(rho=out$rho, alpha=alpha, lambda=lambda, residual=matrix(out$residual,n,p), w_d=out$sigma)

  return(output)
}


#Solve for optimal lobby effort under DGH97-style model with obj fcn W + e

#reserve space for loop output
tau = seq(0.001,.166,0.001) #this will be counter variable in loop
PSx = matrix(NA,length(tau),1)
CSx = matrix(NA,length(tau),1)
TR = matrix(NA,length(tau),1)
PSy = matrix(NA,length(tau),1)
CSy = matrix(NA,length(tau),1)

#calculate producer surplus, consumer surplus, tariff revenue for each possible
#value of the tariff on the grid (just above zero to prohibitive tariff 1/6)
for (j in 1:length(tau)) {
  t = tau[j]

  PSx[j] = ((2 +2*t)^2)/49
  CSx[j] = .5*((3 -4*t)^2)/49
  TR[j] = (t - 6*t^2)/7
  CSy[j] = ((3 +3*t)^2)/98
  PSy[j] = ((4 -3*t)^2)/98
}

#Calculations for when lobby has all the bargaining power

#calculate government welfare when tau = 0 (baseline)
b = ((2 +2*0)^2)/49 + .5*((3 -4*0)^2)/49 + (0 - 6*0^2)/7 + ((3 +3*0)^2)/98 + ((4 -3*0)^2)/98
W = PSx + CSx + TR + CSy + PSy  #social welfare
e = ((b - W)/PSx)^5             #gov't indifference condition when WG = W + e
pi = PSx - e                    #net profits

value = max(pi) #the value at which profits are maximized (over non-negative values)
ind = which.max(pi) #the location at which profits are maximized
RC = arrayInd(ind,c(dim(pi),dim(pi))) #row/column version of maximand location

#Calculations for when government has all the bargaining power
bl = ((2 +2*0)^2)/49           #baseline for lobby: profits when tau = 0
e = PSx - bl                   #effort level giving all excess profits over tau=0 to gov't

g = e^1.2                       #little g(e) function to add to social welfare
G = W + g                      #gov't welfare a la DGH97
plot(G)

value = max(G) #the value at which profits are maximized (over non-negative values)
ind = which.max(G) #the location at which profits are maximized
RC = arrayInd(ind,c(dim(G),dim(G))) #row/column version of maximand location


##Data import
url <- "http://archive.ics.uci.edu/ml/machine-learning-databases/mushroom/agaricus-lepiota.data"
mushrooms <- read.csv(file = url, header = F)

colnames(mushrooms) <- c("edibility", "cap_shape", "cap_surface", "cap_color", "bruises", "odor", "gill_att", "gill_spacing", "gill_size", "gill_color", "stalk_shape", "stalk_root", "stalk_surf_above", "stalk_surf_below", "stalk_color_above", "stalk_color_below", "veil_type", "veil_color", "ring_nr", "ring_type", "spore_print_color", "population", "habitat")

# Before I can perform market basket analysis we need to transform our dataframe to type transaction
trans <- as(mushrooms, "transactions")

# We can extract the rules with apriori() function. We pass our data.
# The resulting RHS is filtered for only edible mushrooms,
# because we want to find rules, that clearly define this outcome.
# Some minimum values for support and confidence are passed as well.
rules <- apriori(data = mushrooms,
         appearance = list(rhs=c("edibility=e"), default='lhs'),
         parameter = list(supp = 0.1, conf = .1))

rules <- sort(rules, by = "lift", decreasing = T)
inspect(rules[1:10])

# The highest lift is 1.93. For all these rules we get a confidence of 1.
# All these inputs on LHS lead to an edible mushroom.
# Since we want to make absolutely sure, that we don’t eat a poisonous mushroom,
# we should only rely on rules with confidence of 1.


# read nc file from gmted2010 @ 0.25x0.25°
# has digital elevation model

require(ncdf4)

# read in data
f <- 'data/gmted2010/GMTED2010_15n060_0250deg.nc'
n <- nc_open(f)
	print(n)
elev <- ncvar_get(n, 'elevation')
dimnames(elev) <- list(lon=ncvar_get(n, 'longitude'), lat=ncvar_get(n, 'latitude'))
	dim(elev)

# put latitude as first dimension
elev <- aperm(elev, c(2,1))

# rotate to 0 to 360 lon and 90 to -90 lat (top to bottom)
lons <- as.numeric(dimnames(elev)[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(dimnames(elev)[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

elev <- elev[newlatord, newlonord] # lat x lon (0-360) x month x year
colnames(elev) <- newcolnms
rownames(elev) <- newrownms

	image(elev)
	summary(as.numeric(elev)) # in m

# save out
save(elev, file='temp/elev.rdata')


#' radtheoric
#'
#' Computes different theoretical radiation in W/mq for a location and a time : Global, Direct Beam radiation,Diffuse Radiation, Reflected radiation based on albedo.
#'
#' @param  jddate   Datetime in DOY Day of year
#' @param  sunelev numeric Sun elevation decimal degrees
#' @param  albedo numeric Surronding albedo value. Default is 0.3
#' @param  param character Theoretical parameter available for radiation "global","direct","diffuse" ( clear sky diffuse),"reflected".
#' @return Requested irradinace in KJ on mq
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  radtheoric
#'
#' @export
#'
#'
#'
#'

radtheoric=function(jddate,sunelev=75,albedo=0.4,param="direct") {
                          ct$assign("jddate", as.array(jddate))
                          ct$assign("elev", as.array(sunelev))
                          ct$assign("albedo", as.array(albedo))
                          ct$assign("param", as.array(param))
                          ct$eval("var res=[]; for(var i=0, len=elev.length; i < len; i++){ res[i]=radtheoric(jddate[i],elev[i],albedo[0],param[0])};")
                          res=ct$get("res")
                          return(ifelse(res==9999,NA,res))
}


# Josep Ll. Berral-García
# ALOJA-BSC-MSR aloja.bsc.es
# 2015-07-14
# Comparision functions library for ALOJA-ML

###############################################################################
# Precision and comparision tools                                             #
###############################################################################

aloja_precision <- function (ds, vin, vout, noout = 0, sigma = 3, saveall = NULL, ...)
{
	if (!is.integer(sigma)) sigma <- as.integer(sigma);
	if (!is.integer(noout)) noout <- as.integer(noout);

	if (noout > 0) ds <- ds[ds[,vout] < mean(ds[,vout]) + sigma * sd(ds[,vout]) & ds[,vout] > mean(ds[,vout]) - sigma * sd(ds[,vout]),];
	ds <- ds[complete.cases(ds),];

	if (nrow(ds) > 1)
	{
		ds_ord <- ds[do.call("order", ds[,vin]),];

		auxset1 <- ds_ord[1,vout];
		auxvar1 <- NULL;
		for (i in 2:nrow(ds_ord))
		{
			if (all(ds_ord[i-1,vin] == ds_ord[i,vin]))
			{
				auxset1 <- c(auxset1,ds_ord[i,vout]);
				if (i == nrow(ds_ord)) auxvar1 <- c(auxvar1,var(auxset1));
			} else {
				if (length(auxset1) > 1) auxvar1 <- c(auxvar1,var(auxset1));
				auxset1 <- ds_ord[i,vout];
			}
		}
		diversity <- (nrow(unique(ds_ord[,vin])) - 1) / (nrow(ds_ord) - 1);

		if (!is.null(auxvar1)) { unprec <- sqrt(mean(auxvar1)); } else { unprec <- NA; }

		stats_mean <- mean(ds[,vout]);
		stats_stdev <- sd(ds[,vout]);
		stats_max <- max(ds[,vout]);
		stats_min <- min(ds[,vout]);

		retval <- cbind(diversity,nrow(ds_ord),unprec,stats_mean,stats_stdev,stats_max,stats_min);
	} else {
		retval <- cbind(0,1,1,ds[1,vout],0,ds[1,vout],ds[1,vout]);
	}
	colnames(retval) <- c("Diversity","Population","Unprecision","Stats [Mean]","Stats [StDev]","Stats [Max]","Stats [Min]");

	if (!is.null(saveall))
	{
		write.table(retval, file = paste(saveall,"-precision.data",sep=""), sep = ",", row.names=FALSE);
	}

	retval;
}

aloja_precision_split <- function (ds, vin, vout, vdisc, noout = 0, sigma = 3, json = 0, saveall = NULL, ...)
{
	if (!is.integer(json)) json <- as.integer(json);

	if (vdisc %in% vin) vin <- vin[!(vin %in% vdisc)];

	auxlist <- list();
	for (i in unique(ds[[vdisc]]))
	{
		auxlist[[as.character(i)]] <- aloja_precision(ds[ds[,vdisc]==i,],vin,vout,noout=noout, sigma=sigma);
	}
	prectable <- do.call(rbind.data.frame, auxlist);

	h <- apply(prectable,1,function(i) paste("'",paste(i,collapse="','"),"'",sep=""));
	j <- sapply(names(h),function(i) paste("['",i,"',",h[i],"]",sep=""));
	precjson <- paste("[",paste(j,collapse=","),"]",sep="");

	if (!is.null(saveall))
	{
		write.table(prectable, file = paste(saveall,"-precsplit.data",sep=""), sep = ",", row.names=FALSE);
		write(precjson, file = paste(saveall,"-precsplit.json",sep=""));
	}

	if (json > 0) { return(precjson); } else { return(prectable); }
}

aloja_reunion <- function (ds, vin, ...)
{
	retval <- list();

	ds <- ds[complete.cases(ds),];

	if (nrow(ds) > 1)
	{
		ds_ord <- ds[do.call("order", ds[,vin]),];

		numsets <- 0;
		auxid1 <- ds_ord[1,"ID"];
		for (i in 2:nrow(ds_ord))
		{
			if (all(ds_ord[i-1,vin] == ds_ord[i,vin]))
			{
				auxid1 <- c(auxid1,ds_ord[i,"ID"]);
				if (i == nrow(ds_ord))
				{
					numsets <- numsets + 1;
					retval[[numsets]] <- auxid1;
				}
			} else {
				if (length(auxid1) > 1)
				{
					numsets <- numsets + 1;
					retval[[numsets]] <- auxid1;
				}
				auxid1 <- ds_ord[i,"ID"];
			}
		}
	}
	retval;
}

aloja_diversity <- function (ds, vin, vout, vdisc, json = 0, noout = 0, sigma = 3, saveall = NULL, ...)
{
	if (!is.integer(sigma)) sigma <- as.integer(sigma);
	if (!is.integer(noout)) noout <- as.integer(noout);

	if (vdisc %in% vin) vin <- vin[!(vin %in% vdisc)];

	if (noout > 0) ds <- ds[ds[,vout] < mean(ds[,vout]) + sigma * sd(ds[,vout]) & ds[,vout] > mean(ds[,vout]) - sigma * sd(ds[,vout]),];

	retval <- list();
	supcount <- NULL;

	icount <- 0;
	a <- aloja_reunion(ds,vin);
	for (i in 1:length(a))
	{
		if (length(unique(ds[ds$ID %in% a[[i]],vdisc])) > 1)
		{
			aux_common <- unique(ds[ds$ID %in% a[[i]],vin]);
			aux_new <- t(sapply(unique(ds[ds$ID %in% a[[i]],vdisc]), function(x) c(as.character(x),mean(ds[ds$ID %in% a[[i]] & ds[,vdisc] == x,vout]),nrow(ds[ds$ID %in% a[[i]] & ds[,vdisc] == x,]))));

			res <- cbind(aux_common, aux_new);
			colnames(res) <- c(vin,vdisc,vout,"Support");

			icount <- icount + 1;
			retval[[icount]] <- res;
			supcount <- c(supcount, max(as.numeric(as.character(res$Support))));
		}
	}
	if (length(supcount) > 0) retval <- retval[order(as.vector(supcount),decreasing=T)];

	retjson <- NULL;
	if (length(retval) > 0)
	{
		auxvar1 <- retval;
		for (i in 1:length(auxvar1))
		{
			a <- apply(auxvar1[[i]],1,function(x) paste("'",paste(as.character(x),collapse="','"),"'",sep=""));
			auxinst <- paste("[",paste("[",paste(a,collapse="],["),"]",sep=""),"]",sep="");
			retjson <- c(retjson,auxinst);
		}
		retjson <- paste("[",paste(retjson,collapse=","),"]",sep="");
	} else {
		retjson <- "[]";
	}

	if (!is.null(saveall))
	{
		aloja_save_object(retval,tagname=saveall);
		write(retjson, file = paste(saveall,"-diversity.json",sep=""));
	}

	if (json > 0) { return(retjson); } else { return(retval); }
}


#install.packages("caret")
#install.packages("lattice")
#install.packages("ggplot2")
library(caret)
library(lattice)
library(ggplot2)
data_url <- c("https://archive.ics.uci.edu/ml/machine-learning-databases/car/car.data")
download.file(url = data_url, destfile = "car.data")

car_df <- read.csv("car.data", sep = ',', header = FALSE)

str(car_df)
head(car_df)
set.seed(3033)
intrain <- createDataPartition(y = car_df$V7, p= 0.7, list = FALSE)
training <- car_df[intrain,]
testing <- car_df[-intrain,]

#check dimensions of train & test set
dim(training); dim(testing);
anyNA(car_df)
summary(car_df)
trctrl <- trainControl(method = "repeatedcv", number = 10, repeats = 3)
set.seed(3333)
dtree_fit <- train(V7 ~., data = training, method = "rpart",
                   parms = list(split = "information"),
                   trControl=trctrl,
                   tuneLength = 10)

dtree_fit
prp(dtree_fit$finalModel, box.palette = "Reds", tweak = 1.2)

testing[1,]
predict(dtree_fit, newdata = testing[1,])
test_pred <- predict(dtree_fit, newdata = testing)
confusionMatrix(test_pred, testing$V7 )  #check accuracy Confusion Matrix and Statistics

set.seed(3333)
dtree_fit_gini <- train(V7 ~., data = training, method = "rpart",
                        parms = list(split = "gini"),
                        trControl=trctrl,
                        tuneLength = 10)
dtree_fit_gini

prp(dtree_fit_gini$finalModel, box.palette = "Blues", tweak = 1.2)

test_pred_gini <- predict(dtree_fit_gini, newdata = testing)
confusionMatrix(test_pred_gini, testing$V7 )  #check accuracy Confusion Matrix and Statistics


#' T-Test for RCTs with Multiple Experimental Arms
#'
#' @description This function performs a t-test to test the null hypothesis
#' that there is no mean difference between the two groups.
#' When there are three or more treatment groups,
#' this function tests the difference of mean between
#' the control group specified by the user with the `ctrl` argument
#' and each group (including the control group).
#'
#' @param outcome a string vector with outcome variables.
#' If missing, try to find out from `option("RCTtool.outcome")`.
#' @param arms a string of treatment variable.
#' If missing, try to find out from `option("RCTtool.arms")`.
#' @param ctrl a string of label of the control.
#' If missing, try to find out from `option("RCTtool.control")`.
#' @param data data object you want to use.
#'
#' @return tibble frame containing with five variables.
#' `treat` is a factor of treatments (baseline is the control).
#' `mean` and `se` is a mean and its standard error of each group.
#' `effect` is a difference of mean between each group and the control.
#' `p.value` is a p-value of t-test.
#'
#' @importFrom dplyr bind_rows
#' @export
#' @examples
#' # DGP
#' set.seed(120511)
#' n <- 1000
#' x1 <- rnorm(n); x2 <- rnorm(n)
#' d1 <- sample(c("A", "B", "C"), size = n, replace = TRUE)
#' d2 <- ifelse(d1 == "A", "control", "treat")
#' ya <- 0.2 + 0.5 * x1 + 0.01 * x2
#' yb <- 1.2 + 0.3 * x2
#' yc <- 0.2 * x1 + 0.5 * x2
#' y1 <- ifelse(d1 == "A", ya, ifelse(d1 == "B", yb, yc))
#' y2 <- ifelse(y1 > 1, 1, 0)
#' dt <- data.frame(
#'   outcome = y1,
#'   bin_outcome = y2,
#'   treat = d1,
#'   bin_treat = d2,
#'   x1,
#'   x2
#' )
#'
#' # t-test
#' set_optRCTtool(outcome ~ treat, ~ x1 + x2, dt, "A")
#' mean_diff_test(data = dt)
#' mean_diff_test(data = subset(dt, treat != "B"))
#' mean_diff_test("bin_outcome", data = dt)
#' mean_diff_test(arms = "bin_treat", ctrl = "control", data = dt)
#'
#' set_optRCTtool(bin_outcome ~ treat, data = dt, ctrl = "A")
#' mean_diff_test(data = dt)
#'
mean_diff_test <- function(outcome, arms, ctrl, data) {
  # check RCTtool.outcome option
  if (missing(outcome)) {
    outcome <- getOption("RCTtool.outcome")
    if (all(outcome == "")) stop("Not register option('RCTtool.outcome')")
  }

  # check RCTtool.arms option
  if (missing(arms)) {
    arms <- getOption("RCTtool.arms")
    if (arms == "") stop("Not register option('RCTtool.arms')")
  }

  # check RCTtool.control option
  if (missing(ctrl)) {
    ctrl <- getOption("RCTtool.control")
    if (ctrl == "") stop("Not register option('RCTtool.control')")
  }

  # check RCTtool.arms_label option
  if (missing(arms)) {
    label <- getOption("RCTtool.arms_label")
    if (all(label == "")) {
      warning("You should register option('RCTtool.arms_label')")
      dv <- data[[arms]]
      if (!is.factor(dv)) dv <- factor(dv)
      label <- levels(dv)
    }
  } else {
    dv <- data[[arms]]
    if (!is.factor(dv)) dv <- factor(dv)
    label <- levels(dv)
    if (!(ctrl %in% label)) stop("Control cannot find.")
  }

  # implement T-test
  t <- lapply(outcome, ttest, arms, label, ctrl, data)
  t <- dplyr::bind_rows(t)

  # convert character of treatment to factor
  level <- getOption("RCTtool.arms_level")
  if (any(!(label %in% level))) {
    treat <- label[grep(paste0("[^", ctrl, "]"), label)]
    t$treat <- factor(t$treat, levels = c(ctrl, treat))
  } else {
    t$treat <- factor(t$treat, levels = level)
  }

  # output
  class(t) <- append("t_test", class(t))
  t
}


setwd("")
y=read.table("", header=T, row.names=1, sep="\t")

pdata=read.csv("blood.csv", header=T)
macrophages <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Macrophages", 1]),]
monocytes <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Monocytes", 1]),]
bcell <- y[rownames(y) %in% as.character(pdata[pdata$cell == "B cells", 1]),]
neutrophils <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Neutrophils", 1]),]
nkcells <- y[rownames(y) %in% as.character(pdata[pdata$cell == "NK cells", 1]),]
plasmacells <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Plasma cells", 1]),]
platelets <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Platelets", 1]),]
Tcells <- y[rownames(y) %in% as.character(pdata[pdata$cell == "T cells", 1]),]
Ribosomes <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Ribosomes", 1]),]
IFN <- y[rownames(y) %in% as.character(pdata[pdata$cell == "IFN", 1]),]
CellCycle <- y[rownames(y) %in% as.character(pdata[pdata$cell == "Cell Cycle", 1]),]

macrophage=sd(colMeans(macrophages))
monocyte=sd(colMeans(monocytes))
bcells=sd(colMeans(bcell))
neutrophil=sd(colMeans(neutrophils))
nkcell=sd(colMeans(nkcells))
plamacell=sd(colMeans(plasmacells))
platelet=sd(colMeans(platelets))
tcell=sd(colMeans(Tcells))
Ribosome=sd(colMeans(Ribosomes))
IFNs=sd(colMeans(IFN))
CellCycles=sd(colMeans(CellCycle))

SD= rbind(macrophage,monocyte,bcells,neutrophil,nkcell,plamacell,platelet,tcell,Ribosome, IFNs, CellCycles)
colnames(SD)="SD"

#Calculate average correlation value

y_macr=cor(t(macrophages),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
macrophage=m2["Median"]

y_macr=cor(t(monocytes),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
monocyte=m2["Median"]

y_macr=cor(t(bcell),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
bcells=m2["Median"]

y_macr=cor(t(neutrophils),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
neutrophil=m2["Median"]

y_macr=cor(t(nkcells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
nkcell=m2["Median"]

y_macr=cor(t(plasmacells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
plamacell=m2["Median"]

y_macr=cor(t(platelets),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
platelet=m2["Median"]

y_macr=cor(t(Tcells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
tcell=m2["Median"]

y_macr=cor(t(Ribosomes),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
Ribosome=m2["Median"]

y_macr=cor(t(IFN),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
IFNs=m2["Median"]

y_macr=cor(t(CellCycle),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m2=m1[,3]
m2=summary(m2)
CellCycles=m2["Median"]

R= rbind(macrophage,monocyte,bcells,neutrophil,nkcell,plamacell,platelet,tcell,Ribosome, IFNs, CellCycles)
colnames(R)="Average Correlation"

#Edges Calculator

for (i in 50:99)
{
y_macr=cor(t(macrophages),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq > (as.numeric(paste(0,i, sep="."))))
macrophage= dim(m1)[1]

y_macr=cor(t(monocytes),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
monocyte= dim(m1)[1]

y_macr=cor(t(bcell),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
bcells= dim(m1)[1]

y_macr=cor(t(neutrophils),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
neutrophil= dim(m1)[1]

y_macr=cor(t(nkcells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
nkcell= dim(m1)[1]

y_macr=cor(t(plasmacells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
plamacell= dim(m1)[1]

y_macr=cor(t(platelets),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
platelet= dim(m1)[1]

y_macr=cor(t(Tcells),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
tcell= dim(m1)[1]

y_macr=cor(t(Ribosomes),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
Ribosome= dim(m1)[1]

y_macr=cor(t(IFN),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
IFNs= dim(m1)[1]

y_macr=cor(t(CellCycle),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
CellCycles= dim(m1)[1]

assign(paste("Edge", i-49, sep="_"), rbind(macrophage,monocyte,bcells,neutrophil,nkcell,plamacell,platelet,tcell,Ribosome, IFNs, CellCycles))
}
Edge = Edge_1
for (i in 2:50) Edge <- cbind(Edge, get(paste("Edge",i, sep="_")))

#Nodes Calculator
all <- y[rownames(y) %in% as.character(pdata[pdata$type == "blood", 1]),]
dim(all)

for (i in 50:99)
{
y_macr=cor(t(all),method="pearson")
y_macr [lower.tri(y_macr,diag=TRUE)]<-NA
m =as.data.frame(as.table(y_macr))
m1=subset(m,!is.na(m $Freq))
m1= subset(m1, m1 $Freq>(as.numeric(paste(0,i, sep="."))))
m2=unique(m1['Var1'])
m3=unique(m1['Var2'])
colnames(m2)[1]="gene"
colnames(m3)[1]="gene"
m4=rbind(m2,m3)
m5=unique(m4)

macrophages <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Macrophages", 1]),]
monocytes <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Monocytes", 1]),]
bcell <- m5[m5$gene %in% as.character(pdata[pdata$cell == "B cells", 1]),]
neutrophils <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Neutrophils", 1]),]
nkcells <- m5[m5$gene %in% as.character(pdata[pdata$cell == "NK cells", 1]),]
plasmacells <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Plasma cells", 1]),]
platelets <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Platelets", 1]),]
Tcells <- m5[m5$gene %in% as.character(pdata[pdata$cell == "T cells", 1]),]
Ribosomes <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Ribosomes", 1]),]
IFN <- m5[m5$gene %in% as.character(pdata[pdata$cell == "IFN", 1]),]
CellCycle <- m5[m5$gene %in% as.character(pdata[pdata$cell == "Cell Cycle", 1]),]

macrophage=length(macrophages)
monocyte=length(monocytes)
bcells=length(bcell)
neutrophil=length(neutrophils)
nkcell=length(nkcells)
plamacell=length(plasmacells)
platelet=length(platelets)
tcell=length(Tcells)
Ribosome=length(Ribosomes)
IFNs=length(IFN)
CellCycles=length(CellCycle)

assign(paste("Node", i-49, sep="_"), rbind(macrophage,monocyte,bcells,neutrophil,nkcell,plamacell,platelet,tcell,Ribosome, IFNs, CellCycles))
}
Node = Node_1
for (i in 2:50) Node <- cbind(Node, get(paste("Node",i, sep="_")))
final=cbind(SD,R)

pdata1=read.csv("pdata_edge.csv", header=T, row.names=1)

final1=cbind(final,pdata1)

for (i in 1: 50)
{
score= ((final1[,2]/final1[,1])*(Edge[,i]/final1[,3])*(Node[,i]/final1[,5]))*100
assign(paste("score", i, sep = "_"), score)
}
score = score_1
for (i in 2:50) score <- cbind(score, get(paste("score",i, sep="_")))

colnames(score) <- paste(rep(0, 50), 50:99, sep='.')

library(plyr)
macrophages= 1- ((count(score[1,] < 20)[2,2])/50)
monocytes= 1- ((count(score[2,] < 20)[2,2])/50)
bcells= 1- ((count(score[3,] < 20)[2,2])/50)
neutrophils=1- ((count(score[4,] < 20)[2,2])/50)
nkcells=1- ((count(score[5,] < 20)[2,2])/50)
plasmacells=1- ((count(score[6,] < 20)[2,2])/50)
platelets=1- ((count(score[7,] < 20)[2,2])/50)
tcells=1- ((count(score[8,] < 20)[2,2])/50)
Ribosomes=1- ((count(score[9,] < 20)[2,2])/50)
IFNs=1- ((count(score[10,] < 20)[2,2])/50)
CellCycle=1- ((count(score[11,] < 20)[2,2])/50)

FinalScore= cbind(macrophages,monocytes,bcells,neutrophils,nkcells,plasmacells,platelets,tcells,Ribosomes,IFNs,CellCycle)
colnames(FinalScore)= c("Macrophages", "Monocytes", "B cells", "Neutrophils", "NK cells", "Plasma cells", "Platelets", "T cells", "Traslational activity", "Interferon signalling", "Cell cycle")
write.table(FinalScore,file="ImSig Score-Microarray-Blood.txt", sep="\t")

ImSig Algorithm/Microarray- BLOOD IMSIG SCORE.r


# Enter your code here. Read input from STDIN. Print output to STDOUT
p<-c(15,12,8,8,7,7,7,6,5,3)
h<-c(10,25,17,11,13,17,20,13,9,15)
ans<-cor(p,h)
ans<-round(ans,3)
cat(ans)

Artificial Intelligence/Statistics and machine learning/Correlation_and_Regression_Lines _ A_Quick_Recap _1.r


# CLUSTER GLEDE NA ZADOVOLJSTVO PREBIVALCEV, ZAPOSLENOST, BDP TER STEVILO PREBIVALCEV

cluster_evropa <- function(){
  evropa1 <- uvozi.svet() %>% filter (continent == 'Europe')
  zadovoljstvo <- uvozi.rating() %>% filter(leto == 2018)
  brezposelnost_cluster <- uvozi.zaposlenost()
  bdp <- uvozi.BDP() %>% filter(leto == 2018) %>% select('Drzava', 'BDP per capita')
  evropa2 <- merge(x = evropa1, y = zadovoljstvo, by.y = 'Drzava', by.x = 'name')
  evropa3 <- merge(x = evropa2, y = brezposelnost_cluster, by.y = 'name', by.x = 'name')
  evropa4 <- merge(x = evropa3, y = bdp, by.y = 'Drzava', by.x = 'name')
  podatki_cluster <- evropa4 %>% filter (leto == 2018) %>% select('name', 'pop_est','BDP per capita', 'Ocena','Brezposelnost')
  podatki_cluster2 <- podatki_cluster
  podatki_cluster$geometry = NULL
  cluster <- podatki_cluster %>% select(-name) %>% scale()
  rownames(cluster) <- podatki_cluster$name
  k <- kmeans(cluster, 5, nstart=1000)
  skupine <- data.frame(name=podatki_cluster2$name, skupina=factor(k$cluster))
  podatki_za_risat <- merge(podatki_cluster2, skupine, by ='name')
  zemljevid <- tm_shape(podatki_za_risat) + tm_polygons('skupina')
  zemljevid
  tmap_mode('view')
  return(zemljevid)
}
cluster <- cluster_evropa()

# GRAF KI PRIKAZUJE GIBANJE REALNEGA BDP SLOVENIJE TER EVROPE NA PREBIVALCA IN NAPOVEDUJE PRIHODNOST

napovedovanje_BDP <- function(){
  BDP <- uvozi.BDP()
  bdp_po_letih_eu <- aggregate(BDP$'BDP per capita', by=list(leto=BDP$leto), FUN=mean)
  bdp_po_letih_eu$x <- as.numeric(bdp_po_letih_eu$x)
  bdp_po_letih_eu$leto <- as.numeric(bdp_po_letih_eu$leto)
  bdp_po_letih_eu$z <- 'evropa'

  bdp_po_letih_slo <- BDP %>% filter(Drzava == 'Slovenia') %>% select('leto', 'BDP per capita')
  bdp_po_letih_slo <- bdp_po_letih_slo %>% rename(x = 'BDP per capita')
  bdp_po_letih_slo$x <- as.numeric(bdp_po_letih_slo$x)
  bdp_po_letih_slo$leto <- as.numeric(bdp_po_letih_slo$leto)
  bdp_po_letih_slo$z <- 'slovenija'

  bdp_po_letih <- rbind(bdp_po_letih_eu, bdp_po_letih_slo)
  colnames(bdp_po_letih)[3] <- "Legenda"

  h <- ggplot(bdp_po_letih, aes(leto, x, shape=Legenda, colour=Legenda, fill=Legenda)) +
        geom_smooth(method="lm", fullrange=TRUE) +
        geom_point(size=3) +
        fte_theme() +
        xlab("Leto") +
        ylab("€") +
        ggtitle("Gibanje realnega BDP v € na prebivalca") +
        scale_x_continuous(breaks = 2013:2022) +
        expand_limits(x = 2020) +
        geom_hline(yintercept=0, size=0.4, color="black") +
        theme(legend.position="right")
  return(h)
}
napovedovanje <- napovedovanje_BDP()


## Exercicio 1
## Prof. James Hunter
## from: https://rstudio.cloud/project/1177204
## 11 de maio de 2020

# 1 - Fazer o cálculo
((42 * 95^2) + 6)/(16 - 3.5)

# 2 - Atribuir à variável calc
calc <- ((42 * 95^2) + 6)/(16 - 3.5)

# 3 - arrondar a 1 casa decimal
round(calc, digits = 1)


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

# author - akashraj

# data-informed PBCM implementation

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

#load required libraries
library("boot")
library("MASS")
library("fitdistrplus")
library("actuar")
library("ggplot")

#load data
eclipse_data_20 <- read.table("data/eclipse-metrics-files-2.0.csv", header = T, sep = ";")

#select only 'filename' and 'pre' columns
eclipse_20_required_columns = eclipse_data_20[, c("filename", "pre")]
eclipse_20_required_columns = eclipse_20_required_columns[order(-eclipse_20_required_columns$pre), , drop = F]

#select non-null values
eclipse_20_nonnull_rows = eclipse_20_required_columns[eclipse_20_required_columns$pre > 0, ]

#step 1: non-parametric bootstrap

statFunction = function(d, i)
{
  d2 = d
  return (4)
}

npbootstrap = boot(eclipse_20_required_columns, statFunction, R=500)
values = boot.array(npbootstrap, indices = T)

goodness_of_fit_A = vector(,1000)
goodness_of_fit_B = vector(,1000)

for(j in 1:500)
{
	generated_data <- values[j,]

	#sampling with replacement
	for(i in 1:ncol(values))
	{
		generated_data[i] <- eclipse_20_required_columns[values[2,i], 2]
	}

	generated_data = sort(generated_data, decreasing = T)
	generated_data_nonnull_rows = generated_data[generated_data > 0]

	#step 2: Fit model A and model B into generated samples resulting in MLE parameter vectors

	#model A = weibull
	fitWeibull = fitdist(generated_data_nonnull_rows, "weibull")
	#mle parameters after weibull is fit into the generated data
	mleParamsA = c(fitWeibull$estimate["shape"], fitWeibull$estimate["scale"])

	fitPareto = fitdist(generated_data_nonnull_rows, "pareto", start = list(shape = 1, scale = 500))
	mleParamsB = c(fitPareto$estimate)

	#step 3: Apply parametric bootstrap to both models

	#pBootFunction = function(d, mle)
	#{
	#  out <- d
	#  out$param <- rweibull(length(out), mle[1], mle[2])
	#  out
	#}
	#
	#pbootstrap = boot(generated_data_nonnull_rows, statFunction, R = 2, sim = "parametric", ran.gen = pBootFunction, mle = mleParamsA)
	#pValues = boot.array(pbootstrap, indices = T)

	generated_data_A = rweibull(length(generated_data_nonnull_rows), fitWeibull$estimate["shape"], fitWeibull$estimate["scale"])
	generated_data_A = sort(generated_data_A, decreasing = T) #generated_data_A = sort(ceiling(generated_data_A), decreasing = T)

	generated_data_B = rpareto(length(generated_data_nonnull_rows), fitPareto$estimate["shape"], fitPareto$estimate["scale"])
	generated_data_B = sort(generated_data_B, decreasing = T) #generated_data_B = sort(ceiling(generated_data_B), decreasing = T)

	#step 4: cross fitting of models (with each other's generated data)

	#fit models A and B with generated_data_A
	cross_fit_A_A <- fitdist(generated_data_A, "weibull")
	cross_fit_A_B <- fitdist(generated_data_A, "pareto", start = list(shape = 1, scale = 500))

	goodness_of_fit_A[j] = cross_fit_A_A$bic - cross_fit_A_B$bic

	#fit models A and B with generated_data_B
	cross_fit_B_A <- fitdist(generated_data_B, "weibull")
	cross_fit_B_B <- fitdist(generated_data_B, "pareto", start = list(shape = 1, scale = 500))

	goodness_of_fit_B[j] = cross_fit_B_A$bic - cross_fit_B_B$bic

}

#fit observed data into models A and B
#obtain the gof

observed_data = eclipse_20_nonnull_rows[, 2]

fitWeibullObs = fitdist(observed_data, "weibull")
fitParetoObs = fitdist(observed_data, "pareto", start = list(shape = 1, scale = 500))

GOF = fitWeibullObs$bic - fitParetoObs$bic

hist(goodness_of_fit_A, freq = F)
lines(density(goodness_of_fit_A))

######## Resources ########

# 1) parametric vs non parametric:  http://stats.stackexchange.com/questions/47253/questions-on-paramatric-and-non-parametric-bootstrap