# coding: utf-8

# # Práctico 4 - Medidas en redes sociales reales
#
# #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_4_measures
# 3.   Guardar el notebook en su Google Drive:
#      File -> Save a Copy in Drive...
# 4.   Renombrar el archivo `"cedula ID"_AR_hw4_IR.ipynb`, por ejemplo *33484022_AR_hw4_IR.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_4_measures

# ## 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("network", "sna","rgexf",
         "networkD3","twitteR","stringr","dplyr", "ggplot2",
         "R.matlab", "sand","igraph","igraphdata") #procesamiento en paralelo

load_libs(libs)

# ## 1.d) Descargar funciones auxiliares

# In[ ]:

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

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. Características de vértices y aristas
# Características de vértices y aristas de un grafo en `R`.
# Seguir las secciones 4.1 y 4.2 del libro [SANDR], ejecutando el código fuente incluido.
#

# In[ ]:

# 4.1 Introduction
# 4.2 Vertex and Edge Characteristics
# 4.2.1 Vertex Degree
data(karate)
summary(karate)

# The degree distribution for the karate club network
# We can see that there are three distinct groups of vertices, as measured by degree.
# The two most highly connected vertices correspond to actors 1 and 34 in the network,
# representing the instructor and administrator a
hist(degree(karate), col="lightblue", xlim=c(0, 50), xlab="Vertex Degree", ylab="Frequency", main="")

# weighted degree distribution
# For weighted networks, a useful generalization of degree is the notion of vertex
# strength, which is obtained simply by summing up the weights of edges incident to a given vertex.
# The previously observed distinction among the three groups of vertices is lost
hist(graph.strength(karate), col="pink", xlab="Vertex Strength", ylab="Frequency", main="")

# In[ ]:

# Degree distributions can exhibit a variety of shapes. For a network of interactions
# among protein pairs in yeast, for next example, the shape is quite different from that of the karate club. In this case,
# the distribution of degrees associated with the edges among vertices is quite heterogeneous, as can be seen from examination of the histogram.
data(yeast)
ecount(yeast) #11855
vcount(yeast) #2617
d.yeast <- degree(yeast)
# degree distribution
hist(d.yeast,col="blue", xlab="Degree", ylab="Frequency", main="Degree Distribution")

# Given the nature of the decay in this distribution, a log–log scale is more effective in summarizing the degree information.
dd.yeast <- degree.distribution(yeast)
d <- 1:max(d.yeast)-1
ind <- (dd.yeast != 0)
plot(d[ind], dd.yeast[ind], log="xy", col="blue",
     xlab=c("Log-Degree"), ylab=c("Log-Intensity"),
     main="Log-Log Degree Distribution")
# we see that there is a fairly linear decay in the log-frequency as a function of log-degree.

# Beyond the degree distribution itself, it can be interesting to understand the manner
# in which vertices of different degrees are linked with each other. Useful in assessing
# this characteristic is the notion of the average degree of the neighbors of a
# given vertex. For example, a plot of average neighbor degree versus vertex degree
a.nn.deg.yeast <- graph.knn(yeast,V(yeast))$knn
plot(d.yeast, a.nn.deg.yeast, log="xy", col="goldenrod", xlab=c("Log Vertex Degree"),
     ylab=c("Log Average Neighbor Degree"))
# suggests that while there is a tendency for vertices of higher degrees to link with similar vertices,
# vertices of lower degree tend to link with vertices of both lower and higher degrees.

# In[ ]:

# 4.2.2 Vertex Centrality
# An intuitively appealing way of displaying vertex centralities (for networks of small to moderate size)
# is to use a radial layout, with more central vertices located closer to the center.
# The function gplot.target, in the package sna, can be used for this purpose.
A <- get.adjacency(karate, sparse=FALSE)
g <- network::as.network.matrix(A)
par(mfrow=c(2, 2))
sna::gplot.target(g, sna::degree(g), main="degree",
                  #circ.lab = FALSE,
                  circ.col="skyblue",
                  usearrows = FALSE,
                  vertex.col=c("blue", rep("red", 32), "yellow"),
                  edge.col="darkgray")
sna::gplot.target(g, sna::closeness(g), main="closeness",
                  #circ.lab = FALSE,
                  circ.col="skyblue",
                  usearrows = FALSE,
                  vertex.col=c("blue", rep("red", 32), "yellow"),
                  edge.col="darkgray")
sna::gplot.target(g, sna::betweenness(g), main="betweenness",
                  #circ.lab = FALSE,
                  circ.col="skyblue",
                  usearrows = FALSE,
                  vertex.col=c("blue", rep("red", 32), "yellow"),
                  edge.col="darkgray")
sna::gplot.target(g, sna::evcent(g), main="evcent",
                  #circ.lab = FALSE,
                  circ.col="skyblue",
                  usearrows = FALSE,
                  vertex.col=c("blue", rep("red", 32), "yellow"),
                  edge.col="darkgray")

# Extensions of these centrality measures from undirected to directed graphs are
# straightforward. However, in the latter case, there are in addition other useful
# options. For example, the HITS algorithm, based on the concept of ‘hubs and authorities’
# Applying these measures to the AIDS blog network indicates, as seen in Fig. 4.5,
# that only six of the 146 blogs in this network play the role of a hub, while the vast
# majority of the vertices (including some of the hubs) play the role of an authority.
l <- layout.kamada.kawai(aidsblog)
plot(aidsblog, layout=l, main="Hubs", vertex.label="",
     vertex.size=10 * sqrt(hub.score(aidsblog)$vector))
plot(aidsblog, layout=l, main="Authorities", vertex.label="",
     vertex.size=10*sqrt(authority.score(aidsblog)$vector))

# In[ ]:

# 4.2.3 Characterizing Edges
# Using edge betweenness with the karate network and examining, for instance,
# the edges with the three largest betweenness values
eb <- edge.betweenness(karate)
E(karate)[order(eb, decreasing=T)[1:3]]
# + 3/78 edges from 4b458a1 (vertex names):
#   [1] Actor 20--John A   Mr Hi   --Actor 20 Mr Hi   --Actor 32
# we are led to note that actor 20 plays a key role from this perspective in facilitating
# the direct flow of information between the head instructor (Mr Hi, vertex 1) and the
# administrator (John A, vertex 34).

# However, many other vertex centrality measures do not extend as easily. One
# way around this problem is to apply vertex centrality measures to the vertices in the
# line graph of a network graph G. The line graph of G, say G' = (V', E'), is obtained
# essentially by changing vertices of G to edges, and edges, to vertices, which in
# igraph may be accomplished using line.graph.
summary(karate)
karate_dual = line.graph(karate)
summary(karate_dual)
A_dual <- get.adjacency(karate_dual, sparse=FALSE)
g_karate_dual <- network::as.network.matrix(A_dual)
sna::closeness(g_karate_dual)
sna::betweenness(g_karate_dual)
sna::evcent(g_karate_dual)

# # 3. Medidas en redes sociales reales.
#
# Calcular e interpretar medidas de centralidad de vértice en redes sociales reales (Linkedin/Facebook/Twiiter, etc.).
#

# ## 3.a) Datos de Twitter de `isDotR`
#
# Utilizando los datos de Twitter publicados por Enmanuel Santana (http://apuntes-r.blogspot.com.uy/2015/07/un-ejemplo-de-pagerank.html),
# cargarlos como un grafo en `R`. Los datos son un pequeño conjunto de la red de ego de la cuenta `isDotR` de Twitter.
# Los datos también pueden descargarse en:
# https://raw.githubusercontent.com/prbocca/na101_master/master/homework_4_measures/Twitter_network_R.csv
#

# In[ ]:

# download data
download.file(url="https://raw.githubusercontent.com/prbocca/na101_master/master/homework_4_measures/Twitter_network_R.csv", destfile="Twitter_network_R.csv", mode="wb")
list.files()

# load data
datos <- read.csv("Twitter_network_R.csv")

# aprendemos de los datos
head(datos)
unique(c(as.character(datos[,2]),as.character(datos[,1]))) # los usuarios unicos son 34

# In[ ]:

# crea objeto de grafo
grafo = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: crear grafo desde el data.frame "datos"
#
#
#
##################################################################
summary(grafo)

# grafica de grafo
plot(grafo,layout=layout.fruchterman.reingold, vertex.size=8,
     vertex.label.dist=0.4, vertex.color="red", edge.arrow.size=0.5)

# Utilizando el paquete `igraph` calcular las métricas de centralidad (considerando el grafo dirigido): `degree(), closeness(), betweenness(), evcent(), page.rank()`,
# y comparar los tres usuarios con mayor centralidad para cada una de ellas.
# El resultado debería ser el de la siguiente Tabla:
#
# |metric|1|2|3|
# |---|---|---|---|
# | `degree()` |revodavid | cjbayesian | freakonometrics |
# | `closeness()` |statbandit | cjbayesian | freakonometrics |
# | `betweenness()` |revodavid | hadleywickham | cjbayesian |
# | `evcent()` | freakonometrics | revodavid | statsinthewild |
# | `page.rank()` | isdotr | hadleywickham | revodavid |

# In[ ]:

# calcular centralidades
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: calcular centralidades: grado, cercanía, intermediación, vector propio, y pagerank sobre "grafo"
#
#
#
##################################################################

# grafica interacciones usando valor page.rank para tamaños en grafico
pr = page.rank(grafo)$vector
V(grafo)$label.cex =  0.6 + pr*3 # tamaño de letra segun page.rank
plot(grafo,layout=layout.fruchterman.reingold, vertex.size=pr*100,
     vertex.label.dist=0.4, vertex.color="red", edge.arrow.size=0.3)

# ## 3.b) (opcional) Centralidad en tu red social
#
# Lamentablemente desde 2015, las principales redes sociales han cerrado sus APIs para acceder a los datos de redes (amigos, etc). Solo algunas tienen un acceso limitado (gratuito o con suscripción).
# El sitio SociLab (http://socilab.com/) realizaba un análisis básico de la red Linkedin del usuario. De forma excepcional (y por razones históricas) este sitio tuvo acceso a esta API hasta el 2018.
# Actualmente estan todas cerradas, solo existen muchas ofertas de servicios online, que utilizan tu cuenta de usuario para extraer a información (muy parcial) de las redes sociales. Ejemplos son: https://mentionmapp.com/, https://socioviz.net, https://netlytic.org/, etc.
#
# En este ejercicio utilizaremos Netlytic con datos de twitter. La interfaz no es intuitiva, pero es potente. Debe:
# i) crearse una cuenta,
# ii) realizar un nuevo dataset vinculando tu cuenta de Twitter, escribiendo un nombre al dataset y las palabras de búsqueda (ej. `#Uruguay`); el resultado lleva unos minutos, y se puede acceder en la sección `mi dataset`,
# iii) una de las opciones de análisis es basado en redes, en donde puede visualizar la red y exportarla.
#
# Se pide realizar los pasos anteriores para generar un dataset sobre algún tema de interés, y exportarlo para visualizarlo con `igraph` o `Gephi`.
#

# ## 4. Twitter
#
# Twitter permite acceder parcialmente a datos de la red utilizando una cuenta de desarrollador gratuita. El 30/08/2018 a las 11.30am se descargaron los $5000$ tweets más recientes sobre `#Uruguay`. Los datos pueden descargarse en:
# https://raw.githubusercontent.com/prbocca/na101_master/master/homework_4_measures/tweets_df.csv

# ## 4.a) Cargar los datos

# In[ ]:

# download and load data
tweets_df = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: similar a otras descargas, cargar los tweets en el data.frame tweets_df
#
#
#
##################################################################
head(tweets_df)

#
# ## 4.b) Tweets más populares
#
# Ver los 5 tweets más populares (con más retweets) que no sean spam, ni retweets. Nota: el spam puede ser eliminado viendo los mensajes con más retweets (por ejemplo con más de 15000 retweets).
#

# In[ ]:

# select top retweeted tweets
tweets_df = tweets_df[order(tweets_df$retweetCount, decreasing = TRUE),]
tweets_df$spam = (tweets_df$retweetCount >= 15000)  #supongo spam lo que tiene mas de 15000 retweets
tweets_df_filter = tweets_df[!tweets_df$spam,] #filtro el spam

# Distribucion de retweets
# mostrar el histograma de la cantidad de tweets que tienen la misma cantidad de retweets.
# También puede mostrarse como tabla.
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: usar tweets_df_filter, y falta filtrar retweets
#
#
#
##################################################################

# Mostrar los 5 tweets mas retweeteados
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: usar tweets_df_filter
#
#
#
##################################################################

