## 1. Visualizing Distributions to Investigate Movie Review Bias ##

reviews <- read_csv("movie_reviews.csv")

## 2. Comparing Averages Among Rating Sites ##

review_avgs <- reviews %>%
  group_by(Rating_Site) %>%
  summarize(mean(Rating))

## 3. Visualizing Differences Among Groups Using Bar Charts ##

review_avgs <- reviews %>%
  group_by(Rating_Site) %>%
  summarize(avg = mean(Rating))
ggplot(data = review_avgs,
  aes(x = Rating_Site, y = avg)) +
  geom_bar(stat = "identity")

## 4. Using Histograms to Understand Distributions ##

ggplot(data = reviews,
  aes(x = Rating)) +
  geom_histogram(bins = 30)

## 5. Comparing Distributions of Multiple Variables: Faceted Plots ##

# ggplot(data = reviews,
#   aes(x = Rating)) +
#   geom_histogram(bins = 30)
ggplot(data = reviews,
  aes(x = Rating)) +
  geom_histogram(bins = 30) +
  facet_wrap(~Rating_Site, nrow= 2)

## 6. Comparing Distributions of Multiple Variables: Specifying Aesthetics ##

# ggplot(data = reviews,
#  aes(x = Rating)) +
#  geom_histogram(bins = 30)
ggplot(data = reviews,
  aes(x = Rating, fill= Rating_Site)) +
  geom_histogram(bins = 30)

## 7. Visualizing Averages and Variation ##

ggplot(data = reviews,
  aes(x = Rating_Site, y = Rating)) +
  geom_boxplot()

## 8. Anatomy of a Box Plot ##

# ggplot(data = reviews,
#   aes(x = Rating_Site, y = Rating)) +
#   geom_boxplot()
ggplot(data = reviews,
  aes(x = Rating_Site, y = Rating)) +
  geom_boxplot() +
  labs(title = "Comparison of Movie Ratings") +
  theme(panel.background = element_rect(fill = "white"))

Data Analyst in R/Step 2 - Data Visualization in R/Data Visualization in R/3. Bar Charts, Histograms, and Box Plots.r


library(ggplot2)
library(reshape2)
library(RColorBrewer)

load("sc2-multi.RData")

ssedata <- data.frame(SSEmat)
if2mat <- ssedata[,1:nTrials]
if2mat[if2mat == Inf] <- NaN
if2means <- rowMeans(if2mat, na.rm = TRUE)
hmcmat <- ssedata[,(nTrials+1):(2*nTrials)]
hmcmat[hmcmat == Inf] <- NaN
hmcmeans <- rowMeans(hmcmat, na.rm = TRUE)

if2meds <- apply(if2mat, 1, median)
hmcmeds <- apply(hmcmat, 1, median)

times <- 1:dim(ssedata)[1]

df <- data.frame(time = times, if2 = log10(if2means), hmc = log10(hmcmeans))
plotdata <- melt(df, id = "time")

## full
q <- qplot(data = plotdata, x = time, y = value, geom = "line", color = variable, xlab = "Truncation", ylab = expression(SSE~(log[10]))) +
		scale_colour_manual(values = c("black","grey"),
		                    labels = c("IF2", "HMCMC"),
		                    name = "Method") +
		theme_bw()

ggsave(q, filename="truncation.pdf", height=4, width=6.5)

df2 <- data.frame(time = times, if2 = log10(if2meds), hmc = log10(hmcmeds))
plotdata2 <- melt(df2, id = "time")

q2 <- qplot(data = plotdata2, x = time, y = value, geom = "line", color = variable, xlab = "Truncation", ylab = "log(SSE)") +
		scale_colour_manual(values = c("black","grey"),
		                    labels = c("IF2", "HMCMC"),
		                    name = "Method") +
		theme_bw()

ggsave(q2, filename="truncation2.pdf", height=4, width=6.5)


function(d, x=NA, genplot=F, color = 2, y.lim = c(100,200), zthresh = 2.5){
#This function plots the column means and confidence intervals of a data matrix as a ribbon plot
#===========

	npts <- dim(d)[2]                #number of data points
	if(is.na(x)) x <- c(1:npts)      #set x values if not specified as argument

	nsjs <- dim(d)[1]                #number of subjects
	mn <- colMeans(d, na.rm=T)       #compute column means across rows
	cis<-rep(0, times = npts)        #initialize vector to hold cis

	for(i1 in c(1:npts)){
		currpt <- d[,i1]
		if(!is.na(zthresh)) currpt[abs(zscore(currpt)) > zthresh] <- NA
		nvalid <- nsjs - sum(is.na(d[,i1]))   #How many valid entries?
		tval <- qt(0.975,nvalid)	      #t value for df = nvalid
		cis[i1] <- tval * (sqrt(var(currpt, na.rm=T))/sqrt(nvalid)) #Store CI as tval * standard error
		}

	#If the plot is to be generated:
	if(genplot) plot(0,0,xlim = range(x), ylim = y.lim, type="n", ylab="Boundary estimate", xlab="Window")

	points(x, mn, col = color)        #add points
	polygon(c(x,x[npts:1]), c(mn-cis, c(mn+cis)[npts:1]), col=hsv((color-2)/3,1,1,.5), border=NA)
}


## Dati
x1 <- 22.05 # (minore)
p1 <- 0.09

x2 <- 25.84 # (maggiore)
p2 <- 0.08

x3 <- 0.578

## Svolgimento

mat_a <- matrix(data = c(1,qnorm(p1),1,qnorm(1-p2)),
              nrow = 2, ncol = 2, byrow = TRUE)
mat_b <- c(x1, x2)
tmp <- solve(mat_a, mat_b)
mi <- tmp[1]
sigma <- tmp[2]
rm(mat_a, mat_b, tmp)

risultato3 <- 1 - pnorm(x3) + pnorm(-x3)

print(mi)
print(sigma)
print(risultato3)


# R - 3.4.1

mul <- function(a, b) {
    a * b
}


install.packages("Exact", repos="https://cloud.r-project.org")

library("Exact")

method_to_use <- "Z-unpooled"

f_obs <- matrix(c(15, 0, 38, 47), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method=method_to_use, model="Binomial", cond.row=FALSE)
result

f_obs <- matrix(c(16, 13, 37, 34), nrow=2, ncol=2, byrow=TRUE)
result <- exact.test(f_obs, alternative="two.sided", method=method_to_use, model="Binomial", cond.row=FALSE)
result


########################
#Functions for calculating
#sufficient statistics
#
########################
legendre_Pl_array<-function(m,y){
  pf<-polynomial.functions(legendre.polynomials(m,normalized=F))
  lv<-sapply(X=1:(m+1),FUN=function(x){
    pf[[x]](y)
  })
  return(t(lv)*sqrt(2))
}

legendre_Pl_array<-function(m,y){
  pf<-polynomial.functions(legendre.polynomials(m,normalized=T))
  lv<-sapply(X=1:(m+1),FUN=function(x){
    pf[[x]](y) #*sqrt(2*(x-1)+1)
  })
  return(t(lv)*sqrt(2))
}

edge.means<-function(dat,edgelist,m,cores){
  n<-dim(dat)[1]
  nedge<- dim(edgelist)[1]
  if(nedge==0) return(array(dim=c(m,m,0)))
  me<-mclapply(
    1:nedge,
    function(e){
      ge<-edgelist[e,]
      s<-ge[1];t<-ge[2]
      tcrossprod(legendre_Pl_array(m,2*dat[,s]-1)[-1,,drop=F],
                 legendre_Pl_array(m,2*dat[,t]-1)[-1,,drop=F])/n
    },
    mc.cores=cores)
  return(array(unlist(me),dim=c(m,m,nedge)))
}

node.means<-function(dat,m,cores){
  if(is.vector(dat)){
    dat<-matrix(dat,length(dat),1)
  }
  d=dim(dat)[2]
  me<-mclapply(
    1:d,
    function(v){
      rowMeans(legendre_Pl_array(m,2*dat[,v]-1)[-1,,drop= F])
    },
    mc.cores=cores
  )
  return(matrix(unlist(me),nrow=d,byrow=T ))
}


y <- c(5,4,3,1,3)
mean_y<-sum(y)/length(y)
sample_variance <-(sum((y-mean_y)^2/(length(y)-1)))
print(sample_variance)


# coding: utf-8

# # Práctico 8 - Predecir información faltante en redes
#
# # 1. Ambientes de trabajo
#
# ## 1.a) Ambiente COLAB remoto
#
# 1.   Abrir en navegador: https://colab.research.google.com/
# 2.   Abrir el notebook de la tarea:
#      File-> Open Notebook -> Github -> https://github.com/prbocca/na101_master -> homework_8_prediction
# 3.   Guardar el notebook en su Google Drive:
#      File -> Save a Copy in Drive...
# 4.   Renombrar el archivo `"cedula ID"_ar_hw8.ipynb`, por ejemplo *33484022_ar_hw8.ipynb*
# 5.   Al final usted deberá descargar el notebook. Asegurarse que se están guardando las salidas de ejecución en el notebook: File -> Download .ipynb
# 6.   Luego estos archivos deberán ser enviados a prbocca@fing.edu.uy
#
# ##1.b) Ambiente RSTUDIO local (opcional)
#
# Abrir el .r de la tarea en: https://github.com/prbocca/na101_master/tree/master/homework_8_prediction

# ## 1.c) Cargar Librerias

# In[ ]:

# cargar librerias
load_libs <- function(libraries = libs, install=TRUE){
  if (install){ # instalar librerias no instaladas
    new.packages <- libs[!(libs %in% installed.packages()[,"Package"])]
    if(length(new.packages)) install.packages(new.packages)
  }
  #cargo librerias
  for (lib in libraries){
    require(lib, character.only=TRUE, quietly = FALSE)
  }
}

libs = c("ROCR", #evaluacion de problemas de clasificacion
         "rgexf", #igraph to gephi
         "vioplot",  "cowplot",
         # "org.Sc.sgd.db", "GOstats", "GO.db", #parecen no estar disponibles en el ambiente COLAB y los instalaremos luego de otra manera
         "foreach", "doMC", #procesamiento en paralelo
         "sand","igraph", "ggplot2", "reshape2") #las basicas

load_libs(libs)

# ## 1.d) Descargar funciones auxiliares

# In[ ]:

#directorio donde se va a trabajar
data_path = "/content/ar/hw8/"

dir.create(data_path, showWarnings = FALSE, recursive = TRUE)
setwd(data_path)
getwd()
list.files()

# cargo funciones auxiliares
source("https://raw.githubusercontent.com/prbocca/na101_master/master/homeworks_common.r")

# # 2. Predicción de enlaces en `R`.
#
# Seguir las Secciones 7.1 y 7.2 del libro [SANDR], ejecutando el código fuente incluido.
#

# In[ ]:

# Chapter 7 Network Topology Inference
# 7.1 Introduction
# 7.2 Link Prediction SANDR (esta es el tutorial de SANDR incluido como ejercicio)
#########################################################
# To illustrate the potential of simple scoring methods like this, recall the network
# fblog of French political blogs. The number of nearest common neighbors for
# each pair of vertices in this network, excluding—if incident to each other—the two
# vertices themselves, may be computed in the following manner.
#library(sand)
fblog = upgrade_graph(fblog)  #evita warnings por ser un grafo en version vieja
nv <- vcount(fblog)
ncn <- numeric()
A <- get.adjacency(fblog)
for(i in (1:(nv-1))){
  ni <- neighborhood(fblog, 1, i)
  nj <- neighborhood(fblog, 1, (i+1):nv)
  nbhd.ij <- mapply(intersect, ni, nj, SIMPLIFY=FALSE)
  temp <- unlist(lapply(nbhd.ij, length)) -
    2 * A[i, (i+1):nv]
  ncn <- c(ncn, temp)
}

# In[ ]:

# In Fig. 7.2 we compare the scores s(i, j) for those vertex pairs that are not incident
# to each other (i.e., ‘no edge’), and those that are (i.e., ‘edge’), using so-called violin
# plots.
#library(vioplot)
Avec <- A[lower.tri(A)]
vioplot(ncn[Avec==0], ncn[Avec==1],
        names=c("No Edge", "Edge"))
title(ylab="Number of Common Neighbors")

# In[ ]:

# It is evident from this comparison that there is a decided tendency towards larger
# scores when there is in fact an edge present. Viewing the calculation we have done
# here as a ‘leave-one-out’ cross-validation, and calculating the area under the curve
# (AUC) of the corresponding ROC curve,
#library(ROCR)
pred <- prediction(ncn, Avec)
perf <- performance(pred, "auc")
slot(perf, "y.values")

