# ESRB Ratings
# 2013-07-02 via http://www.esrb.org/ratings/search.jsp
ESRBRatingsAges <- c(3, 6, 10, 13, 17, 18)
ESRBRatings <- c(289, 20437, 2260, 6017, 1898, 32)
ESRBRatingsT <- c(0,0,0,289,0,0,20437,0,0,0,2260,0,0,6017,0,0,0,1898,32)

# PEGI Ratings
# 2013-07-02 via http://www.pegi.info/en/index/id/509
PEGIRatingsAges <- c(3, 7, 12, 16, 18)
PEGIRatings <- c(9448, 2861, 4535, 2561, 1271)
PEGIRatingsT <- c(0,0,0,9448,0,0,0,2861,0,0,0,0,4535,0,0,0,2561,0,1271)

# USK Ratings
# 2013-07-02 via http://www.usk.de/titelsuche/titelsuche/
# absolute not not available via that frontend, so they had to be estimated
USKRatingsAges <- c(0,6,12,16,18)
USKRatings <- c(1409,461,613,342,114)*10
USKRatingsT <- c(1409,0,0,0,0,0,461,0,0,0,0,0,613,0,0,0,342,0,114)*10

# BPjM Ratings
# 2013-07-02 via http://bundespruefstelle.de/bpjm/Jugendmedienschutz/statistik,did=39254.html
BPjMRatingsAges <- c(18)
BPjMRatings <- c(658)
BPjMRatingsU <- c(0,0,0,0,658)
BPjMRatingsT <- c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,658)

AgeRange = 0:18