# ## 4.c)
#
# Utilizando el paquete `igraph` crear la red de quién hace retweet de quién. Utilizando los tweets con al menos dos retweets (y que no son spam). Debe obtener una red similar a la siguiente Figura.
# ![](https://github.com/prbocca/na101_master/raw/master/homework_4_measures/rt_top_graph.png)
#

# In[ ]:

# crear la red de retweets y guardarla en rt_top_graph
rt_top_graph = NA
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: crear un data.frame de quien retweetea a quien,
#  filtrar en ese data.frame los tweets con solo un retweet, y
#  luego crear grafo desde el data.frame
#
# Tip: el resultado es, summary(rt_top_graph):
#   IGRAPH e7f1de6 DN-- 314 280 --
#   + attr: name (v/c), n (e/n)
#
#
#
##################################################################

#plot
glay = layout_with_fr(rt_top_graph)
ver_labs = igraph::get.vertex.attribute(rt_top_graph, "name", index=V(rt_top_graph))
par(bg="white", mar=c(1,1,1,1))
plot(rt_top_graph, layout=glay, vertex.color="black", vertex.size=10, vertex.label=ver_labs,
     vertex.label.family="sans", vertex.shape="none", vertex.label.color=hsv(h=.165, s=.28, v=.08, alpha=1),
     vertex.label.cex=0.85, edge.arrow.size=0.8, edge.arrow.width=0.5, edge.width=3,
     edge.color=hsv(h=0, s=1, v=1, alpha=1))
title("5000 last tweets on #Uruguay : Who retweets whom",
      cex.main=1, col.main="black") # add title

# ## 4.d) Centralidad
#
# Calcular las métricas de centralidad: `betweenness(), hub_score(), authority_score()` y comparar los cinco usuarios con mayor centralidad para cada una de ellas.  El resultado debería ser el de la siguiente Tabla
#
# |metric|1|2|3|4|5|
# |---|---|---|---|---|---|
# | `betweenness()` | emekavoces | lsm_en_uy | jgamorin | boleadorcharrua | the_view_of_leo |
# | `hub_score()` | jgamorin | emekavoces | ciudadanos_mvd | pablolarraz10 | the_view_of_leo |
# | `authority_score()` | magelameinjua | dibonomiguel | elojochurrinche | arriolaernesto2 | pablolarraz10 |
#
#

# In[ ]:

##################################################################
#                       TU CÓDIGO ACÁ
# Tip: calcular centralidades usando el grafo rt_top_graph
#
#
#
##################################################################

# ## 4.e) (opcional)
#
# En lugar de los datos sugeridos, puede repetirse el proceso utilizando datos propios. Esto puede hacerse mediante el proceso descripto en el ejercicio anterior o utilizando el paquete `twitteR` de `R`. Para hacerlo utilizando `twitteR` es necesario:
# 1.   crear una cuenta de desarrollo en https://developer.twitter.com/,
# 2.   crear una aplicación de Twitter para obtener credenciales de acceso al API (`consumer key, consumer secret, access token, access token secret`),
# 3.   usar el API desde `R`.
# Puede por ejemplo descargarse los 5000 tweets más recientes de `#Uruguay` (o del tópico que se desee) y repetir las partes anteriores.
#
#
#
#

# In[ ]:

# Step 0: You need to use OAuth from Twitter
# 1. Log into the Twitter Developers section Apply for a account in: https://developer.twitter.com/.
# 2. Get Consumer Key & Consumer Secret, you have to create an app in Twitter via https://apps.twitter.com/app/new.
# 3. Then you’ll be taken to a page containing Consumer Key & Consumer Secret.

# collect recent 5000 tweets of #Uruguay
# you need to use your own key, which can be obtain from tweeter
##################################################################
#                       TU CÓDIGO ACÁ
# Tip: copy and paste ;)
#
#
api_key       = "paste here"
api_secret    = "paste here"
access_token  = "paste here"
access_token_secret = "paste here"
#
##################################################################
setup_twitter_oauth(api_key,api_secret,access_token,access_token_secret)

my_tweets = searchTwitter("#Uruguay", n=5000, lang=NULL,since=NULL, until=NULL,locale=NULL,
                          geocode=NULL, sinceID=NULL, maxID=NULL,resultType=NULL, retryOnRateLimit=120)
my_tweets_df = twListToDF(my_tweets) # convert tweets to a data frame
write.csv(my_tweets_df, "my_tweets_df.csv")

head(my_tweets_df)


r <- function(x, log = TRUE){
  xbar <- mean(x, na.rm = TRUE)
  ans <- n*(xbar - .5)
  if(!log) ans <- exp(ans)
  return(ans)
}

theta0 <- 0
theta1 <- 1
n <- 100
alpha0 <- 0.05
cprime <- qnorm(1-alpha0, sd = 1/sqrt(n))
cprime
logc <- n*(cprime-.5)

X0 <-rnorm(n, mean = theta0, sd = 1)
X1 <-rnorm(n, mean = theta1, sd = 1)

## Uma observação: este teste não é ruim:
cat("Rejeita H0 para X0?", r(X0) > logc, "\n")
cat("Rejeita H0 para X1?", r(X1) > logc, "\n")

## Porém...
type_II_prob <- function(n){
    ans <- pnorm(q = qnorm(1-alpha0, sd = 1/sqrt(n)), mean = theta1, sd = 1/sqrt(n), lower.tail = TRUE)
}
ns <- c(1, 25, 100)
data.frame(n = ns, beta = type_II_prob(ns), logc = exp(ns*(cprime-.5)))

curve(type_II_prob, 1, 100,
      xlab = "Tamanho de amostra (n)", ylab = expression(beta(delta)))


sample <- 50000
X <- rexp(sample, 0.2)
x <- data.frame(X = seq(1, sample , 1), Y = sort(X))
plot(x,xlab="Position",ylab="values",main="Scatter_Plot for Exp distribution")
##

list <- split(X,seq(1,500,1))
##

pdata1 <- rep(0, 100);
pdata2 <- rep(0, 100);
pdata3 <- rep(0, 100);
pdata4 <- rep(0, 100);
pdata5 <- rep(0, 100);

for(i in 1:100){
  val=round(X[i], 0);
  if(val <= 100){
    pdata1[val] = pdata1[val] + 1/ 100;
  }
}
for(i in 101:200){
  val=round(X[i], 0);
  if(val <= 100){
    pdata2[val] = pdata2[val] + 1/ 100;
  }
}
for(i in 201:300){
  val=round(X[i], 0);
  if(val <= 100){
    pdata3[val] = pdata3[val] + 1/ 100;
  }
}
for(i in 301:400){
  val=round(X[i], 0);
  if(val <= 100){
    pdata4[val] = pdata4[val] + 1/ 100;
  }
}
for(i in 401:500){
  val=round(X[i], 0);
  if(val <= 100){
    pdata5[val] = pdata5[val] + 1/ 100;
  }
}

xcols1 <- c(0:99)
xcols2 <- c(0:99)
xcols3 <- c(0:99)
xcols4 <- c(0:99)
xcols5 <- c(0:99)

str(pdata1)
str(xcols1)

plot(xcols1, pdata1, "l", xlab="list1", ylab="f(X)", main="pdf")

str(pdata2)
str(xcols2)

plot(xcols2, pdata2, "l", xlab="list2", ylab="f(X)", main="pdf")

str(pdata3)
str(xcols3)

plot(xcols3, pdata3, "l", xlab="list3", ylab="f(X)", main="pdf")

str(pdata4)
str(xcols4)

plot(xcols4, pdata4, "l", xlab="list4", ylab="f(X)", main="pdf")

str(pdata5)
str(xcols5)

plot(xcols5, pdata5, "l", xlab="list5", ylab="f(X)", main="pdf")

cdata1 <- rep(0, 100)

cdata1[1] <- pdata1[1]

for(i in 2:100){
  cdata1[i] = cdata1[i-1] + pdata1[i]
}

plot(xcols1, cdata1, "o", col="blue", xlab="list1", ylab="F(X)", main="cdf")

cdata2 <- rep(0, 100)

cdata2[1] <- pdata2[1]

for(i in 2:100){
  cdata2[i] = cdata2[i-1] + pdata2[i]
}

plot(xcols2, cdata2, "o", col="red", xlab="list2", ylab="F(X)", main="cdf")

cdata3 <- rep(0, 100)

cdata3[1] <- pdata3[1]

for(i in 2:100){
  cdata3[i] = cdata3[i-1] + pdata3[i]
}

plot(xcols3, cdata3, "o", col="green", xlab="list3", ylab="F(X)", main="cdf")

cdata4 <- rep(0, 100)

cdata4[1] <- pdata4[1]

for(i in 2:100){
  cdata4[i] = cdata4[i-1] + pdata4[i]
}

plot(xcols4, cdata4, "o", col="yellow", xlab="list4", ylab="F(X)", main="cdf")

cdata5 <- rep(0, 100)

cdata5[1] <- pdata5[1]

for(i in 2:100){
  cdata5[i] = cdata5[i-1] + pdata5[i]
}

plot(xcols5, cdata5, "o", col="grey", xlab="list5", ylab="F(X)", main="cdf")

mn <- rep(0,500)
std <- rep(0,500)

i=1
for(i in 1:500)
{
  mn[i] <- mean(list[[i]])
  std[i] <- sd(list[[i]])
}
print (mn[1])
print (mn[2])
print (mn[3])
print (mn[4])
print (mn[5])
print (std[1])
print (std[2])
print (std[3])
print (std[4])
print (std[5])
##

pdata_m <- rep(0, 10);

for(i in 1:500){
  val1=round(mn[i], 0);
  if(val1 <= 10){
    pdata_m[val1] = pdata_m[val1] + 1/ 500;
  }
}

xcols_m <- c(1:10)

str(pdata_m)
str(xcols_m)

plot(xcols_m, pdata_m, "l", xlab="mean", ylab="f(X)", main="pdf of means")

cdata_m <- rep(0, 10)

cdata_m[1] <- pdata_m[1]

for(i in 2:10){
  cdata_m[i] = cdata_m[i-1] + pdata_m[i]
}

plot(xcols_m, cdata_m, "o", col="pink", xlab="mean", ylab="F(X)", main="cdf of means")
tab <- table(round(mn))
str(tab)
plot(tab, "h", xlab="Value", ylab="Frequency")
##

mnf <- rep(0, 1)
stdf <- rep(0, 1)
mnf <- mean(mn)
stdf <- sd(mn)

print(mnf)
print(stdf)


dataset = read.csv("/Salaries.csv", header = TRUE) # Open CSV

# PARAMETRIC TEST
cor.test(dataset$Salary,dataset$Yrs.service,method="pearson", na.rm=TRUE)

# NON- PARAMETRIC TEST
cor.test(dataset$Salary,dataset$Yrs.service,method="spearman", na.rm=TRUE)
cor.test(dataset$Salary,dataset$Yrs.service,method="kendall", na.rm=TRUE)


##### 医学統計勉強会18第7回生存時間解析　R code #####

library(survival)

x <- c(2, 4, 4, 5, 7, 8, 10)		# 生存時間
cens0 <- c(1, 1, 1, 1, 1, 1, 1)		# censoring status: 打ち切り状態（0：打ち切り無し，1：打ち切り有り）

Surv(x, cens0)

fit0 <- survfit(Surv(x, cens0) ~ 1)	# 生存関数のKaplan-Meier推定量を求める

plot(fit0)						# Kaplan-Meier curveの描画（信頼区間有り）
plot(fit0, conf.int=FALSE, xlab="time", ylab="Survival Function")		# Kaplan-Meier curveの描画（信頼区間有なし）

cens1 <- c(1, 1, 1, 1, 0, 1, 0)		# 7日目（5番目）と10日目（7番目）に打ち切り

Surv(x, cens1)

fit1 <- survfit(Surv(x, cens1) ~ 1)	# 生存関数のKaplan-Meier推定量を求める
plot(fit1, conf.int=FALSE, xlab="time", ylab="Survival Function")

### 白血病患者に対する寛解期間の臨床比較試験 ###

library(MASS)

data(gehan)

fit.gehan <- survfit(Surv(time, cens) ~ treat, data=gehan)
plot(fit.gehan, mark.time=TRUE, col=c("blue", "red"))
legend(25,1,legend=c("6-MP", "control"), col=c("blue", "red"), lty=1, bty="n")

survdiff(Surv(time, cens) ~ treat, data=gehan)		# log-rank検定

survdiff(Surv(time, cens) ~ treat, data=gehan, rho=1)		# the Peto & Peto modification of the Gehan-Wilcoxon test