#agrego el plot de la curva ROC
roc.perf = performance(pred, measure = "tpr", x.measure = "fpr")
plot(roc.perf, col="red")
abline(a=0, b= 1)

# $\def\ccalN{{\mathcal N}}$
#
# # 3. Predicción de aristas en redes reales.
#
# En este ejercicio veremos que tan bien funcionan los métodos informales de *score* para predecir enlaces en distintas redes. Este ejercicio fue originalmente propuesto por el Prof. Aaron Clauset, en su curso "Network Analysis and Modeling", CSCI 5352, del Santa Fe Institute.
#
# Como vimos, los métodos informales de predicción de enlaces basados en *score* definen una medida de enlace para todo par de vértices que no son aristas (es decir, definen el *score*, $s(i,j)$, para todo $(i,j) \notin E^{obs}$), y predicen las aristas faltantes como aquellas parejas con mayor `score`.
# Hay muchas funciones de `score` posibles, en este ejercicio probaremos tres:
# *   camino más corto: $s(i,j)= \frac{1}{dist_{G^{obs}}(i,j)}$, siendo $dist_{G^{obs}}(i, j)$ la distancia geodésica observada entre los vértices $i$ y $j$ en el grafo observado;
#
# *   vecinos en común: $s(i,j)=|\ccalN_i^{obs}\cap \ccalN_j^{obs}|$; y
#
# *   producto de grados observados: $s(i,j)= d_i d_j$.

# ## 3.a) Descargar y cargar la red de la enfermedad de Malaria.
#
# Existen muchas representaciones en red de las relaciones entre los genes para la enfermedad de la Malaria.
# Usaremos la red de: *D. B. Larremore, A. Clauset, and C. O. Buckee, "A network approach to analyzing highly recombinant malaria parasite genes." PLOS Computational Biology 9(10), e1003268 (2013).*
#
# Esta red tiene $307$ vértices y $2684$ aristas.
# Los vértices son genes, y dos genes están conectados si ellos comparten un substring cuyo largo es estadísticamente significativo. Se tiene una etiqueta en los vértices que clasifica los genes.
# Visualizar la red en la siguiente Figura (el color de los vértices es la etiqueta de clasificación, y el tamaño representa el grado): ![alt text](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_malaria.png)
#
# Descargar el grafo desde: https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_malaria.graphml.

# In[ ]:

# descargar y cargar datos
g_malaria = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: -
#
#
#
##################################################################
summary(g_malaria)

#plot
set.seed(25)
E(g_malaria)$color = "gray"
plot(g_malaria, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=V(g_malaria)$label, vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_malaria), main="Malaria")

# ## 3.b) Descargar y cargar la red de las relaciones entre directivos en empresas públicas de Noruega.
#
# Usaremos los datos del siguiente trabajo: *C. Seierstad and T. Opsahl, "For the few not the many? The effects of affirmative action on presence, prominence, and social capital of women directors in Norway." Scand. J. Manag. 27(1), 44-54 (2011)*.
#
# Es una red de afiliaciones entre directores que comparten alguna junta directiva en  las compañias públicas noruegas.
# La red tiene una gran componente, con $854$ vértices (directivos) y $2745$ aristas (juntas directivas en común), y corresponde a la realidad de agosto de 2011.
# Se incluyen algunos metadatos, como los nombres de directores y compañías, la ciudad y código postal para empresas, y el género de los directores. Visualizar la red en la siguiente Figura (el color de los vértices es el género (azul-hombre, rojo-mujer), y el tamaño representa el grado): ![alt text](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_gcdirectores.png)
#
# Descargar el grafo desde:
# https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/g_gcdirectores.graphml.
#

# In[ ]:

# descargar y cargar datos
g_gcdirectores = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: -
#
#
#
##################################################################
summary(g_gcdirectores)

#plot
set.seed(25)
E(g_gcdirectores)$color = "gray"
plot(g_gcdirectores, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color=V(g_gcdirectores)$gender, vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_gcdirectores), main="Red de afiliación de directores noruegos: componente gigante")

# ## 3.c) Predecir enlaces
#
# Para medir la calidad de predicción de cada método usaremos la métrica $AUC$ (*Area Under Curve*). Ver la página de Wikipedia sobre ROC: http://bit.ly/2ehXHrb. Un predictor aleatorio tiene $AUC=0.5$ y un predictor perfecto tiene $AUC=1.0$ por tanto los métodos serán mejores a mayor valor de $AUC$.
#
# Utilizando la métrica AUC, evaluar la capacidad predictiva del método de *score* de vecinos en común, sobre una subred observada con el $\%80$ de las aristas de la red de Malaria.
#
# Se disponen de varias funciones auxiliares precargadas, incluyendo `score()` y  `delete_edges_rand()`.
# Es posible ver las funciones axiliares en: https://raw.githubusercontent.com/prbocca/na101_master/master/homeworks_common.r.
#
# El siguiente código resuelve el ejercicio y ejemplifica como usar las funciones auxiliares. Se obtiene una muy buena capacidad predictiva, con un $AUC=0.917$ y la curva ROC de la siguiente Figura: ![Curva ROC para el método de score de vecinos en común, sobre una subred con el %80 de las aristas de la red de Malaria.](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/roc_malaria.png)
#
#

# In[ ]:

# computo las aristas reales y las pongo en un vector (triangular inferior, mismo orden que score())
A_malaria <- get.adjacency(g_malaria)
A_malaria_v <- A_malaria[lower.tri(A_malaria)]

#creo una subred observada
set.seed(42)
g_malaria_obs = delete_edges_rand(g_malaria, p=0.2)

# computo las aristas observadas y las pongo en un vector (triangular inferior, mismo orden que score())
A_malaria_obs = get.adjacency(g_malaria_obs)
A_malaria_obs_v <- A_malaria_obs[lower.tri(A_malaria_obs)]
true_possibleedges_no_obs = A_malaria_v[A_malaria_obs_v==0] #vector real sobre aristas no observadas

# computo aristas predichas
s_cn  = score(g_malaria_obs, type="common neighbors")
pred_possibleedges_no_obs = s_cn$score[A_malaria_obs_v==0] #vector prediccho sobre aristas no observadas

# computo la performance
pred_malaria <- prediction(pred_possibleedges_no_obs, true_possibleedges_no_obs)
perf_malaria <- performance(pred_malaria, "auc")
printf("El método de score usando vecinos en cumún, tiene un AUC=%s", slot(perf_malaria, "y.values"))
# el valor de AUC es 0.9172444

#plot de la curva ROC
roc_malaria = performance(pred_malaria, measure = "tpr", x.measure = "fpr")
plot(roc_malaria, col="red")
title("ROC para la red de Malaria y %20 de aristas no observadas")
abline(a=0, b=1)

# ## 3.d) Estudio exahustivo de capacidad predictiva
#
# Realizar un estudio más exahustivo sobre la calidad predictiva del método de score, probando las tres funciones de score definidas anteriormente, variando el porcentaje de aristas observadas entre \%99 y \%20.
# Buscando eliminar casuística, repetir la prueba sorteando distintos grafos observados.
# Realizar este procedimiento para las siguientes redes:
# *   grafo aleatorio de Erdos Renyi con $100$ vértices y una probabilidad de arista de $0.20$;
#
# *   modelo Barabási-Albert con $100$ vértices y $m=9$ aristias agregadas en cada paso;
#
# *   red de Malaria; y
#
# *   red de directores.
#
#
# Es posible utilizar la función auxiliar cargada previamente `summary_predictions(g, n_sample, p, types=c("1/dist","common neighbors", "degree product"), metric="auc", cores=1)`, que recibe un grafo $g$, crea un grafo observado para cada probabilidad de eliminación de arista del vector $p$, y prueba el métoodo de *score* para distintos tipos de medidas y para la métrica $AUC$. Repite cada caso `n_sample` y promedia resultados.
#
#

# In[ ]:

# defino los parámetros del experimento

# para cada grafo, sorteo un subgrafo observado, calculo todos los tipos de score, predigo aristas faltantes y evaluo la metrica
p_v = c(0.01, 0.05, 0.10, 0.20, 0.50, 0.80) #las probabilidades de eliminacion de arista a evaluar
n_sample = 5 #cantidad de sorteos de g_obs
types = c("1/dist","common neighbors", "degree product")
metric="auc"
n_cores = 1 #la ejecución en COLAB solo permite 1 CPU

# In[ ]:

#realizo los cálculos para el grafo aleatorio

# sorteo un grafo
g_erdosrenyi = erdos.renyi.game(100,0.20)
write.graph(g_erdosrenyi, file="g_erdosrenyi.graphml", format= "graphml")
plot(g_erdosrenyi, edge.color="gray", edge.width=1, edge.lty=1, edge.arrow.size=.5,
     vertex.color="black", vertex.size=3, vertex.label=NA,
     layout=layout_with_drl(g_erdosrenyi), main="Erdos-Renyi")

# evaluo la capacidad predictiva sobre ese grafo
results_erdosrenyi = summary_predictions(g_erdosrenyi, n_sample, p_v, types, metric, cores=n_cores)
saveRDS(results_erdosrenyi, "results_erdosrenyi.RDS")

# imprimo resultados
ggplot(results_erdosrenyi$results_summary, aes(100*p, auc, colour = score)) +
  geom_line() +
  geom_point(data=results_erdosrenyi$results, aes(100*p, auc, colour = score), alpha=0.01) +
  labs(title = "AUC para distintos scores y porcentaje de aristas no observadas",
       subtitle = "grafo Erdos Renyi", x="% aristas no observadas", y="AUC")

# In[ ]:

#realizo los cálculos para el grafo Barabasi-Albert

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# In[ ]:

#realizo los cálculos para el grafo g_malaria

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# In[ ]:

#realizo los cálculos para el grafo g_gcdirectores

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# ## 3.e) Interpretar resultados de sección anterior
#
# En la sección anterior debieron obtenerse resultados similares a los de la siguiente Figura: ![AUC de los métodos de score para predecir enlaces, usando distintos porcentajes de aristas no observadas y distintas redes.](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/result_auc_p.png)
#
# Como es de esperar:
# *    no puede predecirse aristas en los grafos aleatorios;
# *    el *score* del producto de grado solo es útil en el modelo preferencial de Barabási-Albert debido a que en la construcción del grafo son más probables las aristas entre vértices más populares; y
# *    la capadidad predictiva en redes reales es bastante buena, inclusive para altos porcentajes de aristas no observadas.

# # 4. Predicción de atributos de vértices en `R`
#
# Seguir las Secciones 8.1 y 8.2 del libro [SANDR], ejecutando el código fuente incluido.
#

# In[ ]:

# Chapter 8 Modeling and Prediction for Processes on Network Graphs
# 8.1 Introduction
# 8.2 Nearest Neighbor Methods
#############################################################

# We illustrate through the problem of protein function prediction.
# We saw examples of strong assortative mixing of protein function in
# the underlying network of protein–protein interactions. While the gold standard for
# establishing the functionality of proteins is through direct experimental validation
# (or ‘assays’), results like these have been taken to suggest that, given the vast num-
# ber of proteins yet to be annotated, it is natural to approach this problem from the
# perspective of statistical prediction. Approaches to protein function prediction that
# incorporate network-based information have become standard.
set.seed(42)

data(ppi.CC)
ppi.CC = upgrade_graph(ppi.CC)
summary(ppi.CC)
# IGRAPH 006c919 UN-- 134 241 --
#   + attr: name (v/c), ICSC (v/n), IPR000198 (v/n), IPR000403 (v/n), IPR001806 (v/n), IPR001849 (v/n),
# | IPR002041 (v/n), IPR003527 (v/n)
# contains a network data object, called ppi.CC, that consists of a network of 241
# interactions among 134 proteins, as well as various vertex attributes.
#
# The vertex attribute ICSC is a binary vector
V(ppi.CC)$ICSC[1:10]

# A visualization of this network is shown in Fig. 8.1.
V(ppi.CC)[ICSC == 1]$color <- "yellow"
V(ppi.CC)[ICSC == 0]$color <- "blue"
plot(ppi.CC, vertex.size=5, vertex.label=NA)

# In[ ]:

# A simple, but often quite effective, method for producing local predictions is the
# nearest-neighbor method. See Hastie, Tibshirani, and Friedman [71, Chap. 2.3.2],
# for example, for general background on nearest-neighbor methods. For networks,
# the nearest-neighbor method centers on the calculation, for a given vertex i ∈ V , of
# the nearest-neighbor average
# i.e., the average of the values of the vertex attribute vector X in the neighborhood
# N i of i. Here |N i | denotes the number of neighbors of i in G. Calculation of these
# averages over all vertices i ∈ V corresponds to a nearest-neighbor smoothing of X
# across the network.