svg('age-rating-distribution.svg', height=6, width=12)
plot(ESRBRatingsAges,ESRBRatings,col="red",xlim=c(0,18),ylim=c(0,20000),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
title(main = "Number of Game Age Ratings as Function of Age", sub = "ESRB (red), PEGI (green), USK (blue), BPjM (black)", xlab = "Rated Age", ylab = "Number of Ratings")
axis(1,0:18)
axis(2,0:20*1000)
par(new=TRUE)
plot(PEGIRatingsAges,PEGIRatings,col="green",xlim=c(0,18),ylim=c(0,20000),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(USKRatingsAges,USKRatings,col="blue",xlim=c(0,18),ylim=c(0,20000),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(BPjMRatingsAges,BPjMRatings,col="black",xlim=c(0,18),ylim=c(0,20000),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
dev.off()

svg('age-rating-distribution-1.svg', height=6, width=12)
plot(0:18,cumsum(ESRBRatingsT)/sum(ESRBRatingsT),col="red",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
title(main = "Relative Number of Game Age Ratings as Function of Age", sub = "ESRB (red), PEGI (green), USK (blue), USK+BPjM (pink)", xlab = "Rated Age", ylab = "% of Games Available at Given Age")
axis(1,0:18)
axis(2,c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1))
par(new=TRUE)
plot(0:18,cumsum(PEGIRatingsT)/sum(PEGIRatingsT),col="green",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(0:18,cumsum(USKRatingsT)/sum(USKRatingsT),col="blue",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(0:18,cumsum(USKRatingsT+BPjMRatingsT)/sum(USKRatingsT+BPjMRatingsT),col="pink",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
dev.off()

svg('age-rating-distribution-2.svg', height=6, width=12)
plot(ESRBRatingsAges,cumsum(ESRBRatings)/sum(ESRBRatings),col="red",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
title(main = "Relative Number of Game Age Ratings as Function of Age", sub = "ESRB (red), PEGI (green), USK (blue), USK+BPjM (pink)", xlab = "Rated Age", ylab = "% of Games Available at Given Age")
axis(1,0:18)
axis(2,c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1))
par(new=TRUE)
plot(PEGIRatingsAges,cumsum(PEGIRatings)/sum(PEGIRatings),col="green",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(USKRatingsAges,cumsum(USKRatings)/sum(USKRatings),col="blue",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
par(new=TRUE)
plot(USKRatingsAges,cumsum(USKRatings+BPjMRatingsU)/sum(USKRatings+BPjMRatingsU),col="pink",xlim=c(0,18),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",type="b")
dev.off()


library(rgdal)
library(raster)
library(caret)
library(snow)
library(doParallel)

set.seed(13)

## Carregando dados

ano <- '2020'
resolucao <- 'baixa'

dataset <- paste(resolucao,'_',ano,sep='')

imagem <- stack(paste('./',resolucao,'/',dataset,'.tif',sep=''))

treinamento <- shapefile(paste('./',resolucao,'/',dataset,'.shp',sep=''))

## Definindo numero de classes k, atributo classe deve ser preenchido com o
## nome do atributo contendo a classe no shape

classe <- "class"

k <- length(unique(treinamento[[classe]]))

amostragem = data.frame(matrix(vector(), nrow = 0, ncol = length(names(imagem)) + 1))

# Armazenando amostragem em um dataframe
for (i in 1:k){ # loop para coletar os dados de cada classe
  id <- unique(treinamento[[classe]])[i] # seleciona a id da classe a extrair
  mapa_id <- treinamento[treinamento[[classe]] == id,] # seleciona somente os shapes da categoria a ser extraida
  dados <- extract(imagem, mapa_id) # extrai os dados sobrepostos pelos shapes da categoria selecionada

  # remove os dados nulos da amostra
  dados <- dados[!unlist(lapply(dados, is.null))]

  # seta o valor da coluna classe para o id da classe extraída
  dados <- lapply(dados, function(m){cbind(m, classe = as.numeric(rep(id, nrow(m))))})

  # transforma a lista de amostras para uma unica matriz
  df <- do.call("rbind",dados)

  # aloca os vetores da matriz no dataframe amostragem
  amostragem <- rbind(amostragem,df)
}

## Downsampling da amostragem (opcional, descomentar)
#ds_amostragem <- amostragem[sample(1:nrow(amostragem), 0.1 * nrow(amostragem)),]

ds_amostragem <- amostragem

## Selecionando 80% das amostras para treinamento
indice_amostra <- sample(1:nrow(ds_amostragem), 0.80 * nrow(ds_amostragem))
train_amostragem <- ds_amostragem[indice_amostra,]
test_amostragem <- ds_amostragem[-indice_amostra,]

### Utilizando o pacote randomForest

# importar o pacote RANDOM FOREST
library(randomForest)

formula = as.factor(classe) ~ .

rf <- randomForest(formula,
                   data = train_amostragem,
                   importance=TRUE,
                   ntree=1000,
                   do.trace=TRUE,
                   mtry=2)

# Predizendo pela randomForest

pred_rf <- predict(rf, test_amostragem)

cm <- confusionMatrix(pred_rf,as.factor(test_amostragem$classe))

sink(file = paste('./stats/',dataset,'_stats.txt',sep=''))
cm
sink(file = NULL)

cm$table

# Predizendo a imagem classificada

beginCluster()
pred <- clusterR(imagem, raster::predict, args = list(model = rf))
endCluster()

crs(pred) <- '+proj=utm +zone=24 +south +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs '

plot(pred)

raster::writeRaster(pred,paste('./classes/class_',dataset,'.tif',sep=''), overwrite=TRUE)


library(ggplot2)
library(ggvis)
library(dplyr)
library(rgdal)
library(mosaic)
library(maptools)
library(ggmap)
library(mapproj)
library(munsell)
library(maps)
library(rgeos)
source("lib/uvozi.zemljevid.r")

tipi <- c("boleto"="Boleto",
          "credit_card"="Kreditna kartica",
          "debit_card"="Debetna kartica",
          "voucher"="Vavčer")

meseci <- c("Januar", "Februar", "Marec", "April", "Maj", "Junij", "Julij", "Avgust", "September", "Oktober", "November", "December")
graf_promet <- ggplot(promet_2017, aes(x = promet_2017$mesec.dostave, y = promet_2017$vrednost.placila / 1000)) +
  geom_col() +
  labs(title = "Pregled prometa v letu 2017", x = "Mesec", y = "Skupni promet (v 1000€)") +
  scale_x_continuous(breaks = 1:12, labels = meseci ) +
  theme(axis.text.x = element_text(angle = 90))

graf_tipi <- ggplot(narocila, aes(tipi[narocila$tip.placila])) +
  geom_bar() +
  labs(title = "Plačilna sredstva", x = "Tip plačilnega sredstva", y = "Število nakupov") +
  scale_x_discrete() +
  coord_flip()

graf_gostot <- ggplot(narocila, aes(x = narocila$vrednost.placila, color=tipi[narocila$tip.placila])) +
  geom_density()  +
  scale_x_log10(labels=scales::comma_format(big.mark="")) +
  labs(title = "Gostota cen glede na plačilno sredstvo", x = "Gostota", y = "Gostota plačil", color="Tip plačila")

graf_december <- ggplot(december, aes(x=december$dan.narocila, y = december$vrednost.placila)) +
  geom_col() +
  labs(title = "Pregled prometa v decembru 2017", x = "Dan", y = "Skupni promet") +
  scale_x_continuous(breaks = 1:31)

graf_november <- ggplot(november, aes(x=november$dan.narocila, y=november$vrednost.placila)) +
  geom_col() +
  labs(title = "Pregled prometa v novembru 2017", x = "Dan", y = "Skupni promet") +
  scale_x_continuous(breaks = 1:30)

brazilija <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_BRA_shp.zip", "gadm36_BRA_0", force=FALSE) %>% fortify()

map <- ggplot(brazilija, aes(x=long, y=lat)) +
  geom_polygon(aes(group=group)) +
  geom_point(aes(x=zemljepisna.dolzina, y=zemljepisna.sirina), data = lokacija_prodajalcev, col="red", alpha = 0.05) +
  coord_cartesian(xlim = c(-73.98283055, -34.79314722), ylim = c(-33.75116944, 5.27438888)) +
  labs(title ="Vizualizacija prodajalcev", x = "Zemljepisna dolžina", y = "Zemljepisna širina")


##Save functions for creating methods plots

##Compare plot

cPlotM = function(x, y, xlab = 'x', ylab = 'y', lwd = 2, ...){
  #Plot x and y against each other, compare w/ line y=x

  plot(x, y, ...)
  abline(0,1, lwd = lwd, col = 'red', lty = 2)

  mtext(side = 1, line = 2, xlab)
  mtext(side = 2, line = 2, ylab)

  c_val = round(cor(x,y), 2)
  legend('bottomright', c(paste('Correlation: ',c_val)), bty = 'n')
}

#Ranking plot (be able to fix the order of the columns)

qualPlot = function(d_vec, se_vec, order_vec = FALSE, ylab = 'Estimated Quality', main = '', lwd = 3,...){

  stopifnot( length(d_vec) == length(se_vec)) #estimated quality and standard error should be the same length

  #If order_vec isn't specified, sort by effect
  if (is.logical(order_vec) & !order_vec){
    order_vec = order(d_vec)
  }

  #Sort everything
  d_vec = d_vec[order_vec]
  se_vec = se_vec[order_vec]
  x = 1:length(d_vec)

  #Create upper and lower limits
  lower = d_vec - 1.96 * se_vec
  upper = d_vec + 1.96 * se_vec

  #Generate the caterpiller plots
  plot(x, d_vec, ylab = '', xlab = '', axes = FALSE, ylim = c(min(lower), max(upper)))
  box()
  axis(2)
  axis(1)
  mtext(side = 2, line = 2, ylab)
  mtext(side = 1, line = 2, 'Institution')
  title(main)

graphics::segments(x0=x, x1=x,y0 = lower, y1 = upper, lwd = lwd, ...)
lower_indices = upper < 0
upper_indices = lower > 0
graphics::segments(x0=x[lower_indices], x1=x[lower_indices],
                   y0 = lower[lower_indices], y1 = upper[lower_indices],  col = 'red',lwd = lwd* 1.5 , ...)
graphics::segments(x0=x[upper_indices], x1=x[upper_indices],
                   y0 = lower[upper_indices], y1 = upper[upper_indices],  col = 'blue', lwd = lwd * 1.5, ...)
graphics::abline(h = 0, lty = 3)

  #Now plot upper and lower segments...
  return(order_vec)
}


rm(list=ls())

#packages
packages <- c('lmerTest','plyr', 'jsonlite', 'performance')
lapply(packages, library, character.only = TRUE)

#json
mj<-fromJSON('validation_behavior.json')

#empowerment
empowerment<-read.csv("..\\..\\..\\empowermentexploration\\additionalexperiments\\validation_datageneration\\element_empowerment.csv")

#initialize data frame
d<-data.frame(id=numeric(), element=numeric(), pred=numeric(), emp=numeric(), rating=numeric())
for (i in 1:length(mj)){
  #get it
  m<-mj[[i]]
  #empowerment rating
  emp<-as.numeric(m$empowermentanswers)
  #which one
  rand_element<-m$randomempelement
  #predicted emp
  predicted_emp<-empowerment$emp_value_predicted[empowerment$element_string %in% rand_element]
  #true emp
  true_emp<-empowerment$emp_value_true[empowerment$element_string %in% rand_element]
  #id
  id<-rep(i, length(true))
  #bind
  d<-rbind(d, data.frame(id=i, element=rand_element, pred=predicted_emp, emp=true_emp, rating=emp))
}

#regress onto rating, we log because of non-normal dist
m1<-lmer(rating~scale(log(pred+0.1))+scale(log(emp+0.1))+(1|id), data=d)
#summary
summary(m1)
#r2
r2(m1)

#taken alone
m2<-lmer(rating~scale(log(emp+0.1))+(1|id), data=d)
#summary
summary(m2)
#r2
r2(m2)

#prediction frame
prediction<-read.csv("..\\..\\..\\empowermentexploration\\additionalexperiments\\validation_datageneration\\prediction_selection.csv")
#initialize
d<-data.frame(id=numeric(), pred=numeric(), outcome=numeric(), rating=numeric())
#loop through
for (i in 1:length(mj)){
  #select
  m<-mj[[i]]
  #initialize
  probpred<-outcome<-numeric()
  #go through all choices
  for (k in 1:nrow(m$currentcombinationstring)){
    #which one did they see?
    mark<-which(paste(prediction$first_string) %in% m$currentcombinationstring[k,1] & paste(prediction$second_string) %in% m$currentcombinationstring[k,2])
    #what was the predicted prob of the comb being successful
    probpred<-c(probpred, prediction$predSuccess[mark])
    #what would actually come out
    outcome<-c(outcome, paste(prediction$result_string[mark]))
  }
  #what did they say?
  probs<-as.numeric(m$linkanswers)
  #bind
  d<-rbind(d, data.frame(id=i, pred=probpred, outcome=outcome, rating=probs))
}

#see how prediction matches rating
m3<-lmer(rating~scale(pred)+(1|id), data=d)
#summarize
summary(m3)
#r2
r2(m3)

#just for element combs that weren't successes according to game tree
m4<-lmer(rating~scale(pred)+(1|id), data=subset(d, outcome=='None'))
#summarize
summary(m4)
#r2
r2(m4)

#initialize frame for probs of which element they chose
d<-data.frame(prob=numeric(), probnot=numeric(), outcome=numeric(), id=numeric())
#loop through
for (i in 1:length(mj)){
  #select
  m<-mj[[i]]
  #initialize
  prob<-probnot<-outcome<-numeric()
  for (k in 1:length(m$randomcombinations)){
    #which one (note +1 conversion because js to R)
    current<-prediction[m$randomcombinations[k]+1,]
    #get answers
    mark<-which(current[,17:20]==m$elementanswers[k])
    #the ones they didn't choose
    notmark<-(1:4)[-mark]
    #sample one of the non-chosen
    notmark<-sample(notmark, 1)
    #standardize prob of chosen
    prob<-c(prob, as.numeric(current[,9:12][mark]/sum(current[,9:12])))
    #standardize prob of not chosen
    probnot<-c(probnot, as.numeric(current[,9:12][notmark]/sum(current[,9:12])))
    #what came actually out
    outcome<-c(outcome, paste(current$result_string))
  }
  #bind to data frame
  d<-rbind(d, data.frame(prob, probnot, outcome, id=i))
}

#get means for both probs
dd<-ddply(d, ~id, summarise, m1=mean(prob), m2=mean(probnot))
#compare via t-test
t.test(dd$m1, dd$m2, var.equal = TRUE)
#Cohens d
cohensD(dd$m1, dd$m2)
#get them for combs that wouldn't return an element
dd<-ddply(subset(d, outcome=='None'), ~id, summarise, m1=mean(prob), m2=mean(probnot))
#get t-test
t.test(dd$m1, dd$m2)
#cohens d
cohensD(dd$m1, dd$m2)

#sample random position
d$random<-runif(nrow(d))
#assign left or right
d$diff<-ifelse(d$random>0.5, d$prob-d$probnot, d$probnot-d$prob)
#assign fictitious choice
d$choice<-ifelse(d$random>0.5, 1, 0)
#regress differences
m4<-glmer(choice~-1+scale(diff)+(-1+scale(diff)|id), family='binomial', data=d)
#check summary
summary(m4)
#r2
r2(m4)
#do with interaction of outcome 'none'
d$outnone<-ifelse(d$outcome=='None', 1, 0)
#compute
m4<-glmer(choice~-1+scale(diff)*outnone+(1|id), family='binomial', data=d)
#summarize
summary(m4)


#===============================================================================
#  File:    01-first-stage.R
#  Date:    Feb 3, 2021
#  Purpose: replicate Fig 2 and paper results re: impact of encouragement on
#            visits to news sites (compliance)
#  Data In:
#           ./data/survey_data.csv
#           ./data/daily_pulse_data.csv
#===============================================================================

# PACKAGES
#===============================================================================
library(dplyr)
library(readr)
library(estimatr)
library(glmnet)
library(reshape2)
library(ggplot2)
library(cowplot)
library(stringr)
source('code/functions.r')
sessionInfo()

# DATA
#===============================================================================
pulse <- read_csv("data/daily_pulse_data.csv")
svy <- read_csv("data/survey_data.csv")

# SIZE OF TREATMENT GROUPS
#===============================================================================
table(svy$W3_PATA306_treatment_w3)
nrow(svy)

# SAMPLE SIZE
#===============================================================================
# respondents who received the encouragement and consented to wave 4
sum(!is.na(svy$W3_PATA306_treatment_w3) & !is.na(svy$W4_consent))

# DATA WRANGLING
#===============================================================================
# Dropping observations where treatment is missing
svy <- svy[!is.na(svy$W3_PATA306_treatment_w3),]

# Merge pulse data with survey data
pulse <- merge(pulse,
                   dplyr::select(svy, id, W3_PATA306_treatment_w3, starttime_w3, W3_Browser_treatment_w3),
                   by.x = "id", by.y = "id", all.x = TRUE) %>%
  mutate(treatment = factor(W3_PATA306_treatment_w3,
                            labels = c("Control group", "Fox News group", "HuffPost group")),
         starttime_w3 = as.Date(starttime_w3),
         timing = as.numeric(date - as.Date("2018-10-05"))) %>%
  as_tibble()

# FIGURE 2
#===============================================================================

pd <- pulse %>%
  filter(!is.na(treatment)) %>% # dropping those who are not part of the experiment: NA
  filter(date!="2018-11-19") %>% # drop the data from 2018-11-19 because of missing data
  filter(timing >= (-30) & timing <= 50) %>%
  mutate(week = ifelse(timing>=0, ceiling((timing+1)/7),
                       floor(timing/7))) %>%
  group_by(week, treatment) %>%
  summarize(mean_fn = mean(log_fn_day),
            se_fn = sd(log_fn_day)/sqrt(n()),
            mean_hp = mean(log_hp_day),
            se_hp = sd(log_hp_day)/sqrt(n())
  ) %>%
  ungroup()
plot_data <- merge(
  melt(pd, id.vars = c("week", "treatment"),
       mesure.vars = c("mean_fn", "mean_hp"), value.name = "mean",
       factorsAsStrings = FALSE) %>%
    filter(variable %in% c("mean_fn", "mean_hp")) %>%
    mutate(variable = ifelse(variable == "mean_fn", "Visits to FoxNews.com",
                             "Visits to HuffingtonPost.com"))
  ,
  melt(pd, id.vars = c("week", "treatment"),
       mesure.vars = c("se_fn", "se_hp"), value.name = "se",
       factorsAsStrings = FALSE) %>%
    filter(variable %in% c("se_fn", "se_hp")) %>%
    mutate(variable = ifelse(variable == "se_fn", "Visits to FoxNews.com",
                             "Visits to HuffingtonPost.com"))
)

p_fn <- plot_data %>%
  filter(variable == "Visits to FoxNews.com") %>%
  ggplot(aes(week, mean, color = treatment, group=treatment)) +
  scale_x_continuous("Weeks before and after treatment was administered",
                     limits=c(-4.2, +7.2),
                     breaks=c(seq(-4, -1, by=1), seq(1, 7, by=1)),
                     expand=c(0,0)) +
  scale_y_continuous("Average count of total web visits per day (log)", limits = c(0, 0.32)) +
  geom_linerange(aes(ymin=mean-1*se, ymax=mean+1*se, color=treatment), size=1) +
  geom_linerange(aes(ymin=mean-2*se, ymax=mean+2*se, color=treatment)) +
  scale_color_manual(values = c("darkgray", "red", "blue")) +
  geom_vline(xintercept = 0, lty = 2) +
  geom_hline(yintercept = 0, alpha=.5) +
  facet_grid(treatment~variable) +
  theme_bw() +
  theme(legend.position="none", panel.grid.major.x=element_blank(),
        panel.grid.minor.x=element_blank(), axis.title.x = element_blank(),
        strip.text.y=element_blank())
p_fn
p_hp <- plot_data %>%
  filter(variable == "Visits to HuffingtonPost.com") %>%
  ggplot(aes(week, mean, color = treatment, group=treatment)) +
  scale_x_continuous("Weeks before and after treatment was administered",
                     limits=c(-4.2, +7.2),
                     breaks=c(seq(-4, -1, by=1), seq(1, 7, by=1)),
                     expand=c(0,0)) +
  scale_y_continuous("Average count of total web visits per day (log)", limits = c(0, 0.32)) +
  geom_linerange(aes(ymin=mean-1*se, ymax=mean+1*se, color=treatment), size=1) +
  geom_linerange(aes(ymin=mean-2*se, ymax=mean+2*se, color=treatment)) +
  scale_color_manual("Treatment group", values = c("darkgray", "red", "blue")) +
  geom_vline(xintercept = 0, lty = 2) +
  geom_hline(yintercept = 0, alpha=.5) +
  facet_grid(treatment~variable) +
  theme_bw() +
  theme(legend.position = "none", panel.grid.major.x=element_blank(),
        panel.grid.minor.x=element_blank(), axis.title = element_blank())
p_hp

plot_row <- plot_grid(p_fn, p_hp, rel_widths = c(.50, .50))

# now add the title
title <- ggdraw() +
  draw_label(
    "Weeks before and after treatment was administered",
    x = .5
  ) + theme(plot.margin = margin(0, 0, 0, 0))
p_all <- plot_grid(
  plot_row, title,
  ncol = 1,
  # rel_heights values control vertical title margins
  rel_heights = c(1, .1)
)

ggsave(p_all, file="graphs/main-fig2.pdf", height=5, width=8)
ggsave(p_all, file="graphs/main-fig2.png", height=5, width=8)

# FIRST STAGE: CHANGE IN VISITS TO FOX NEWS / HUFFINGTON POST
#===============================================================================

pd <- pulse %>%
  filter(!is.na(treatment)) %>% # dropping those who are not part of the experiment: NA
  filter(date!="2018-11-19") %>% # drop the data from 2018-11-19 because of missing data
  filter(timing >= (-30) & timing <= 50) %>%
  mutate(week = ifelse(timing>=0, ceiling((timing+1)/7),
                       floor(timing/7))) %>%
  filter(week == 1) %>%
  group_by(id, treatment) %>%
  summarize(mean_fn = mean(totalfn_day),
            mean_hp = mean(totalhp_day),
  ) %>%
  ungroup()

# Change in visits in week after encouragement, compared to control
pd %>% filter(treatment %in% c("Fox News group", "Control group")) %>%
  lm(mean_fn ~ treatment, data=.) %>% summary()

pd %>% filter(treatment %in% c("HuffPost group", "Control group")) %>%
  lm(mean_hp ~ treatment, data=.) %>% summary()

# FIRST STAGE: CHANGE IN DURATION OF VISITS TO FOX NEWS / HUFFINGTON POST
#===============================================================================

pd <- pulse %>%
  filter(!is.na(treatment)) %>% # dropping those who are not part of the experiment: NA
  filter(date!="2018-11-19") %>% # drop the data from 2018-11-19 because of missing data
  filter(timing >= (-30) & timing <= 50) %>%
  mutate(week = ifelse(timing>=0, ceiling((timing+1)/7),
                       floor(timing/7))) %>%
  filter(week == 1) %>%
  group_by(id, treatment) %>%
  summarize(meandurfn_week=mean(dur_fn_day),
            meandurhp_week=mean(dur_hp_day)
  ) %>%
  ungroup()

# Change in duration of visits to treatment sites after encouragement
pd %>% filter(treatment %in% c("Fox News group", "Control group")) %>%
  lm(meandurfn_week ~ treatment, data=.) %>% summary()

pd %>% filter(treatment %in% c("HuffPost group", "Control group")) %>%
  lm(meandurhp_week ~ treatment, data=.) %>% summary()

# CHANGE IN VISITS TO FOX NEWS / HUFFINGTON POST 8 WEEKS AFTER TRTMENT
#===============================================================================

pd <- pulse %>%
  filter(!is.na(treatment)) %>% # dropping those who are not part of the experiment: NA
  filter(date!="2018-11-19") %>% # drop the data from 2018-11-19 because of missing data
  filter(timing >= (-30) & timing <= 50) %>%
  mutate(week = ifelse(timing>=0, ceiling((timing+1)/7),
                       floor(timing/7))) %>%
  filter(week == 8) %>%
  group_by(id, treatment) %>%
  summarize(mean_fn = mean(totalfn_day),
            mean_hp = mean(totalhp_day),
  ) %>%
  ungroup()

# Change in visits in week after encouragement, compared to control
pd %>% filter(treatment %in% c("Fox News group", "Control group")) %>%
  lm(mean_fn ~ treatment, data=.) %>% summary()

pd %>% filter(treatment %in% c("HuffPost group", "Control group")) %>%
  lm(mean_hp ~ treatment, data=.) %>% summary()

# Number of compliers according to pre-registered metric
#===============================================================================

(svy %>%
  filter(W3_PATA306_treatment_w3=="FoxNews") %>%
  summarise(mean(comp_fn, na.rm=TRUE))) - # treated = compliers + always-takers
(svy %>%
  filter(W3_PATA306_treatment_w3=="Control") %>%
  summarise(mean(comp_fn, na.rm=TRUE))) # always-takers

(svy %>%
    filter(W3_PATA306_treatment_w3=="HuffPost") %>%
    summarise(mean(comp_hp, na.rm=TRUE))) - # treated = compliers + always-takers
  (svy %>%
     filter(W3_PATA306_treatment_w3=="Control") %>%
     summarise(mean(comp_hp, na.rm=TRUE))) # always-takers

# Similar computation but with model
lm_robust(comp_fn ~ W3_PATA306_treatment_w3, data =
            filter(svy, W3_PATA306_treatment_w3 != "HuffPost"))

lm_robust(comp_hp ~ W3_PATA306_treatment_w3, data =
            filter(svy, W3_PATA306_treatment_w3 != "FoxNews"))

# % of users who increased visits to assigned site
svy %>%
  filter(!is.na(log_fn_6w) & !is.na(log_fn_pre)) %>%
  # computing raw counts from logs
  mutate(fn_6w = exp(log_fn_6w) - 1,
         fn_pre = exp(log_fn_pre) - 1,
         hp_6w = exp(log_hp_6w) - 1,
         hp_pre = exp(log_hp_pre) - 1) %>%
  group_by(W3_PATA306_treatment_w3) %>%
  summarise(fn_increase = mean(fn_6w>fn_pre, na.rm=TRUE),
            hp_increase = mean(hp_6w>hp_pre, na.rm=TRUE))

# FIGURE 3
#===============================================================================

# potential control variables across all models
vars <- c("party7", "age", "agesq", "female", "raceeth", "educ",
          "ideo", "income", "employ", "state", "polint", "freq_tv", "freq_np",
          "freq_rad", "freq_net", "freq_disc", "log_news_pre", "diet_mean_pre")

########################################################
### News visits
########################################################

dvs <- c("weekly_log_news_plus1_1w", "weekly_log_news_plus1_4w",
         "weekly_log_news_plus1_6w", "log_cons_1w", "weekly_log_cons_4w",
         "weekly_log_cons_6w", "log_lib_1w", "weekly_log_lib_4w", "weekly_log_lib_6w")

ests <- NULL
for(dv in dvs) {
  dat <- tidy(run_model(dv = dv, trt = "FoxNews")[[1]])[2,]
  dat$trt <- "Fox News"
  ests <- rbind(ests, dat)
  dat <- tidy(run_model(dv = dv)[[1]])[2,]
  dat$trt <- "HuffPost"
  ests <- rbind(ests, dat)
}

rownames(ests) <- NULL
ests <- ests %>% select(estimate, conf.low, conf.high, std.error, p.value, outcome, trt)

########################################################
### Twitter link shares (lib)
########################################################

# creating Twitter variables
svy$log_lib_links <- log(svy$lib_links+1)
svy$log_lib_links_pre <- log(svy$lib_links_pre+1)
svy$log_total_links_pre <- log(svy$total_links_pre+1)

trt <- "HuffPost"
dv <- "log_lib_links"
dv_pre <- "log_lib_links_pre"
D <- "comp_hp"

# using chrome vs others as blocks here
svy$chrome <- ifelse(svy$W3_Browser_treatment_w3=="Chrome", 1, 0)
## DIM
(dim <- difference_in_means(formula(paste0(dv, " ~ W3_PATA306_treatment_w3")),
                            blocks = chrome,
                            data = svy,
                            condition1 = "Control",
                            condition2 = trt))
## ITT, with Lin's covariate adjustment
itt <- run_model(dv = dv, dv_pre = dv_pre, trt = trt, blocks="chrome", more_vars="log_total_links_pre")
compute_proportion_missing_covars(itt)

## CACE
cace <- estimate_cace(Y=dv, D = D, Z = "W3_PATA306_treatment_w3",
                      X = extract_covariates(itt), trt=trt)

dat <- cace %>% tidy() %>% filter(term == "comp_hp") %>% dplyr::select(estimate, conf.low, conf.high, std.error, p.value)
dat$outcome <- "Link shares on Twitter"
dat$trt <- "HuffPost"
ests <- rbind(ests, dat)

########################################################
### Twitter link shares (cons)
########################################################

# creating Twitter variables
svy$log_cons_links <- log(svy$cons_links+1)
svy$log_cons_links_pre <- log(svy$cons_links_pre+1)
svy$log_total_links_pre <- log(svy$total_links_pre+1)

trt <- "FoxNews"
dv <- "log_cons_links"
dv_pre <- "log_cons_links_pre"
D <- "comp_fn"

# using chrome vs others as blocks here
svy$chrome <- ifelse(svy$W3_Browser_treatment_w3=="Chrome", 1, 0)

## DIM
(dim <- difference_in_means(formula(paste0(dv, " ~ W3_PATA306_treatment_w3")),
                            blocks = chrome,
                            data = svy,
                            condition1 = "Control",
                            condition2 = trt))
## ITT, with Lin's covariate adjustment
itt <- run_model(dv = dv, dv_pre = dv_pre, trt = trt,
                 blocks="chrome", more_vars = "log_total_links_pre")
compute_proportion_missing_covars(itt)
## CACE
cace <- estimate_cace(Y=dv, D = D, Z = "W3_PATA306_treatment_w3",
                      X = extract_covariates(itt), trt=trt)

dat <- cace %>% tidy() %>% filter(term == "comp_fn") %>%
  dplyr::select(estimate, conf.low, conf.high, std.error, p.value)
dat$outcome <- "Link shares on Twitter"
dat$trt <- "Fox News"
ests <- rbind(ests, dat)

########################################################
### Event knowledge: HP group
########################################################

trt <- "HuffPost"
dv <- "event_mokken"
dv_pre <- "event_pre_mokken"
D <- "comp_hp"

# standardizing event knowledge variable
svy$event_mokken <- svy$event_mokken/
  sd(svy$event_mokken[which(
    svy$W3_PATA306_treatment_w3 == "Control")], na.rm = TRUE)

## ITT, with Lin's covariate adjustment
itt <- run_model(dv = dv, trt = trt, dv_pre = dv_pre)

## CACE
cace <- estimate_cace(Y=dv, D = D, Z = "W3_PATA306_treatment_w3",
                      X = extract_covariates(itt), trt=trt)

dat <- cace %>% tidy() %>% filter(term == "comp_hp") %>% dplyr::select(estimate, conf.low, conf.high, std.error, p.value)
dat$outcome <- "Event knowledge"
dat$trt <- "HuffPost"
ests <- rbind(ests, dat)

########################################################
### Event knowledge: FN group
########################################################

trt <- "FoxNews"
dv <- "event_mokken"
dv_pre <- "event_pre_mokken"
D <- "comp_fn"

# standardizing event knowledge variable
svy$event_mokken <- svy$event_mokken/
  sd(svy$event_mokken[which(
    svy$W3_PATA306_treatment_w3 == "Control")], na.rm = TRUE)

## ITT, with Lin's covariate adjustment
itt <- run_model(dv = dv, trt = trt, dv_pre = dv_pre)

## CACE
cace <- estimate_cace(Y=dv, D = D, Z = "W3_PATA306_treatment_w3",
                      X = extract_covariates(itt), trt=trt)

dat <- cace %>% tidy() %>% filter(term == "comp_fn") %>%
  dplyr::select(estimate, conf.low, conf.high, std.error, p.value)
dat$outcome <- "Event knowledge"
dat$trt <- "Fox News"
ests <- rbind(ests, dat)

########################################################
### Producing graph
########################################################

ests$type <- str_sub(ests$outcome, 1, -4)
ests$type <- str_remove(ests$type, "weekly_")
ests$type <- c("News visits", "Conservative news visits", "Liberal news visits",
               "Liberal/conservative\n link shares on Twitter", "Event knowledge")[match(ests$type, unique(ests$type))]
ests$outcome[seq(1, 21, by = 2)] <- c("1 week", "4 weeks", "6 weeks",
                                      "1 week", "4 weeks", "6 weeks",
                                      "1 week", "4 weeks", "6 weeks", "4 weeks", "Wave 4")
ests$outcome[seq(2, 22, by = 2)] <- c("1 week", "4 weeks", "6 weeks",
                                      "1 week", "4 weeks", "6 weeks",
                                      "1 week", "4 weeks", "6 weeks", "4 weeks", "Wave 4")

ests$type <- factor(ests$type, levels = c("News visits", "Conservative news visits", "Liberal news visits",
                                          "Liberal/conservative\n link shares on Twitter", "Event knowledge"))

g <- ggplot(data = filter(ests), aes(y=estimate, x=outcome, color=trt)) +
  facet_grid(~ type, scales = "free_x") +
  geom_hline(yintercept = 0, colour = gray(1/2), lty = 2) +
  geom_pointrange(aes(y = estimate,
                      ymin = conf.low,
                      ymax = conf.high), position=position_dodge(width=-.5))+
  scale_color_manual("Treatment", values=c("red", "blue")) +
  ylim(-.7, 1.5) + xlab("") + ylab("") +
  theme_minimal() + theme(legend.position = "bottom", axis.text.x = element_text(angle = 45))
g

ggsave(g, file = "graphs/main-fig3.pdf", width = 10, height = 6)
ggsave(g, file = "graphs/main-fig3.png", width = 10, height = 6)

# results highlighted in manuscript text
ests %>% filter(trt == "Fox News" &
                  type == "Conservative news visits")


# Databricks notebook source
# MAGIC %md
# MAGIC #libraries and imported from data related to the SABHA correction method

# COMMAND ----------

# this file provides functions for computing q-hat for the SABHA method
# includes:
# Solve_q_step = q-hat of the form (eps,...,eps,1,...,1)
# Solve_q_ordered = q-hat of the form (q1,...,qn) with eps<=q1<=q2<=...<=qn<=1
# Solve_q_block = q-hat that is block-wise constant, and eps<=q<=1
# Solve_q_TV_1dim = q-hat that has bounded 1d total variation norm, and eps<=q<=1
# Solve_q_TV = q-hat that has bounded total variation norm on a specified graph, and eps<=q<=1

##########################################################
## SABHA with ordered q: q = step function
##########################################################

# Solve_q_step: returns a vector q subject to the constraint that (q1, q2, ...,  qn) = (eps, eps, ..., eps, 1, 1, ..., 1), with as many eps's as possible, subject to sum_i 1{P[i]>tau}/q[i](1-tau) <= n
Solve_q_step = function(Pvals, tau, eps){
  n = length(Pvals)
  sum_p_over_threshold = sum(Pvals > tau)
  K = max(which(cumsum(Pvals > tau) <= (n*(1-tau) - sum_p_over_threshold) / (1/eps - 1)), 0)

  return (c(rep(eps, K), rep(1, n-K)))
}

##########################################################
## SABHA with ordered q: q satisfies eps<=q1<=q2<=...<=qn=1
##########################################################

Solve_q_ordered = function(Pvals, tau, eps, ADMM_params){
	PAVA_alg = create_PAVA_alg_function()
	M = diag(length(Pvals))
	q = Solve_q_ADMM(Pvals, tau, eps, M, PAVA_alg, ADMM_params)
	q
}

create_PAVA_alg_function = function(){
	function(y){
         # solving: min{1/2 ||x-y||^2_2 : x_1<=..<=x_n}
	       # PAVA algorithm (Barlow et al 1972)
	       n=length(y)
	       thresh = 1e-8
	       groups = 1:n
	       block = 1

	       stop = FALSE
	       while(!stop){
		         if(any(groups==block+1)){
			             block_plus = which(groups==block+1)
			             if(mean(y[which(groups==block)])<=mean(y[which(groups==block+1)])+thresh){
				              block = block+1
			             } else{
				              groups[which(groups>block)] = groups[which(groups>block)] - 1
				              stop_inner = FALSE
				              while(!stop_inner)
					               if(any(groups==block-1)){
						               if(mean(y[which(groups==block-1)])>mean(y[which(groups==block)])+thresh){
							                groups[which(groups>=block)] = groups[which(groups>=block)] - 1
							                block = block-1
						               } else{
							                stop_inner=TRUE
						               }
					               } else{
						                stop_inner=TRUE
					               }
				           }
			       } else{
				        stop=TRUE
			       }
	       }
	       x=y
	       for(i in 1:max(groups)){
		         x[which(groups==i)]=mean(y[which(groups==i)])
	       }
	       x
     }

}

##########################################################
## SABHA with block q: q = constant over blocks
##########################################################

Solve_q_block = function(Pvals, tau, eps, blocks, ADMM_params){
	# blocks[i] gives the index of the block to which Pvals[i] belongs
	block_proj = create_block_function(blocks)
	q_init = block_proj((Pvals>tau)/(1-tau))
	if(min(q_init)>=eps & max(q_init)<=1){
		q = q_init
	}else{
		M = diag(length(Pvals))
		q = Solve_q_ADMM(Pvals, tau, eps, M, block_proj, ADMM_params)
	}
	q
}

create_block_function = function(blocks){
	function(y){
         # solving: min{1/2 ||x-y||^2_2 : x is constant over the blocks}
		x = y
		block_inds = sort(unique(blocks))
		for(i in block_inds){
			x[which(blocks==block_inds[i])] = mean(x[which(blocks==block_inds[i])])
		}
		x
	}
}

##########################################################
## SABHA with TV norm constraint on q: ||q||_TV <= TV_bd
##########################################################

Solve_q_TV_1dim = function(Pvals, tau, eps, TV_bd, ADMM_params){
	edges = cbind(1:(length(Pvals)-1),2:length(Pvals))
	Solve_q_TV(Pvals, tau, eps, edges, TV_bd, ADMM_params)
}

Solve_q_TV_2dim = function(Pvals, tau, eps, TV_bd, ADMM_params){
	n1 = dim(Pvals)[1]
	n2 = dim(Pvals)[2]
	edges = NULL
	get_ind = function(i,j){i+(j-1)*n1}
	# horizontal edges
	for(i in 1:n1){for(j in 1:(n2-1)){edges=rbind(edges,c(get_ind(i,j),get_ind(i,j+1)))}}
	# vertical edges
	for(j in 1:n2){for(i in 1:(n1-1)){edges=rbind(edges,c(get_ind(i,j),get_ind(i+1,j)))}}
	Solve_q_TV(c(Pvals), tau, eps, edges, TV_bd, ADMM_params)
}

Solve_q_TV = function(Pvals, tau, eps, edges, TV_bd, ADMM_params){
	# edges is a e-by-2 matrix giving the edges of the adjacency graph
	# edges[i,1:2] gives the indices of the nodes on the i-th edge
	# constraint: sum_{i=1,..,e} |q[edges[i,1]] - q[edges[i,2]]| <= TV_bd
	L1_proj = create_L1_function(TV_bd)
	nedge = dim(edges)[1]; n = length(Pvals)
	M = matrix(0,nedge,n); for(i in 1:nedge){M[i,edges[i,1]]=1; M[i,edges[i,2]]=-1}
	q = Solve_q_ADMM(Pvals, tau, eps, M, L1_proj, ADMM_params)
	q
}

create_L1_function = function(bound){
	function(y){
         # solving: min{1/2 ||x-y||^2_2 : ||x||_1 <= bound}
        if(sum(abs(y))<=bound){x=y} else{
			    mu = sort(abs(y), decreasing = TRUE)
    	    xi = max(which(mu - (cumsum(mu)-bound)/(1:length(mu))>0))
        	theta = (sum(mu[1:xi])-bound)/xi
	        tmp = abs(y)-theta
    	    x = rep(0, length(tmp))
        	x[which(tmp>0)] = tmp[which(tmp>0)]
	        x[which(tmp<=0)] = 0
    	    x = x*sign(y)
    	  }
        x
	}
}

##########################################################
## SABHA ADMM algorithm
##########################################################

Solve_q_ADMM = function(Pvals, tau, eps, M, projection, ADMM_params){
# min -sum_i (B[i]*log((1-tau) q[i]) + (1-B[i])*log(1-(1-tau) q[i]))
# subject to (1) q \in Qset (characterized by M*q \in Mset)
# and (2) sum_i B[i]/q[i] <= gamma and (3) eps<=q<=1
# introduce auxiliary variables x, y under the constraint Mq = x, q = y
# ADMM optimization:
# minimize -sum_i (B_i*log((1-tau) q_i)+(1-B_i)*log(1-(1-tau) q_i)) + <u, Mq-x> + <v, q-y> + alpha/2 ||Mq-x||^2 + beta/2 ||q-y||^2 + alpha/2 (q-qt)'(eta I - M'M)(q-qt)
# where qt is the previous iteration's q value

# ADMM_params are: alpha, beta, eta, max_iters, converge_thr
	alpha_ADMM = ADMM_params[1]
	beta = ADMM_params[2]
	eta = ADMM_params[3]
	max_iters = ADMM_params[4]
	converge_thr = ADMM_params[5]

	n = length(Pvals)
	B = (Pvals > tau)
  gamma = n*(1-tau) # bound on sum_i (Pvals[i]>tau) / q[i]*(1-tau)
	q = y = rep(1,n)
	v = rep(0,n)
	u = x = rep(0,dim(M)[1])

	converge_check = function(q,x,y,u,v,q_old,x_old,y_old,u_old,v_old){
		max(c(sqrt(sum((q-q_old)^2))/sqrt(1+sum(q_old^2)),
          sqrt(sum((x-x_old)^2))/sqrt(1+sum(x_old^2)),
          sqrt(sum((y-y_old)^2))/sqrt(1+sum(y_old^2)),
          sqrt(sum((u-u_old)^2))/sqrt(1+sum(u_old^2)),
          sqrt(sum((v-v_old)^2))/sqrt(1+sum(v_old^2))))
	}

	stop = FALSE
	iter = 0
  while(!stop){
    iter = iter+1
    q_old = q; x_old = x; y_old = y; u_old = u; v_old = v
    q = q_update(B, M, tau,eps,q,x,y,u,v,alpha_ADMM,gamma,beta, eta)
    x = x_update(B, M, tau,eps,q,x,y,u,v,alpha_ADMM,gamma,beta, eta, projection)
    y = y_update(B, M, tau,eps,q,x,y,u,v,alpha_ADMM,gamma,beta, eta)
    u = u_update(B, M, tau,eps,q,x,y,u,v,alpha_ADMM,gamma,beta, eta)
	  v = v_update(B, M, tau,eps,q,x,y,u,v,alpha_ADMM,gamma,beta, eta)
	  if(converge_check(q,x,y,u,v,q_old,x_old,y_old,u_old,v_old)<=converge_thr){stop=TRUE}
	  if(iter>=max_iters){stop=TRUE}
  }

  return(q)

}

# inverse_sum_prox solves: min{1/2 ||x-y||^2 : x_i>0, sum_i 1/x_i <= bound}
# Used in y-update step of ADMM
inverse_sum_prox = function(y,bound){

	y = pmax(0,y) # the solution will have all positive x_i's now
					# and we can now ignore the constraint x_i>0

	if(sum(1/y)<= bound){
		x=y
	}else{ # use Lagrange multipliers

		# we should have - lambda * d/dx_j (sum_i 1/x_i) = d/dx_j (1/2 ||x-y||^2)
		# for all j, for some single lambda>0
		# in other words, lambda / x^2 = x-y (this holds elementwise)
		# rearranging, lambda = x^3 - x^2*y
		# let c = log(lambda) so that it's real-valued
		# we need to solve x^3 - x^2*y - exp(c) = 0 (elementwise)

		cuberoot = function(c){ # this solves the cubic equation x^3-x^2*y-exp(c)=0
			temp1 = ((y/3)^3 + exp(c)/2 + (exp(c)*(y/3)^3 + exp(c)^2/4)^0.5)
			temp2 = ((y/3)^3 + exp(c)/2 - (exp(c)*(y/3)^3 + exp(c)^2/4)^0.5)
			x = sign(temp1)*abs(temp1)^(1/3) + sign(temp2)*abs(temp2)^(1/3) + (y/3)
			x
		}

		# now we need to choose c, i.e. choose the lagrange multiplier lambda=exp(c)
		# the right value of c is the one that produces an x satisfying sum_i 1/x_i = bound

		c = uniroot(function(c){sum(1/cuberoot(c))-bound},c(-100,100))$root
		x = cuberoot(c)
	}
	x
}

q_update = function(B, M, tau,eps,q,x,y,u,v,alpha,gamma,beta, eta){
# minimize -sum_i (B_i*log((1-tau) q_i)+(1-B_i)*log(1-(1-tau) q_i)) + <u, Mq-x> + <v, q-y> + alpha/2 ||Mq-x||^2 + beta/2 ||q-y||^2 + alpha/2 (q-qt)'(eta I - M'M)(q-qt)
# where qt is the previous iteration's q value
# equivalently, -sum_i (B_i*log((1-tau) q_i)+(1-B_i)*log(1-(1-tau) q_i)) + (alpha eta + beta)/2 * ||q-w||_2^2
# where w = - (M'(ut + alpha (M qt - xt)) + (vt - beta yt - alpha eta qt))/(alpha eta + beta)

	w = - ( t(M)%*%(u + alpha*(M%*%q - x)) + (v - beta*y - alpha*eta*q) )/(alpha*eta + beta)

	q[B==1] = (w[which(B==1)]+sqrt(w[which(B==1)]^2+4/(alpha*eta + beta)))/2
	q[B==0] = ((w[which(B==0)]+1/(1-tau))-sqrt((w[which(B==0)]-1/(1-tau))^2+4/(alpha*eta+beta)))/2
	q[q<eps] = eps
	q[q>1] = 1
	q
}

x_update = function(B, M, tau,eps,q,x,y,u,v,alpha,gamma,beta, eta, projection){
	# Proj_Mset (M q + u/alpha)
	x = projection(M%*%q + u/alpha)
}

y_update = function(B, M, tau,eps,q,x,y,u,v,alpha,gamma,beta, eta){
	# Prof_B (q + v/beta)
	# where B = {sum_i B[i]/y[i]<= gamma}
	y = q + v/beta
	y[which(B==1)] = inverse_sum_prox((q+v/beta)[which(B==1)], gamma)
	y
}

u_update = function(B, M, tau,eps,q,x,y,u,v,alpha,gamma,beta, eta){
	u = u + alpha * (M%*%q -x)
	u
}

v_update = function(B, M, tau,eps,q,x,y,u,v,alpha,gamma,beta, eta){
	v = v + beta * (q-y)
	v
}

BH_method = function(pvals,alpha){
	khat=max(c(0,which(sort(pvals)<=alpha*(1:length(pvals))/length(pvals))))
	which(pvals<=alpha*khat/length(pvals))
}

Storey_method = function(pvals,alpha,thr){
	est_proportion_nulls=min(1,mean(pvals>thr)/(1-thr))
	pvals[pvals>thr] = Inf
	khat=max(c(0,which(sort(pvals)<=alpha/est_proportion_nulls*(1:length(pvals))/length(pvals))))
	which(pvals<=alpha/est_proportion_nulls*khat/length(pvals))
}

SABHA_method = function(pvals, qhat, alpha, tau){
	# Use the original, or estimated q as input
	pvals[pvals>tau] = Inf
	khat=max(c(0,which(sort(qhat*pvals)<=alpha*(1:length(pvals))/length(pvals))))
    which(qhat*pvals<=alpha*khat/length(pvals))
}

# COMMAND ----------

install.packages("vegan")
install.packages("ape")
install.packages("arules")
install.packages("jmuOutlier")
install.packages("coin")
install.packages("data.table")
install.packages("perm")
install.packages("ThresholdROC")
library(SparkR)
library(ape)
library(vegan)
library(arules)
library(jmuOutlier )
library(coin)
library(perm)
library(data.table)
library(ThresholdROC)

#install.packages("ggplot2")

# COMMAND ----------

install.packages("tibble")
install.packages("purrr")
library(purrr)
library(dplyr)
library(tibble)

# COMMAND ----------

# MAGIC %run /PhdProject/utils

# COMMAND ----------

# MAGIC %md
# MAGIC #uploading data

# COMMAND ----------

sc <- sparklyr::spark_connect(method = "databricks")
SparkR::registerTempTable(tableToDF("imagingFrame"), "imagingFrame")
imagingFrame<-     as_tibble ( as.data.frame(dplyr::tbl(sc, "imagingFrame")) )

SparkR::registerTempTable(tableToDF("numbsFrame"), "numbsFrame")
controlVsStudyFrame<-   as_tibble(as.data.frame(dplyr::tbl(sc, "numbsFrame")))

# COMMAND ----------

# MAGIC %md
# MAGIC #Utility functions

# COMMAND ----------

# performing the Permanova - method detecting weather there is a relation between some value and group of other values
# We will also check First the beta dispersion  to say weather it is sufficiently small in order to be able to still in a valid way perworm permanova
# @param mainFrame {DataFrame} representin all data we are analyzing
# @param referenceColumnName {String} name of column to which we want to check weather it has a significant correlation with all other columns (so reference column holds dependent variable)
# returns {List} return p value of permanova and p value related of beta dispersion in order for the test to be valid we need
myPermanova <- function (mainFrame,referenceColumnName) {
reducedFr <-  mainFrame %>% dplyr::select(-all_of(referenceColumnName)) # %>% as.matrix() %>% sqrt() # square root transformation in order to reduce the effect of strongest values

  parmaNov<-adonis(reducedFr ~ mainFrame[[referenceColumnName]], perm=999)
  #calculating permanova p value
  permanovaPValue <- as.data.frame(as.data.frame(parmaNov$aov.tab)[6])[1,1]

  dist<-vegdist(reducedFr, method='jaccard')
  dispersion<-betadisper(dist, group=mainFrame[[referenceColumnName]])

  c(permanovaPValue, permutest(dispersion) )

}

# COMMAND ----------

# based on the implementation from perm test https://cran.r-project.org/web/packages/perm/perm.pdf
myPermTest <- function(booleansColName, numbVectorColName, frame) {
  framee <-  frame %>% dplyr::select(booleansColName,numbVectorColName)  %>% dplyr::filter( !is.na(.[1]))%>% dplyr::filter( !is.na(.[2]))
  numbVector <- framee[[numbVectorColName]]
  booleans<- framee[[booleansColName]]

trueOnes <-numbVector[booleans]
falseOnes <-numbVector[!booleans]
if(length(falseOnes)>1){
permTS(trueOnes , falseOnes)$p.values[1][["p.twosided"]]   } else{2}

}
#myPermTest("FocalAccumulation", "SuvInFocus", imagingFrame)

#Implementation of structure aware BH we supply p values and labels both vectors should be of the same length
myBH <- function (pValues,labels) {
n = length(pValues) # here important  we need to
BH_Res = Storey_Res = SABHA_Res = rep(0,n)

############## set of parameters copied from fMRI example
alpha = 0.05 # target FDR level
tau = 0.5; eps = 0.1 # parameters for SABHA
ADMM_params = c(10^2, 10^3, 2, 15000, 1e-3) # alpha_ADMM,beta,eta,max_iters,converge_thr

# gather results
labels[SABHA_Res ==1]

qhat = Solve_q_block(pValues,tau,eps,labels,ADMM_params)

# it returns a vector with the same order as supplied at the beginning in this vecto when we did not achieved significance we get 0 when we did we get 1
SABHA_Res[SABHA_method(pValues,qhat,alpha,tau)] = 1
#selecting from labels those that are significantly significant

labels[SABHA_Res ==1]
}

# COMMAND ----------

# MAGIC %md
# MAGIC #Analyzing image characteristics

# COMMAND ----------

#Here we define boolean columns we are intrested in
colsprim<- names(imagingFrame)
cols<- colsprim[!colsprim %in% c("SuvInFocus","TBR" ,"Fluid", "IrregularBorders","FocalAccumulation" )]
pValsA<- cols %>%
  map( ~myPermTest(.x,  "SuvInFocus", imagingFrame ))
pValsB<- cols %>%
  map( ~myPermTest(.x,  "TBR", imagingFrame ))
df<- as.data.frame(cbind(cols, flatten_dbl(pValsA), flatten_dbl(pValsB) ))
colnames(df) <- c("imageCharacteristic", "SuvInFocus", "TBR")
#result<- frameWithPs %>% dplyr::filter(SuvInFocus<2)
# result <-dplyr::transform(frameWithPs, SuvInFocus      = as.numeric(SuvInFocus),
#                                     TBR = as.numeric(TBR))
df[] <- lapply(df, as.character)
df <- data.frame(lapply(df, function(x) ifelse(!is.na(as.numeric(x)), as.numeric(x),  x)))
result<- df

# COMMAND ----------

labels<- c( result[[1]],result[[1]]  )
pValues<- c(result[[2]],result[[3]])

n = length(pValues) # here important  we need to
BH_Res = Storey_Res = SABHA_Res = rep(0,n)

############## set of parameters copied from fMRI example
alpha = 0.05 # target FDR level
tau = 0.5; eps = 0.1 # parameters for SABHA
ADMM_params = c(10^2, 10^3, 2, 15000, 1e-3) # alpha_ADMM,beta,eta,max_iters,converge_thr

# gather results
labels[SABHA_Res ==1]

qhat = Solve_q_block(pValues,tau,eps,labels,ADMM_params)

# it returns a vector with the same order as supplied at the beginning in this vecto when we did not achieved significance we get 0 when we did we get 1
SABHA_Res[SABHA_method(pValues,qhat,alpha,tau)] = 1
#selecting from labels those that are significantly significant

result[[1]][SABHA_Res ==1]

# COMMAND ----------

labels<- c( result[[1]],result[[1]]  )
pValues<- c(result[[2]],result[[3]])

validImagingTests<-  as.character(result[[1]][SABHA_Res ==1] )

# COMMAND ----------

# MAGIC %md
# MAGIC #looking for association pairs in imaging characteristics

# COMMAND ----------

frameOfBools<- imagingFrame %>% dplyr::select(-SuvInFocus, -TBR, -Fluid)

# COMMAND ----------

#rules <- apriori(frameOfBools, parameter = list(support = 0.01, confidence = 0.6))
trans <- as(frameOfBools, "transactions")
summary(trans)

# COMMAND ----------

install.packages("arulesViz")
library(arulesViz)
itemsets <- apriori(trans, parameter = list(target = "frequent",
  supp=0.001, minlen = 2, maxlen=4))

plot(head(sort(itemsets), n=50), method = "graph", control=list(cex=.8))

# COMMAND ----------

rules<- apriori(trans,parameter=list(supp=0.3,conf=.80, minlen=3,maxlen=7, target='rules')) # run a priori algorithms
arules<-rules

# COMMAND ----------

inspect(sort(arules, by="confidence", decreasing=TRUE))

# COMMAND ----------

rules_dataframe <- as(rules, 'data.frame') %>% filter(lift>1.2)

# COMMAND ----------

display(as.DataFrame(rules_dataframe))

# COMMAND ----------

# MAGIC %md
# MAGIC #Analyzing numerical values like Age ...

# COMMAND ----------

controlVsStudyFrame <-transform(controlVsStudyFrame, isStudy  = as.logical(isStudy), ageInYearsWhenSurgery = as.numeric(ageInYearsWhenSurgery)   )
controlVsStudyFrame

# COMMAND ----------

# "Comapring age during study in control and study group"
ageTest<- myPermTest("isStudy",  "ageInYearsWhenSurgery", controlVsStudyFrame )
# "Comapring prosthesis type in control and study group"
prosthesisTypeTest<-fisher.test(controlVsStudyFrame$prosthesisType == "stentgraft", controlVsStudyFrame$isStudy )$p.value
# "Comapring prosthesis location in control and study group"
locFrame <- controlVsStudyFrame %>% dplyr::filter(simplifiedClassification == "Y" | simplifiedClassification == "B") # filtering out or localistaions other than thoracic and abdominal aorta
locTest <- fisher.test(locFrame$simplifiedClassification == "Y", locFrame$isStudy )$p.value

studyVsControl<- myBH( c(ageTest, prosthesisTypeTest, locTest), c("ageTest","prosthesisTypeTest","locTest"))

# COMMAND ----------

# MAGIC %md
# MAGIC # looking for treshold values

# COMMAND ----------

#SUV max analysis
trueOnesSUV <-controlVsStudyFrame$SuvInFocus[controlVsStudyFrame$isStudy]
falseOnesSUV <-controlVsStudyFrame$SuvInFocus[!controlVsStudyFrame$isStudy]
#TBR analysis
trueOnesTBR <-controlVsStudyFrame$TBR[controlVsStudyFrame$isStudy]
falseOnesTBR <-controlVsStudyFrame$TBR[!controlVsStudyFrame$isStudy]

tresholdSuv<- thres2(trueOnesSUV,falseOnesSUV,0.01 )[[1]]$thres
tresholdTBR<- thres2(trueOnesTBR,falseOnesTBR,0.01 )[[1]]$thres

# COMMAND ----------

# MAGIC %md
# MAGIC #export data

# COMMAND ----------

sparkR.session()
#dataFrame p values related to imaging characteristics
result
# list of strings representing which imaging characteristics still have valid p after B-H correction
validImagingTests

# tests that are valid after BH correction
# ageTest string  "Comapring age during study in control and study group"
# prosthesisTypeTeststring "Comapring prosthesis type in control and study group"
# locTest string "Comapring prosthesis location in control and study group"
studyVsControl

# COMMAND ----------

#registering table so later with already developed functions in scala we can save them
registerTempTable(as.DataFrame(result), "imegeCharRawData")
registerTempTable(as.DataFrame(as.data.frame(cbind(validImagingTests,studyVsControl))), "statisticalValid")

titless<-c("ageTest","prosthesisTypeTest","locTest")
numbss<-c(ageTest, prosthesisTypeTest, locTest)
registerTempTable(as.DataFrame(as.data.frame(cbind(titless ,numbss))), "rawNotImage")

registerTempTable(as.DataFrame(as.data.frame(cbind(tresholdSuv ,tresholdTBR))), "tresholds")
registerTempTable(as.DataFrame(rules_dataframe),"arules")

# COMMAND ----------

# MAGIC %scala
# MAGIC
# MAGIC createTablesWithMeta( "imegeCharRawData", "raw p values that we analyzed about the image characteristics" , spark.table("imegeCharRawData"))
# MAGIC createTablesWithMeta( "statisticalValid", "statistically significal dependence proven" , spark.table("statisticalValid"))
# MAGIC createTablesWithMeta( "rawNotImage", "p values related to test not connected immidiately to image" , spark.table("rawNotImage"))
# MAGIC createTablesWithMeta( "tresholds", "tresholds fur SUV max and TBR based on data in study and control groups" , spark.table("tresholds"))

# COMMAND ----------

# MAGIC %scala
# MAGIC createTablesWithMeta( "arules", "associative rules" , spark.table("arules"))

notebooks/PhdProject/main Statistical Analysis/Hypothesis testing R.r


# Load required library packages from specified CRAN repo
if(!require(tidyverse)) install.packages("tidyverse",repos = "https://mirror.lyrahosting.com/CRAN/")
if(!require(dplyr)) install.packages("dplyr",repos = "https://mirror.lyrahosting.com/CRAN/")
library(tidyverse)
library(dplyr)

givts_per_periode <- function(givt_all,periode) {

givt_all$Datum.begin <- as.POSIXct(givt_all$Datum.begin,format="%d-%m-%Y")
givt_all$period <- cut(givt_all[,"Datum.begin"], breaks=periode)

Collecte1 <- givt_all %>% filter(str_detect(Toewijzing, var_Collecte1_label)&!str_detect(Toewijzing, var_Collecte2_label)) %>% filter(!is.na(Brutobedrag),!is.na(Aantal.giften)) %>% group_by(period) %>% summarise(totaalKerk=sum(as.numeric(str_replace(Brutobedrag,',','.'))))
Collecte2 <- givt_all %>% filter(str_detect(Toewijzing, var_Collecte2_label)) %>% filter(!is.na(Brutobedrag),!is.na(Aantal.giften)) %>% group_by(period) %>% summarise(totaalDiaconie=sum(as.numeric(str_replace(Brutobedrag,',','.'))))
Collectes_per_Period <- merge(Collecte1, Collecte2, by.x="period",by.y="period")

return(Collectes_per_Period)
}

givts_plot <- function(givt_all,periode) {
Collectes <- givts_per_periode(givt_all,periode)
myplot <- barplot(t(Collectes[,2:3]), main=var_Main_label, xlab=var_X_axis_label, ylab=var_Y_axis_label, col=c(var_Collecte1_color,var_Collecte2_color), beside = T, names.arg=Collectes[order(as.Date(as.character(Collectes[,1]), "%Y-%m-%d")),1], las=1)
legend("topleft", legend = c(var_Collecte1_label, var_Collecte2_label), fill = c(var_Collecte1_color,var_Collecte2_color))
mysubtitle = paste(var_Subtitle_label,periode,dep="")
mtext(side = 3, line = 0.25, at = 1, adj = -0.8, mysubtitle)
return(myplot)
}


require(caret)
a <- read.csv("/Users/tom/projects-workspace/set-game/data/train-out-shading.csv", header = FALSE, col.names = c("label", "v1"))
a$label <- as.factor(a$label)
set.seed(1)
aFit <- train(label ~ ., data = a, method = "svmRadial", preProc = c("center", "scale"),
              tuneLength = 10,
              tr = trainControl(method = "repeatedcv", repeats = 5, classProbs = TRUE))
aFit

aFitKnn <- train(label ~ ., data = a, method = "knn", preProc = c("center", "scale"))
aFitKnn

# Try using the model to predict test data labels
testData <- read.csv("/Users/tom/projects-workspace/set-game/data/test-out-shading.csv", col.names = c("label", "v1"))
testData$label <- as.factor(testData$label)
testDataNoLabel <- testData[-c(1)]

predictions <- predict(aFitKnn, newdata = testDataNoLabel)
predictions

print(postResample(pred=predictions, obs=as.factor(testData$label)))

# Plot data
stripchart(a$v1 ~ a$label, method="jitter", col=c("red", "blue", "green"), pch=1)


# Run the code below to set up the data

library(tidyverse)
# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
unisex_data <- unisex_data %>%
  select(-prop) %>%
  spread(sex, n, fill=0)
unisex_data

# Change the color scale for the lines with scale_color_viridis_d()
# Change the y-axis to have labels every 1000 babies and go from 0 to 11000

ggplot(unisex_data, aes(x=year, y=Male+Female, color=name)) +
  geom_line(size=2) +
  theme_minimal()

# What's the difference between scale_color_viridis_d() and
# scale_color_viridis_c()? >> check the help

# Bonus:
# Can you define your own colors?
# A vector with 9 colors is provided for you, but you can change it!
# (You need 9 for the 9 names in the data)
# Look at the help for scale_color_manual - especially the examples

cols <- c("red", "orange", "yellow", "lightgreen", "green",
          "lightblue", "blue", "purple", "pink")
names(cols) <- unique(unisex_data$name)

ggplot(unisex_data, aes(x=year, y=Male+Female, color=name)) +
  geom_line(size=2) +
  theme_minimal()


# loading both tables
arriendos <- read.csv("data/amsterdam_airbnb.csv")
migraciones <- read.csv("data/migrations.csv")

# loading dplyr library
library(dplyr)
library(digest)

#################################
# Second try joining tables
#################################

# We will join both tables using a hash of the countries,
# to work with numeric values:
# in arriendos: the host_location column
# in migraciones: the country column

extractCountry <- function(l) {
  l <- sapply(l, as.character, USE.NAMES = FALSE)
  l <- sapply(l, strsplit, ",", USE.NAMES = FALSE)
  l <- sapply(l, tail, n = 1L, USE.NAMES = FALSE)
  l <- sapply(l, trimws, USE.NAMES = FALSE)
  return(l)
}

countryToHash <- function(c) {
  c <- sapply(c, as.character)
  c <- sapply(c, digest, algo="xxhash32")
  c <- sapply(c, strtoi, 16)
  return(c)
}

arriendos_filtrados <- arriendos %>%
  mutate(Country = extractCountry(host_location)) %>%
  mutate(CountryHash = countryToHash(Country)) %>%
  filter(!is.na(CountryHash)) %>%
  filter(!is.na(Country))

# Now we have to transform the migrations database
# to transform the column Country to a Hash list
migraciones_filtradas <- migraciones %>%
  mutate(CountryHash = countryToHash(Country.of.birth.nationality)) %>%
  filter(!is.na(CountryHash))

# trying to join the databases
inner_join_arriendos_migraciones_2 <- migraciones_filtradas %>%
  inner_join(arriendos_filtrados, by=c("CountryHash" = "CountryHash"))

# Question 1
# How many listings are there from the countrys
# with more emigrations in 2016
migraciones_filtradas %>%
  filter(Year == 2016) %>%
  filter(VAR == "B11") %>%
  group_by(Country) %>%
  summarise(n=n(), Pais=Country[1], Hash=CountryHash[1]) %>%
  arrange(desc(n)) %>%
  top_n(1, n) %>%
  inner_join(arriendos_filtrados, by=c("Hash"="CountryHash"))

# Question 2: How many countrys are in both tables?
inner_join_arriendos_migraciones_2 %>%
  distinct(CountryHash) %>%
  tally()

# Question 3: Whats the country that appears the most
# in both tables joined?
inner_join_arriendos_migraciones_2 %>%
  group_by(Country.x) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)

# Question 4: Whats the host_name that appears the most
# in both tables joined?
inner_join_arriendos_migraciones_2 %>%
  group_by(host_name) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)

# Question 5: Whats the neighbourhood that appears the most
# in both tables joined?
inner_join_arriendos_migraciones_2 %>%
  group_by(neighbourhood) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)

# Question 6: Whats the price that appears the most
# in both tables joined?
inner_join_arriendos_migraciones_2 %>%
  group_by(price) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)

# Question 7: How many emmigrations had the host_location
# with more beds in 2015?
arriendos_filtrados %>%
  arrange(desc(beds)) %>%
  top_n(1, beds) %>%
  select(CountryHash) %>%
  distinct() %>%
  inner_join(
    migraciones_filtradas %>% filter(Year == 2015) %>% filter(VAR == "B11"), by=c("CountryHash"="CountryHash")
  )

# Question 8: How many immigrations had the country with more
# listings in airbnb amsterdam in 2014?
arriendos_filtrados %>%
  group_by(CountryHash) %>%
  summarise(n=n()) %>%
  top_n(1, n) %>%
  inner_join(
    migraciones_filtradas %>%
      filter(VAR == "B12") %>%
      filter(Year == 2014),
      by=c("CountryHash"="CountryHash")
  )

# Question 9: Whats the Var with more ocurrences in the joined table?
inner_join_arriendos_migraciones_2 %>%
  group_by(VAR) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)

# Question 10: Whats the Country of birth with more ocurrences in the joined table?
inner_join_arriendos_migraciones_2 %>%
  group_by(Country.of.birth.nationality) %>%
  summarise(n=n()) %>%
  arrange(desc(n)) %>%
  top_n(1, n)


#Obtaining all except NA
age[c(-5, -11)] ==  age[c(1, 2, 3, 4, 6, 7, 8, 9, 10, 12)] == age[!is.na(age)]

#import
library(tidyverse)
papers <- as_tibble(read_csv(???filepath???))
papers_select <- select(papers, journal, year, cites, title, au1)

summary(filter(papers, cites >= 100))
summarize(group_by(papers, journal), sum_ci = sum(cites))
n_distinct(papers$au1)  == length(unique(papers_select$au1))

select(papers, contains("female"))

aggregate(papers_select$cites, by=list(journal=papers_select$journal), FUN=sum)

filter(group_by(papers, journal), journal == "Econometrica")

nrow(filter(papers, cites >= 100))


args = commandArgs(trailingOnly=TRUE)

dist.mat <- args[1]
thres <- args[2]
outfile <- args[3]
dist.dat <- read.table(dist.mat)#0.01

## clustering
cluster.full <- hclust(as.dist(dist.dat), method = 'single' )

clusters <- cutree(cluster.full, h=thres)
write.table(data.frame(clusters), outfile, sep='\t')


setwd('/home/pc-752828/Dev/results-search-master/outputs-pi')
library(ggplot2)
library(dplyr)
library(extrafont)
library(dplyr)
library('EnvStats')
library("tikzDevice")

value <- function(x, name) {
  mym = median(x)
  mysd = sd(x)
  #mysd = mean(x)

  #mysd = geoSD(x, na.rm = FALSE, sqrt.unbiased = TRUE)
  mysqrt = sqrt(length(x))
  Q1 <- quantile(x, probs = 0.25)
  Q2 <- quantile(x, probs = 0.50)
  Q3 <- quantile(x, probs = 0.75)

  mym =  geoMean(x, na.rm = FALSE)
  print(mym)
  print(exp(mean(log(x))))
  #mym = mean(log(x))
  #mysd = geoSD(x, na.rm = FALSE, sqrt.unbiased = TRUE)
  mysd <- ci.gm(x)
  return(c(mn = mym, sd = mysd, bo = name))
}

data_f<-data.frame(data_new[data_new['bo'] == 'bo1',])
bo1 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EIdef')))
bo1 <- as.data.frame(as.list(bo1))

data_f<-data.frame(data_new[data_new['bo'] == 'bo5',])
bo2 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'BO-6rnd-EInova')))
bo2 <- as.data.frame(as.list(bo2))

data_f<-data.frame(data_new[data_new['bo'] == 'rs',])
bo3 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'Ranking Search')))
bo3 <- as.data.frame(as.list(bo3))