### NCCTG Lung Cancer Data ###
fit.lung <- survfit(Surv(time, status) ~ pat.karno, data=lung)
plot(fit.lung, col=rainbow(8), main="NCCTG Lung Cancer Data")
label <- names(table(lung$pat.karno))
legend(800, 1, legend=label, lty=rep(1,8), col=rainbow(8), bty="n")

survdiff(Surv(time, status) ~ pat.karno, data=lung)
survdiff(Surv(time, status) ~ pat.karno + strata(inst), data=lung)

### Cox proportional hazard model: 白血病患者に対する寛解期間の臨床比較試験 ###

fit.ph <- coxph(Surv(time, cens) ~ treat, data=gehan)
summary(fit.ph)

### complementary log-log plot: Gehanの白血病データ ###

plot(fit.gehan, fun="cloglog", ylab="Log(-Log(survival))", xlab="time", lty=1:2)
legend(2, 0.6, c("control", "6-MP"), lty=1:2)

### Cox比例ハザードモデルにおける比例ハザード性の仮定についての、Schoenfeld residualによる検定 ###
cox.zph(fit.ph)

### 一般化加法モデルによる非線形モデル: 在郷軍人の肺がんデータ ###

fit <- coxph(Surv(time, status) ~ trt + karno + age, data=veteran)

cox.zph(fit)		# karno, ageのp値は小さく比例ハザード性の破綻が示唆される

library(mgcv)
fit.gam <- gam(time ~ trt + s(karno) + s(age), family=cox.ph(), weights=status, data=veteran)
summary(fit.gam)
plot(fit.gam)


library(GA)

# Baday graf - odległości miedzy miastami
data("eurodist", package = "datasets")
D <- as.matrix(eurodist)

tourLength <- function(tour, distMatrix) {
  tour <- c(tour, tour[1])
  route <- embed(tour, 2)[,2:1]
  sum(distMatrix[route])
}

tspFitness <- function(tour, ...) 1/tourLength(tour, ...) # ponieważ algorytm maksymalizuje to funkcja odwrotna

GA <- ga(
  type = "permutation", fitness = tspFitness, distMatrix = D,
  min = 1, max = attr(eurodist, "Size"), popSize = 200, maxiter = 1000,
  run = 500, pmutation = 0.2
)

summary(GA)

apply(GA@solution, 1, tourLength, D)

mds <- cmdscale(eurodist)
x <- mds[, 1]
y <- -mds[, 2]
plot(x, y, type = "n", asp = 1, xlab = "", ylab = "")
abline(h = pretty(range(x), 10), v = pretty(range(y), 10), col = "light gray")
tour <- GA@solution[1, ]
tour <- c(tour, tour[1])
n <- length(tour)
arrows(x[tour[-n]], y[tour[-n]], x[tour[-1]], y[tour[-1]], length = 0.15, angle = 25, col = "steelblue", lwd = 2)
text(x, y, labels(eurodist), cex=0.8)


# Working with vapply

# vapply(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE)
# FUN.VALUE: argument expects a template for the return argument of this function

# 1. Basic overview of the method
# Definition of basics()
basics <- function(x) {
  c(min = min(x), mean = mean(x), max = max(x))
}

# Apply basics() over temp using vapply() - returns matrix with the variable names outlined in the vector
vapply(temp, basics, numeric(3))

# 2. Additional method added to the function
# Definition of the basics() function
basics <- function(x) {
  c(min = min(x), mean = mean(x), median = median(x), max = max(x))
}

# Fix the error: initial value was 3 which matched the vapply from above, this caused an error as four methods are now present in the function
vapply(temp, basics, numeric(4))

# 3. Convert sapply to vapply methods
# temp is already defined in the workspace

# Convert to vapply() expression
sapply(temp, max)
vapply(temp, max, numeric(1))

# Convert to vapply() expression
sapply(temp, function(x, y) { mean(x) > y }, y = 5)
vapply(temp, function(x, y) { mean(x) > y }, y = 5, logical(1))


#!/usr/bin/Rscript

require(deSolve)

## ==============================================================================
## Numerical solution of the SIR epidemiological model, a
## system of ordinary differential equations with state variables
## # susceptible (X), # infected (Y) # resistant (Z)
## ==============================================================================

parameters <- c(beta  = 0.01,
                gamma = 0.01,
                m = 0.1)

state <- c(X = 100, Y = 1, Z = 0)

## the ODE system

lorenz <- function(t, state, parameters) {
    with(as.list(c(state, parameters)),{

# rate of change

        dX <- -beta*X*Y + gamma*Z
        dY <- beta * X * Y - m*Y
        dZ <- m*Y - gamma * Z

# return the rate of change

        list(c(dX, dY, dZ))

    })

}

times <- seq(0, 100, by = 0.01)

out <- ode(y = state, times = times, func = lorenz, parms = parameters)

head(out)

par(oma = c(0, 0, 3, 0))
matplot(out[,"time"],out[,2:4], xlab = "Time (days)", type="l", ylab = "Numbers",col="black")
legend("topright", inset=0, legend=c("X (susceptible)", "Y (infected)", "Z (immune)"),  lty=1:3,  col="black",  bty = "n", horiz=FALSE)
mtext(outer = TRUE, side = 3, "SIR Model", cex = 1.5)


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 06

rm(list = ls())

observed <- c(442, 38, 514, 6)

(k <- length(observed))
# 4

(n <- sum(observed))
# 1000

EspectedProbabilities <- function(p) {
  c(0.5 * p, 0.5 * (1 - p), 0.5 * p ^ 2 + p * (1 - p), 0.5 * (1 - p) ^ 2)
}

LogLikelihood <- function(p, y) {
  sum(y * log(EspectedProbabilities(p)))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(0.5, NegativeLogLikelihood, y = observed, hessian = TRUE,
             lower = 10e-4, upper = 1 - 10e-4, method = 'L-BFGS-B')

(p.hat <- opt$par)
# 0.912941500560347

expected <- EspectedProbabilities(p.hat) * n

(Q <- sum((observed - expected) ^ 2 / expected))
# 3.08815842598583

(pvalue <- 1 - pchisq(Q, 2))
# 0.213508376478253


# Master Thesis Project - Extreme Value Theory
# Illustrating the sequence of maxima with a real
# world example : the evolution of the prices of
# shares of 5 companies listed on CAC40.
# Killian Martin--Horgassan
# 19-02-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("/Users/kimartin/Desktop/R_files_pdm/Tache3/netReturns.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache3/logGrossReturns.r")
source("/Users/kimartin/Desktop/R_files_pdm/Tache3/inputCac40_illustration.r")

# Loading the data into variables
STOCK <- InputCAC40_illustration()
Stock <- read.csv(STOCK, header = FALSE)

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Getting the right column of the stock dataframe, as well as the
# log gross returns and the net returns.
Stock_processed <- rev(Stock[[CHOICE]])
returnsStock <- netReturns(Stock_processed)
logReturnsStock <- logGrossReturns(Stock_processed)

# Plotting the stock prices, the returns and the log returns

x_label <- "Weekly measurements"
y_label1 <- "Stock price"
y_label2 <- "Net returns on the stock"
y_label3 <- "Log gross returns on the stock"
y_label4 <- "Gross returns on the stock"
y_label5 <- "1 plus the log gross returns on the stock"
title1 <- STOCK
title2 <- "exp(Rt)"
title3 <- "1 + Rt"

# Stock prices - net returns - log gross returns
quartz()
par(mfrow = c(1,3))
plot(Stock_processed, pch = 1, col = "black", type = 'l', xlab = x_label, ylab = y_label1, main = title1)
plot(returnsStock, pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label2, main = title1)
plot(logReturnsStock, pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label3, main = title1)

# Comparing exp(Rt) and 1+Rt, is the approximation valid in practice
quartz()
par(mfrow = c(1,2))
plot(exp(logReturnsStock), pch = 1, col = "blue", type = 'l', xlab = x_label, ylab = y_label4, main = title2)
plot(1+returnsStock, pch = 1, col = "magenta", type = 'l', xlab = x_label, ylab = y_label5, main = title3)
cat("Residual :\n")
print(sum(abs(1+returnsStock-exp(logReturnsStock))))


# Dexter Barrows
# run with:
#
# Rscript sc1-multi.r > sc1-multi.log 2>&1
#
# or
#
# Rscript sc1-multi.r > sc1-multi-time.log 2>&1

library(reshape2)
library(foreach)
library(parallel)
library(doParallel)
library(rstan)

## Stochastic SIR function
##############################################################################################

StocSIR <- function(y, pars, T, steps) {

    out <- matrix(NA, nrow = (T+1), ncol = 4)

    R0 <- pars[['R0']]
    r <- pars[['r']]
    N <- pars[['N']]
    eta <- pars[['eta']]
    berr <- pars[['berr']]

    S <- y[['S']]
    I <- y[['I']]
    R <- y[['R']]

    B0 <- R0 * r / N
    B <- B0

    out[1,] <- c(S,I,R,B)

    h <- 1 / steps

    for ( i in 1:(T*steps) ) {

        B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

        BSI <- B*S*I
        rI <- r*I

        dS <- -BSI
        dI <- BSI - rI
        dR <- rI

        S <- S + h*dS  #newInf
        I <- I + h*dI  #newInf - h*dR
        R <- R + h*dR  #h*dR

        if (i %% steps == 0)
            out[i/steps+1,] <- c(S,I,R,B)

    }

    return(out)

}

## Setup
##############################################################################################

set.seed(1004)

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

## Generate true trajecory and synthetic data
##

pars_true <- 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

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

nTrials <- 10

numCores <- detectCores()
cl <- makeCluster(numCores)
registerDoParallel(cl)

## external files

if2file <- paste(getwd(),"../../if2", "if2.cpp", sep="/")
hmcfile <- paste(getwd(), "../../hmc", "sirode_euler.stan", sep="/")

## IF2 settings

NP          <- 2500
nPasses     <- 50
coolrate    <- 0.975

## fit once to compile
##

# get raw data
sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

# conform data to stan's required format
datlen <- T*7 + 1

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

#options
rstan_options(auto_write = TRUE)

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1)   		# thinning number

# data
sir_data <- list( T = datlen,       # simulation time
                  y = standata,     # infection count data
                  N = 500,          # population size
                  h = 1/steps )     # step size per day

# fit!
initialfit <- with(stan_options,
                stan(file   = hmcfile,
                    data    = sir_data,
                    chains  = chains,
                    iter    = iter,
                    warmup  = warmup,
                    thin    = thin)
                )

## Run multiple trajectories
#########################################################################################################

estmat <- foreach ( i = 1:nTrials, .combine = rbind, .packages = c("Rcpp","rstan","reshape2") ) %dopar% {

    sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
    colnames(sdeout_true) <- c('S','I','R','B')

    infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
    infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

    # IF2

    sourceCpp(if2file)
    if2time <- system.time( if2data <- if2(infec_counts[1:(Tlim+1)], Tlim+1, N, NP, nPasses, coolrate) )

    paramdata <- data.frame( if2data$paramdata )
    names(paramdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

    parnames <- c("R0","r","sigma","eta","berr","Iinit")
    parvars <- var(paramdata[parnames])
    if2parmeans <- colMeans(paramdata[parnames])
    names(if2parmeans) <- c("if2.R0","if2.r","if2.sigma","if2.eta","if2.berr","if2.Iinit")

    ## HMC fitting with stan

    datlen <- T*7 + 1

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

    sir_data <- list( T = datlen,       # simulation time
                      y = standata,     # infection count data
                      N = 500,          # population size
                      h = 1/steps )     # step size per day

    hmctime <- system.time(fit <- with(stan_options,
                            stan(#file      = hmcfile,
                                 fit = initialfit,
                                data    = sir_data,
                                chains  = chains,
                                iter    = iter,
                                warmup  = warmup,
                                thin    = thin)
                            )
                )

    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,
                            Sinit = melt(exfit[,,'y0[1]'])$value,
                            Iinit = melt(exfit[,,'y0[2]'])$value,
                            Rinit = melt(exfit[,,'y0[3]'])$value )

    parnames <- c("R0","r","sigma","eta","berr","Iinit")
    parvars <- var(paramdata[parnames])
    hmcparmeans <- colMeans(paramdata[parnames])
    names(hmcparmeans) <- c("hmc.R0","hmc.r","hmc.sigma","hmc.eta","hmc.berr","hmc.Iinit")

    return( c(if2parmeans,
           	  if2times = if2time[['user.self']],
           	  hmcparmeans,
           	  hmctimes = hmctime[['user.self']]) )

}

stopCluster(cl)

save.image(file = "sc1-multi-time.RData")


# Basics of working with functions