# In the context of protein function prediction, X is a binary vector, with entries
# indicating whether or not each protein is or is not annotated with a function of
# interest (e.g., ICSC). In predicting binary vertex attributes, the nearest-neighbor av-
#   erages (8.1) typically are compared to some threshold. For example, a threshold
# of 0.5 is commonly used, with a nearest-neighbor average greater than this value
# meaning that a majority of neighbors have the characteristic indicated by X = 1,
# resulting in a prediction for X i of 1 as well. Such methods are also known as ‘guilt-
#   by-association’ methods in some fields.

# me quedo con la componente gigante
clu <- clusters(ppi.CC)
ppi.CC.gc <- induced.subgraph(ppi.CC, clu$membership==which.max(clu$csize))
plot(ppi.CC.gc, vertex.size=5, vertex.label=NA)

# we can calculate the nearest-neighbor average
# for each of the proteins in the giant connected component of our network.
nn.ave <- sapply(V(ppi.CC.gc), function(x) mean(V(ppi.CC.gc)[nei(x)]$ICSC))

# We then plot histograms of the resulting values, separated according to the status
# of the vertex defining each neighborhood, i.e., according to the status of the ‘ego’
# vertex, in the terminology of social networks.
# The results, shown in Fig. 8.2, confirm that ICSC can be predicted with fairly
# good accuracy.
par(mfrow=c(2,1))
hist(nn.ave[V(ppi.CC.gc)$ICSC == 1], col="yellow",
     ylim=c(0, 30), xlab="Proportion Neighbors w/ ICSC",
     main="Egos w/ ICSC")
hist(nn.ave[V(ppi.CC.gc)$ICSC == 0], col="blue",
     ylim=c(0, 30), xlab="Proportion Neighbors w/ ICSC",
     main="Egos w/out ICSC")

# In particular, using a threshold of 0.5 would yield an error rate
# of roughly 25 %.
nn.pred <- as.numeric(nn.ave > 0.5)
mean(as.numeric(nn.pred != V(ppi.CC.gc)$ICSC))
#[1] 0.2598425

# In[ ]:

# La siguiente sección requiere previamente instalar algunos paquetes especiales

if (!requireNamespace("BiocManager", quietly = TRUE))
    install.packages("BiocManager")
BiocManager::install()
BiocManager::install(c("GOstats", "GO.db", "org.Sc.sgd.db"))

# In[ ]:

# Interestingly, we can push this illustration a bit further by taking advantage of the
# evolving nature of biological databases like GO. In particular, the proteins annotated
# in GO as not having a given biological function include both (1) those that indeed are
# known not to have that function, and (2) those whose status is simply unknown. As
# a result, by comparing against more recent versions of GO, it is sometimes possible
# to identify proteins whose status has changed for a given functional annotation,
# indicating that in the interim it has been discovered to in fact have that function.
# The R package GOstats, a part of the Bioconductor package, may be used to
# manipulate and analyze Gene Ontology, as contained in the database GO.db.
library(GOstats)
library(GO.db)
# And the annotations specific to the organism yeast can be obtained from the
# org.Sc.sgd.db database.
library(org.Sc.sgd.db)
# At the time of this writing, these annotations were last updated in September of
# 2013, roughly six years after the data in ppi.CC were assembled.

# In[ ]:

# We extract those proteins with the function ICSC—now subsumed under the
# term intercellular signaling transduction (ICST), or GO label 003556—and keep
# only those that have been identified from direct experimental assay, as indicated by
# the evidence code ‘IDA’.
x <- as.list(org.Sc.sgdGO2ALLORFS)
current.icst <- x[names(x) == "GO:0035556"]
ev.code <- names(current.icst[[1]])
icst.ida <- current.icst[[1]][ev.code == "IDA"]
# We then separate out the names of those proteins that had ICSC in our original data
orig.icsc <- V(ppi.CC.gc)[ICSC == 1]$name
# and similarly extract the names of those proteins under the new annotations that
# were present in the giant connected component of our original network.
candidates <- intersect(icst.ida, V(ppi.CC.gc)$name)
# Among these candidates, there are four that have been newly discovered to have
# ICSC, with the following names.
new.icsc <- setdiff(candidates, orig.icsc)
new.icsc
# [1] "YDL159W" "YHL007C" "YIL033C" "YLR362W"
# And among these four, we find that two of them would have been correctly predicted
# by comparing the value of their nearest-neighbor averages to a threshold of 0.5.
nn.ave[V(ppi.CC.gc)$name %in% new.icsc]

# # 5. Predicción de atributos de vértices en redes reales.
#
# Por lo general, los vértices de las redes reales tiene atributos, los cuales pueden ser categóricos, escalares o reales.
# En muchos casos no se conocen estos atributos para algunos vértices, por ejemplo cuando solo se tiene una muestra de la red, cuando explicitamente el atributo es ocultado por el vértice, cuando el atributo aun no existe y se creará a futuro, etc.
#
# Un método sencillo para predecir los atributos faltantes es el método de los vecinos más cercanos (*NNM - nearest-neighbor method*), donde se estima el atributo faltante en el vértice $i$ como el promedio de los atributos en el vecindario de $i$. La idea de vecindario y promedio puede variar dependiendo del caso particular. Este método suele funcionar bien cuando existe una marcada homofilia entre los vértices participantes respecto a ese atributo.

# ## 5.a) Cargar los datos
#
# Cargar la red de la enfermedad de Malaria y la red de relaciones entre directivos en empresas públicas de Noruega siguiendo el procedimiento del ejercicio anterior.
#

# In[ ]:

# Cargar la red de Malaria
g_malaria = read.graph(file="g_malaria.graphml", format= "graphml")
summary(g_malaria)

# Cargar la red de directores
g_gcdirectores = read.graph(file="g_gcdirectores.graphml", format= "graphml")
summary(g_gcdirectores)

# ## 5.b) Predecir atributos en la red de Malaria
#
# Evaluar la precisión del método NNM, sobre una subred observada con el $\%80$ de los atributos de vértice `label` de la red de Malaria.
# El atributo `label`, disponible en la red, es un enumerado (variable categórica) y es representado en `igraph` como números. Por tal motivo, el promedio sobre los vecinos del método NNM se define como el enumerado de mayor frecuencia.
# Para medir la calidad de predicción del método usaremos la exactitud  (*accuracy* - fracción de predicciones correctas).
#
# Se disponen de varias funciones auxiliares, incluyendo `nnm()` y `delete_vertex_attr_rand()`.
# Es posible ver las funciones axiliares en: https://github.com/prbocca/na101_master/raw/master/homeworks_common.r.
#
# El siguiente código resuelve el ejercicio y ejemplifica como usar las funciones auxiliares. Se obtiene una muy buena capacidad predictiva, con una exactitud de $acc=0.712$.
#

# In[ ]:

#creo una subred observada
set.seed(42)
g_malaria_obs = delete_vertex_attr_rand(g_malaria,"label", p=0.2)
vertex_attr_deleted = is.na(vertex_attr(g_malaria_obs, "label")) #vector booleando con los atributos borrados

#computo vector con los atributos reales
vertex_attr_actual = vertex_attr(g_malaria, "label")[vertex_attr_deleted] #vector con los atributos reales
vertex_attr_actual = factor(vertex_attr_actual, levels=unique(vertex_attr(g_malaria, "label")))

#computo vector con atributos predichos
vertex_attr_pred  = nnm(g_malaria_obs,"label", fun="freq")[vertex_attr_deleted] #vector con los atributos predichos
vertex_attr_pred = factor(vertex_attr_pred, levels=unique(vertex_attr(g_malaria, "label")))

# computo la exactitud
cm = as.matrix(table(pred=vertex_attr_pred, actual=vertex_attr_actual)) # create the confusion matrix
accuracy = sum(diag(cm)) / sum(cm)
printf("La exactitud de NNM para la red de Malaria es %s", accuracy) # [1] 0.7121212

# otra forma corta de hacerlo
# comparo con funcion de prediccion que hace todo
#r = evaluate_predictions_vertexattr(g_malaria, g_malaria_obs, "label", fun="freq", metric="acc")
#r$metrics

# ## 5.c) Predecir atributos en la red de directores
#
# En la red de relaciones entre directivos se conoce el género de los directivos, como un atributo binario de vértice llamado `gender`.
# Dado que el atributo es binario se puede utilizar tanto la métrica de exactitud como $AUC$ vista anteriormente. Además el método NNM puede realizarse usando el promedio entre los vecinos (y no la frecuencia más alta).
# Repetir la parte anterior para esta red.
# ¿Qué se puede concluir sobre la homofilia en esta red?
#

# In[ ]:

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a anterior
#
#
#
##################################################################

# ## 5.d) Estudio exahustivo de capacidad predictiva
#
# Realizar un estudio más exahustivo sobre la calidad predictiva del método NNM, variando el porcentaje de atributos `label` observados entre \%99 y \%20 para la red de Malaria.
# Buscando eliminar casuística, repetir la prueba sorteando distintos grafos observados.
#
# Es posible utilizar la función auxiliar cargada previamente  `summary_predictions_vertexattr(g, attr, n_sample, p, fun="mean", metric="auc", cores=1)`, que recibe un grafo `g`, crea un grafo observado para cada probabilidad de eliminación de arista del vector `p`, y prueba el método NNM promediando con la función `fun` y para la métrica `acc`. Repite cada caso `n_sample` y promedia resultados.
#
# Deben obtenerse resultados similares a los de la siguiente Figura: ![precisión del método NNM para predecir atributos de vértices, usando distintos porcentajes de atributos no observados](https://github.com/prbocca/na101_master/raw/master/homework_8_prediction/result_acc_p.png). Observar que en este caso, la capadidad predictiva no es muy buena, y existe gran variación en los resultados entre muestras.
#
#

# In[ ]:

# defino los parámetros del experimento

# para cada grafo, sorteo un subgrafo observado, calculo todos los tipos de score, predigo aristas faltantes y evaluo la metrica
p_v = c(0.01, 0.05, 0.10, 0.20, 0.50, 0.80) #las probabilidades de eliminacion de arista a evaluar
n_sample = 5 #cantidad de sorteos de g_obs
metric="acc" #metric="auc" #metric="f"
n_cores = 1 #la ejecución en COLAB solo permite 1 CPU

# In[ ]:

#realizo los calculos para el grafo g_malaria

results_malaria_vertexattr = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: ver funciones auxiliares
#
#
#
##################################################################
str(results_malaria_vertexattr)

#imprimo resultados
ggplot(results_malaria_vertexattr$results_summary, aes(100*p, acc)) +
  geom_line() +
  geom_point(data=results_malaria_vertexattr$results, aes(100*p, acc), alpha=0.20) +
  labs(title = "Precisión para distintos porcentajes de atributos no observados",
       subtitle = "grafo Malaria", x="% atributos de vértices no observados", y="precisión")


# Enter our code here. Read input from STDIN. Print output to STDOUT
hits <- pbinom(1, size = 4, prob = 0.2)
write(round(hits, 3), stdout())
misses <- pbinom(1, size = 4, prob = 0.8)
write(round(misses, 3), stdout())


#' @title pressure2Depth
#' @description Unesco 1983. Algorithms for computation of fundamental properties of seawater, 1983
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
pressure2Depth <- function (pressure, lat = 45) {
    lat <- lat * 0.0174532925199433
    x <- sin(lat)^2
    gr <- 9.780318 * (1 + (0.0052788 + 2.36e-05 * x) * x) + 1.092e-06 * pressure
    d <- (((-1.82e-15 * pressure + 2.279e-10) * pressure - 2.2512e-05) *
        pressure + 9.72659) * pressure/gr

    return(d)
}


# Day 7: The Treachery of Whales

get_day7_input_path <- function() {
    paste(getwd(), "/2021/Day 7/Day7_input.txt", sep = "")
}