data <- read.csv(file = 'output-n-pi.csv', sep = ',', header = T)
data <- read.csv(file = 'output-n-pi-cost.csv', sep = ',', header = T)

data <- read.csv(file = 'output-ecp-pi.csv', sep = ',', header = T)
data <- read.csv(file = 'output-ecp-pi-cost.csv', sep = ',', header = T)

data_new <- data

data_f<-data.frame(data_f<-data.frame(data_new[data_new['bo'] == 'bo4' & data_new['target'] == 0,]))
bo1 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'PB3Opt - PI')))
bo1 <- as.data.frame(as.list(bo1))

data_f<-data.frame(data_f<-data.frame(data_new[data_new['bo'] == 'bo4' & data_new['target'] == 1,]))
bo2 <- aggregate(x = data_f$best,
                 by = list(data_f$ite),
                 FUN = function(x) return(value(x, 'PB3Opt - Real')))
bo2 <- as.data.frame(as.list(bo2))

df <- rbind(bo2, bo1)

df$x.mn = as.numeric(as.character(df$x.mn))
df$Group.1 = as.numeric(as.character(df$Group.1))
df$x.sd1 = as.numeric(as.character(df$x.sd1))
df$x.sd2 = as.numeric(as.character(df$x.sd2))
df_new <- df
df_new <- df[df['Group.1'] >= 6,]