# 1. Function documentation
# Consult the documentation on the mean() function
help(mean)
# ?mean

# Inspect the arguments of the mean() function
args(mean)

# 2. Calling a function
# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)

# Calculate average number of views
avg_li <- mean(linkedin)
avg_fb <- mean(facebook)

# Inspect avg_li and avg_fb
avg_li
avg_fb

# 3. Using an optional keyword parameter within the mean() function
# Calculate the mean of the sum
avg_sum <- mean(linkedin + facebook)

# Calculate the trimmed mean of the sum
avg_sum_trimmed <- mean(linkedin + facebook, trim = 0.2)

# Inspect both new variables
avg_sum
avg_sum_trimmed

# 4. Working with missing values parameter. The parameter na.rm relates to the missing values and whether
# they should be excluded when performing the calculations. By default the option is set to FALSE and missing
# values are included.
# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, NA, 17, 14)
facebook <- c(17, NA, 5, 16, 8, 13, 14)

# Basic average of linkedin - result is NA
mean(linkedin)

# Advanced average of linkedin - result is average of non missing values
mean(linkedin, na.rm = TRUE)

# 5. Functions inside functions
# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, NA, 17, 14)
facebook <- c(17, NA, 5, 16, 8, 13, 14)

# Calculate the mean absolute deviation
mean(abs(linkedin - facebook), na.rm = TRUE)


# Goal: "Dummy variables" in regression.

# Suppose you have this data:
people = data.frame(
  age =       c(21,62,54,49,52,38),
  education = c("college", "school", "none", "school", "college", "none"),
  education.code = c(  2,        1,      0,        1,         2,      0 )
  )
# Here people$education is a string categorical variable and
# people$education.code is the same thing, with a numerical coding system.
people

# Note the structure of the dataset --
str(people)
# The strings supplied for `education' have been treated (correctly) as
# a factor, but education.code is being treated as an integer and not as
# a factor.

# We want to do a dummy variable regression. Normally you would have:
#  1 Chosen college as the omitted category
#  2 Made a dummy for "none" named educationnone
#  3 Made a dummy for "school" named educationschool
#  4 Ran a regression like lm(age ~ educationnone + educationschool, people)
# But this is R. Things are cool:
lm(age ~ education, people)

# ! :-)
# When you feed him an explanatory variable like education, he does all
# these steps automatically. (He chose college as the omitted category).

# If you use an integer coding, then the obvious thing goes wrong --
lm(age ~ education.code, people)
# because he's thinking that education.code is an integer explanatory
# variable. So you need to:

lm(age ~ factor(education.code), people)
# (he choose a different omitted category)

# Alternatively, fix up the dataset --
people$education.code <- factor(people$education.code)
lm(age ~ education.code, people)

#
# Bottom line:
# Once the dataset has categorical variables correctly represented as factors, i.e. as
str(people)
# doing OLS in R induces automatic generation of dummy variables while leaving one out:
lm(age ~ education, people)
lm(age ~ education.code, people)

# But what if you want the X matrix?
m <- lm(age ~ education, people)
model.matrix(m)
# This is the design matrix that went into the regression m.

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


### RandomForest with R
library(randomForest)
# download Titanic Survivors data
data <- read.table("http://math.ucdenver.edu/RTutorial/titanic.txt", h=T, sep="\t")
# make survived into a yes/no
data$Survived <- as.factor(ifelse(data$Survived==1, "yes", "no"))
# split into a training and test set
idx <- runif(nrow(data)) <= .75
data.train <- data[idx,]
data.test <- data[-idx,]

### Train a random forest
rf <- randomForest(Survived ~ PClass + Age + Sex,
data=data.train, importance=TRUE, na.action=na.omit)

### How important is each variable in the model?
imp <- importance(rf)
o <- order(imp[,3], decreasing=T)
imp[o,]

### Display the confusion matrix

# confusion matrix [[True Neg, False Pos], [False Neg, True Pos]]
table(data.test$Survived, predict(rf, data.test),
dnn=list("actual", "predicted"))

library(caret)
mod <- train(Species ~ ., data = iris,
method = "cforest",
controls = cforest_unbiased(ntree = 10))
varImp(mod)
returns:
cforest variable importance
Overall
Petal.Width 100.0000
Petal.Length 86.6279
Sepal.Length 0.5814
Sepal.Width 0.0000


library(diffeqr)
diffeqr::diffeq_setup()

f <- function (u, p, t) {
    # State variables
    # ---------------
    # u1: rabbits
    # u2: foxes
    du1 = p[1]*u[1] - p[2]*u[1]*u[2]
    du2 = -p[3]*u[2] + p[4]*p[2]*u[1]*u[2]

    return(c(du1, du2))
}

u0 = c(10, 5)
tspan <- list(0.0, 18.0)
p = c(1.0, 0.1, 1.5, 0.75)
sol = diffeqr::ode.solve(f, u0, tspan, p=p, saveat=0.01)

udf = as.data.frame(sol$u)
matplot(sol$t, udf, type = "l", xlab = "Time", ylab = "Population")
legend("topright", c("Rabbits", "Foxes"), lty = c(1,2), col = c(1,2), box.lwd = 0)


newton <- function(f, fprime, x0, tol_approx=1e-8, tol_consec=1e-8){
    # Solves a given equation for its roots using Newton's Method given its derivative
    # and an initial guess.  Also takes in function value tolerance and consecutive value tolerance.
    #
    # Args:
    #     f (function): equation to be solved
    #     fprime (function): derivative of f
    #     x0 (numeric): initial guess
    #     tol_approx (numeric): tolerance from 0
    #     tol_consec (numeric): tolerance from previous value
    # Returns:
    #     numeric: root of f
    x1 <- x0
    x0 <- x0 - 1 # To enter loop
    while (abs(f(x1))>tol_approx || abs(x1-x0)>tol_consec){
        x0 <- x1
        x1 <- x1 - f(x0)/fprime(x0)
    }
    return(x1)
}

bisection <- function(f, a, b, tol_approx=1e-8, tol_consec=1e-8){
    # Solves a given equation for its roots using Bisection Method given an initial
    # interval.  Also takes in function value tolerance and consecutive value tolerance.
    #
    # Args:
    #     f (function): equation to be solved
    #     a (numeric): left bound (function evaluation must be of opposite sign than b)
    #     b (numeric): right bound (function evaluation must be of opposite sign than a)
    #     tol_approx (numeric): tolerance from 0
    #     tol_consec (numeric): tolerance from previous value
    # Returns:
    #     numeric: root of f
    if (f(a)*f(b) > 0) stop('Initial bounds must evaluate to opposite sign.')
    xL <- a;    xR <- b;    xM <- NA
    while (abs(xR-xL) > tol_consec || max(abs(c(f(xL),f(xR)))) > tol_approx){
        xM <- .5 * (xL + xR)
        if(f(xL)*f(xM) < 0) xR <- xM else xL <- xM # If sign changes in [xL,xM], make xM the new right bound, otherwise left
    }
    return(xM)
}

call_black_scholes <- function(S, K, T, sigma, r, q){
    # Returns the Black-Scholes value of a vanilla call option.
    d1 <- (log(S/K) + (r - q + 0.5*sigma*sigma)*T) / (sigma*sqrt(T))
    return(S*exp(-q*T)*pnorm(d1) - K*exp(-r*T)*pnorm(d1 - sigma*sqrt(T)))
}

calculate_implied_vol <- function(S, K, T, r, q, price, solver='newton'){
    # Returns the Black-Scholes implied volatility.
    vega <- function(sigma){
        # Vega of a vanilla option in the Black-Scholes framework.
        # This is plugged into Newton's method as the first derivative.
        d1 <- (log(S/K) + (r - q + 0.5*sigma*sigma)*T) / (sigma*sqrt(T))
        return(S*exp(-q*T)*sqrt(T)*dnorm(d1))
    }

    if (solver == 'newton') {
        newton(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, vega, x0=0.25)
    } else if (solver == 'bisection'){
        bisection(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, a=1e-4, b=1.5)
    } else {
        uniroot(function(sigma) call_black_scholes(S, K, T, sigma, r, q) - price, interval=c(1e-4,1.5))
    }

}

calculate_smile <- function(S, T, r, q, strikes, prices, plot_smile=FALSE, plot_title='', solver='newton'){
    # Calculates the implied volatility for a range of strikes.
    # Can plot the implied volatility smile.
    #
    # Args:
    #     S (numeric): Spot price
    #     T (numeric): Maturity
    #     r (numeric): Risk-neutral return rate
    #     q (numeric): Continuous dividend rate
    #     strikes (array-like): A range of strike prices
    #     prices (array-like): Prices for range of strikes
    #     plot_smile (logical): Should the function plot the implied volatility smile
    # Returns:
    #     (vector): The vector of implied volatilities for the range of strike prices

    implied_vols <- mapply(function(K,V) calculate_implied_vol(S, K, T, r, q, V, solver=solver), strikes, prices)
    if (plot_smile) plot(strikes, implied_vols, main=plot_title, xlab='K', ylab='Implied Volatility', type='l', col='blue', las=1)
    return(implied_vols)
}


cat("Likelihood functions; ");
# Likelihood Function;
# The parameters may have different numbers depend on the model we are
# going to use;
# par5 is (p,r1,lambda1,r2,lambda2) for mixed model and par2 is (r,lambda)
# for simple model;
# Construct likelihood kernel
## Generation interval kernel
# probability transfer from i to j, the interval is +-1day;
# shifted gamma distribution: allow for negative serial intervals
ptij <- function(ti,tj,dt,tshft,a,b){
  pgamma(ti-tj+dt+tshft,shape=a,scale=b)-pgamma(ti-tj-dt+tshft,shape=a,scale=b)
}

logit<-function(x){
  exp(x)/(1-exp(x))
}

# serial interval pdf;
serintpdf <- function(x,tshft,r,lambda){
  dgamma(x+tshft,shape=r,scale=lambda)
}
unifpdf <- function(x,u1,u2){
  dunif(x,min=u1,max=u2)
}

#serial interval cdf;
serintcdf <- function(x,tshft,r,lambda){
  pgamma(x+tshft,shape=r,scale=lambda)
}

maxgenint <- function(par){ # only positive roots
  f <- function(x){1-serintcdf(exp(x),par[1],par[2],par[3])-10^-3}
  return(c(-par[1],exp(uniroot(f, c(-10^8,10^8))$root)))
}

## Likelihood: product over all terms
ppij <- function(i,j,par,data){
  ifelse(i!=j,ptnegij(data[i],data[j],1,par[1],par[2],par[3]),0)
}

# Generate table with probabilities for generation interval kernel
# Maximum admissable generation interval: 99.9 percentile of interval
# distribution
probtab <- function(par){
  j <- 0
  stop <- FALSE
  prvect <- c()
  while(stop!=TRUE){
    new <- ptij(j,0,1,par[1],par[2],par[3])
    prvect[j+1] <- new
    if(sum(prvect)>(0.999999*2) | j>100 | new==0) {stop <- TRUE}
    j <- j+1
  }
  return(c(prvect,0))
}

# Generate vector of time differences (time intervals) for all possible
# contacts:
# replace inadmissable ones with -2 (including self, this is the outer
# Replace). See next line for reason why not -1.

diffs <- function(i,vec,rng){
  diff_t <- vec[i]-vec
  diff_t[which(diff_t<rng[1] | diff_t>rng[2])] <- -2
  diff_t[i] <- -2
  return(diff_t)
}

# Probability of j infecting i
# two parameters
probvec <- function(i,par,data,maxint){
  serintpdf(diffs(i,data,maxint),par[1],par[2],par[3])
}
probunif <- function(i,par,data){
  unifpdf(data[i]-data,par[1],par[2])
}

# probij <- function(i,j,par,data){
#   c(probunif(i,c(0,tswuhan),timedata)[j==1], # for Wuhan, uniform distribution
#     probvec(i,par,data,maxgenint(par))[j>1])
# }

probij <- function(i,j,par,data){
  probvec(i,par,data,maxgenint(par))[j]
}

# j can be vector, i can only be a number.
probijnp <- function(i,j,par,data){
  pvec<-probij(i,(1:length(data)),par,data)
  return(pvec[j]/(1-pvec[j])*prod(1-pvec))
}


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

plot(Seatbelts)
x1 = tslm(DriversKilled ~ trend, data=Seatbelts)
x2 = tslm(DriversKilled ~ season, data=Seatbelts)
x3 = tslm(DriversKilled ~ trend + season, data=Seatbelts)

CV(x1)
CV(x2)
CV(x3)

#fazendo previsao
r1 = forecast(x1,h=12)
r2 = forecast(x2,h=12)
r3 = forecast(x3,h=12)