part1 <- function(fuel_type = "standard") {
    positions <- strtoi(unlist(strsplit(readLines(get_day7_input_path()), ",")))

    unique_crab_pos <- sort(unique(positions))
    max_crab_pos <- unique_crab_pos[length(unique_crab_pos)]
    crabs <- matrix(ncol = 2)[-1, ]

    for (i in seq_len(length(unique_crab_pos))) {
        sum_crabs_in_pos <- sum(positions == unique_crab_pos[i])
        crabs <- rbind(crabs, c(unique_crab_pos[i], sum_crabs_in_pos))
    }

    optimal_pos <- 0
    optimal_fuel <- 2147483647

    for (i in 0:max_crab_pos) {
        fuel_used <- 0
        target_pos <- i
        for (c in seq_len(length(unique_crab_pos))) {
            if (fuel_type == "standard") {
                fuel_used <- fuel_used +
                    calc_fuel_std(target_pos, crabs[c, 1], crabs[c, 2])
            } else {
                fuel_used <- fuel_used +
                    calc_fuel_crab(target_pos, crabs[c, 1], crabs[c, 2])
            }
        }

        if (fuel_used < optimal_fuel) {
            optimal_fuel <- fuel_used
            optimal_pos <- target_pos
        }
    }

    cat("Optimal Position: ", optimal_pos, "; Fuel Used: ", optimal_fuel, "\n")
}

part2 <- function() {
    part1("crab")
}

calc_fuel_std <- function(tar_pos, cur_pos, num_crabs) {
    abs(tar_pos - cur_pos) * num_crabs
}

calc_fuel_crab <- function(tar_pos, cur_pos, num_crabs) {
    delta <- abs(tar_pos - cur_pos)
    crab_adj <- 0

    if (delta > 0) {
        crab_adj <- sum(1:delta)
    }

    crab_adj * num_crabs
}

part1()
part2()


rndProportions <- function(bins, sample_size){

  if(bins < 2) return(sample_size)

  weigths <- round(runif(bins),2)
  #weigths <- sample(seq(0,1,0.01), bins)
  sum_weigths <- sum(weigths)
  quantities <- floor(sample_size*weigths/sum_weigths)
  total <- sum(quantities)

  lack <- sample_size - total

  lack <- round(lack,0)
  for(i in 1:lack){
    p <- sample(1:bins,1)
    quantities[p] <- quantities[p] + 1
  }

  return(quantities)
}


library(epimdr)
library(bbmle)
library(statnet)

data(niamey)
head(niamey[, 1:5])

par(mar = c(5,5,2,5))
plot(niamey$absweek, niamey$tot_cases, type = "b",
     xlab = "Week", ylab = "Incidence")
par(new = TRUE)
plot(niamey$absweek, niamey$cum_cases, type = "l",
     col = "red", axes = FALSE, xlab = NA, ylab = NA, log = "y")
axis(side = 4)
mtext(side = 4, line = 4, "Cumulative incidence")
legend("topleft", legend = c("Cases", "Cumulative"),
       lty = c(1,1), pch = c(1,NA), col = c("black", "red"))

fit=lm(log(cum_cases)~absweek, subset=absweek<7,
     data=niamey)
r=fit$coef["absweek"]
V=c(1.5, 1.8)
V*r+1

V = c(1.5, 1.8)
f = (5/7)/V
V * r + 1 + f * (1 - f) * (V * r)^2

llik.cb = function(S0, beta, I) {
    n = length(I)
    S = floor(S0 - cumsum(I[-n]))
    p = 1 - exp(-beta * (I[-n])/S0)
    L = -sum(dbinom(I[-1], S, p, log = TRUE))
    return(L)
}

twoweek = rep(1:15, each = 2)
y = sapply(split(niamey$cases_1[1:30], twoweek), sum)
sum(y)

S0cand = 6500
betacand = seq(0,10, by = .1)
ll = rep(NA, length(betacand))
for(i in 1:length(betacand)){
     ll[i] = llik.cb(S0 = S0cand, beta = betacand[i],
     I = y)}
plot(ll ~ betacand, ylab = "Neg log-lik",
     xlab = expression(beta))
betacand[which.min(ll)]

betacand = 2.3
S0cand = seq(5920,8000, length = 101)
ll = rep(NA, length = 101)
for(i in 1:101){
     ll[i] = llik.cb(S0 = S0cand[i], beta = betacand,
     I = y)}
plot(ll ~ S0cand, ylab = "Neg log-lik",
     xlab = expression(S[0]))
S0cand[which.min(ll)]

fit = mle2(llik.cb, start = list(S0 = 7085, beta = 2.3),
    method = "Nelder-Mead",data = list(I = y))
summary(fit)
confint(fit)

cov2cor(vcov(fit))

sim.cb=function(S0, beta, I0){
   I=I0
   S=S0
   i=1
   while(!any(I==0)){
        i=i+1
        I[i]=rbinom(1, size=S[i-1], prob=1-
           exp(-beta*I[i-1]/S0))
        S[i]=S[i-1]-I[i]
   }
   out=data.frame(S=S, I=I)
   return(out)
}

plot(y, type="n", xlim=c(1,18),
   ylab="Predicted/observed", xlab="Week")
for(i in 1:100){
     sim=sim.cb(S0=floor(coef(fit)["S0"]),
     beta=coef(fit)["beta"], I0=11)
     lines(sim$I, col=grey(.5))
}
points(y, type="b", col=2)

data(flu)
plot(flu$day, flu$cases, type="b", xlab="Day",
     ylab="In bed", log="y")
tail(flu)

fit=lm(log(cases)~day, subset=day<=5,
     data=flu)
r=fit$coef["day"]
V=c(2,3)
V*r+1

data(ebola)
par(mar = c(5,5,2,5))
plot(ebola$day, ebola$cases, type="b", xlab="Week",
     ylab="Incidence")
par(new=T)
plot(ebola$day, ebola$cum_cases, type="l", col="red",
      axes=FALSE, xlab=NA, ylab=NA, log="y")
axis(side = 4)
mtext(side = 4, line = 4, "Cumulative incidence")
legend("right", legend=c("Cases", "Cumulative"),
     lty=c(1,1), pch=c(1,NA), col=c("black", "red"))
tail(ebola)

fit=lm(log(cum_cases)~day, subset=day<100,
   data=ebola)
r=fit$coef["day"]
V=15
f=.5
V*r+1+f*(1-f)*(V*r)^2

#Data aggregation
cases=sapply(split(ebola$cases,
   floor((ebola$day-.1)/14)), sum)
sum(cases)

#Removal MLE
fit = mle2(llik.cb, start = list(S0 = 20000, beta = 2),
   method = "Nelder-Mead",data = list(I = cases))
summary(fit)

confint(fit, std.err = c(100, 0.1))

names(ferrari)
ferrari$Ebolacases95
sum(ferrari$Ebolacases95, na.rm = TRUE)
y = c(na.omit(ferrari$Ebolacases95))

fit = mle2(llik.cb, method = "Nelder-Mead",
    start = list(S0 = 300, beta = 2),
    data = list(I = y))
fit
confint(fit, std.err = 2)

data(gonnet)
nwt = network(gonnet, directed = TRUE)
plot(nwt, vertex.col = c(0, rep(1, 17), rep(2, 71)))

F1 = quote(beta * S * I/N)
F2 = 0

Vm1 = quote(mu * E + sigma * E)
Vm2 = quote(mu * I + alpha * I + gamma * I)

Vp1 = 0
Vp2 = quote(sigma * E)

V1 = substitute(a - b, list(a = Vm1, b = Vp1))
V2 = substitute(a - b, list(a = Vm2, b = Vp2))

f11 = D(F1, "E"); f12 = D(F1, "I")
f21 = D(F2, "E"); f22 = D(F2, "I")

v11 = D(V1, "E"); v12 = D(V1, "I")
v21 = D(V2, "E"); v22 = D(V2, "I")

paras = list(S = 1, E = 0, I = 0, R = 0, mu = 0,
   alpha = 0, beta = 5, gamma = .8, sigma = 1.2, N = 1)
f = with(paras,
   matrix(c(eval(f11),eval(f12),eval(f21),
   eval(f22)), nrow = 2, byrow = TRUE))
v=with(paras,
   matrix(c(eval(v11),eval(v12),eval(v21),
   eval(v22)), nrow=2, byrow=TRUE))

max(eigen(f %*% solve(v))$values)

with(paras,
sigma/(sigma+mu)*beta/(gamma+mu+alpha))

F1 = expression(betai * S * I / N + betah* S * H / N +
   betaf * S * F / N)
F2=0
F3=0
F4=0

Vm1 = quote(sigma * E)
Vm2 = quote(Theta * gammah * I + (1 - Theta) * (1-
   Lambda) * gammar * I + (1 - Theta) * Lambda *
   gammaf * I)
Vm3 = quote(Lambda * etaf * H + (1 - Lambda) * etar * H)
Vm4 = quote(chi * F)

Vp1 = 0
Vp2 = quote(sigma * E)
Vp3 = quote(Theta * gammah * I)
Vp4 = quote((1 - Theta) * (1 - Lambda) * gammar * I+
   Lambda * etaf * H)

V1 = substitute(a - b, list(a = Vm1, b = Vp1))
V2 = substitute(a - b, list(a = Vm2, b = Vp2))
V3 = substitute(a - b, list(a = Vm3, b = Vp3))
V4 = substitute(a - b, list(a = Vm4, b = Vp4))

f11 = D(F1, "E"); f12 = D(F1, "I"); f13 = D(F1, "H")
     f14 = D(F1, "F")
f21 = D(F2, "E"); f22 = D(F2, "I"); f23 = D(F2, "H")
     f24 = D(F2, "F")
f31 = D(F3, "E"); f32 = D(F3, "I"); f33 = D(F3, "H")
     f34 = D(F3, "F")
f41 = D(F4, "E"); f42 = D(F4, "I"); f43 = D(F4, "H")
     f44 = D(F4, "F")

v11 = D(V1, "E"); v12 = D(V1, "I"); v13 = D(V1, "H")
     v14 = D(V1, "F")
v21 = D(V2, "E"); v22 = D(V2, "I"); v23 = D(V2, "H")
     v24 = D(V2, "F")
v31 = D(V3, "E"); v32 = D(V3, "I"); v33 = D(V3, "H")
     v34 = D(V3, "F")
v41 = D(V4, "E"); v42 = D(V4, "I"); v43 = D(V4, "H")
     v44 = D(V4, "F")

gammah = 1/5 * 7
gammaf = 1/9.6 * 7
gammar = 1/10 * 7
chi = 1/2 * 7
etaf = 1/4.6 * 7
etar = 1/5 * 7
paras = list(S = 1,E = 0, I = 0, H = 0, F = 0,R = 0,
     sigma = 1/7*7, Theta = 0.81, Lambda = 0.81, betai = 0.588,
     betah = 0.794, betaf = 7.653, N = 1, gammah = gammah,
     gammaf = gammaf, gammar = gammar, etaf = etaf,
     etar = etar, chi = chi)

f = with(paras,
matrix(c(eval(f11), eval(f12), eval(f13), eval(f14),
     eval(f21), eval(f22), eval(f23), eval(f24),
     eval(f31), eval(f32), eval(f33), eval(f34),
     eval(f41), eval(f42), eval(f43), eval(f44)),
     nrow = 4, byrow = T))

v = with(paras,
matrix(c(eval(v11), eval(v12), eval(v13), eval(v14),
     eval(v21), eval(v22), eval(v23), eval(v24),
     eval(v31), eval(v32), eval(v33), eval(v34),
     eval(v41), eval(v42), eval(v43), eval(v44)),
     nrow = 4, byrow = T))

max(eigen(f %*% solve(v))$values)


# Load tag intent data and calculate inter-rater agreement

json.tagIntent2 <- read.csv(file="json_tag_2.csv", header = TRUE)
django.tagIntent2 <- read.csv(file="django_tag_2.csv", header = TRUE)
regex.tagIntent2 <- read.csv(file="regex_tag_2.csv", header = TRUE)
head(json.tagIntent2)

# load the library
library(irr)