p1<-ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  geom_errorbar(aes(ymin=x.sd1, ymax=x.sd2,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  coord_cartesian(ylim=c(1,1.25), xlim=c(1,30))+
  labs(color = element_blank(), x="Iteração", y="Média do Melhor Custo Normalizado")+
  theme(legend.justification=c(1, 1),legend.position=c(.8, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        #axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 30, 1))+
  ggtitle('a) Melhor Custo Encontrado')

p2<-ggplot(data=df_new, aes(x=Group.1, y=x.mn, group=x.bo)) +
  #geom_errorbar(aes(ymin=x.mn-x.sd, ymax=x.mn+x.sd,color=x.bo), width=0.2, size=.3) +
  geom_errorbar(aes(ymin=x.sd1, ymax=x.sd2,color=x.bo), width=0.2, size=.3) +
  geom_line(aes(color=x.bo), size=1) +
  geom_vline(xintercept=6, linetype="dashed", size=1)+
  #coord_cartesian(ylim=c(1,4), xlim=c(1,30))+
  labs(color = element_blank(), x="Iteração", y="Média do Custo Normalizado Acumulado")+
  theme(legend.justification=c(1, 1),legend.position=c(.6, .9),legend.title=element_blank())+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        #axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  scale_x_continuous(breaks = seq(1, 30, 1))+
  ggtitle('b) Custo Acumulado')

tikz('fig2-pi.tex')
grid.arrange(p1, p2, nrow = 2, ncol=1, top="", left="")
dev.off()


##############################################################
# Start with a clean workspace
rm(list=ls())

# Function to load packages
loadPkg=function(toLoad){
  for(lib in toLoad){
	if(! lib %in% installed.packages()[,1])
	  { install.packages(lib, repos='http://cran.rstudio.com/') }
	suppressMessages( library(lib, character.only=TRUE) ) }
}

# Load libraries
packs=c("ggplot2", 'reshape2', 'sp', 'geosphere', 'MASS', 'grid')
loadPkg(packs)

# Set a theme for gg
theme_set(theme_bw())

# Functions that I use frequently
char = function(x){ as.character(x) }
num = function(x){ as.numeric(char(x)) }

# Relevant paths
labPath='~/Dropbox/Duke/Spring 2015/PS 733/lab6/'
##############################################################

##############################################################
# Out of sample validation
setwd(labPath)
load('fish.RData')

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

##############################################################
# Cross Validation

# Divide Fish data into n random subsets

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

##############################################################
# Review of HW4
# First lets load map
setwd(labPath)
load('crisp.map.rda')
centroids=sp::coordinates(crisp.map)
rownames(centroids)=crisp.map$COWCODE
colnames(centroids)=c('long','lat')

# Lets load in contagion data
load('contagionMatrices.rda')

# Lets divide contMats into four time periods
brks=cbind(start=seq(1, length(contMats), length(contMats)/4),
	end=seq(38, length(contMats), length(contMats)/4))
contMatBuck=lapply(1:nrow(brks), function(ii){
	contSub=contMats[brks[ii,1]:brks[[ii,2]]]
	contSubSum=Reduce('+', contSub)
	contDyadic=melt(contSubSum)
	contDyadic[contDyadic$value>0,]
	})
names(contMatBuck)=paste(
	names(contMats)[brks[,1]],
	names(contMats)[brks[,2]], sep=' to ')
summary(contMatBuck)

# Now lets plot maps with contagion arrows for each of these matrices
par(mfrow=c(2,2), mar=c(0,0,0,0), oma=c(0,0,0,0))
for(ii in 1:length(contMatBuck)){
	contM=contMatBuck[[ii]]
	segCont=cbind( centroids[char(contM$Var1),],  centroids[char(contM$Var2),])
	colnames(segCont)=c('longStart','latStart','longEnd','latEnd')

	# Create base map
	plot(crisp.map, lwd=0.5, border='darkgrey', col='white', bg='white')
	# Add date label
	text(-5, -50, names(contMatBuck)[ii])
	# Draw line segments
	for(i in 1:nrow(segCont)){
	  spread=geosphere::gcIntermediate( segCont[i,1:2], segCont[i,3:4],
	  	n=50, addStartEnd=TRUE)
	  lines(spread, col="black", lwd=0.8)
	  arrows(spread[nrow(spread)-1,1],spread[nrow(spread)-1,2],
	  	spread[nrow(spread),1],spread[nrow(spread),2],length=.04)
	  points(segCont[i,1], segCont[i,2], cex=.4)
	}
}
par(mar=c(4, 4, 2, 0.5), oma=c(2,2,2,2), mfrow=c(1,1), mgp=c(2,.7,0))
##############################################################

##############################################################
# Reviw of HW5
setwd(labPath)
load('fish.RData')

# Interaction between elf and income
dv='fhrev'
ivs=c('muslim', 'income', 'elf', 'growth', 'britcol', 'postcom', 'opec', 'elf*income')
modForm=formula(paste0( dv, ' ~ ', paste(ivs, collapse=' + ') ))
mod = lm(modForm, data=fish)
round(summary(mod)$'coefficients',3)

# Lets assess the interactive effect

# Create a scenario matrix
elfRange=quantile(fish$elf, probs=seq(0,1,.25))
incRange=sort(unique(fish$income))

attach(fish)
scen = expand.grid(1, median(muslim), incRange, elfRange, mean(growth),
	median(britcol), median(postcom), median(opec))
detach(fish)
# Add interaction term
scen = cbind( scen, scen[,3]*scen[,4] )
# Add column headers to scenario
colnames(scen) = names( coef(mod) )
# Convert scen to matrix so we can perform operations on it
scen = data.matrix(scen)

# Lets get predicted values
pred = scen %*% coef(mod)

# Account for systematic uncertainty
sims=1000
draws = mvrnorm(sims, coef(mod), vcov(mod))
sysUncert = scen %*% t(draws)
sysInts = t(apply(sysUncert, 1, function(x){ quantile(x, c(0.025, 0.975)) }))

# Account for stochastic uncertainty
sigma=sqrt( mean( resid(mod)^2 ) )
stoUncert = t(apply(sysUncert, 1, function(x){ rnorm(sims, x, sigma) }))
stoInts = t(apply(stoUncert, 1, function(x){ quantile(x, c(0.025, 0.975)) }))

# Combine for plotting
ggData=data.frame(
		cbind(pred, sysInts, stoInts, scen[,'income'], scen[,'elf'])
	)
names(ggData)=c('fit', 'sysLo', 'sysHi', 'stoLo', 'stoHi', 'income', 'elf')

# Plot
tmp=ggplot(ggData, aes(x=income, y=fit))
tmp=tmp + geom_line()
tmp=tmp + geom_ribbon(aes(ymin=sysLo, ymax=sysHi), alpha=.9)
tmp=tmp + geom_ribbon(aes(ymin=stoLo, ymax=stoHi), alpha=.3)
tmp=tmp + facet_grid(~elf)
tmp

# Dag's surface plot (a.k.a. : heatmap, matrix diagram)
# Create a scenario matrix
attach(fish)
elfRange=seq(min(elf), max(elf), .05)
incRange=seq(min(income), max(income), .05)

scen = expand.grid(1, median(muslim), incRange, elfRange, mean(growth),
	median(britcol), median(postcom), median(opec))
detach(fish)
# Add interaction term
scen = cbind( scen, scen[,3]*scen[,4] )
# Add column headers to scenario
colnames(scen) = names( coef(mod) )
# Convert scen to matrix so we can perform operations on it
scen = data.matrix(scen)

# Get predicted values
pred = scen %*% coef(mod)

# Create dataframe for plotting
ggData = data.frame( cbind(scen[,'income'], scen[,'elf'], pred) )
names(ggData)=c('income', 'elf', 'pred')

# Make a surface plot
tmp=ggplot(ggData, aes(x=income, y=elf, fill=pred))
tmp=tmp + xlab('Income') + ylab('Ethnic Frac.')
tmp=tmp + geom_tile(colour='darkgrey')
tmp=tmp + scale_fill_gradient2(midpoint=4.5, space='rgb',
  low="#d73027", mid="white", high="#4575b4",
  name='FH\n')
tmp=tmp + scale_x_continuous(expand=c(0,0)) + scale_y_continuous(expand=c(0,0))
tmp=tmp + theme(axis.ticks=element_blank(),
  legend.position='top', legend.key.width=unit(2,'cm'),
  panel.grid.major = element_blank(), panel.grid.minor = element_blank() )
tmp
##############################################################


    rescale.min.max = function( x, xmax=1 ) {
      y = x - min(x, na.rm=T)
      y = y / max(y, na.rm=T)
    }


#' Estimating the generalised joint exceedance (GJE) environmental contours
#'
#' @description
#' This function estimates the generalised joint exceedance (GJE) environmental contours, as proposed in Jonathan et al. (2014), for a
#' given sample data set or a fitted joint distribution of class \code{ht} or \code{wln}.
#'
#' @param object either a fitted joint distribution of class \code{wln} or \code{ht}, or an existing sample data
#' set containing \code{hs} and \code{tp} as columns. See details.
#'
#' @param output_rp the required return periods (in years) for the estimated contours.
#'
#' @param type the type of joint exceedance definition. The default value is 2. See details.
#'
#' @param npy the (optional) number of data points per year. This argument is only needed if the input
#' \code{object} is a sample data set.
#'
#' @param n_point the number of points to output around each contour. The default value is 100.
#'
#' @details
#' The joint exceedance contour is a collection of points corresponding to a constant joint exceedance proability.
#' The definition is one-sided or two-sided depending on the input argument \code{type}:
#'
#' \itemize{
#'
#'   \item If \code{type = 1}, the \eqn{T}-year contour passes through any point \eqn{(hs, tp)} such that the
#'   joint exceedance probability \eqn{P(Hs > hs & Tp > tp)} is one in \eqn{T} years.
#'
#'   \item If \code{type = 2}, the \eqn{T}-year contour passes through an anchor point \eqn{(hs0, tp0)}
#'   where \eqn{hs0} is the (\eqn{T/2})-year wave heights, and \eqn{tp0} is the conditional median of the
#'   wave period given the wave height is \eqn{hs0}. The joint exceedance probability is defined as
#'   \eqn{P(Hs > hs & Tp > tp)} for all \eqn{tp > tp0} and \eqn{P(Hs > hs & Tp < tp)} for all \eqn{tp < tp0}.
#'
#' }
#'
#' The function can be applied to an existing sample set, which can be generated by function \code{\link{sample_jdistr}}
#' or otherwise by importing a CSV file using function \code{\link[data.table]{fread}}. The input sample data
#' object must contain \code{hs} and \code{tp} as columns. The user must also specify the number of points per year
#' \code{npy} and a valid \code{output_rp}, i.e. the maximum \code{output_rp} must be shorter than the total
#' duration of the data set.
#'
#' Alternatively this function can be applied to a fitted joint distribution object
#' generated by function \code{\link{fit_ht}} or \code{\link{fit_wln}}.  When applied to a
#' \code{wln} or \code{ht} object, the contour estimation makes use of the importance
#' sampling technique proposed in Huseby et. al. (2014) to improve the efficiency of the function.
#'
#'
#' @return
#' A set of estimated GJE contours with the specified return periods in the format
#' of a \code{data.table} with \code{rp}, \code{hs}, and \code{tp} as columns.
#'
#' @examples
#' # Estimating type-1 GJE contours based on a fitted model
#' data(ww3_pk)
#' wln = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10)
#' ec_wln = estimate_gje(object = wln, output_rp = c(10,100,1000,10000), type = 1)
#' plot_ec(ec = ec_wln, raw_data = ww3_pk)
#'
#' # Estimating type-2 GJE contours based on a sample data set
#' data(ww3_ts)
#' ec_data = estimate_gje(object = ww3_ts, output_rp = c(.5, 1, 2), type = 2, npy = ww3_ts[, .N/10])
#' plot_ec(ec = ec_data, raw_data = ww3_ts)
#'
#' @references
#' Jonathan, P., Ewans, K., Flynn, J., 2014. On the estimation of ocean engineering design contours.
#' ASME J. Offshore Mech. Arct. Eng. 136:041101.
#'
#' Huseby, A., Vanem, E., Natvig, B., 2014. A new Monte Carlo method for environmental contour estimation.
#' Conference Proceedings. DOI:10.1201/b17399-286.
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}, \code{\link{sample_jdistr}}, \code{\link{plot_ec}}
#'
#' @export
estimate_gje = function(
  object, output_rp, type = 2, npy = NULL, n_point = 100){

  if("wln" %in% class(object)){

    res = .estimate_gje_from_wln(wln = object, output_rp = output_rp, type = type, n_point = n_point)

    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("ht" %in% class(object)){

    res = .estimate_gje_from_ht(ht = object, output_rp = output_rp, type = type, n_point = n_point)

    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("data.table" %in% class(object)){

    if(is.null(npy)){
      stop("Argument npy must be provided for estimating contours from sample data.")
    }else{
      invalid_rp = output_rp[output_rp>object[, .N/npy]]
      if(length(invalid_rp)==length(output_rp)){
        stop("All output_rp values are invalid as they require extrapolation. Consider fitting a joint distribution first.")
      }else if(length(invalid_rp)>=1 & length(invalid_rp)<length(output_rp)){
        warning("Certain output_rp values are ignored as they requires extrapolation. Consider fitting a joint distribution first.")
      }
      output_rp = setdiff(output_rp, invalid_rp)
    }

    res_list=list()
    for(this_rp in output_rp){
      this_ap_hs = quantile(object$hs, 1-type/npy/this_rp)
      this_contour = .estimate_gje_from_data(
        sample_data = object, n_jex = object[,.N/npy]/this_rp,
        ap_hs = this_ap_hs, type=type, n_point = n_point)
      res_list[[as.character(this_rp)]] = cbind(rp = this_rp, this_contour)
    }
    res = rbindlist(res_list)

  }else{
    stop("The input object must be of class ht, wln or data.table.")
  }

  return(res)
}

.estimate_gje_from_data = function(sample_data, n_jex, ap_hs, type, n_point){
  if(!type %in% c(1,2)){
    stop("Only type 1 or 2 is supported.")
  }
  if(type==2){
    calc = data.table(hs1 = seq(ap_hs, min(sample_data$hs), length.out = ceiling((n_point+1)/2)))
    calc[, n_hs_tail:=sample_data[hs>=hs1, .N], .(hs1)]
    calc[, p_tp_upper:=1-n_jex/n_hs_tail]
    calc[, p_tp_lower:=n_jex/n_hs_tail]
    calc[, tp_upper:=sample_data[hs>=hs1, quantile(tp, p_tp_upper)], .(hs1)]
    calc[, tp_lower:=sample_data[hs>=hs1, quantile(tp, p_tp_lower)], .(hs1)]
    out = rbind(calc[.N:2, .(hs=hs1, tp=tp_upper)], calc[, .(hs=hs1, tp=tp_lower)])
  }else{
    # browser()
    calc = data.table(hs1 = seq(ap_hs, min(sample_data$hs), length.out = n_point))
    calc[, tp:=sample_data[hs>=hs1, sort(tp, decreasing = T)[n_jex]], .(hs1)]
    out = calc[, .(hs=hs1, tp)]
  }
  return(out)
}

.estimate_gje_from_wln = function(wln, output_rp, type, n_point){

  res_list=list()
  for(this_rp in output_rp){
    this_sample_data = .sample_wln_is(wln, target_rp=this_rp)
    this_out = .estimate_gje_from_data(
      sample_data = this_sample_data, n_jex = .target_rp_ub,
      ap_hs = this_sample_data[, sort(hs, decreasing = T)[type*.target_rp_ub]],
      type = type, n_point = n_point)
    res_list[[as.character(this_rp)]] = cbind(rp=this_rp, this_out)
  }
  res = rbindlist(res_list)
  return(res)
}

.estimate_gje_from_ht = function(ht, output_rp, type, n_point){

  res_list=list()
  for(this_rp in output_rp){
    this_sample_data = .sample_ht_is(ht, target_rp=this_rp)
    this_out = .estimate_gje_from_data(
      sample_data = this_sample_data, n_jex = .target_rp_ub,
      ap_hs = this_sample_data[, sort(hs, decreasing = T)[type*.target_rp_ub]],
      type = type, n_point = n_point)
    res_list[[as.character(this_rp)]] = cbind(rp=this_rp, this_out)
  }
  res = rbindlist(res_list)
}


library("zoo")
library("xts")

bins <- read.csv("output/binning/part-r-00000", header=F)
z_tcp_data <- zoo(bins$V2/(1024*1024), as.POSIXlt(bins$V1,origin="1970-01-01", tz="GMT"))
z_udp_data <- zoo(bins$V3/(1024*1024), as.POSIXlt(bins$V1,origin="1970-01-01", tz="GMT"))
z_tot_data <- zoo(bins$V4/(1024*1024), as.POSIXlt(bins$V1,origin="1970-01-01", tz="GMT"))

pdf(file="output/binning/plot.pdf")

plot(z_tcp_data, col=2)
lines(z_udp_data, col=3)
lines(z_tot_data, col=5)


# -----------------------------------------------------------------------------
# PROJECT:
#    Evaluating the structure of the communities of the estuary
#    and gulf of St.Lawrence
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# STEP:
#    1. Evaluating similarity of consumers and resources
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# NOTES:
# // TODO: Evaluate similarity based on set of consumers for resources
# // TODO: Look into proximity graphs for better performance
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# LIBRARIES:
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# SCRIPT
# -----------------------------------------------------------------------------
load("./RData/S0_catalog.RData")
# Weight values for 2-way similarity measurements
    wt <- seq(0, 1, by = 0.1)

# 1st is for similarity measured from set of resources and taxonomy, for consumers
    similarity.consumers <- vector('list',11)
    names(similarity.consumers) <- wt
    for(i in 1:length(wt)) {
        similarity.consumers[[i]] <- similarity_taxon(S0 = S0_catalog, wt = wt[i], taxa = 'consumer')
        save(x = similarity.consumers, file = "./RData/Similarity_consumers.RData")
    }
    save(x = similarity.consumers, file = "./RData/Similarity_consumers.RData")

# 2nd is for similarity measured from set of consumers and taxonomy, for resources
    similarity.resources <- vector('list',11)
    names(similarity.resources) <- wt
    for(i in 1:length(wt)) {
        similarity.resources[[i]] <- similarity_taxon(S0 = S0_catalog, wt = wt[i], taxa = 'resource')
        save(x = similarity.resources, file = "./RData/Similarity_resources.RData")
    }
    save(x = similarity.resources, file = "./RData/Similarity_resources.RData")


make.auc.plot.jpg<-function(ma.reduced,pred,plotname,modelname,test.split=FALSE,thresh=NULL,train=NULL,train.pred=NULL,opt.methods=2,weight,out){

      if(is.null(weight)) weight=rep(1,times=dim(ma.reduced)[1])
    auc.data <- data.frame(ID=1:nrow(ma.reduced),pres.abs=ma.reduced[,1],pred=pred)
    p.bar <- sum(auc.data$pres.abs * weight) / sum(weight)
    n.pres <- sum(auc.data$pres.abs>=1)
    n.abs <- nrow(auc.data)-n.pres

    null.dev<-calc.dev(auc.data$pres.abs, rep(p.bar,times=length(auc.data$pres.abs)), weight, family=out$input$model.family)$deviance*nrow(ma.reduced)
    dev.fit<-calc.dev(auc.data$pres.abs, pred, weight, family=out$input$model.family)$deviance*nrow(ma.reduced)
    dev.exp <- null.dev - dev.fit
    pct.dev.exp <- dev.exp/null.dev*100
   correlation<-cor(auc.data$pres.abs,pred)
    residual.smooth.fct<-NULL
     if(test.split==FALSE) residual.smooth.fct<-resid.image(calc.dev(auc.data$pres.abs, pred, weight, family=out$input$model.family)$dev.cont,pred,
          auc.data$pres.abs,out$dat$ma$train.xy[,1],out$dat$ma$train.xy[,2],out$input$model.family,out$input$output.dir,out)

    if(is.null(thresh) & out$input$model.family!="poisson"){
      thresh <- as.numeric(optimal.thresholds(auc.data,opt.methods=opt.methods))[2]
    }

    if(out$input$model.family%in%c("binomial","bernoulli")){
      auc.fit <- auc(auc.data,st.dev=T)
          if(test.split==TRUE){
            jpeg(file=plotname)
            d<-data.frame(ID=1:nrow(train),pres.abs=train[,1],pred=train.pred)
            thresh<- as.numeric(optimal.thresholds(d,opt.methods=opt.methods))[2]
            TestTrainRocPlot(DATA=d,opt.thresholds=thresh,add.legend=FALSE,lwd=2)
            TestTrainRocPlot(auc.data,model.names=modelname,opt.thresholds=thresh,add.roc=TRUE,line.type=2,color="red",add.legend=FALSE)
            legend(x=.66,y=.2,c("Training Split","Testing Split"),lty=2,col=c("black","red"),lwd=2)
            graphics.off()}
          else {
            jpeg(file=plotname)
            TestTrainRocPlot(auc.data,model.names=modelname,opt.thresholds=thresh)
            graphics.off()
          }
        cmx <- cmx(auc.data,threshold=thresh)
        PCC <- pcc(cmx,st.dev=F)*100
        SENS <- sensitivity(cmx,st.dev=F)
        SPEC <- specificity(cmx,st.dev=F)
        KAPPA <- Kappa(cmx,st.dev=F)
        TSS <- SENS+SPEC-1
    }

    if(out$input$model.family%in%c("poisson")){
      auc.fit <- auc(auc.data,st.dev=T)
          if(test.split==FALSE){
            jpeg(file=plotname)
            par(mfrow=c(2,2))
            #plot(out$mods$final.mod)
             plot(log(pred[pred!=0]),(auc.data$pres.abs[pred!=0]-pred[pred!=0]),xlab="Predicted Values (log scale)",ylab="Residuals",main="Residuals vs Fitted",ylim=c(-3,3))
              abline(h=0,lty=2)
              #this is the residual plot from glm but I don't think it will work for anything else
              qqnorm(residuals(out$mods$final.mod),ylab="Std. deviance residuals")
              qqline(residuals(out$mods$final.mod))
               yl <- as.expression(substitute(sqrt(abs(YL)), list(YL = as.name("Std. Deviance Resid"))))
              plot(log(pred[pred!=0]),sqrt((abs(residuals(out$mods$final.mod,type="deviance")[pred!=0]))),xlab="Predicted Values (log Scale)",ylab=yl)
            graphics.off()}
       prediction.error<-sum((auc.data$pres.abs-pred)^2)
       cmx=PCC=SENS=SPEC=KAPPA=TSS<-NA
    }

      calibration.stats<-calibration(auc.data$pres.abs, pred, family =out$input$model.family)
      response<-ma.reduced$response

    capture.output(cat("\n\n============================================================",
                        "\n\nEvaluation Statistics"),file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)
          if(!is.null(out$dat$ma$ma.test))
                        capture.output(cat(" applied to",ifelse(!test.split,"train","test"), "split:\n",sep=" "),
                        file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)
                      capture.output(cat( "\n",
                       "\n\t Correlation Coefficient      : ",cor.test(pred,response)$estimate,
                       "\n\t NULL Deviance                : ",null.dev,
                       "\n\t Fit Deviance                 : ",dev.fit,
                       "\n\t Explained Deviance           : ",dev.exp,
                       "\n\t Percent Deviance Explained   : ",pct.dev.exp,
                       file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE))

                        if(out$input$model.family%in%c("binomial","bernoulli")){
                               capture.output(cat(
                                 "\n\n  Threshold Methods based on", switch(opt.methods,
                                "1"=".5 threshold",
                                "2"="Sens=Spec",
                                "3"="maximize (sensitivity+specificity)/2",
                                "4"="maximize Kappa",
                                "5"="maximize percent correctly classified",
                                "6"="predicted prevalence=observed prevalence",
                                "7"="threshold=observed prevalence",
                                "8"="mean predicted probability",
                                "9"="minimize distance between ROC plot and (0,1)",
                                ),
                                "\n\t Threshold                    : ",
                                thresh,
                                "\n\n\t Confusion Matrix: \n\n"),
                                print.table(cmx),
                           cat("\n\t AUC                          : ",auc.fit[1,1],
                           "\n\t Percent Correctly Classified : ",PCC,
                           "\n\t Sensitivity                  : ",SENS,
                           "\n\t Specificity                  : ",SPEC,
                           "\n\t Kappa                        : ",KAPPA,
                           "\n\t True Skill Statistic         : ",TSS,"\n"),
                           file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)
                       }

                         capture.output(cat( "\n\n   Calibration Statistics",
                          "\n\t Intercept (general calibration)                            : ",calibration.stats[1],
                          "\n\t Slope   (direction and variation in fit)                   : ",calibration.stats[2],
                          "\n\t Testa0b1 (overall reliability of predictors)               : ",calibration.stats[3],
                          "\n\t Testa0|b1(incorrect calibration given correct refinement)  : ",calibration.stats[4],
                          "\n\t Testb1|a (refinement given correct calibration)            : ",calibration.stats[5],"\n",
                       file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE))

                       last.dir<-strsplit(out$input$output.dir,split="\\\\")
                        parent<-sub(paste("\\\\",last.dir[[1]][length(last.dir[[1]])],sep=""),"",out$input$output.dir)

                         compile.out<-paste(parent,
                              paste(switch(out$input$model.family,"binomial"="Binary","bernoulli"="Binary","poisson"="Count"),ifelse(!is.null(out$dat$ma$ma.test),"TestTrain",""),
                              "AppendedOutput.csv",sep="."),sep="/")

                       if(out$input$model.family%in%c("binomial","bernoulli")){
                       x=data.frame(cbind(c("Correlation Coefficient","Percent Deviance Explained","Percent Correctly Classified","Sensitivity","Specificity"),
                            c(as.vector(cor.test(pred,response)$estimate),pct.dev.exp,PCC,SENS,SPEC)))
                       }else  x=data.frame(cbind(c("Correlation Coefficient","Percent Deviance Explained","Prediction Error"),
                            c(as.vector(cor.test(pred,response)$estimate),pct.dev.exp,prediction.error)))

                        Header<-cbind(c("","Original Field Data","Field Data Template","PARC Output Folder","PARC Template","Covariate Selection Name",""),
                            c(last.dir[[1]][length(last.dir[[1]])],
                            out$dat$ma$input$OrigFieldData,out$dat$ma$input$FieldDataTemp,out$dat$ma$input$ParcOutputFolder,
                            out$dat$ma$input$ParcTemplate,ifelse(length(out$dat$ma$input$CovSelectName)==0,"NONE",out$dat$ma$input$CovSelectName),""))

AppendOut(compile.out,Header,x,out,test.split,parent=parent)

    return(list(thresh=thresh,cmx=cmx,null.dev=null.dev,dev.fit=dev.fit,dev.exp=dev.exp,pct.dev.exp=pct.dev.exp,auc=auc.fit[1,1],auc.sd=auc.fit[1,2],
        plotname=plotname,pcc=PCC,sens=SENS,spec=SPEC,kappa=KAPPA,tss=TSS,correlation=correlation,residual.smooth.fct=residual.smooth.fct))
}


#' Generate the "adaptive walk" node rankings, starting from a given perturbed variable
#'
#' This function calculates the node rankings starting from a given perturbed variable in a subset of variables in the background knowledge graph.
#' @param S - A character vector of the node names for the subset of nodes you want to encode.
#' @param G - A list of probabilities with list names being the node names of the background graph.
#' @param num.misses - The number of "misses" the network walker will tolerate before switching to fixed length codes for remaining nodes to be found.
#' @param verbose - If TRUE, print statements will execute as progress is made. Default is FALSE.
#' @return ranks - A list of character vectors of node names in the order they were drawn by the
#'                 probability diffusion algorithm, from each starting node in S.
#' @keywords probability diffusion algorithm
#' @keywords network walker algorithm
#' @export multiNode.getNodeRanks
#' @examples
#' # Read in any network via its adjacency matrix
#' tmp = matrix(1, nrow=100, ncol=100)
#' for (i in 1:100) {
#'   for (j in 1:100) {
#'     tmp[i, j] = rnorm(1, mean=0, sd=1)
#'   }
#' }
#' colnames(tmp) = sprintf("Compound%d", 1:100)
#' ig = graph.adjacency(tmp, mode="undirected", weighted=TRUE, add.colnames="name")
#' V(ig)$name = tolower(V(ig)$name)
#' # Get node rankings for graph
#' G = vector(mode="list", length=length(V(ig)$name))
#' names(G) = V(ig)$name
#' S = names(G)[1:3]
#' ranks = multiNode.getNodeRanks(S, G)
multiNode.getNodeRanks = function(S, G, num.misses=NULL, verbose=FALSE) {
  if (is.null(num.misses)) {
    thresholdDrawT = log2(length(G))
  } else {
    thresholdDrawT = num.misses
  }
  ranks = list()
  for (n in 1:length(S)) {
    if (verbose) {
      print(sprintf("Calculating node rankings %d of %d.", n, length(S)))
    }
    current_node_set = NULL
    stopIterating=FALSE
    startNode = S[n]
    hits = startNode
    numMisses = 0
    current_node_set = c(current_node_set, startNode)
    while (stopIterating==FALSE) {
      sumHits = as.vector(matrix(0, nrow=length(G), ncol=1))
      names(sumHits) = names(G)
      for (hit in 1:length(hits)) {
        #Clear probabilities.
        G[1:length(G)] = 0
        #determine base p0 probability
        baseP = p0/(length(G)-length(current_node_set))
        #set probabilities of unseen nodes to diffused p0 value, baseP
        G[which(!(names(G) %in% current_node_set))] = baseP
        # Sanity check: p0_event should be equal to p0 global variable.
        p0_event = sum(unlist(G[!(names(G) %in% current_node_set)]))
        # Diffuse p1.
        G = graph.diffuseP1(p1, hits[hit], G, current_node_set, 1, verbose=FALSE)
        # Sanity check: p1_event should be within 'thresholdDiff' (global variable) of 1.
        p1_event = sum(unlist(G[!(names(G) %in% current_node_set)]))
        if (abs(p1_event-1)>thresholdDiff) {
          extra.prob.to.diffuse = 1-p1_event
          G[names(current_node_set)] = 0
          unseen_nodes = which(!(names(G) %in% names(current_node_set)))
          G[unseen_nodes] = unlist(G[unseen_nodes]) + extra.prob.to.diffuse/length(unseen_nodes)
        }
        sumHits = sumHits + unlist(G)
      }
      sumHits = sumHits/length(hits)
      #Set startNode to a node that is the max probability in the new G
      maxProb = names(which.max(sumHits[-which(names(sumHits) %in% current_node_set)]))
      # Break ties: When there are ties, choose the first of the winners.
      startNode = names(G[maxProb[1]])
      if (startNode %in% S) {
        numMisses = 0
        #print(sprintf("Drew %s on draw %d, a hit!", startNode, length(current_node_set)+1))
        hits = c(hits, startNode)
      } else {
        numMisses = numMisses + 1
      }

      current_node_set = c(current_node_set, startNode)
      if (all(S %in% current_node_set) || numMisses>thresholdDrawT) {
        stopIterating = TRUE
      }

    }
    ranks[[n]] = current_node_set
  }
  names(ranks) = S
  return(ranks)
}


#' Populate Date Columns
#'
#' Creates various date columns for WRTDS study.
#'
#' @param rawData vector with dateTime
#' @return DateFrame dataframe
#' @importFrom lubridate decimal_date
#' @export
#' @examples
#' dateTime <- c('1984-02-28 13:56', '1984-03-01', '1986-03-01')
#' expandedDateDF <- populateDateColumns(dateTime)
populateDateColumns <- function(rawData){  # rawData is a vector of dates
  DateFrame <- as.data.frame(matrix(ncol=1,nrow=length(rawData)))
  colnames(DateFrame) <- c('Date')
  DateFrame$Date <- rawData
  dateTime <- as.POSIXlt(rawData)
  DateFrame$Julian <- as.numeric(julian(dateTime,origin=as.Date("1850-01-01")))
  DateFrame$Month <- dateTime$mon + 1
  DateFrame$Day <- dateTime$yday + 1
  year <- dateTime$year + 1900
  hour <- dateTime$hour
  minute <- dateTime$min

  if (sum(hour) == 0 & sum(minute) == 0){
    dateTime$hour <- rep(12,length(dateTime))
  }

  leapOffset <- ifelse((year%%4 == 0) & ((year%%100 != 0) | (year%%400 == 0)), 0,1)

  DateFrame$Day[DateFrame$Day > 59] <- DateFrame$Day[DateFrame$Day > 59] + leapOffset[DateFrame$Day > 59]

  DateFrame$DecYear <- decimal_date(dateTime)
  DateFrame$MonthSeq <- ((year-1850)*12)+DateFrame$Month
  return (DateFrame)

}