autoplot(r1)
autoplot(r2)
autoplot(r3)

plot(r1)
lines(r2$mean, col="red")
lines(r3$mean, col="green")
legend("topright",legend=c("Tend","Seas","Tend + Seas"), col = c("blue","red","green"), lty=1:2, cex=0.8)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/8.3.Regressao Linear.r


# https://fivethirtyeight.com/features/can-you-solve-these-colorful-puzzles/
# You play a game with four balls: One ball is red, one is blue,
# one is green and one is yellow. They are placed in a box. You
# draw a ball out of the box at random and note its color. Without
# replacing the first ball, you draw a second ball and then paint
# it to match the color of the first. Replace both balls, and repeat
# the process. The game ends when all four balls have become the
# same color. What is the expected number of turns to finish the game?

# Libraries
library(ggplot2)

# Input
num_colors <- 4
num_balls  <- 4
num_trials <- 25000

# Code
rpl <- num_balls > num_colors
num_turns <- numeric(num_trials)

for (i in 1:num_trials) {
  a <- sample(1:num_colors, num_balls, replace = rpl)
  count <- 0
  while(!isTRUE(all.equal(min(a), max(a)))) {
    b  <- sample(a, 2, replace = FALSE)
    c1 <- min(which(a == b[1]))
    c2 <- min(which(a == b[2]))
    a[c(c1, c2)] <- b[1]
    count <- count + 1
  }
  num_turns[i] <- count
}

# Output
ggplot(mapping = aes(num_turns)) +
  geom_histogram(binwidth = 1) +
  theme_bw() +
  labs(title = "Riddler 4/28", x = "Num. of Turns", y = "Count")
median(num_turns)
mean(num_turns)


#!/usr/bin/env Rscript

##############################################################################
## Functions

integer_partition = function(n) {
    part_nums = c()
    for (k in 1:n) {
        part_nums = c(part_nums, A(n=n, k=k))
    }
    return(part_nums)
}

A = function(n, k) {
    if ((k == 1) || (n == k)) {
        return(1)
    }
    if ((k > n) || (k < 1)) {
        return(0)
    }
    return(A(n=(n-1), k=(k-1)) + A(n=(n-k), k=k))
}

expand_integer_vector = function(v) {
    expanded = c()
    for (i in 1:length(v)) {
        expanded = c(expanded, rep(i, v[i]))
    }
    return(expanded)
}

get_psi_prior = function(n) {
    integer_parts = integer_partition(n=n)
    return(1/(n * integer_parts))
}

parse_file_ext = function(path) {
    return(tail(strsplit(path, '\\.')[[1]], n=1))
}

plot_div_model_prior = function(n, output_path="partition_numbers.pdf") {
    prior_probs = get_psi_prior(n=n)
    names(prior_probs) = c(1:n)
    partition_numbers = expand_integer_vector(integer_partition(n=n))
    plot_letters = LETTERS[1:2]
    format = 'pdf'
    ext = parse_file_ext(output_path)
    if ((tolower(ext) == 'eps') || (tolower(ext) == 'ps')) {
        format = 'eps'
    }

    if (format == 'eps') {
        postscript(output_path, onefile = F, paper="special", horizontal=F, width=7.087, height=3)
    } else {
        pdf(output_path, width=7.087, height=3)
    }
    par(yaxs = "i", xaxs = "i")
    par(cex.axis=0.7)
    par(mgp = c(1.4,0.4,0)) # mgp adjusts space of axis labels
    # oma is space around all plots
    par(oma = c(0,0,0.3,0.2), mar = c(2.65,2.45,0.5,0.1))
    par(mfrow = c(1, 2))
    hist(partition_numbers,
            breaks= c(1:(n+1)),
    		right=FALSE,
    		xlab="",
    		ylab=bquote("# of divergence models"),
            main="",
    		# xlim=c(0,22),
    		# ylim=c(0,140),
    		xaxt="n",
    		col="gray50", border="gray50")
    box()
    axis(1, at=seq(1.5, (n+.5), 1), labels=c(1:n), tick=F)
    axis(1, at=c(1:(n+1)), labels=F)
    #mtext("Number of divergence models", WEST<-2, padj=0, cex=1, outer = T)
    mtext(plot_letters[[1]], side=3, adj=0, line=0, cex=0.75, font=2)

    par(mgp = c(1,0.4,0)) # mgp adjusts space of axis labels
    barplot(prior_probs,
            border="gray50",
            space=0,
            # axis.lty=1,
    	    xaxt = "n",
            col="gray50",
    		xlab="",
            ylab=bquote(italic(p)(italic(M)[group("|", bold(tau), "|")*","*italic(i)])),
            ylim=c(0, max(prior_probs))
            )
    box()
    axis(1, at=seq(0.5, (n-.5), 1), labels=c(1:n), tick=F)
    axis(1, at=c(0:n), labels=F)
    mtext(plot_letters[[2]], side=3, adj=0, line=0, cex=0.75, font=2)
	mtext(bquote("# of divergence events, " * group("|", bold(tau), "|")), SOUTH<-1, padj=-0.7, cex=1.1, outer = T)
    dev.off()
}

##############################################################################
## Main CLI

## Option parsing
suppressPackageStartupMessages(library("optparse"))
option_list <- list(
        make_option(c("-n", "--num-elements"), type="integer", dest="n", default=22,
                help="Number of elements (default: 22)"),
        make_option(c("-o", "--output-path"), type="character",
                dest="output_path", default="partition_numbers.pdf",
                help=paste("Output path for plot file (default: ",
                           "'./partition_numbers.pdf'). If you want an EPS-",
                           "formatted plot file, simply specify a path with ",
                           "an '.eps' or '.ps' extension. Otherwise, the ",
                           "plot file will be a PDF."))
)
options <- parse_args(OptionParser(option_list=option_list))

plot_div_model_prior(n = options$n,
                     output_path = options$output_path)


suppressPackageStartupMessages(library(dplyr))

set.seed(1234)

n = 10000
p = 10

cov_mat = diag(p)

random_off_diag_structure <- abs(rnorm(n = length(cov_mat[lower.tri(cov_mat)]), mean = 0, sd = 0))

cov_mat[lower.tri(cov_mat)] <- random_off_diag_structure

cov_mat[2, 1] <- 0.95
cov_mat[3, 2] <- 0.90
cov_mat[3, 1] <- 0.93

cov_mat[6, 5] <- 0.90
cov_mat[7, 6] <- 0.85
cov_mat[7, 5] <- 0.88

cov_mat[upper.tri(cov_mat)] <- t(cov_mat)[upper.tri(cov_mat)]

cov_mat

cov_mat %>%
    dplyr::as_tibble(.name_repair = "minimal")

feature_ids <- paste0("feature_", seq(1, nrow(cov_mat)))

cov_mat_df <- cov_mat %>%
    dplyr::as_tibble(.name_repair = "minimal")

colnames(cov_mat_df) <- feature_ids

cov_mat_df <- cov_mat_df %>%
    dplyr::mutate(feature_num = feature_ids) %>%
    dplyr::select(feature_num, dplyr::everything())

out_file <- file.path("data", "simulated_covariance_structure.tsv")
cov_mat_df %>% readr::write_tsv(out_file)

cov_mat_df

simulated_data <- MASS::mvrnorm(n = n, mu = rep(0, p), Sigma = cov_mat)
colnames(simulated_data) <- paste0("feature_", 1:ncol(simulated_data))
simulated_data <- simulated_data %>% dplyr::as_tibble(.name_repair = "minimal")

print(dim(simulated_data))
head(simulated_data)

out_file <- file.path("data", "simulated_signal_n1000_p10.tsv")
simulated_data %>% readr::write_tsv(out_file)


library('ggplot2')

gwas  = read.table('data/CRP_st_Whole_Blood.csv', header=T, sep=",")

cgenes = read.table('data/community_genes.txt', header=F)

t = subset(gwas, gwas$gene_name %in% cgenes[,1])
nt  = subset(gwas, !gwas$gene_name %in% cgenes[,1])

# https://slowkow.com/notes/ggplot2-qqplot/
ps = t$pvalue
qs = nt$pvalue
ci = 0.95

 n  <- length(ps)
  df <- data.frame(
    observed = -log10(sort(ps)),
    expected = -log10(ppoints(n)),
    clower   = -log10(qbeta(p = (1 - ci) / 2, shape1 = 1:n, shape2 = n:1)),
    cupper   = -log10(qbeta(p = (1 + ci) / 2, shape1 = 1:n, shape2 = n:1))
  )
  log10Pe <- expression(paste("Expected -log"[10], plain(P)))
  log10Po <- expression(paste("Observed -log"[10], plain(P)))

 m  <- length(qs)
  gf <- data.frame(
    observed = -log10(sort(qs)),
    expected = -log10(ppoints(m)),
    clower   = -log10(qbeta(p = (1 - ci) / 2, shape1 = 1:m, shape2 = m:1)),
    cupper   = -log10(qbeta(p = (1 + ci) / 2, shape1 = 1:m, shape2 = m:1))
  )
#  log10Pe <- expression(paste("Expected -log"[10], plain(P)))
#  log10Po <- expression(paste("Observed -log"[10], plain(P)))

qqp =   ggplot(gf) +
    geom_ribbon(
      mapping = aes(x = expected, ymin = clower, ymax = cupper),
      alpha = 0.1
    ) +
    geom_point(data=df, aes(expected, observed), col="red", shape = 2, size = 2) +
    geom_point(data=gf,  aes(expected, observed), col="blue", shape = 2, size = 2) +
    geom_abline(intercept = 0, slope = 1, alpha = 0.5) +
    # geom_line(aes(expected, cupper), linetype = 2, size = 0.5) +
    # geom_line(aes(expected, clower), linetype = 2, size = 0.5) +
    xlab(log10Pe) +
    ylab(log10Po) +   theme_bw(base_size = 22) +
  theme(
   axis.ticks = element_line(size = 0.5),
    panel.grid = element_blank(), panel.border = element_blank(),
#     panel.grid = element_line(size = 0.5, color = "grey80"),
	panel.background = element_blank()  ) +
xlim(c(0,5)) + ylim(c(0,140))  + theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid")) + labs(tag = expression(bold("A")))

# legend("top", legend = c("Communities", "Complement"), pch = 2, col = c("red", "blue"), cex=1.6)

#### Q-values

library(qvalue)
ps.qval = qvalue(ps)
qs.qval = qvalue(qs)
1-ps.qval$pi0
# [1] 0.4529955
1-qs.qval$pi0
# [1] 0.3735661


# 调用R包
library("FactoMineR");
library("factoextra");

data(decathlon2)
head(decathlon2)

decathlon2.active <- decathlon2[1:23, 1:10]
head(decathlon2.active[, 1:6], 4)

# 获得数据
library("FactoMineR")
library("factoextra")
data(decathlon2)
decathlon2.active <- decathlon2[1:23, 1:10]

# PCA计算
res.pca <- PCA(decathlon2.active, graph = FALSE)
# 提取变量的分析结果
var <- get_pca_var(res.pca)
var

# Coordinates of variables
head(var$coord, 4)
# col.var设定线条颜色
fviz_pca_var(res.pca, col.var = "black")

head(var$cos2)
library("corrplot")
# is.corr表示输入的矩阵不是相关系数矩阵
corrplot(var$cos2, is.corr=FALSE)

# Total cos2 of variables on Dim.1 and Dim.2
# 在第一第二主成分是显示结果（通过值的叠加显示）
fviz_cos2(res.pca, choice = "var", axes = 1:2)

# Color by cos2 values: quality on the factor map
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping
             )

# Change the transparency by cos2 values
fviz_pca_var(res.pca, alpha.var = "cos2")

head(var$contrib, 4)
library("corrplot")
corrplot(var$contrib, is.corr=FALSE)

# Contributions of variables to PC1
# 各变量对第一主成分的贡献
fviz_contrib(res.pca, choice = "var", axes = 1, top = 10)
# Contributions of variables to PC2
# 各变量对第二主成分的贡献
fviz_contrib(res.pca, choice = "var", axes = 2, top = 10)

fviz_contrib(res.pca, choice = "var", axes = 1:2, top = 10)

fviz_pca_var(res.pca, col.var = "contrib",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07")
             )

# Change the transparency by contrib values
fviz_pca_var(res.pca, alpha.var = "contrib")

# Create a random continuous variable of length 10
# 生成随机数
set.seed(123)
my.cont.var <- rnorm(10)
# Color variables by the continuous variable
# col.var设置颜色
# gradient.cols设置颜色渐变范围
fviz_pca_var(res.pca, col.var = my.cont.var,
             gradient.cols = c("blue", "yellow", "red"),
             legend.title = "Cont.Var")