kappam.fleiss(json.tagIntent2[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(django.tagIntent2[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(regex.tagIntent2[c("Rater1", "Rater2", "Rater3")])

tagIntent2 <- rbind(json.tagIntent2, django.tagIntent2, regex.tagIntent2)

kappam.fleiss(tagIntent2[c("Rater1", "Rater2", "Rater3")])


#' Generate likelihood statistics (AIC, AICC, BIC, etc.)
#'
#' Generate likelihood statistics that include the Jacobian adjustment for transformations as done in the X-13ARIMA-SEATS program
#'
#' @param Y numeric vector, original time series.
#' @param Lnlkhd numeric scalar, maximized log likelihood of model.
#' @param Np Integer scalar, Number of parameters in model used. Default is 2.
#' @param Nintvl Integer scalar, Number of differences in model used. Default is 2.
#' @param Adj numeric vector, prior adjustment factor time series. Default is NULL, which indicates there is no prior adjustment.
#' @param Logit logical scalar, if TRUE the logit transformation is used. Default is FALSE.
#' @param Trans logical scalar, if TRUE a Box-Cox transform is used. Default is TRUE
#' @param Lam numeric scalar, Box-Cox transformation parameter. Default is 0 (Log transform).
#' @param Eick numeric scalar, weighting paramter for Empiracle Information Criterion. Default is NULL (EIC not computed).
#' @return List of likelihood diagnostics and related estimates (ll = log likelihood, jacadj = jacobian transformation adjustment,
#'    lladj = adjusted likelihood, nobs = number of observations, neffective = effective number of observations,
#'    nparams = number of parameters, df = Nspobs - Nintvl - Np, aic = AIC, aicc = AICC, hannanquinn = Hannan Quinn,
#'    bic = BIC, bic2 = BIC2, EIC = Empiracle Information Criterion)
#' @examples
#' ic_default_log_est <-
#'    rjd3highfreq::fractionalAirlineEstimation(log(ic_obs), periods=c(365.25/7),
#'                                              x=ic_default_matrix)
#' ic_default_log_lkhd_stat <-
#'    gen_likelihood_stats(ic_obs,
#'                         Lnlkhd = ic_default_log_est$likelihood$ll,
#'                         Nintvl = 2,
#'                         Np     = ic_default_log_est$likelihood$nparams)
#' ic_default_log_aicc <- ic_default_log_lkhd_stat$aicc
#' @import stats
#' @export
gen_likelihood_stats <- function(Y, Lnlkhd, Nintvl = 2, Np = 2, Adj = NULL,
                                 Logit = FALSE, Trans = TRUE, Lam = 0.0,
                                 Eick = NULL) {
   # Author: Brian C. Monsell (OEUS), Version 2.0, 2/2/2022

   # generate jacobian adjustment
   Nspobs <- length(Y)
   jacadj <- jacobian_trans_adj(Y, Nspobs, Nintvl, Adj = Adj, Logit = Logit, Trans = Trans, Lam = Lam)

   dnefob <- Nspobs - Nintvl
   TWO <- 2.0
   lladj <- Lnlkhd + jacadj

   # AIC
   Aic=-TWO*(lladj-Np)

   # AICC
   Aicc=-TWO*(lladj-dnefob*Np/(dnefob-(Np+1)))

   # Hannon-Quinn
   Hnquin=-TWO*(lladj-log(log(dnefob))*Np)

   # BIC
   Bic=-TWO*(lladj)+Np*log(dnefob)

   # BIC2
   Bic2=(-TWO*Lnlkhd+Np*log(dnefob))/dnefob

   # BICC

   # EIC (only produced if EICk is specified) and return a list of likelihood statistics
   if (!is.null(Eick)) {
      Eic=-TWO*(lladj)+Np*Eick
      return(list(ll = Lnlkhd, jacadj = jacadj, lladj = lladj, nobs = Nspobs, neffective = dnefob,
               nparams = Np, df = dnefob - Np, aic = Aic, aicc = Aicc, hannanquinn = Hnquin,
               bic = Bic, bic2 = Bic2, eic = Eic, eick = Eick))
   } else {
      return(list(ll = Lnlkhd, jacadj = jacadj, lladj = lladj, nobs = Nspobs, neffective = dnefob,
               nparams = Np, df = dnefob - Np, aic = Aic, aicc = Aicc, hannanquinn = Hnquin,
               bic = Bic, bic2 = Bic2))
   }

}


require(datasets)
require(stats)
require(RCUrl)
require(ggplot2)
require(ggthemes)
require(scales)
require(tidyverse)
require(gridExtra)
require(rstudioapi)

rm(list = ls())
setwd(dirname(getActiveDocumentContext()$path ))
#print( getwd() )
source("./covid19_functions.r")

#select countries to plot, support only two countries
#countries <- c ("US", "Italy", "Germany", "France", "China")

countries <- c("India", "Singapore", "Australia", "Japan")

#download the data file
d_sums <- build_dataframe("time_series_covid19_confirmed_global.csv", countries)
dates <- seq(c(as.Date("2020/2/16")), by = "day", length.out = ncol(d_sums))
d_sums <- rbind(date=as.Date(dates), d_sums[1:length(countries),])
d_sums <- data.frame(t(d_sums))

#Create a dataframe for rate of change
d_trend <- d_sums[-1,-1]/d_sums[-nrow(d_sums),-1]
d_trend <- data.frame(t(d_trend))
d_trend <- rbind(date=as.Date(dates), d_trend[1:length(countries),])

#create a line plot
yMarker <- 10^ceiling(log10(max(d_sums[-1])))/20
p1 <- get_base_plot(d_sums, "Confirmed cases") +
  scale_y_continuous(breaks = round(seq(0, max(d_sums[-1]), by = yMarker),1)) +
  geom_line() +
  geom_point()

d_trend <- data.frame(t(d_trend))
#d_trend$Value <- replace_na(d_trend$Value, 1)
#d_trend$Value[is.infinite(d_trend$Value)] <- 1

#create a smoothen line plot for growth rate multiplier trend
p2 <- get_base_plot(d_trend, "Day over day growth multiplier") +
  geom_smooth(method="loess", formula = y ~ x, se = FALSE)

grid.arrange(p1, p2, nrow = 2, top = "COVID-19 : Confirmed cases and growth rate")


#' Title predictor of KPLS AND guassian kriging
#'
#' @param model a model from KPLS or guassian kriging
#' @param input x need to be create y_hat
#'
#' @return the prediction of x
#' @import stats
#' @export
#'

Predictor <- function(model,input){
  xsam <- model$xsam
  ysam <- model$ysam
  r_hat <- model$r_hat
  beta_hat <- model$beta_hat
  sigma_hat <- model$sigma_hat
  theta_aimm <- model$theta_aimm
  beta_hat_vect <- vector(length = length(ysam))
  for (i in 1:length(ysam)){
    beta_hat_vect[i] <- as.numeric(beta_hat)
  }
  r0_matrix <- matrix(nrow = length(input[,1]),ncol = length(xsam[,1]))
  r0_matrix[is.na(r0_matrix)] <- 0
  for (i in 1:length(input[,1])){
    for (j in 1:length(xsam[,1])){
      r0_matrix[i,][j] <- exp(-1*as.numeric(sum((theta_aimm*(input[i,]-xsam[j,])^2))))
    }
  }
  pre_vect <- vector(length = length(input[,1]))
  pre_vect[is.na(pre_vect)] <- 0
  for (i in 1:length(input[,1])){
    pre_vect[i] <- as.numeric(beta_hat)+t(r0_matrix[i,])%*%solve(r_hat)%*%(as.vector(ysam-beta_hat_vect))
  }
  return(list(pre_vect))
}


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/caching/data_all.csv', sep = ';')
data_amf <- read.csv('../../results/client_algos/data_all.csv', sep = ';')
data_noamf <- read.csv('../../results/caching_none/data_all.csv', sep = ';')

# Means
aggregate(data$time, list(data$combination), median)
# HTTP+Filter   732.0
# Filter        1126.0
# HTTP          652.5
# None          254672.5
aggregate(data_noamf$time, list(data_noamf$combination), median)
# HTTP          2408.0
# None          4156.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: No statistical difference between combinations
kruskal.test(time ~ combination, data = data)
# p: < 2.2e-16
# => Reject H0, non-equal means => big statistical difference

# H0: Filter == HTTP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_1' | data$combination=='combination_2'),])
# p: 0.02255
# => Reject H0, non-equal means => Filter > HTTP

# H0: HTTP+Filter == HTTP
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_2'),])
# p: 0.7694
# => Accept H0, equal means => HTTP+Filter == HTTP

# H0: AMF-nocache == noAMF-nocache
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_3' | data_noamf$combination=='combination_1'),])
# p: < 2.2e-16
# => Reject H0, non-equal means => AMF-nocache < noAMF-nocache

# H0: AMF-cache == noAMF-cache
kruskal.test(time ~ combination, data = data[which(data_amf$combination=='combination_3' | data_noamf$combination=='combination_0'),])
# p: < 2.2e-16
# => Reject H0, non-equal means => AMF-cache < noAMF-cache


#------------------------#
# lmer model diagnostics #
#------------------------#

library(dplyr)
library(lme4)
library(broom)

# 1 - qqplot of level 1 residuals:
lmer1_qnorm <- function(model) {
  p <- qqnorm(residuals(model))
  p <- p + qqline(residuals(model))
  return(p)
}

# 1 - histogram of level 1 residuals:
lmer1_hist <- function(model) {
  p <- hist(residuals(model, scaled = TRUE))
  return(p)
}

# 2 - linearity of relationship between outcome and response:
lmer_linrel <- function(model, var) {
  p <- plot(resid(model, scaled = TRUE), filter(model_dat, any_bad_linkrate == 0))[[var]]
  return(p)
}

# 4 - qqplot of level 2 residuals:
lmer2_int_qnorm <- function(model) {

  re_sd <- unlist(filter(tidy(model), group == "la_code")$estimate)
  resid_sd <- unlist(filter(tidy(model), group == "Residual")$estimate)

  dat <- model@frame %>%
    group_by(la_code) %>%
    summarise(nobs = n()) %>%
    ungroup()

  std_lvl2 <- data.frame(nobs = dat$nobs, uhat_eb2 = model@u)%>%
    mutate(R = (re_sd^2)/(re_sd^2 + (resid_sd^2))/nobs,
           var_eb = R*(re_sd^2),
           uhat_st2 = uhat_eb2/sqrt(var_eb))

  p <- qqnorm(std_lvl2$uhat_st2)
  qqline(std_lvl2$uhat_st2)

  return(p)
}

# 5 - histogram of level 2 residuals:
lmer2_hist <- function(model) {

  re_sd <- unlist(filter(tidy(model), group == "la_code")$estimate)
  resid_sd <- unlist(filter(tidy(model), group == "Residual")$estimate)

  dat <- model@frame %>%
    group_by(la_code) %>%
    summarise(nobs = n()) %>%
    ungroup()

  std_lvl2 <- data.frame(nobs = dat$nobs, uhat_eb2 = model@u)%>%
    mutate(R = (re_sd^2)/(re_sd^2 + (resid_sd^2))/nobs,
           var_eb = R*(re_sd^2),
           uhat_st2 = uhat_eb2/sqrt(var_eb))

  p <- hist(std_lvl2$uhat_st2, breaks = 15)
  return(p)
}

icc_lmer <- function(model) {
  qtidy <- quietly(tidy)
  re_sd <- unlist(filter(qtidy(model)$result, group == "la_code")$estimate)
  resid_sd <- unlist(filter(qtidy(model)$result, group == "Residual")$estimate)

  icc <- (re_sd^2)/(re_sd^2 + resid_sd^2)
  return(icc)
}

# adj R-squared for LMM:
r2_lmer <- function(model) {
  qtidy <- quietly(tidy)
  re_sd <- unlist(filter(qtidy(model)$result, group == "la_code")$estimate)
  resid_sd <- unlist(filter(qtidy(model)$result, group == "Residual")$estimate)
}


#' Calculate Information Value for numeric (double/integer) vectors
#'
#' This function calculates information value for numeric vectors. This is done using decision tree.
#'
#' @param df data frame with at least two columns
#' @param x column (numeric) for which Information Value should be calculated
#' @param y column (integer/factor) with binary outcome.  It is suggested that y is factor with two levels "bad" and "good" If there are no levels good/bad than the following assumptions are applied - if y is integer, than 0=good and 1=bad. If y is factor than level 2 is assumed to mean bad and 1 good.
#' @param verbose Prints additional details when TRUE. Useful mainly for debugging.
#' @param rcontrol Additional parameters used for rpart tree generation. Use \code{?rpart.control()} to get more details.
#' @export
#' @examples
#' iv.num(german_data,"duration","gb")
#' iv.num(german_data,"age","gb")
#' iv.num(german_data,"age","gb")

iv.num <- function(df,x,y,verbose=FALSE,rcontrol=NULL) {

  if(verbose) cat("  Building rpart model",sep="\n")
  #rcontrol <- ifelse(is.null(rcontrol),rpart.control(cp=0.001,minbucket=nrow(df)/10),rcontrol)
  if(is.null(rcontrol)) {
    rcontrol <- rpart.control(cp=0.001,minbucket=nrow(df)/10)
  }
  model   <- rpart(data=df,formula=as.integer(df[,y])~df[,x],control=rcontrol)
  if(verbose) cat("  Model finished",sep="\n")
  model_where <- data.frame(node_id=model$where,obs_id=as.numeric(names(model$where)),stringsAsFactors=F) # str(model_where)
  model_frame <- data.frame(model$frame,tree_node=rownames(model$frame),node_id=row(model$frame["var"]))

  if(verbose) cat("  Sending model to tree parser",sep="\n")
  log <- capture.output({
    rpart.rules <- path.rpart(model,rownames(model$frame)[model$frame$var=="<leaf>"])
  })

  tree_rules <- iv.parse.rpart.rule(x,rpart.rules)
  if(verbose) cat(paste("  Rules parsed:",nrow(tree_rules)),"  Mapping nodes to data",sep="\n")
  if(verbose) cat("    SQL Merge",sep="\n")
  t <- sqldf("select obs_id, tr.class_label as tmp_iv_calc_label
              from
                  model_where mw
                  join model_frame mf using (node_id)
                  join tree_rules tr using (tree_node)")
  t$tmp_iv_calc_label <- factor(t$tmp_iv_calc_label)

  if(verbose) cat("    DF Merge",sep="\n")
  df <- merge(df, t["tmp_iv_calc_label"], by=0, all=TRUE) # str(df)
  if(verbose) cat("  Calling iv.str for nodes",sep="\n")
  iv_data <- iv.str(df,"tmp_iv_calc_label",y)

  if(verbose) cat("  Formatting output",sep="\n")
  iv_data$variable <- x

  sqldf("select iv.*, tr.sql || woe as sql from iv_data iv join tree_rules tr on (iv.class=tr.class_label) order by tr.min")
}


for(j in 2:10) {
  r <- sprintf("%d: ", j)
  for(n in 1:j) {
    r <- paste(r, format(exp(2i*pi*n/j), digits=4), ifelse(n<j, ",", ""))
  }
  print(r)
}


###############################
## Imports
###############################
imports <- c('ggplot2','scales','rio')
invisible(lapply(imports, require, character.only = TRUE))
##########################################
## HELPER FUNCTIONS
##########################################
EstimateMetric <- function(B, x){
  # Use a second order polynoial function to estimate a metric
  # Args:
  #   B: Vector of estimated coefficients used in second order polynomial regression
  #   x: Integer representing spend level
  round(B[1] + (B[2]*x) + (B[3]*(x)^2))
}
ObjectiveFunction <- function(B, x){
  # Define second order polynomial as an objective function. This function will be used for optimization.
  # Args:
  #   B: Vector of estimated coefficients used in second order polynomial regression
  #   x: Integer representing spend level
  B[1] + (B[2]*x) + (B[3]*(x)^2)
}
FitPolynomial <- function(dat, y, x, d = 2, xlabel = 'x', ylabel = 'y',
                          title='title', sub.title="x vs. y", caption = "test data"){
  # Perfrom second order polynomial regression of y on x.
  # Args:
  #   dat: data frame containg variables of interest
  #   y: string provding the column name of the dependent variable
  #   x: string providing the column name of the independent variable
  #   d: degree of polynomial to be estimated
  y <- dat[[y]]
  x <- dat[[x]]

  poly.fit <- lm(y ~ poly(x, degree = d, raw=TRUE)) # Second order polynomial regression model

  plot.out <- ggplot(dat, aes(y=y, x=x)) + # Scatter plot and regression line
    geom_point(alpha = .5) +
    stat_smooth(method="lm", formula = y  ~ poly(x, d, raw = TRUE), se=FALSE)+
    scale_y_continuous(labels = comma) + scale_x_continuous(labels = comma) + theme_minimal() +
    labs(subtitle = sub.title, y = ylabel, x = xlabel, title = title, caption = caption)

  list(poly.fit, plot.out)
}
###############################
## Regression, Estimation, and Optimization
###############################
yourdata <- import('path_to_your_data')
y <- 'Impressions'  #name of column containing dependent variable
x <- 'Revenue (Adv Currency)'  #name of column containing independet variable

fit <- FitPolynomial(yourdata, y, x, d = 2) #Fit the model
fit[[2]] #Plot function
#Optimize the objective function given estimated coefficients
fit.optim <- optimize(ObjectiveFunction, B = unname(coef(fit[[1]])), interval = c(100, 10000), maximum = TRUE)
fit.optim
#Estimate value of the objective function at the maximum
EstimateMetric(B = unname(coef(fit[[1]])), x = fit1.optim$maximum)


# Tutorial on iNEXT
# https://cran.r-project.org/web/packages/iNEXT/vignettes/Introduction.html

library(iNEXT)

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

data(spider)
str(spider) # abundance data (species abundance x species)

m <- c(1, 5, 20, 50, 100, 200, 400)
x <- iNEXT(spider, q=0, datatype="abundance", size=m)
x$DataInfo
est1 = x$iNextEst$Girdled
est2 = x$iNextEst$Logged
x$AsyEst

x <- iNEXT(spider, q=c(0,1,2), datatype="abundance", size=m)
x$DataInfo
est1 <- x$iNextEst$Girdled
est2 <- x$iNextEst$Logged
x$AsyEst

x <- iNEXT(spider, q=0, datatype="abundance")
x$DataInfo
est1 = x$iNextEst$Girdled
est2 = x$iNextEst$Logged
x$AsyEst

ggiNEXT(x, type=1, se=TRUE, facet.var="none", color.var="site", grey=FALSE)
ggiNEXT(x, type=2, se=TRUE, facet.var="none", color.var="site", grey=FALSE)
ggiNEXT(x, type=3, se=TRUE, facet.var="none", color.var="site", grey=FALSE)

ggiNEXT(x, type=1, se=TRUE, facet.var="site", grey=FALSE)
ggiNEXT(x, type=2, se=TRUE, facet.var="site", grey=FALSE)
ggiNEXT(x, type=3, se=TRUE, facet.var="site", grey=FALSE)

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

data(ant)
str(ant) # incidence data (species incidence frequency x species) + sampling unit

t <- seq(1, 700, by=10)
out.inc <- iNEXT(ant, q=0, datatype="incidence_freq", size=t)

# Sample‐size‐based R/E curves
ggiNEXT(out.inc, type=3, color.var="site") +
  theme_bw(base_size = 18) +
  theme(legend.position="none")

# https://rstudio-pubs-static.s3.amazonaws.com/210845_860b29c5e0a643f987a80179b61bcf16.html
# http://www.flutterbys.com.au/stats/tut/tut13.2.html

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

data(ciliates)
str(ciliates)
head(ciliates$EtoshaPan) # species incidence raw x plot

out.raw <- iNEXT(ciliates, datatype="incidence_raw", endpoint=150)
ggiNEXT(out.raw)
out.raw

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

library(vegan)
data(BCI)

S <- vegan::specnumber(BCI) # total no of species in each site
raremax <- min(rowSums(BCI)) # min no of individuals in each site
Srare <- vegan::rarefy(BCI, raremax)

par(mfrow = c(1,2))
plot(S, Srare, xlab = "Observed No. of Species",
     ylab = "Rarefied No. of Species",
     main = " plot(rarefy(BCI, raremax))")
abline(0, 1)
rarecurve(BCI, step = 20,
          sample = raremax,
          col = "blue",
          cex = 0.6,
          main = "rarecurve()")


#' Cross Validationg
#' for Quantile Sheets with pya's constraint
#'
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param k k-fold cross-validation
#' @param xsp spar range(from 0 to 1):
#'              either a vector of tau smoothing parameters
#'              or an integer indicating the range of the selection range
#'              : (1 - 0.3) / range * (0:range) + 0.3
#' @param tausp spar range(from 0 to 1):
#'              either a vector of tau smoothing parameters
#'              or an integer indicating the range of the selection range
#'              : (1 - 0.3) / range * (0:range) + 0.3
#'
#' @param ...   additional arguement pass into qs_scam
#' (eg. maxit = 10, ntaus = 10, arg_bs = c("tesmi1", "ps"),
#' opt = "bfgs", dims = c(5, 10), ords = NA,
#' analysis = F, trace=F, sp = NULL, tol = 1e-2,)
#'
#' @import scam
#'
#' @return a scam object
#'

cv_qsscam <- function(x, y, k = 5, xsp=10^(-5:0), tausp=1, ...) {
    s_n <- length(y) # Define the number of observation
    if (s_n < k) {
        stop(paste("folds:", k, "is greater than n:", s_n))
    }
    v_tausp <- tausp

    if (length(xsp) == 1) {
        v_xsp <- (1 - 0.3) / xsp * (0:xsp) + 0.3
    } else {
        v_xsp <- xsp
    }

    loss <- matrix(0, nrow = length(v_tausp), ncol = length(v_xsp))
    # Randomly shuffle the data
    y <- y[sample(s_n)]
    v_folds <- cut(seq(s_n), breaks = k, labels = FALSE) # Create k folds

    for (fold in 1:k) { # Perform k fold cross validation
        test_idx <- which(v_folds == fold, arr.ind = TRUE) # Segement data by fold
        test_y <- y[test_idx]; test_x <- x[test_idx]
        train_y <- y[-test_idx]; train_x <- x[-test_idx];
        # Loop the range
        for (i in seq_along(v_tausp)) {
            tausp <- v_tausp[i]
            for (j in seq_along(v_xsp)) {
                xsp <- v_xsp[j]
                # Build the model
                fit <- qs_scam(train_x, train_y,
                        sp = c(tausp, xsp), ...)
                # Store the loss
                loss[i, j] <- loss[i, j] + qs_loss(test_x, test_y, fit) / k
            }
        }
    }
    cv_idx <- arrayInd(which.min(loss), dim(loss))
    tausp <- v_tausp[cv_idx[1]]
    xsp <- v_xsp[cv_idx[2]]
    return(list(sel = c(tausp, xsp),
            loss = loss))
}

#' qs_loss
#'
#' Return the quantile loss criteria
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param fit vector of y produced by qs_scam, qs_gam, ex_scam or ex_gam
#'
#'
#' @return the quantile sheet loss
#'
qs_loss <- function(x, y, fit) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }
    ntaus <- fit$ntaus
    bnd <- fit$bnd
    # form data
    #repeat Y ntaus times
    ystar <- rep(y, ntaus)
    #data
    v_taus <- seq(bnd, 1 - bnd, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)
    #reweight
    v_pred <- c(predict(fit, dat))
    v_idx <- ystar <= v_pred
    v_weight <- v_wog
    v_weight[v_idx] <- 1 - v_weight[v_idx]

    #calculate loss
    sum(abs(ystar - v_pred) * v_weight)
}


numeric(5)
1:10
c(1, 3, 6, 10, 7 + 8, sqrt(441))


#@reemuru
#data mining
#conditional inference trees

#set the working directory
setwd("./ci-trees/")

#load imports-85 file with headers in the first row
letter<- read.csv(file = "letter.csv", header = TRUE, sep = ",")

#load and initialize the necessary packages
#install.packages("psych")
#install.packages("party")
library(psych)
library(party)

#check for missing data
summary(letter)

#structure of the dataset, verify DV is factor
str(letter)

#view distribution of DV
plot(letter$class)

#scatterplot matrix
modLetter<-letter
modLetter$xbox<-NULL
modLetter$ybox<-NULL
modLetter$width<-NULL
modLetter$high<-NULL
pairs.panels(modLetter)

#divide the data into training set and test set
set.seed(1234)
ind <- sample(2, nrow(letter), replace = TRUE, prob = c(0.7, 0.3))
train.data <- letter[ind == 1, ]
test.data <- letter[ind == 2, ]

#set class as DV with all remaining variables as IV using . wildcard for training data
myFormula<-class~.
model <- ctree(myFormula, data = train.data)

#print the tree
print(model)

#build the confusion matrix for training data in model
table(predict(model), train.data$class)
cm<-table(predict(model), train.data$class)

#accuracy = TN + TP / N + P for training data in model
#sum diag and divide by sum of all observations to derive classification accuracy
sum(diag(table(predict(model), train.data$class)))/sum(table(predict(model), train.data$class))

#set class as DV with all remaining variables as IV using . wildcard for test data
myFormula<-class~.
model <- ctree(myFormula, data = test.data)
#build the confusion matrix for test data
table(predict(model), test.data$class)
cm<-table(predict(model), test.data$class)

#accuracy = TN + TP / N + P test data
#sum diag and divide by sum of all observations to derive classification accuracy
sum(diag(table(predict(model), test.data$class)))/sum(table(predict(model), test.data$class))

#reload dataset
letter<- read.csv(file = "letter.csv", header = TRUE, sep = ",")

#subset for the letter Q and O only to observe performance against letters with similar structure
letter<-subset(letter, class=="Q" | class=="O")
#drop unused levels
letter$class<-droplevels(letter$class)

#rebuild the model
#divide the data into training set and test set
set.seed(1234)
ind <- sample(2, nrow(letter), replace = TRUE, prob = c(0.7, 0.3))
train.data <- letter[ind == 1, ]
test.data <- letter[ind == 2, ]

#set class as DV with ybar, x2ybr and xegvy as predictors
myFormula<-class~+ybar+x2ybr+xegvy
model2 <- ctree(myFormula, data = train.data)

#print the tree
print(model2)

#evaluate the model for the training data
trainPred <- predict(model2, newdata = train.data)
table (trainPred, train.data$class)
cm2<-table(trainPred, train.data$class)

#accuracy = TN + TP / N + P
(cm2[1]+cm2[4])/sum(cm2)

#evaluate the model for the test data
myFormula<-class~+ybar+x2ybr+xegvy
model2 <- ctree(myFormula, data = train.data)

testPred <- predict(model2, newdata = test.data)
table (testPred, test.data$class)
cm3<-table(testPred, test.data$class)

#accuracy = TN + TP / N + P
(cm3[1]+cm3[4])/sum(cm3)

#dataviz
plot(model)
plot(model2)
#mosaic plot using test data
mosaicplot(table(predict(model2, test.data), test.data$class), shade=TRUE, main="O vs. Q")


# Load tag intent data and calculate inter-rater agreement

json.tagIntent1 <- read.csv(file="json_tag_1.csv", header = TRUE)
django.tagIntent1 <- read.csv(file="django_tag_1.csv", header = TRUE)
regex.tagIntent1 <- read.csv(file="regex_tag_1.csv", header = TRUE)
head(json.tagIntent1)

# load the library
library(irr)

kappam.fleiss(json.tagIntent1[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(django.tagIntent1[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(regex.tagIntent1[c("Rater1", "Rater2", "Rater3")])

# overall agreement
tagIntent1 <- rbind(json.tagIntent1, django.tagIntent1, regex.tagIntent1)

kappam.fleiss(tagIntent1[c("Rater1", "Rater2", "Rater3")])


library(forecast)

fraser <- scan("fraser.txt")

plot(fraser)

fraser.ts <- ts(fraser, frequency=12, start=c(1913,3))

fraser.stl = stl(fraser.ts, s.window="periodic")

monthplot(fraser.stl)

seasonplot(fraser.ts)


library(survival)
options(warn=-1)
Args<-commandArgs()
in_file<-Args[6]
out_file<-Args[7]
out_summary<-Args[8]

data<-read.table(in_file, header=T, com='', sep="\t")
data$Time <- as.numeric(as.character(data$Time))
s<-Surv(data$Time, data$Status == 1)
sorted_exp <- sort(data$Exp)
#cutoffs <- unique(round(sorted_exp, 2))
cutoffs <- unique(round(sorted_exp[ceiling(length(sorted_exp)/10):floor(length(sorted_exp)/10*9)], 2))
print(cutoffs)
if (length(cutoffs) == 1) {
	cat('only one group',file=out_summary)
} else {
	min_pvalue <- 100;
	min_cutoff <- 0;
	pvalue <- vector(, length(cutoffs))
	for (n in 1:length(cutoffs))
	{
		res <- tryCatch({
			diff <- survdiff(s~(data$Exp > cutoffs[n]))
			pvalue[n] <- 1 - pchisq(diff$chisq, length(diff$n) - 1)
			if (pvalue[n] < min_pvalue) {
				min_pvalue <- pvalue[n]
				min_cutoff <- cutoffs[n]
			}
		}, error= function(e){
			print(e)
		})
	}

	df = data.frame(cutoffs, pvalue)
	df = df[order(df[,2]),]
	write.table(df, file=out_file, sep='\t', col.names=FALSE, row.names=FALSE);

	med <- median(sorted_exp)
	print(med)
	diff <- survdiff(s~(data$Exp > med))
	med_pvalue <- 1 - pchisq(diff$chisq, length(diff$n) - 1)
	cat(med,med_pvalue,min_cutoff,min_pvalue,file=out_summary)
}


##load data
data(iris)
table(iris$Species)
# Using the Caret package to partition the data
inTrain <- createDataPartition( y=iris$Species, p= 0.7, list=FALSE)
training <- iris[inTrain,]
testing <- iris[-inTrain,]

## Filter
inTrain <- (segmentationOriginal[segmentationOriginal$Case == "Train", ] )

#plot
qplot(Petal.Width, Sepal.Width, colour=Species, data=training)

#Classification using Decision Tree
library(rattle)
fancyRpartPlot(modFit$finalModel)

## Bagging [ Bootstrap Aggregation ] ( similar bias and reduced variance, useful for non-linear functions )
## Useful for non-linear functions
library(ElemStatLearn)
data(ozone, package="ElemStatLearn")
ozone <- ozone[ order(ozone$ozone), ] # sorting based on a column
## Basic Idea
## Bagged LOESS
ll <- matrix(NA, nrow=10, ncol=155)
for(i in 1:10){
    ss <- sample(1:dim(ozone)[1], replace=T)
    ozone0 <- ozone[ss, ]; ozone0 <- ozone0[ order(ozone$ozone), ]
    loess0 <- loess(temperature ~ ozone, data=ozone0, span=0.2)
    ll[i,] <- predict(loess0, newdata=data.frame(ozone=1:155))
}
plot(ozone$ozone, ozone$temperature, pch=19, cex=0.5)
## Bagging using the caret pkg
predictor = data.frame(ozone=ozone$ozone)
temperature = ozone$temperature
treebag <- bag(predictor, temperature, B=10, bagcontrol= bagControl(fit = ctreeBag$fit, predict= ctreeBag$pred, aggregate = ctreeBag$aggregate ))
plot(ozone$ozone, temperature, col='lightgrey', pch=19)
points(ozone$ozone, predict(treebag$fit[[1]]$fit, predictor), pch=19, col="red")
points(ozone$ozone, predict(treebag, predictor), pch=19, col="blue")

## Random Forest, Caret pkg ( Can be very accurate for wide range of problems )
## Difficult to interpret but very accurate, often used by the Data Science experts
data(iris)
library(ggplot2)
inTrain <- createDataPartition(y=iris$Species, p=0.7, list=FALSE)
training <- iris[inTrain, ]
testing <- iris[-inTrain, ]
modFit <- train(Species ~ ., data=training, method="rf", prox=TRUE) # Random Forest
getTree(modFit$finalModel, k=2)

irisP <- classCenter(training[, c(3,4)], training$Species, modFit$finalModel$proximity)
irisP <- as.data.frame(irisP); irisP$Species <- rownames(irisP)
p <- qplot(Petal.Width, Petal.Length, col=Species, data=training)
## Predicting new values
pred <- predict(modFit, testing); testing$predRight <- pred==testing$Species
table(pred, testing$Species)
## visualize the prediction
qplot(Petal.Width, Petal.Length, colour=predRight, data=testing, main="newData Predictions")

## Boosting
## Used for imporving the performance of weak classifiers, by averaging them together
library(ISLR)
data(Wage); library(ggplot2); library(caret)
Wage <- subset(Wage, select =-c(logwage))
modFit <- train(wage ~ ., method="gbm", data=training, verbose=FALSE);

## Model Based predicition
## 1. Naive Bayes ( Assumption, all the features are independent and not related )
data(iris)
inTrain <- createDataPartition(y=iris$Species, p=0.7, list=FALSE)
training <- iris[inTrain, ]
testing <- iris[-inTrain, ]
## Linear Discrimant Analysis
modlda <- train (Species ~ ., data=training, method="lda")
## Naive Bayes
modlda <- train (Species ~ ., data=training, method="nb")
### Predict
plda <- predict(modlda, testing) ; pnb <- predict(modnb, testing)
### Compare the results
table(plda, pnb)
equalPred = (plda == pnb)
qplot(Petal.Width, Sepal.Width, colour=equalPred, data=testing)

### Reference: Material provided by <Jeff Leek, PhD, Roger D. Peng, PhD, Brian Caffo, PhD>


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 7   Chapter : 5.3     Page No: 275
# CrossProduct of Vectors
library(pracma)
u<-c(3,2,0)
v<-c(1,4,0)
cp<-cross(u,v)
print("u * v is ")
print(cp)


library(Rcpp)
library(rstan)
library(reshape2)

source(paste(getwd(), "../../sir-functions", "StocSSIR.r", sep = "/"))

T 		<- 60
N 		<- 500
i_infec <- 5
nloc  	<- 5
steps   <- 7
sigma   <- 10

pars <- c(	R0 	 = 3.0, # new infected people per infected person
          	r 	 = 0.1, # recovery rate
          	N 	 = 500, # population size
          	eta  = 0.5, # geometric random walk
          	berr = 0.5, # Beta geometric walk noise
          	phi  = 0.1) # degree of interconnectivity

initcond <- matrix(NA, nloc, 3)
colnames(initcond) <- c("S","I","R")

## default (everyone susceptible)
initcond[,"S"] <- N
initcond[,"I"] <- 0
initcond[,"R"] <- 0

## one region infected
initcond[2,] <- c(N - i_infec, i_infec, 0);

## set up number of neighbors vector and neighbor index matrix

## ring topology:
neinum <- rep(2,nloc)
neibmat <- matrix(-1, nloc, nloc)
neibmat[,1] <- c( ((0:(nloc-1)-1)%%nloc)+1 )
neibmat[,2] <- c( ((0:(nloc-1)+1)%%nloc)+1 )

ssdeout <- StocSSIR(initcond, pars, T, steps, neinum, neibmat)

infec_counts <- ssdeout[,'I',] + matrix(rnorm(nloc*(T+1), 0, sigma), nloc, T+1)
infec_counts <- ifelse(infec_counts < 0, 0, infec_counts)

datlen <- T*7 + 1

standata <- matrix(NA, nloc, datlen)

for (loc in 1:nloc) {
	data <- matrix(data = -1, nrow = T+1, ncol = steps)
	data[,1] <- infec_counts[loc,]
	standata[loc,] <- as.vector(t(data))[1:datlen]
}

sir_data <- list( T = datlen,   		# simulation time
                  nloc = nloc, 			# number of locations
                  y = standata, 		# infection count data
                  N = 500,      		# population size
                  h = 1/steps,    		# step size per day
                  neinum = neinum, 		# number of neibours for each location
                  neibmat = neibmat)	# neighbour list for each location

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 4000, 		# iterations per chain
                        warmup = 2000, 		# warmup interations
                        thin   = 1,   		# thinning number
                        verbose = FALSE,
                        refresh = 50)

fit <- with(stan_options,
            stan(file  	= "sir-spa-euler.stan",
	            data    = sir_data,
	            chains  = chains,
	            iter    = iter,
	            warmup  = warmup,
	            thin    = thin,
	            verbose = verbose,
	            refresh = refresh )
        	)

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
               			r = melt(exfit[,,'r'])$value,
               			sigma = melt(exfit[,,'sigma'])$value,
               			eta = melt(exfit[,,'eta'])$value,
               			berr = melt(exfit[,,'berr'])$value,
               			phi = melt(exfit[,,'phi'])$value )

# Iinit extraction
for (j in 1:nloc) {
	varname <- paste('Iinit[', j, ']', sep = '')
	paramdata[[varname]] <- melt( exfit[,,varname] )$value
}

# Bnoise extraction
for (loc in 1:nloc) {
	for (t in 1:datlen) {
		varname <- paste('Bnoise[', loc,',',t,']', sep = '')
		paramdata[[varname]] <- melt( exfit[,,varname] )$value
	}
}


library(dplyr)
library(tidyr)
library(ggplot2)

gap_dat <- read.delim("06_gap-merged-with-continent.tsv")
gap_dat %>% str
# 'data.frame':  3312 obs. of  6 variables:
# $ country  : Factor w/ 187 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year     : int  1952 1957 1962 1967 1972 1977 1982 1987 1992 1997 ...
# $ pop      : num  8425333 9240934 10267083 11537966 13079460 ...
# $ gdpPercap: num  779 821 853 836 740 ...
# $ lifeExp  : num  28.8 30.3 32 34 36.1 ...
# $ continent: Factor w/ 6 levels "Africa","Americas",..: 3 3 3 3 3 3 3 3 3 3 ...

## During data exploration, I learned that most countries have data every five
## years, e.g. 1952, 1957, 1962, and so on. Let's just make that official.
gap_dat <- gap_dat %>%
  filter(year %% 5 == 2)
gap_dat %>% str # 'data.frame':	2012 obs. of  6 variables:

## number of distinct values for year
(n_years <- n_distinct(gap_dat$year)) # 12

## Does every country contribute data for all years?
country_freq <- gap_dat %>%
  group_by(country) %>%
  tally

ggplot(country_freq, aes(x = n)) + geom_bar(binwidth = 1)
country_freq$n %>% table

## Most countries do contribute data for 12 years
## Who contributes less?
country_freq %>%
  filter(n < 12) %>%
  arrange(n)

## The only thing I see here that I want to fix is to rescue China, which has
## data for 11 of 12 years. Otherwise, I will let these countries go.
keepers <- c(with(country_freq, as.character(country[n == 12])),
             "China") %>% sort
keepers %>% length # 142 countries

## filter gap_dat
gap_dat <- gap_dat %>%
  filter(country %in% keepers) %>%
  droplevels %>%
  arrange(country, year)
gap_dat %>% str
# 'data.frame':  1703 obs. of  6 variables:
# $ country  : Factor w/ 142 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year     : int  1952 1957 1962 1967 1972 1977 1982 1987 1992 1997 ...
# $ pop      : num  8425333 9240934 10267083 11537966 13079460 ...
# $ gdpPercap: num  779 821 853 836 740 ...
# $ lifeExp  : num  28.8 30.3 32 34 36.1 ...
# $ continent: Factor w/ 5 levels "Africa","Americas",..: 3 3 3 3 3 3 3 3 3 3 ...

## BEGIN: Fill in missing data for China

## which year is the problem?
(china <- gap_dat %>%
   filter(country == "China"))      # 1952 is missing

## what does the data look like?
china_tidy <- china %>%
  gather(key = "variable", value = "value",
         pop, lifeExp, gdpPercap)
ggplot(china_tidy, aes(x = year, y = value)) +
  facet_wrap(~ variable, scales="free_y") +
  geom_point() + geom_line() +
  scale_x_continuous(breaks = seq(1950, 2011, 15))

## extremely low, low tech imputation for 1952
china_gdp_fit <- lm(gdpPercap ~ year, gap_dat,
                    subset = country == 'China' & year <= 1982)
summary(china_gdp_fit)
(china_gdp_1952 <- predict(china_gdp_fit, data.frame(year = 1952)))
## 400.4486

china_pop_fit <- lm(pop ~ year, gap_dat, subset = country == 'China')
summary(china_pop_fit)
(china_pop_1952 <- predict(china_pop_fit, data.frame(year = 1952)))
## 556263528

china_lifeExp_1952 <- 44 # fiction, but no simple linear fit seems appropriate

gap_dat <- rbind(gap_dat,
                 data.frame(country = 'China', year = 1952,
                            pop = china_pop_1952, continent = 'Asia',
                            lifeExp = china_lifeExp_1952,
                            gdpPercap = china_gdp_1952))
gap_dat <- gap_dat %>%
  arrange(country, year)
gap_dat %>%
  filter(country == "China")
str(gap_dat)
# 'data.frame':  1704 obs. of  6 variables:
# $ country  : Factor w/ 142 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year     : num  1952 1957 1962 1967 1972 ...
# $ pop      : num  8425333 9240934 10267083 11537966 13079460 ...
# $ gdpPercap: num  779 821 853 836 740 ...
# $ lifeExp  : num  28.8 30.3 32 34 36.1 ...
# $ continent: Factor w/ 5 levels "Africa","Americas",..: 3 3 3 3 3 3 3 3 3 3 ...

## revisit the data
china_tidy <- gap_dat %>%
  filter(country == "China") %>%
  gather(key = "variable", value = "value",
         pop, lifeExp, gdpPercap)
ggplot(china_tidy, aes(x = year, y = value)) +
  facet_wrap(~ variable, scales="free_y") +
  geom_point() + geom_line() +
  scale_x_continuous(breaks = seq(1950, 2011, 15))

## END: Fill in missing data for China

write.table(gap_dat,
            "07_gap-every-five-years.tsv",
            quote = FALSE, sep = "\t", row.names = FALSE)


#' Calculate each of the variability estimates used by the PEB
#'
#' A utility function used to calculate each of the variability
#' estimates used by the PEB algorithm from from any two of them
#'
#' @export
#' @family peb
#'
#' @param mu The population mean
#'
#' @param sigma2 The within group variation
#'
#' @param tau2 The between group variation
#'
#' @param v The total variation (=sigma2 + tau2)
#'
#' @param beta1,beta The proportion of toal variation attributable to between group variation (=tau2 / v)
#'
#' @note mu,sigma2,tau2,v, and beta may be substitured by a the object returned by \code{\link{PEBparams}}
#'
#' @return a list containing the values sigma2, tau2, v, beta1, and mu,
#' and a function 'bn' which calculates bn for various values of n
#' given these parameters in this
#'

pebVarArgs <-  function(...){
	# calculates all the
	ARGS = list(...)
	# fastPath out for the special case that the only argument
	# was the product of PEBparams()
	if((length(ARGS) == 1) & inherits(ARGS[[1]],'PEBparams')){
		params <- ARGS[[1]]
		sigma2 = params$s2
		tau2 = params$t2
		v = sigma2 + tau2
		mu = params$mu
		fun = function(n)tau2/((sigma2/n) + tau2)
		return(list(sigma2=sigma2,
					tau2=tau2,
					v=v,
					mu=mu,
					beta1=fun(1),
					bn = fun))
	}

	sigma2 = if('sigma2' %in% names(ARGS)) ARGS$sigma2 else NA
	tau2 = if('tau2' %in% names(ARGS)) ARGS$tau2 else NA
	v = if('v' %in% names(ARGS)) ARGS$v else NA
	beta1 = (if('beta1' %in% names(ARGS))
				ARGS$beta1
			else if('beta' %in% names(ARGS))
				ARGS$beta
			else NA)

	if(!is.na(sigma2)) 	stopifnot(sigma2>0)
	if(!is.na(tau2)) 	stopifnot(tau2>0)
	if(!is.na(v)) 		stopifnot(v>0)
	if(!is.na(beta1)) 	stopifnot(beta1>0)

	if(sum(c((is.na(sigma2)||is.nan(sigma2)),
			 (is.na((tau2)||is.nan(tau2))),
			 (is.na((v)||is.nan(v))),
			 (is.na((beta1)||is.nan(beta1))))) != 2)
		stop("please specifiy exacty two parameters out of 'sigma2','tau2','v', and 'beta'")
	# beta1 / v specified
	if(is.na(tau2) & (!is.na(beta1))& (!is.na(v)))
		tau2 = beta1*v
	if(is.na(sigma2) & (!is.na(beta1))& (!is.na(v)))
		sigma2 = (1-beta1)*v
	# sigma2 /v specified
	if(is.na(sigma2) & (!is.na(tau2))& (!is.na(v)))
		sigma2 = v - tau2
	# tau2/v specified
	if(is.na(tau2) & (!is.na(sigma2))& (!is.na(v)))
		tau2 = v - sigma2
	# tau2 / V specified
	if(is.na(sigma2) & (!is.na(tau2))& (!is.na(beta1)))
		sigma2 = (tau2/beta1) - tau2
	# tau2 / V specified
	if(is.na(tau2) & (!is.na(sigma2))& (!is.na(beta1)))
		tau2 = (sigma2*beta1)/(1-beta1)
	if(is.na(sigma2) |is.na(tau2) )
		stop('Insufficient arguments:  ')
	if(is.na(v))
		v = sigma2 + tau2
	if(is.na(beta1))
		beta1 = tau2 / v
	return(list(sigma2=sigma2,
			   	tau2=tau2,
			   	v=v,
			   	beta1=beta1,
				mu=ARGS$mu,
				bn = function(n)tau2/((sigma2/n) + tau2)))
}


mvdnorm <- function(X, mu, Sigma)
{
	X <- as.matrix(X)

	n <- dim(X)[1]
	p <- dim(X)[2]

	B <- chol(Sigma)
	U <- (X-matrix(rep(mu,n),nrow=n,byrow=T))%*%ginv(B)

	dens <- exp(-rowSums(U*U)/2) * (2*pi)^(-p/2) / det(B)
}


## Instructions to run your output files in R manually (with indicspecies package)

## You will need the following files (output from indicator_species.sh):
##	1) map.indicspecies.txt (metadata file)
##	2) otutable.indicspecies.txt (OTU table file)

## Open R
R

## Load indicspecies
library(indicspecies)

## Read in your files
map <- read.csv("map.indicspecies.txt", sep="\t", header=TRUE)
biom <- read.csv("otutable.indicspecies.txt", sep="\t", header=TRUE)

## List available factors from your metadata
colnames(map)

## Read in your factor
f1 <- map[,"Moisture"] ## if factor is "Moisture"

## Indicator value analysis
indval = multipatt(biom, f1, control=how(nperm=9999)) ## If you wish to do 9999 permutations
summary(indval)

## Assess coverage of indicator value analysis
coverage(biom, indval)

## Pearson's phi coefficient of association
phi = multipatt(biom, f1, func="r.g", control=how(nperm=9999)) ## If you wish to do 9999 permutations
summary(phi)

## Assess coverage of phi
coverage(biom, phi)

##FDR corrections (IndVal)
## Read all indval results to variable
indval.all <- indval$sign

## Extract p-values to separate vectors for fdr correction
indval.all.pvals <- indval.all[,"p.value"]

## Correct p-values (FDR) and bind the results to original output
fdr.p.value <- p.adjust(indval.all.pvals, method="fdr")
indval.all.fdr <- cbind(indval.all, fdr.p.value)

## Omit NA values and print only those with p <= 0.05
attach(indval.all.fdr) ## allows sorting by header
indval.all.fdr.nona.sort <- indval.all.fdr[order(fdr.p.value, p.value, na.last=NA),] ## sort output by fdr, then p-value, omit "NA"
indval.all.fdr.nona.sort
detach(indval.all.fdr)

##FDR corrections (Phi)
## Read all phi results to variable
phi.all <- phi$sign
phi.all.pvals <- phi.all[,"p.value"]

## Correct p-values (FDR) and bind the results to original output
fdr.p.value <- p.adjust(phi.all.pvals, method="fdr")
phi.all.fdr <- cbind(phi.all, fdr.p.value)

## Omit NA values and print only those with p <= 0.05
attach(phi.all.fdr)
phi.all.fdr.nona.sort <- phi.all.fdr[order(fdr.p.value, p.value, na.last=NA),]
phi.all.fdr.nona.sort
detach(phi.all.fdr)

## See the official indicspecies documentation and tutorial for more functionality:
## https://cran.r-project.org/web/packages/indicspecies/indicspecies.pdf
## https://cran.r-project.org/web/packages/indicspecies/vignettes/indicspeciesTutorial.pdf


 ZGGQRF Example Program Results

 Generalized least squares solution
 (  -0.9846,   1.9950) (   3.9929,  -4.9748) (  -3.0026,   0.9994)

 Residual vector
 ( 1.26E-04,-4.66E-04) ( 1.11E-03,-8.61E-04) ( 3.84E-03,-1.82E-03)
 ( 2.03E-03, 3.02E-03)

 Square root of the residual sum of squares
   5.79E-03


library(corrplot)

dn.fig = "figures/sig_ranked_correlation/"
dir.create(dn.fig, showWarnings = F, recursive = T)

df.scores = fread("results/Score_table.txt")

df.scores.ranked = df.scores %>%
  mutate_at(vars(matches("\\(")), rank, na.last="keep")

score.mat.ranked = df.scores.ranked %>%
  dplyr::select(-response) %>%
  tibble::column_to_rownames("subject") %>% data.matrix()

cc = cor(score.mat.ranked, method = "spearman", use = "pairwise.complete.obs")
ccm = cor.mtest(score.mat.ranked, method = "spearman")
ccp = ccm$p

sname = colnames(score.mat.ranked)
svar = glue::glue("`{sname}`")
xvar = which(sname == "TGSig (microarray)")

for(k in seq_along(sname)[-xvar]) {
  cat(sname[k],"\n")
  ccr = cc[xvar, k]
  ccp = ccm$p[xvar, k]
  df.cc = data.frame(label = glue::glue("r = {format(ccr, digits=2)} p = {format(ccp, digits=2)}"))
  ggplot(df.scores.ranked, aes_string(svar[xvar], svar[k], fill="response")) +
    geom_point(shape = 21, size=3, col="black", show.legend = F) +
    scale_fill_manual(values = c("black","white")) +
    geom_text(data = df.cc, aes(label=label), x = Inf, y=-Inf, hjust=1.1, vjust = -1, col="black", inherit.aes = F) +
    xlab(paste0(sname[xvar], ", ranked")) +
    ylab(paste0(sname[k], ", ranked")) +
    theme_bw()
  fn.fig = glue::glue("{dn.fig}/{sname[k]}_vs_{sname[xvar]}")
  ggsave(paste0(fn.fig, ".png"), w=2.6, h=2.5)
  ggsave(paste0(fn.fig, ".pdf"), w=3, h=2.5, useDingbats=F)
}