# Create a grouping variable using kmeans
# Create 3 groups of variables (centers = 3)
set.seed(123)
# 进行聚类
# center聚类数量
res.km <- kmeans(var$coord, centers = 3, nstart = 25)
# 将向量编码为因子
grp <- as.factor(res.km$cluster)
# Color variables by groups
fviz_pca_var(res.pca, col.var = grp,
             palette = c("#0073C2FF", "#EFC000FF", "#868686FF"),
             legend.title = "Cluster")

#proba用于表征维度的显着性阈值，
res.desc <- dimdesc(res.pca, axes = c(1,2), proba = 0.05)
# Description of dimension 1 第一主成分
res.desc$Dim.1

# 第二主成分
res.desc$Dim.2

ind <- get_pca_ind(res.pca)
ind

fviz_pca_ind(res.pca)

# Quality of individuals
head(ind$cos2)
# repel=TRUE能够避免部分重合的点重叠
fviz_pca_ind(res.pca, col.ind = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping (slow if many points)
             )

fviz_pca_ind(res.pca, col.ind = "cos2", pointsize = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Avoid text overlapping (slow if many points)
             )

fviz_cos2(res.pca, choice = "ind")

# Total contribution on PC1 and PC2
fviz_contrib(res.pca, choice = "ind", axes = 1:2)

head(iris, 3)

# The variable Species (index = 5) is removed before PCA analysis
# 第5列不进行PCA运算
iris.pca <- PCA(iris[,-5], graph = FALSE)

fviz_pca_ind(iris.pca,
             # show points only (nbut not "text") 只显示点而不显示文本，默认都显示
             geom.ind = "point",
             # 设定分类种类
             col.ind = iris$Species,
             # 设定颜色
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             # 添加椭圆 Concentration ellipses
             addEllipses = TRUE,
             legend.title = "Groups",
             )

fviz_pca_ind(iris.pca,
             label = "none", # hide individual labels
             habillage = iris$Species, # color by groups
             addEllipses = TRUE, # Concentration ellipses
             palette = "jco"
             )

# Variables on dimensions 2 and 3
fviz_pca_var(res.pca, axes = c(2, 3))
# Individuals on dimensions 2 and 3
fviz_pca_ind(res.pca, axes = c(2, 3))

# Show variable points and text labels
fviz_pca_var(res.pca, geom.var = c("point", "text"))

# Show individuals text labels only
fviz_pca_ind(res.pca, geom.ind =  "text")

# Change the size of arrows an labels
fviz_pca_var(res.pca, arrowsize = 1, labelsize = 5,
             repel = TRUE)
# Change points size, shape and fill color
# Change labelsize
fviz_pca_ind(res.pca,
             pointsize = 3, pointshape = 21, fill = "lightblue",
             labelsize = 5, repel = TRUE)

# Add confidence ellipses
fviz_pca_ind(iris.pca, geom.ind = "point",
             # 使用iris数据集
             col.ind = iris$Species, # color by groups
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             addEllipses = TRUE, ellipse.type = "confidence",
             legend.title = "Groups"
             )
# Convex hull
fviz_pca_ind(iris.pca, geom.ind = "point",
             col.ind = iris$Species, # color by groups
             palette = c("#00AFBB", "#E7B800", "#FC4E07"),
             # 用凸包多边形代替椭圆
             addEllipses = TRUE, ellipse.type = "convex",
             legend.title = "Groups"
             )

fviz_pca_var(res.pca, axes.linetype = "dotted")

ind.p <- fviz_pca_ind(iris.pca, geom = "point", col.ind = iris$Species)
ggpubr::ggpar(ind.p,
              title = "Principal Component Analysis",
              # 下标题
              subtitle = "Iris data set",
              # 说明
              caption = "Source: factoextra",
              # x,y轴标题
              xlab = "PC1", ylab = "PC2",
              # 标题名字位置
              legend.title = "Species", legend.position = "top",
              # 主题和配设
              ggtheme = theme_gray(), palette = "jco"
              )

fviz_pca_biplot(res.pca, repel = TRUE,
                col.var = "#2E9FDF", # Variables color
                col.ind = "#696969"  # Individuals color
                )

fviz_pca_biplot(iris.pca,
                # 观测量颜色
                col.ind = iris$Species, palette = "jco",
                # 添加椭圆
                addEllipses = TRUE, label = "var",
                # 线条颜色
                col.var = "black", repel = TRUE,
                legend.title = "Species")

fviz_pca_biplot(iris.pca,
                # Fill individuals by groups
                geom.ind = "point",
                # 点的形状
                pointshape = 21,
                # 点的大小
                pointsize = 2.5,
                # 按照组类特定形状
                fill.ind = iris$Species,
                col.ind = "black",
                # Color variable by groups
                # 颜色
                col.var = factor(c("sepal", "sepal", "petal", "petal")),
                # 标题
                legend.title = list(fill = "Species", color = "Clusters"),
                repel = TRUE        # Avoid label overplotting
             )+
  ggpubr::fill_palette("jco")+      # Indiviual fill color
  ggpubr::color_palette("npg")      # Variable colors

fviz_pca_biplot(iris.pca,
                # Individuals
                geom.ind = "point",
                fill.ind = iris$Species, col.ind = "black",
                pointshape = 21, pointsize = 2,
                palette = "jco",
                addEllipses = TRUE,
                # Variables
                alpha.var ="contrib", col.var = "contrib",
                gradient.cols = "RdYlBu",

                legend.title = list(fill = "Species", color = "Contrib",
                                    alpha = "Contrib")
                )

# Visualize variable with cos2 >= 0.6
# 可视化cos2>0.6
fviz_pca_var(res.pca, select.var = list(cos2 = 0.6))

# Select by names
# 根据名字显示
name <- list(name = c("Long.jump", "High.jump", "X100m"))
fviz_pca_var(res.pca, select.var = name)

# 根据前五贡献
# top 5 contributing individuals and variable
fviz_pca_biplot(res.pca, select.ind = list(contrib = 5),
               select.var = list(contrib = 5),
               ggtheme = theme_minimal())


# logistic regression (no heterogeneity)
policy.RPM.Logit.Homog <- function(m,y,...){

  d$impressions <- m
  d$conversions <- y

  me <- glm(cbind(conversions,impressions-conversions) ~ size + concept + size:concept,
           family=binomial(link="logit"), data=d)

  d.long <- d[ rep(1:nrow(d), each=n.iters), ]
  d.long$iternum <- rep( 1:n.iters, nrow(d) )

concept.names <- levels(d$concept)
concept_each <- factor(rep(levels(d$concept),3))
size_each <- factor(rep(levels(d$size),each=4))
creative.names <- paste(size_each, concept_each, sep="_")
designmatrix <- cbind(model.matrix( ~ size_each )[,-1],
                      model.matrix( ~ concept_each)[,-1]
                      )

designmatrix.interactions <- model.matrix( ~ size_each*concept_each)[,-1]
rownames(designmatrix.interactions) <- creative.names
desmat <- designmatrix.interactions

fixef.est.coef <- coef(me)
fixef.est.varcov <- vcov(me)
medf.fixef <- data.frame( fixef.est.coef )
names(medf.fixef) <- "est.mean"
medf.fixef$est.se <- sqrt(diag( fixef.est.varcov ))

fixef.coef.samp <- mvrnorm(n.iters, fixef.est.coef, fixef.est.varcov)
fixef.linpred.samp.wide <- fixef.coef.samp  %*% t(cbind(rep(1,nrow(desmat)),desmat))

fixef.linpred.samp <- rep(0, nrow(d)*n.iters)
for (place in levels(d$placeid) ){
  for (conc in levels(d$concept) ){
    curobslong <- which(d.long$placeid==place & d.long$concept==conc)
    sandc <- unique(d.long$sizeandconcept[curobslong])
    fixef.linpred.samp[ curobslong ] <- fixef.linpred.samp.wide[,sandc]
  }
}

d.long$fixef.linpred.samp <- fixef.linpred.samp
d.long$linpred.samp <- d.long$fixef.linpred.samp

d.long$iter <- paste("iter", rep(n.iters*10+ 1:n.iters , nrow(d) ) ,sep="")
d.long$placeid_iter <- paste(d.long$placeid, d.long$iter, sep="_")

zstar.samp <- d.long$linpred.samp
zstar.which.max.perplaceid <- tapply(d.long$linpred.samp, INDEX=d.long$placeid_iter, FUN=which.max)
zstar.which.max.perplaceid.table <- table( rep(levels(d$placeid),each=n.iters), factor(zstar.which.max.perplaceid, levels=c(1,2,3,4)) )

alloc.probs.table <- zstar.which.max.perplaceid.table/n.iters

alloc.probs.mat <- matrix( as.numeric(alloc.probs.table), ncol=4 , byrow=F)
outallocprob <- c( t(alloc.probs.mat) )

w <- outallocprob

#fixef.coef.samp
out <- list(w=w, paramvec=fixef.coef.samp)
return(out)
}


test.ae <- function()
{
    checkEqualsNumeric(ae(3.4, 3.4), 0)
    checkEqualsNumeric(ae(3.4, 4.4), 1.0)
    checkEqualsNumeric(ae(9, 11), 2)
}

test.ce <- function()
{
    checkEqualsNumeric(ce(c(1,1,1,0,0,0),c(1,1,1,0,0,0)), 0.0)
    checkEqualsNumeric(ce(c(1,1,1,0,0,0),c(1,1,1,1,0,0)), 1/6)
    checkEqualsNumeric(ce(c(1,2,3,4),c(1,2,3,3)), 1/4)
    checkEqualsNumeric(ce(c("cat","dog","bird"),c("cat","dog","fish")), 1/3)
    checkEqualsNumeric(ce(c("cat","dog","bird"),c("caat","doog","biird")), 1.0)
}

test.mae <- function()
{
    checkEqualsNumeric(mae(0:10, 1:11), 1)
    checkEqualsNumeric(mae(seq(0,2,0.5), seq(0,2,0.5)), 0)
    checkEqualsNumeric(mae(1:4, c(1,2,3,5)), 0.25)
}

test.mse <- function()
{
    checkEqualsNumeric(mse(0:10, 1:11), 1.0)
    checkEqualsNumeric(mse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(mse(1:4, c(1,2,3,6)), 1.0)
}

test.msle <- function()
{
    checkEqualsNumeric(msle(c(exp(2)-1),c(exp(1)-1)), 1)
    checkEqualsNumeric(msle(seq(0,2,0.5),seq(0,2,0.5)), 0)
    checkEqualsNumeric(msle(c(1,2,3,exp(1)-1),c(1,2,3,exp(2)-1)), 0.25)
}

test.rmse <- function()
{
    checkEqualsNumeric(rmse(0:10, 1:11), 1.0)
    checkEqualsNumeric(rmse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(rmse(1:4, c(1,2,3,5)), 0.5)
}

test.rmsle <- function()
{
    checkEqualsNumeric(rmsle(c(exp(2)-1),c(exp(1)-1)), 1)
    checkEqualsNumeric(rmsle(seq(0,2,0.5),seq(0,2,0.5)), 0)
    checkEqualsNumeric(rmsle(c(1,2,3,exp(1)-1),c(1,2,3,exp(2)-1)), 0.5)
}

test.se <- function()
{
    checkEqualsNumeric(se(3.4, 3.4), 0)
    checkEqualsNumeric(se(3.4, 4.4), 1.0)
    checkEqualsNumeric(se(9, 11), 4)
}

test.sle <- function()
{
    checkEqualsNumeric(sle(3.4,3.4), 0)
    checkEqualsNumeric(sle(exp(2)-1,exp(1)-1), 1)
}


## 2. Sampling Rows ##

library(readr)
library(dplyr)
wnba <- read_csv("wnba.csv")
set.seed(1)
thirty_samples <-  sample_n(wnba, size = 30)
mean_age <- mean(thirty_samples$Age)
mean_games <- mean(thirty_samples$Games_Played)

## 3. Creating and Analyzing Strata with dplyr ##

set.seed(1)
wnba <- wnba %>%
  mutate(pts_game = PTS/Games_Played)

total_points_estimates <- wnba %>%
  group_by(Pos) %>%
  sample_n(10) %>%
  summarise(mean_pts_season = mean(PTS),
            mean_pts_game = mean(pts_game)) %>%
  arrange(Pos)

## 4. Proportional Stratified Sampling ##

set.seed(1)
under_12 <- wnba %>%
  filter(Games_Played <= 12) %>%
  sample_n(1)
btw_13_22 <- wnba %>%
  filter(Games_Played > 12 & Games_Played <= 22) %>%
  sample_n(2)
over_22 <- wnba %>%
  filter(Games_Played > 22) %>%
  sample_n(7)

combined <- bind_rows(under_12, btw_13_22, over_22)
mean(combined$PTS)

## 5. Many Proportional Stratified Samples ##

library(purrr)
library(tibble)
library(ggplot2)
set.seed(1)
sample_mean <- function(x){
under_12 <- wnba %>%
  filter(Games_Played <= 12) %>%
  sample_n(1)
btw_13_22 <- wnba %>%
  filter(Games_Played > 12 & Games_Played <= 22) %>%
  sample_n(2)
over_22 <- wnba %>%
  filter(Games_Played > 22) %>%
  sample_n(7)

combined <- bind_rows(under_12, btw_13_22, over_22)
mean(combined$PTS)
}

sample_number <- 1:100

mean_points_season <- map_dbl(sample_number, sample_mean)

df <- tibble(sample_number, mean_points_season)

ggplot(data = df) +
    aes(x = sample_number, y = mean_points_season) +
    geom_point() +
    geom_hline(yintercept = mean(wnba$PTS), color = "blue") +
    ylim(80, 320)

## 6. Alternative Approach ##

set.seed(1)
sample_mean <- function(x) {
  sample <- wnba %>%
  group_by(games_stratum) %>%
  sample_frac(.07)

  mean(sample$PTS)
}

sample_number <- 1:100

mean_points_season <- map_dbl(sample_number, sample_mean)

df <- tibble(sample_number, mean_points_season)
ggplot(data = df) +
    aes(x = sample_number, y = mean_points_season) +
    geom_point() +
    geom_hline(yintercept = mean(wnba$PTS), color = "blue") +
    ylim(80, 320)

## 8. Cluster Sampling ##

set.seed(10)
clusters <-  unique(wnba$Team) %>% sample(size = 4)

sample <- wnba %>% filter(Team %in% clusters)

sampling_error_height <- mean(wnba$Height) - mean(sample$Height)
sampling_error_age <- mean(wnba$Age) - mean(sample$Age)
sampling_error_games <- mean(wnba$Games_Played) - mean(sample$Games_Played)
sampling_error_points <- mean(wnba$PTS) - mean(sample$PTS)

Data Analyst in R/Step 5 - Probability and Statistics/1. Statistics Fundamentals in R/2. Stratified Sampling and Cluster Sampling.r


library(reshape2)
library(ggplot2)
library(ggthemes)

# set up ggplot theme
theme_set(theme_bw())
theme_update(legend.background = element_rect(colour="transparent", fill="transparent"),
	panel.grid.major = element_blank(),
	panel.grid.minor = element_blank()
)
corr <- read.csv("corr.csv")
corr <- as.matrix(corr)
colnames(corr) <- gsub("\\.", " ", colnames(corr))
rownames(corr) <- colnames(corr)
hc <- hclust(as.dist(exp(-corr)), 'ave')
perm <- hc$order
sub <- 31:60
corr.30 <- corr[perm[sub], perm[sub]]

corr.30[upper.tri(corr.30,diag=F)]<-NA #We only want to plot 1/2 the matrix

pd<-melt(t(corr.30),value.name='Correlation')

pd$Var2 <- factor(as.character(pd$Var2), levels=rev(as.character(levels(pd$Var1))))

p<-ggplot(data=pd,aes(x=Var1,y=Var2,fill=Correlation,label=Correlation))+geom_raster()
p<-p+geom_raster()+theme_bw()+labs(title='The Raw Plot')

p<-p+scale_fill_gradient2(name='Correlation',na.value='white') #create a diverging color gradient
p+labs(title='Now we have a diverngent Color Scale')

p<-p+theme(panel.border=element_rect(colour=NULL,fill=NULL),panel.grid.major=element_line(colour=NULL),axis.text=element_text(size=8),axis.text.x=element_text(size=8,angle=45, hjust = 1))

p<-p+scale_x_discrete(expand=c(0,0))+scale_y_discrete(expand=c(0,0))

p<-p+labs(x='',y='',title='Cosine Similarity between Painters')
p+coord_equal()

print(p)
ggsave(filename = "~/Dropbox/Slides/Insight/figure/similarity.png", width=7, height = 6)

## comparing three schools of painters

impressionist = c("Claude Monet", "Pierre Auguste Renoir", "Edgar Degas", "Georges Seurat")

classical= c("Raphael", "Sandro Botticelli", "Leonardo da Vinci", "Michelangelo")

dutch = c("Rembrandt", "Johannes Vermeer", "Peter Paul Rubens", "Frans Hals")

abstract= c("Mark Rothko", "Jackson Pollock", "Willem de Kooning", "Georgia O Keeffe")

post = c("Paul Cezanne", "Vincent van Gogh", "Paul Gauguin", "Henri Matisse")

index = match(c(impressionist, dutch, classical, abstract, post), rownames(corr))

index.impressionist = match(impressionist, rownames(corr))
index.classical = match(classical, rownames(corr))
index.dutch = match(dutch, rownames(corr))
index.abstract = match(abstract, rownames(corr))
index.post = match(post, rownames(corr))

corr.impressionist <- corr[index.impressionist, index.impressionist]
corr.classical <- corr[index.classical, index.classical]
corr.dutch <- corr[index.dutch, index.dutch]
corr.post <- corr[index.post, index.post]
corr.abstract <- corr[index.abstract, index.abstract]

mds <- cmdscale(as.dist((1-corr)/2))
plot(mds, type="n")
text(mds, labels=rownames(mds))
pdata=as.data.frame(mds[index, ])
colnames(pdata) <- c("x", "y")
pdata['label'] <- rownames(pdata)
pdata['genre'] <- rep(c("impressionist", "classical", "dutch", "abstract", 'post-imp'), rep(4, 5))

p <- ggplot(data=pdata, aes(x=x, y=y, label=label, color=genre))
p <- p + geom_text() + labs(x="Component 1", y="Component 2", title="Separation of Genres using Cosine Similarity") + scale_color_tableau()
print(p)
ggsave(filename = "~/Dropbox/Slides/Insight/figure/separation.png", width=7, height = 5)
text(mds[index, ], labels=rownames(mds[index, ]), col=rep(1:5, rep(4,5)))


# Derive statistics from confusion matrix
# [ref] https://en.wikipedia.org/wiki/Confusion_matrix
generateCM <- function(pred, ref){
  return(table(pred, ref))
}

cmToMetrics <- function(cm, positive=1){
  # Decode the matrix
  if(positive==0){
    TP <- cm[1,1]/sum(cm)
    TN <- cm[2,2]/sum(cm)
    FP <- cm[1,2]/sum(cm)
    FN <- cm[2,1]/sum(cm)
  } else {
    TP <- cm[2,2]/sum(cm)
    TN <- cm[1,1]/sum(cm)
    FP <- cm[2,1]/sum(cm)
    FN <- cm[1,2]/sum(cm)
  }
  # Derive Metrics
  sensitivity <- TP/(TP+FN)
  specificity <- TN/(FP+TN)
  prevalence <- TP+FN/(FN+TP+FP+TN)
  ppv <- TP/(TP+FP)
  npv <- TN/(TN+FN)
  fpr <- FP/(FP+TN)
  fnr <- FN/(FN+TP)
  fdr <- FP/(FP+TP)
  FOR <- FN/(TN+FN)
  accuracy <- (TP+TN)/(FN+TP+FP+TN)
  F1 <- 2*TP/(2*TP+FP+FN)
  MCC <- (TP*TN-FP*FN)/sqrt((TP+FP)*(TP+FN)*(TN+FP)*(TN+FN))
  informedness <- sensitivity + specificity - 1
  markedness <- ppv + npv -1
  # Output
  output <- c("Accuracy"=accuracy,
              "True.Positive"=TP,
              "False.Negative"=FN,
              "False.Positive"=FP,
              "True.Negative"=TN,
              "Sensitivity"=sensitivity,
              "Specificity"=specificity,
              "Prevalence"=prevalence,
              "Positive.Predictive.Value"=ppv,
              "Negative.Predictive.Value"=npv,
              "False.Positive.Rate"=fpr,
              "False.Discovery.Rate"=fdr,
              "False.Negative.Rate"=fnr,
              "False.Omission.Rate"=FOR,
              "F1.Score"=F1,
              "Matthews.correlation.coefficient"=MCC,
              "Informedness"=informedness,
              "Markedness"=markedness)
  return(output)
}


# Multinomial logistic regression simulation code
# For K levels of the dependent variable, estimates K-1 sets of
# coefficients for the independent variables.

# Currently set up for 3 classes but can be extended to any number

# Raymond Viviano
# rayviviano@gmail.com
# March 23, 2020

# TODO: Encapsulate certain code sections into smaller functions
# TODO: Bound coverage probability between 0 & 1

# Easy access to mlogit models
suppressPackageStartupMessages(library(mlogit))

# Set error reporting options
options(show.error.locations=TRUE)
options(error=recover)

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Ensure reproducible results
set.seed(10000)

# Set logistic regression parameters (Can be calculated as log(oddsRatio)) for
# Classes A and B (against reference C).

# Class a
b0a <- .2        # Set Logistic Regression Intercept True Value
b1a <- .5        # Set Logistic Regression Slope True Value

# Class b
b0b <- -.2
b1b <- .75

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 55

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=12)

# Loop through simulations
for(i in 1:nsims){
    # Participant/subject/case/index
    case = c(1:n)

    # Generate independant variable data, uniform random between -1 and 1
    x <- runif(n, -1, 1)

    # Compute probabilities of each class based on generated data
    prob.a <- exp(b0a +b1a*x) / (1 + exp(b0a + b1a*x) + exp(b0b + b1b*x))
    prob.b <- exp(b0b +b1b*x) / (1 + exp(b0a + b1a*x) + exp(b0b + b1b*x))
    prob.c <- 1 - prob.a - prob.b

    # Generate y data based on calculated probabilities
    y <- rep(NA, n)
    for (j in 1:n){
        y[j] <- sample(c("a", "b", "c"), 1, replace = TRUE,
                       prob = c(prob.a[j], prob.b[j], prob.c[j]))
    }

    # Prep data for mlogit package
    sim.data <- data.frame(case, x, y, stringsAsFactors=FALSE)

    # Convert data to long format for mlogit
    sim.data <- mlogit.data(sim.data, shape='wide', choice="y", id.var='case')

    # Estimate logit model
    model <- mlogit(y ~ -1|x, data=sim.data, reflevel='c')

    # Get variance-covariance matrix
    var.covar <- vcov(model)

    # Put model paramters in simulation matrix
    sim.prms[i,1] <- model$coef[1]             # Estimate for b0a
    sim.prms[i,2] <- model$coef[3]             # Estimate for b1a
    sim.prms[i,3] <- model$coef[2]             # Estimate for b0b
    sim.prms[i,4] <- model$coef[4]             # Estimate for b1b
    sim.prms[i,5] <- sqrt(diag(var.covar)[1])  # b0a standard error
    sim.prms[i,6] <- sqrt(diag(var.covar)[3])  # b1a standard error
    sim.prms[i,7] <- sqrt(diag(var.covar)[2])  # b0b standard error
    sim.prms[i,8] <- sqrt(diag(var.covar)[4])  # b1b standard error
    sim.prms[i,9]  <- summary(model)$CoefTable[,4][1] # b0a pvalue
    sim.prms[i,10] <- summary(model)$CoefTable[,4][3] # b1a pvalue
    sim.prms[i,11] <- summary(model)$CoefTable[,4][2] # b0b pvalue
    sim.prms[i,12] <- summary(model)$CoefTable[,4][4] # b1b pvalue
}

# Get Covarage probabilities for the parameters
b0a.coverage <- coverage.prob(sim.prms[,1], sim.prms[,5], b0a, .95, n-length(coef(model)))
b1a.coverage <- coverage.prob(sim.prms[,2], sim.prms[,6], b1a, .95, n-length(coef(model)))
b0b.coverage <- coverage.prob(sim.prms[,3], sim.prms[,7], b0b, .95, n-length(coef(model)))
b1b.coverage <- coverage.prob(sim.prms[,4], sim.prms[,8], b1b, .95, n-length(coef(model)))

# Print intercept for class a coverage probability and 95% confidence interval
print("Coverage Probability for b0a")
print(b0a.coverage)

# Print coefficent on x for class a coverage probability and 95% confidence interval
print("Coverage Probability for b1a")
print(b1a.coverage)

# Print intercept for class b coverage probability and 95% confidence interval
print("Coverage Probability for b0b")
print(b0b.coverage)

# Print coefficent on x for class b coverage probability and 95% confidence interval
print("Coverage Probability for b1b")
print(b1b.coverage)

cat("Power to detect b0a\n")
power.detect.effect(sim.prms[,9])

cat("\nPower to detect b1a\n")
power.detect.effect(sim.prms[,10])

cat("Power to detect b0b\n")
power.detect.effect(sim.prms[,11])

cat("\nPower to detect b1b\n")
power.detect.effect(sim.prms[,12])


# File name: iris_spmd.r
# Run: mpiexec -np 4 Rscript iris_spmd.r

rm(list = ls())                                       # Clean environment
library(pbdMPI, quiet = TRUE)                         # Load library
if(comm.size() != 4)
  comm.stop("4 processors are required.")

### Load data
X <- as.matrix(iris[, -5])                            # Dimension 150 by 4
X.cid <- as.numeric(iris[, 5])                        # True id

### Distribute data
jid <- get.jid(nrow(X))
X.spmd <- X[jid,]                                     # SPMD row-major format

### Standardized
N <- allreduce(nrow(X.spmd))                          # 150
p <- ncol(X.spmd)                                     # 4
mu <- allreduce(colSums(X.spmd / N))
X.std <- sweep(X.spmd, 2, mu, FUN = "-")              # Substract mean
std <- sqrt(allreduce(colSums(X.std^2 / (N - 1))))
X.std <- sweep(X.std, 2, std, FUN = "/")              # Divide standard error

### SVD manually in serial
X.tmp <- crossprod(X.std)                             # X'X (local)
X.tmp <- allreduce(X.tmp)
dim(X.tmp) <- c(p, p)
ret <- eigen(X.tmp)                                   # X'X = V D^2 V'
d <- sqrt(ret$values)
v <- ret$vectors
u <- X.std %*% v %*% diag(1/d)                        # Why X V D^(-1)) = U?

### Validation
tmp <- svd(scale(X))
comm.print(c(sum(abs(tmp$u[jid,] - u)),
             sum(abs(tmp$v - v)),
             sum(abs(tmp$d - d))))

### Project on column space of singular vectors
A <- u %*% diag(d)
B <- X.std %*% v                                      # A ~ B
X.prj <- A[, 1:2]                                     # Only useful for plot
X.prj <- do.call("rbind", allgather(X.prj))

### Clustering
library(pmclust, quiet = TRUE)
comm.set.seed(123, diff = TRUE)

X.spmd <- X.std
PARAM.org <- set.global(K = 3)                        # Preset storage
.pmclustEnv$CONTROL$debug <- 0                        # Disable debug messages
PARAM.org <- initial.center(PARAM.org)                # Initial parameters
PARAM.kms <- kmeans.step(PARAM.org)                   # K-means
X.kms.cid <- allgather(.pmclustEnv$CLASS.spmd,
                       unlist = TRUE)

PARAM.org <- set.global(K = 3)                        # Preset storage
.pmclustEnv$CONTROL$debug <- 0                        # Disable debug messages
PARAM.org <- initial.em(PARAM.org,
                        MU = PARAM.kms$MU)            # Initial by K-means
PARAM.mbc1 <- em.step(PARAM.org)                      # Model-based clustering
X.mbc1.cid <- allgather(.pmclustEnv$CLASS.spmd,
                        unlist = TRUE)

PARAM.org <- set.global(K = 3, RndEM.iter = 1000)     # Preset storage
.pmclustEnv$CONTROL$debug <- 0                        # Disable debug messages
PARAM.org <- initial.RndEM(PARAM.org)                 # Initial by Rand-EM
PARAM.mbc2 <- em.step(PARAM.org)                      # Model-based clustering
X.mbc2.cid <- allgather(.pmclustEnv$CLASS.spmd,
                        unlist = TRUE)

### Validation
X.kms.adjR <- EMCluster::RRand(X.cid, X.kms.cid)$adjRand
X.mbc1.adjR <- EMCluster::RRand(X.cid, X.mbc1.cid)$adjRand
X.mbc2.adjR <- EMCluster::RRand(X.cid, X.mbc2.cid)$adjRand
comm.print(c(X.kms.adjR, X.mbc1.adjR, X.mbc2.adjR))

### Swap classification id
tmp <- X.kms.cid
X.kms.cid[tmp == 1] <- 2
X.kms.cid[tmp == 2] <- 1
tmp <- X.mbc1.cid
X.mbc1.cid[tmp == 1] <- 2
X.mbc1.cid[tmp == 2] <- 1

### Display on first 2 components
if(comm.rank() == 0){
  pdf("spmd_plot.pdf")

  par(mfrow = c(2, 2))
  plot(X.prj, col = X.cid + 1, pch = X.cid,
       main = "iris (true)", xlab = "PC1", ylab = "PC2")
  plot(X.prj, col = X.kms.cid + 1, pch = X.kms.cid,
       main = paste("iris (kmeans)", sprintf("%.4f", X.kms.adjR)),
       xlab = "PC1", ylab = "PC2")
  plot(X.prj, col = X.mbc1.cid + 1, pch = X.mbc1.cid,
       main = paste("iris (model-based 1)", sprintf("%.4f", X.mbc1.adjR)),
       xlab = "PC1", ylab = "PC2")
  plot(X.prj, col = X.mbc2.cid + 1, pch = X.mbc2.cid,
       main = paste("iris (model-based 2)", sprintf("%.4f", X.mbc2.adjR)),
       xlab = "PC1", ylab = "PC2")

  dev.off()
}

### Finish
finalize()


set.seed(1)

# case 1: t-oracles; case 2: normal oracles.
case = 1
# energy function for the Gaussian mixture distribution
if (case == 1) {
    mean1 = -4
    mean2 = 3
    f = function(x) return(-log(0.4 * dnorm(x, mean=mean1, sd=0.7) + 0.6 * dnorm(x, mean=mean2, sd=0.5)))
    noisy_f = function(x) return(f(x) + rt(1, df=5))
} else {
    mean1 = -3
    mean2 = 2
    f = function(x) return(-log(0.4 * dnorm(x, mean=mean1, sd=0.7) + 0.6 * dnorm(x, mean=mean2, sd=0.5)))
    noisy_f = function(x) return(f(x) + rnorm(1, 0, 2))
}
# target Gaussian mixture distribution
density = function(x) exp(-f(x))

# Important hyperparameters
lr = 0.03
T_high = 10
T_low = 1

# Other hyperparameters
x_low = 0
x_high = 0
part1 = 100
grad_std = 0.1
thinning = 100

# You can set a larger value to obtain more stable results.
total = 100000

################################################### SGLD ###################################################
samples_sgld = c()
x_low = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)

        if (j %% (thinning) == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_sgld = c(samples_sgld, samples_part)
}

################################################### Naive reSGLD ###################################################
samples_naive = c()
x_low = 0
x_high = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)
        x_high = x_high - lr * (numDeriv::grad(f, x_high) + rnorm(1, 0, grad_std)) + sqrt(2 * lr * T_high) * rnorm(1, 0, 1)

        integrand_corrected = min(1, exp((1 / T_high - 1 / T_low) * (noisy_f(x_high) - noisy_f(x_low))))

        if (runif(1) < integrand_corrected) {
            tmp = x_low
            x_low = x_high
            x_high = tmp
        }
        if (j %% thinning == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_naive = c(samples_naive, samples_part)
}

################################################### reSGLD ###################################################
samples_ptsgld = c()
hat_var = 10
counter = 1
x_low = 0
x_high = 0
for (i in 1:part1) {
    samples_part = c()
    for (j in 1:(total/part1)) {
        x_low  = x_low  - lr * (numDeriv::grad(f, x_low) + rnorm(1, 0, grad_std))  + sqrt(2 * lr * T_low)  * rnorm(1, 0, 1)
        x_high = x_high - lr * (numDeriv::grad(f, x_high) + rnorm(1, 0, grad_std)) + sqrt(2 * lr * T_high) * rnorm(1, 0, 1)

        if (j %% 20 == 0) {
            loss_stat = c()
            for (jjj in 1:10) {
                loss_stat = c(loss_stat, noisy_f(x_low))
            }
            unbiased_var = var(loss_stat)
            hat_var = (1 - 1 / counter) * hat_var + (1 / counter) * unbiased_var
            counter = counter + 1
        }

        integrand_corrected = min(1, exp((1 / T_high - 1 / T_low) * (noisy_f(x_high) - noisy_f(x_low) - (1 / T_high - 1 / T_low) * hat_var)))

        if (runif(1) < integrand_corrected) {
            tmp = x_low
            x_low = x_high
            x_high = tmp
        }
        if (j %% thinning == 0) {samples_part = c(samples_part, x_low)}
    }
    print(i)
    samples_ptsgld = c(samples_ptsgld, samples_part)
}

real_samples = c(rnorm(length(samples_ptsgld)*0.4, mean=mean1, sd=0.7), rnorm(length(samples_ptsgld)*0.6, mean=mean2, sd=0.5))

wdata = data.frame(
        Type = factor(rep(c("Ground truth", "SGLD", "Naive reSGLD", "reSGLD"), each=length(samples_ptsgld))),
        weight = c(real_samples, samples_sgld, samples_naive, samples_ptsgld)
        )

library(ggplot2)

p=ggplot(wdata, aes(x = weight)) +
    stat_density(aes(x=weight, colour=Type, linetype=Type), size=2, geom="line", position="identity") +
    scale_linetype_manual(values=c("solid", "dotdash", "longdash", "twodash"))+
    scale_color_manual(values = c("#666666", "#7570B3", "#E7298A", "#1B9E77")) +
    scale_x_continuous(name="X") +
    scale_y_continuous(name="Density") +
    theme(
        legend.position = c(0.3, 0.8),
        legend.title =element_blank(),
        legend.text = element_text(colour="grey15", size=24),
        legend.key.size = unit(2,"line"),
        legend.key = element_blank(),
        legend.background=element_rect(fill=alpha('grey', 0.1)),
        axis.title=element_text(size=24),
        axis.text.y = element_text(size=24),
        axis.text.x = element_text(size=24)
        )
p


#!/usr/bin/env Rscript

# Bhishan Poudel
# Jan 8, 2016
# clear; Rscript functions.r; rm *~

# Example of a Function
pow <- function(x, y) {
   # function to print x raised to the power y

   result <- x^y
   print(paste(x,"raised to the power",y,"is",result))
}

# Function Calls
pow(8,2)
pow(2,8)

# Named Arguments
pow(x=8, y=2)
pow(y=2, x=8)
pow(x=8, 2)

# Default Values for Arguments
pow <- function(x, y=2) {
   # function to print x raised to the power y
   result <- x^y
   print(paste(x,"raised to the power",y,"is",result))
}

# function call
pow(3)
# [1] "3 raised to the power 2 is 9"
pow(3,1)
# [1] "3 raised to the power 1 is 3"

# Returning an object in the function
#By default the value of the last line is returned.
cat("\n\n")

test <- function(){
                    x <-1
                    y <- 2
                    z <- 3
                    #return(x)
}
res <- test()  # result
res


# Fiecare student primește un i unic
i <- 1

# Exercițiul 1
# Folosim repartiția hipergeometrică
p1 <- dhyper(x=1, m=2, n=i, k=2)
p2 <- dhyper(x=2, m=2, n=i, k=2)

print("P(X = 2):")
print(p1 / (p1 + p2))

# Exercițiul 2
# Folosim repartiția binomială
print("P(X = i):")
print(dbinom(i, size=100, prob=1/6))

# Exercițiul 3
# Folosim repartiția normală
right <- 1

print("P(X < 1):")
print(pnorm(right, mean=3, sd=sqrt(54)))

# Statistică
X <- c(1, 2, 3, i + 3)
n <- 4

# Exercițiul 4
X_bar <- mean(X)
sigma <- sqrt(3)

alpha <- 0.01

dx <- (sigma*qnorm(1 - alpha/2))/sqrt(n)

c(X_bar - dx, X_bar + dx)

# Exercițiul 5
s = var(X)

aux <- (n - 1) * s

left <- aux/qchisq(alpha/2, df=n-1)
right <- aux/qchisq(1-alpha/2, df=n-1)

# Exercițiul 6
C <- cbind(1, X, X^2)
y <- c(1, 2, 3, 4)

# beta = (C^T * C)^(-1) * C^T * y
beta <- solve(t(C)%*%C, t(C)%*%y)

print(t(beta)) # Afișare pe linie

# Verificare cu lm
X_sq <- X^2

model <- lm(y ~ X + X_sq)
print(model$coefficients)