#' Performance Analysis Tools for R
#'
#' pbdPAPI is an R package which offers a set of R bindings for the Performance
#' Application Programming Interface (PAPI).  PAPI is a high-level C library
#' for gathering information from hardware performance counters.  PAPI measures
#' events like cache misses, flops, etc.
#'
#' \tabular{ll}{
#'    Package: \tab pbdPAPI\cr
#'    Type: \tab Package\cr License: \tab BSD 2-Clause\cr
#' }
#'
#' @useDynLib pbdPAPI,
#'    papi_event_avail, papi_epc_on, papi_epc_off, papi_flips_on,
#'    papi_flips_off, papi_flops_on, papi_flops_off, papi_hwinfo,
#'    R_papi_cpuinfo, papi_hwname, papi_check_counters,
#'    papi_event_counter_init, papi_event_counter_on,
#'    papi_event_counter_off, papi_utilization_on, papi_utilization_off
#'
#' @name pbdPAPI-package
#' @docType package
#' @author Drew Schmidt \email{schmidt AT math.utk.edu}, Christian Hckendorf,
#' and Wei-Chen Chen.
#' @references Programming with Big Data in R Website: \url{http://r-pbd.org/}
#' PAPI website: \url{http://icl.cs.utk.edu/PAPI/}
NULL


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of uniform prior wonky world model predictions"
#' author: "Judith Degen"
#' date: "January 26, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/writing/_2015/_journal_cognition/pics/")
source("../rscripts/helpers.r")

# get prior modes
priormodes = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/modes.txt",sep="\t", header=T, quote="")
row.names(priormodes) = paste(priormodes$Item)

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/24_sinking-marbles-prior-fourstep/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = priorexpectations$Item

# histogram of expectations
exps = ggplot(priorexpectations, aes(x=expectation_corr)) +
  geom_histogram() +
  scale_x_continuous(name="Expected value of prior distribution",breaks=seq(1,15, by=2)) +
  scale_y_continuous(name="Number of cases",breaks=seq(0,8, by=2))
ggsave("priorexpectations-histogram.pdf",width=5,height=3.7)

# get prior allstate-probs
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/24_sinking-marbles-prior-fourstep/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
row.names(priorprobs) = priorprobs$Item
head(priorprobs)

# histogram of allstate-probs
allprobs = ggplot(priorprobs, aes(x=X15)) +
  geom_histogram() +
  scale_x_continuous(name="Prior all-state probability") +
  scale_y_continuous(name="Number of cases")
ggsave("priorallprobs-histogram.pdf")

library(gridExtra)
pdf("priordistributions.pdf",width=10,height=4)
grid.arrange(exps, allprobs, nrow=1,widths=unit.c(unit(.5, "npc"), unit(.5, "npc")))
dev.off()

#####################################
# plot model predictions: expectations
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/mp-uniform.RData")

# plot expectations for unreliable speaker model:
toplot = droplevels(subset(mp, Quantifier == "some"))
nrow(toplot)
head(toplot)
summary(toplot)
ub = droplevels(subset(toplot, State == 15))

ggplot(ub, aes(x=PriorProbability, y=PosteriorProbability, color=as.factor(SpeakerOptimality))) +
  geom_point() +#color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth() +#color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior all-state probability") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior all-state probability") +
  facet_wrap(~WonkyWorldPrior)
ggsave("speakerreliability-ieoptimality.pdf",height=8,width=11)

# plot expectations for best basic model:
toplot = droplevels(subset(mp, QUD == "how-many" & Alternatives == "0_basic" & Quantifier == "some" & WonkyWorldPrior == .5))
nrow(toplot)
pexpectations = ddply(toplot, .(Item), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability)/15)
head(pexpectations)
some = pexpectations#droplevels(subset(pexpectations, Quantifier == "some"))

toplot = droplevels(subset(some, SpeakerOptimality == 2))
nrow(toplot)
head(toplot)
toplot$Mode = priormodes[as.character(toplot$Item),]$Mode

ggplot(toplot, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior expectation")

pexpectations = ddply(toplot, .(Item, SpeakerOptimality,PriorExpectation_smoothed, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability)/15)
head(pexpectations)
some = pexpectations#droplevels(subset(pexpectations, Quantifier == "some"))

toplot = droplevels(subset(some, SpeakerOptimality == 2))
nrow(toplot)
head(toplot)
toplot$Mode = priormodes[as.character(toplot$Item),]$Mode

ggplot(toplot, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior expectation")
#  geom_text(data=cors, aes(label=r)) +

#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
ggsave("model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
save(toplot, file="../data/toplot-expectations.RData")

# plot by prior mode instead
ggplot(toplot, aes(x=Mode, y=PosteriorExpectation_predicted)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,15), name="Prior mode") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior expectation")

toplot_w = toplot
# get rRSA predictions for qud=how-many, alts=0_basic, spopt=2
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/complex_prior/smoothed_unbinned15/results/data/toplot-expectations.RData")
toplot_r = toplot
head(toplot_w)
summary(toplot_r)
toplot_r$Model = "RSA"
toplot_w$Model = "wRSA"

# plot regular rsa predictions
ggplot(toplot_r, aes(x=PriorExpectation_smoothed*15, y=PosteriorExpectation_predicted*15)) +
  geom_point(color="#007fb1") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#007fb1") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Prior expected number of objects") +
  scale_y_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Posterior predicted number of objects")
#  geom_text(data=cors, aes(label=r)) +

#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
ggsave("model-expectations-rrsa.pdf",width=6.5,height=4.5)#,width=30,height=10)

# plot both rRSA and uniform wRSA expectation predictions in same plot
toplot = merge(toplot_r,toplot_w, all=T)
head(toplot)
nrow(toplot)
p_exps = ggplot(toplot, aes(x=PriorExpectation_smoothed*15, y=PosteriorExpectation_predicted*15, color=Model)) +
  geom_point() + #color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth() + #color="#00B0F6") +
  scale_color_manual(values=c("#007fb1", "#4ecdff")) +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Prior expected number of objects") +
  scale_y_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Posterior predicted number of objects")
#  geom_text(data=cors, aes(label=r)) +
#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
#ggsave("graphs/model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("model-expectations-binomial-regular.pdf",width=6.5,height=4.5)
ggsave("model-expectations-uniform-regular.pdf",width=6.5,height=4.5)

# plot model predictions: allstate-probs
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/mp-uniform.RData")
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/mp-binomial.RData")

# plot expectations for best basic model:
toplot = droplevels(subset(mp, QUD == "how-many" & Alternatives == "0_basic" & Quantifier == "some" & WonkyWorldPrior == .5 & State == 15))
nrow(toplot)

# adjust speaker optimality at will
toplot = droplevels(subset(toplot, SpeakerOptimality == 2))
nrow(toplot)
head(toplot)

ggplot(toplot, aes(x=PriorProbability, y=PosteriorProbability)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior probability of all-state") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior probability of all-state")
#  geom_text(data=cors, aes(label=r)) +

#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
ggsave("model-allprobs.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("model-uniform-allprobs.pdf",width=5.5,height=4.5)#,width=30,height=10)
save(toplot, file="../data/toplot-allprobs.RData")

toplot_w = toplot
# get rRSA predictions for qud=how-many, alts=0_basic, spopt=2
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/complex_prior/smoothed_unbinned15/results/data/mp.RData")
summary(mp)
toplot = droplevels(subset(mp, QUD == "how-many" & Alternatives == "0_basic" &  State == 15))
nrow(toplot)

# adjust speaker optimality at will
toplot = droplevels(subset(toplot, SpeakerOptimality == 2))
nrow(toplot)
head(toplot)

toplot_r = toplot

# plot only rrsa
ggplot(toplot_r, aes(x=PriorProbability, y=PosteriorProbability)) +
  geom_point(color="#007fb1") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#007fb1") + #color="#00B0F6") +
  #scale_color_manual(values=c("#007fb1")) +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior probability of all-state") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior probability of all-state")
#  geom_text(data=cors, aes(label=r)) +
#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
#ggsave("graphs/model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("model-allprobs-rrsa.pdf",width=6.5,height=4.5)

head(toplot_w)
summary(toplot_r)
toplot_r$Model = "RSA"
toplot_w$Model = "wRSA"

# plot both rRSA and uniform wRSA expectation predictions in same plot
toplot = merge(toplot_r,toplot_w, all=T)
head(toplot)
nrow(toplot)
p_probs = ggplot(toplot, aes(x=PriorProbability, y=PosteriorProbability, color=Model)) +
  geom_point() + #color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth() + #color="#00B0F6") +
  scale_color_manual(values=c("#007fb1", "#4ecdff")) +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior probability of all-state") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior probability of all-state")
#  geom_text(data=cors, aes(label=r)) +
#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
#ggsave("graphs/model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("model-allprobs-binomial-regular.pdf",width=6.5,height=4.5)
ggsave("model-allprobs-uniform-regular.pdf",width=6.5,height=4.5)

library(gridExtra)
#  share a legend between multiple plots
g <- ggplotGrob(p_exps + theme(legend.position="right"))$grobs
legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]]
p_exps_nolegend = p_exps + theme(legend.position="none")
p_probs_nolegend = p_probs + theme(legend.position="none")

#pdf("rsa-predictions-uniform.pdf",width=10,height=4)
pdf("rsa-predictions.pdf",width=10,height=4)
grid.arrange(p_exps_nolegend, p_probs_nolegend, legend,nrow=1,widths=unit.c(unit(.45, "npc"), unit(.45, "npc"), unit(.1, "npc")))
dev.off()

s = subset(r, quantifier=="Some" & Proportion == "100")
nrow(s)

library(lmerTest)
m=lmer(normresponse ~ AllPriorProbability + (1+AllPriorProbability|workerid) + (1|Item), data=s)
summary(m)

#####################################
# plot model predictions: wonkiness
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/wr-uniform.RData")
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/wr-binomial.RData")

# plot expectations for best basic model:
toplot = droplevels(subset(wr, WonkyWorldPrior == .5 & Wonky == "true"))
nrow(toplot)
toplot$Mode = priormodes[as.character(toplot$Item),]$Mode

toplot = droplevels(subset(toplot, SpeakerOptimality == 2))
mod = toplot
nrow(toplot)
head(toplot)

p_wmodel = ggplot(toplot, aes(x=PriorExpectation, y=PosteriorProbability,color=Quantifier)) +
  geom_point() + #color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth() + #color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior expected number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Model predicted wonkiness probability")

ggsave("model-wonkiness-uniform.pdf",width=5.5,height=4)#,width=30,height=10)
ggsave("model-wonkiness-binomial.pdf",width=5.5,height=4)#,width=30,height=10)

# plot by mode
ggplot(toplot, aes(x=Mode, y=PosteriorProbability,color=Quantifier)) +
  geom_point() + #color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth() + #color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior expected number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Model predicted wonkiness probability")

############
# empirical wonkiness posteriors
############
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/17_sinking-marbles-normal-sliders/results/data/r.RData")
head(r)
nrow(r)

ggplot(r, aes(x=response, fill=quantifier)) +
  geom_histogram() +
  facet_grid(workerid~quantifier)
ggsave("subject-variability-wonkiness.pdf",width=7,height=25)

toplot = aggregate(response ~ quantifier + Item + PriorExpectation, FUN="mean", data=r)
toplot = droplevels(subset(toplot, quantifier %in% c("All","Some","None")))
toplot$Quantifier = factor(tolower(toplot$quantifier), levels=c("all", "none","some"))
toplot$Mode = priormodes[as.character(toplot$Item),]$Mode

p_wempirical = ggplot(toplot, aes(x=PriorExpectation, y=response, color=Quantifier)) +
  geom_point() +
  geom_smooth() +
  scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior expected number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Mean empirical wonkiness probability")
ggsave(file="empirical-wonkiness.pdf",width=5.5,height=4)

library(gridExtra)
#  share a legend between multiple plots
g <- ggplotGrob(p_wmodel + theme(legend.position="right"))$grobs
legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]]
p_wmodel_nolegend = p_wmodel + theme(legend.position="none")
p_wempirical_nolegend = p_wempirical + theme(legend.position="none")

#pdf("rsa-predictions-uniform.pdf",width=10,height=4)
pdf("wonkiness-fullplot.pdf",width=12,height=5)
grid.arrange(p_wmodel_nolegend, p_wempirical_nolegend, legend,nrow=1,widths=unit.c(unit(.45, "npc"), unit(.45, "npc"), unit(.1, "npc")))
dev.off()

# scatterplot of mdoel vs empirical
head(toplot)
toplot$PosteriorProbability = toplot$response
head(mod)
toplot$Type = "empirical"
mod$Type = "model"

pl = merge(mod, toplot, all=T)
summary(pl)
pl$Type = as.factor(as.character(pl$Type))
topl = pl %>% select(Item, Quantifier,PosteriorProbability,Type) %>%
  spread(Type,PosteriorProbability)
summary(topl)

ggplot(topl, aes(x=model,y=empirical,color=Quantifier,group=1)) +
  geom_point() +
  geom_smooth(method="lm") +
  scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6"))
cor(topl$model,topl$empirical,use="pairwise.complete.obs") # cor=.69

library(hydroGOF)
gof(topl$model,topl$empirical,na.rm=T,do.spearman=T)

#plot by mode
ggplot(toplot, aes(x=Mode, y=response, color=Quantifier)) +
  geom_point() +
  geom_smooth() +
  scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior expected number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Mean empirical wonkiness probability")

###############
## EMPIRICAL PLOTS
###############

# expectations
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")

agr = aggregate(ProportionResponse ~ PriorExpectationProportion + quantifier + Item,data=r,FUN=mean)
#agr$CILow = aggregate(ProportionResponse ~ PriorExpectationProportion + quantifier + Item,data=r, FUN=ci.low)$ProportionResponse
#agr$CIHigh = aggregate(ProportionResponse ~ PriorExpectationProportion + quantifier + Item,data=r,FUN=ci.high)$ProportionResponse
#agr$YMin = agr$ProportionResponse - agr$CILow
#agr$YMax = agr$ProportionResponse + agr$CIHigh

min(agr[agr$quantifier == "Some",]$ProportionResponse)
max(agr[agr$quantifier == "Some",]$ProportionResponse)

p_eexps = ggplot(agr, aes(x=PriorExpectationProportion*15, y=ProportionResponse*15, color=quantifier)) +
  geom_point() +
  #geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_smooth(method="lm") +
  scale_color_manual(values=c("#F8766D", "black", "#00BF7D", "gray30", "#00B0F6"),breaks=levels(agr$quantifier),labels=c("all","long filler","none","short filler","some")) +
  scale_y_continuous(breaks=seq(1,15,by=2),name="Posterior mean number of objects") +
  #  geom_abline(intercept=0,slope=1,color="gray70") +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior mean number of objects")
ggsave(file="meanresponses.pdf",width=5,height=3.7)

# allstate-probs
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/16_sinking-marbles-sliders-certain/results/data/r.RData")

# exclude people who are doing some sort of bullshit and not responding reasonably to all/none (see subject-variability.pdf for behavior on zero-slider)
tmp = subset(r,!workerid %in% c(0,22,43,98,100,103,117,118))
agrr = aggregate(normresponse ~ AllPriorProbability + Proportion + quantifier + Item,data=tmp,FUN=mean)
agrr = aggregate(normresponse ~ AllPriorProbability + Proportion + quantifier + Item,data=r,FUN=mean)
ub = subset(agrr, Proportion == "100")
ub = droplevels(ub)

p_eprobs = ggplot(ub, aes(x=AllPriorProbability, y = normresponse, color=quantifier)) +
  geom_point() +
  geom_smooth(method="lm") +
  scale_color_manual(values=c("#F8766D", "black", "#00BF7D", "gray30", "#00B0F6"),breaks=levels(agrr$quantifier),labels=c("all","long filler","none","short filler","some")) +
  scale_y_continuous(limits=c(0,1),name="Posterior probability of all-state ") +
  #  geom_abline(intercept=0,slope=1,color="gray70") +
  scale_x_continuous(limits=c(0,1),name="Prior probability of all-state")
ggsave(file="empirical-allprobs.pdf",width=5,height=3.7)

library(gridExtra)
#  share a legend between multiple plots
g <- ggplotGrob(p_eexps + theme(legend.position="right"))$grobs
legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]]
p_eexps_nolegend = p_eexps + theme(legend.position="none")
p_eprobs_nolegend = p_eprobs + theme(legend.position="none")

pdf("empirical-results.pdf",width=10,height=4)
grid.arrange(p_eexps_nolegend, p_eprobs_nolegend, legend,nrow=1,widths=unit.c(unit(.45, "npc"), unit(.45, "npc"), unit(.1, "npc")))
dev.off()

# plot subejct variability for exclusion
ggplot(r[r$Proportion == "0",], aes(x=normresponse,fill=quantifier)) +
  geom_histogram() +
  facet_grid(workerid~quantifier)
ggsave("subject-variability.pdf",width=5.5,height=4)

######################
### NOAH'S MODEL PREDICTIONS
rsa_allstate = read.csv(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/ndg-code/RSA-allstate.csv",header=F)
head(rsa_allstate)
colnames(rsa_allstate) = c("BinomialCW","PosteriorAllProbability")
ggplot(rsa_allstate, aes(x=BinomialCW,y=PosteriorAllProbability)) +
  geom_point(color="#00B0F6") +
  scale_x_continuous(limits=c(0,1), name="Binomial coin weight") +
  scale_y_continuous(limits=c(0,1), name="Predicted posterior probability of all-state")
ggsave("noahs-allstate-predictions.pdf",width=4.5,height=3.5)

rsa_expectation = read.csv(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/ndg-code/RSA-expectation.csv",header=F)
head(rsa_expectation)
colnames(rsa_expectation) = c("PriorExpectation","PosteriorExpectation")
ggplot(rsa_expectation, aes(x=PriorExpectation/15,y=PosteriorExpectation/15)) +
  geom_point(color="#00B0F6") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Predicted posterior expectation")
ggsave("noahs-expectation-predictions.pdf",width=4.5,height=3.5)

rsa_expall = read.csv(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/ndg-code/RSA-expectedVsallstate.csv",header=F)
head(rsa_expall)
colnames(rsa_expall) = c("PriorExpectation","PosteriorExpectation")
ggplot(rsa_expall, aes(x=PriorExpectation/15,y=PosteriorExpectation)) +
  geom_point(color="#00B0F6") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Predicted posterior probability of all-state")
ggsave("noahs-allstate-predictions-bypriorexp.pdf",width=4.5,height=3.5)


#pdf("test.pdf")
#GRvar=3
#group_ids=as.character(levels(factor(f_table[,GRvar])))
par(cex.axis=0.6)

MINCOL=ncol(add_table)+ncol(id_table)-1
GRvar=2
message("writeoutput_positive")
save.image(file= paste(outputfile,"_datainputbeforewrite.rdata"))
if (ncol(f_table_positive)>MINCOL){
for (i in c((MINCOL+1): ncol(f_table_positive))){
    thisdatatable= data.frame(values=f_table_positive[,i], group=f_table_positive[,GRvar])
	  thisdataname = names(f_table_positive)[i]
	  meanstable = create.mean.table(thisdatatable,group_ids)
  	ymax = max(meanstable$means$values)+1.2*max(meanstable$ses$values)
  	ymin = min(0,min(meanstable$means$values)-1.2*max(meanstable$ses$values))
  	ymin=ifelse(is.na(ymin),0,ymin)
  	ymax=ifelse(is.na(ymax),0,ymax)
	  mybarplot(meanstable$means$values,meanstable$ses$values,rownames = group_ids,main=paste("mean of ", thisdataname),ylab=thisdataname,ylim= c(ymin,ymax))
  }
}

message("writeoutput index")
if (ncol(f_table_index)> MINCOL){
for (i in c((MINCOL+1):(ncol(f_table_index)-1))){
  	thisdatatable= data.frame(values=f_table_index[,i], group=f_table_positive[,GRvar])
  	thisdataname = names(f_table_index)[i]
  	meanstable = create.mean.table(thisdatatable,group_ids)
  	ymax = 1
  	ymin = -1
  	mybarplot(meanstable$means$values,meanstable$ses$values,rownames = group_ids,main=paste("mean of ", thisdataname),ylab=thisdataname,ylim= c(ymin,ymax))
  }
}
##plot stripe deviation
if (ncol(f_table_index)> MINCOL+2){
  i= MINCOL+3
    thisdatatable= data.frame(values=f_table_index[,i], group=f_table_positive[,GRvar])
	  thisdataname = names(f_table_index)[i]
	  meanstable = create.mean.table(thisdatatable,group_ids)
	  ymax = 50
	  ymin = 0
	  mybarplot(meanstable$means$values,meanstable$ses$values,rownames = group_ids,main=paste("mean of ", thisdataname),ylab="stripe deviation [degrees]",ylim= c(ymin,ymax))
	  abline(h=44, col=2)

}
# ###
###now with boxplots
groupn=length(levels(f_table_index$group))
genotypen=length(levels(as.factor(f_table_index$genotype)))
if (genotypen<2){genotypen=groupn}

rep=groupn/genotypen

colors=c()
for (i in c(0,2:genotypen)){
  colors=c(colors,rep(i,rep))
}

if (ncol(f_table_positive)> MINCOL){
  for (i in c((MINCOL+1): ncol(f_table_positive))){
    message(i)
    thisdatatable= data.frame(values=f_table_positive[,i], group=f_table_positive[,2])
    thisdataname = names(f_table_positive)[i]

    ymax =  max(thisdatatable$values)
    ymin = min(0,thisdatatable$values)
    ymin=ifelse(is.na(ymin),0,1.05*ymin)
    ymax=ifelse(is.na(ymax),0,1.05*ymax)
    boxplot(thisdatatable$values~thisdatatable$group,col=colors,las=2, main= thisdataname, ylab=thisdataname,ylim= c(ymin,ymax))

  }
}
message("writeoutput index")
if (ncol(f_table_index)>2){
  for (i in c(MINCOL+1,MINCOL+2)){
    thisdatatable= data.frame(values=f_table_index[,i], group=f_table_index[,2])
    thisdataname = names(f_table_index)[i]
    meanstable = create.mean.table(thisdatatable,group_ids)
    ymax = 1
    ymin = -1
    boxplot(thisdatatable$values~thisdatatable$group,col=colors,las=2, main= thisdataname, ylab=thisdataname,ylim= c(ymin,ymax))
  abline(h=0, col=2)
    }
}
##plot stripe deviation
if (ncol(f_table_index)>MINCOL+2){
  i=MINCOL+3
  thisdatatable= data.frame(values=f_table_index[,i], group=f_table_index[,2])
  thisdataname = names(f_table_index)[i]
  meanstable = create.mean.table(thisdatatable,group_ids)
  ymax = 60
  ymin = 0
  boxplot(thisdatatable$values~thisdatatable$group,col=colors, main= thisdataname, ylab=thisdataname,ylim= c(ymin,ymax),las=2)
  abline(h=45, col=2)
  #legend(x=1,y=60,legend=levels(as.factor(f_table_index$genotype)), fill=c(0:5))
}

# #dev.off()


#' @title df_to_sp
#' @description This function takes a dataframe and converts in to a spatialpointsdataframe
#' @param df default is \code{NULL}. This is the dataframe you want to spatialize.
#' @param lat.field the default is \code{"LATITUDE"}. the name of the field holding latitude values
#' (in decimal degrees)
#' @param lon.field the default is \code{"LONGITUDE"}.  the name of the field holding longitude
#' values (in decimal degrees)
#' @param the.crs the default is \code{EPSG:4326}.  This is the projection
#' of the incoming data.  This is NOT what you want the projection to be.
#' Assigning a projection, and reprojecting are different.
#' @param autoQC the default is \code{TRUE}.  This runs df_qc_spatial()
#' automatically, ensuring that all coordinates are in the Northern hemsisphere
#' (i.e. Latitude between 0 and 90N) and the western hemisphere (i.e. Longitude
#' between -180 and 0W)
#' @return spatialpointsdataframe
#' @family general_use
#' @author  Mike McMahon, \email{Mike.McMahon@@dfo-mpo.gc.ca}
#' @export
df_to_sp <- function(df = NULL, lat.field="LATITUDE", lon.field="LONGITUDE", the.crs = "EPSG:4326", autoQC = TRUE){
  df = df_qc_spatial(df = df, lat.field = lat.field, lon.field = lon.field, return.bad = FALSE, autoQC=autoQC)
  df.sp = sp::SpatialPointsDataFrame(
    coords = df[, c(lon.field, lat.field)],
    data = df,
    proj4string = sp::CRS(SRS_string=the.crs)
  )
  return(df.sp)
}


###VISUALISE MODEL OUTPUTS###
library(tidyverse)
library(ggpubr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, '..', 'results')

#get peru cost data
data_per = read.csv(file.path(folder_inputs, 'PER', 'cost_item_results.csv'))
data_per$country = "Peru (PER)"

per_deciles = select(data_per, modeling_region, pop_density_km2)
per_deciles = unique(per_deciles)
per_deciles$decile <- cut(per_deciles$pop_density_km2,
                       breaks = quantile(per_deciles$pop_density_km2, probs = seq(0, 1, 0.1)),
                       labels = 10:1, include.lowest = TRUE)
per_deciles$modeling_region = NULL
data_per <- merge(data_per,per_deciles,by="pop_density_km2")

#get indonesia cost data
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, '..', 'results')

data_idn = read.csv(file.path(folder_inputs, 'IDN', 'cost_item_results.csv'))
data_idn$country = ifelse(grepl("Papua", data_idn$names),
                          "Papua (IDN)", "Kalimantan (IDN)")

papua = data_idn[data_idn$country == 'Papua (IDN)',]
kalimantan = data_idn[data_idn$country == 'Kalimantan (IDN)',]

###papua
papua_deciles = select(papua, modeling_region, pop_density_km2)
papua_deciles = unique(papua_deciles)
papua_deciles$decile <- cut(papua_deciles$pop_density_km2,
                          breaks = quantile(papua_deciles$pop_density_km2,
                                            probs = seq(0, 1, 0.1)),
                          labels = 10:1, include.lowest = TRUE)
papua_deciles$modeling_region = NULL
papua <- merge(papua,papua_deciles,by="pop_density_km2")

###kalimantan
kalimantan_deciles = select(kalimantan, modeling_region, pop_density_km2)
kalimantan_deciles = unique(kalimantan_deciles)
kalimantan_deciles$decile <- cut(kalimantan_deciles$pop_density_km2,
                          breaks = quantile(kalimantan_deciles$pop_density_km2,
                                            probs = seq(0, 1, 0.1)),
                          labels = 10:1, include.lowest = TRUE)
kalimantan_deciles$modeling_region = NULL
kalimantan <- merge(data_idn,kalimantan_deciles,by="pop_density_km2")

###combine
data_idn = rbind(papua, kalimantan)
data = rbind(data_per, data_idn)
remove(data_per, data_idn, papua, kalimantan, per_deciles, papua_deciles, kalimantan_deciles)

deciles_values = data %>%
  group_by(country, decile) %>%
  top_n(1, pop_density_km2)

deciles_values = select(deciles_values, country, decile, pop_density_km2)
deciles_values = unique(deciles_values)

data$cost_usd = data$cost_usd / 1e6

data$asset_type = factor(data$asset_type, levels=c(
  'two_60cm_antennas_usd', 'two_90cm_antennas_usd',
  'tower_10_m_usd', 'radio_installation',
  'site_survey_and_acquisition', 'power_system', 'cost_freq_for_link_usd'),
  labels=c('Antennas', 'Antennas',
           'Tower + Transport', 'Radios + Installation',
           'Site Survey + Acquisition',
           'Power System', "Frequency Cost"))

data$strategy = factor(data$strategy, levels=c(
  'clos', 'nlos'),
  labels=c('CLOS-only', 'Hybrid CLOS-NLOS'))

# data$country = factor(data$iso3, levels=c(
#   'PER', 'IDN'),
#   labels=c('Peru', 'Indonesia'))

data$decile = factor(data$decile, levels=c(
  '1', '2', '3', '4', '5', '6', '7', '8', '9', '10'),
  labels=c('1', '2', '3', '4', '5', '6', '7', '8', '9', '10'))

totals <- data %>%
  select(country, strategy, decile, cost_usd) %>%
  group_by(country, strategy, decile) %>%
  summarize(total = round(sum(cost_usd)))

costs = ggplot(data, aes(x=decile, y=cost_usd, fill=asset_type)) +
  geom_bar(stat="identity") +
  theme(legend.position = 'bottom') +
  scale_y_continuous(expand = c(0, 0), breaks = seq(0,200,50),
                     limits = c(0, 150)) +
  labs(colour=NULL,
       title = "Cost per Smartphone User for Universal Broadband",
       subtitle = "Results reported by scenario, strategy and population decile",
       x = 'Population Density Decile (Inhabitants km^2', y = "Per Smartphone Cost ($USD)",
       fill='Cost\nType') +
  theme(panel.spacing = unit(0.6, "lines"),
        axis.text.x = element_text(angle = 45)) +
  expand_limits(y=0) +
  guides() +
  geom_text(
    aes(decile, total +10, label = total, fill = NULL), #total + 225
    size=2.5, data = totals) +
  facet_grid(strategy~country, scales = "free")

path = file.path(folder, 'figures', 'cost_composition.png')
ggsave(path, units="in", width=7, height=6, dpi=300)
print(costs)
dev.off()


presence.absence = function( X, px=NULL, include_zero_values_in_quantiles=FALSE ) {

  if( is.null(px)) stop("Must define px, the lower probability to consider no observation of significance in the quanttile distribution")
  # calc quantiles

  nX = length(X)
  probs = pa = rep( NA, nX )

  zerovalues = which( X == 0 ) # zero valued

  if (include_zero_values_in_quantiles) {
    si = 1:nX    # all values
  } else {
    si = which( X > 0)  # positive values
  }

  # operating upon empirical qunatiles
  Y = X[si]
  i = which( is.finite( Y ) )
  pr = ecdf(Y[i]) ( Y[i] )
  ix = which( pr ==1 )
  if ( !{ length(ix) %in% c(0, nX) } )  pr[ix] = max( pr[-ix] )
  Y[i] = pr

  probs[si] = Y

  sb = which( probs < px )  # buffer zone
  s0 = unique( c(sb, zerovalues ) )
  s1 = which( probs >= px )

  # presence-absence
  pa[s1] = 1
  pa[zerovalues] = 0
  pa[s0] = 0

  # after the above is set, modify for those with values known to be zero
  probs[zerovalues] = 1

  # determine appropriate weights
  # quantiles less than px have a weight that is 1-px  -- maximum close to zero
  probs[s1] = pmax( 0.01, probs[s1] )
  if (length(sb)>0) probs[sb] = pmax( 0.01,  1 - probs[sb] )  # inverting probs
  probs[zerovalues] = 1

  return ( list(data=X, pa=pa, probs=probs ) )  # returns/adds pa and X$wt to data frame which represents the P/A and relative confidence of correctness
}


#' qual.aov
#'
#' total qualitative data
#'
#' @param formula,data,r,i,j,fac
#'
#' @return table, anova
#'
#' @examples
#' A<-c(1,1,2,2,3,3,4,4)
#' B<-rep(c("plus","minus"),4)
#' Y<-c(190.00,10.00,178.00,22.00,194.00,6.00,170.00,30.00)
#' k<-data.frame(A,B,Y)
#'
#' @export
#'
#' @importFrom
#' stats model.frame
#' stats anova
#' stats lm

qual.aov<-function(formula,data,r,i,j,fac){
  Call<-match.call()
  indx<-match(c("formula","data"),names(Call),nomatch=0L)
  if(indx[1]==0L)
    stop("a 'formula' argument is required")
  temp<-Call[c(1L,indx)]
  temp[[1L]]<-quote(model.frame)
  m<-eval.parent(temp)
  Terms<-attr(m,"terms")

  formula.t<-as.character(formula)
  Y.name<-formula.t[2]

  data.n<-strsplit(formula.t[3]," \\* ")[[1]]

  if(data.n[1]=="."){
    var.list<-colnames(data)[colnames(data)!=Y.name]
  } else{
    temp1<-unlist(sapply(data.n,strsplit," "))
    var.list<-unique(temp1[temp1!=" " & temp1 !="*"& temp1!=""])
  }
  if(fac==1){
    ay<-as.numeric(data[[3]])
    v<-matrix(ay,i,j)
    print(v)

    A<-as.numeric(data[[1]])
    B<-as.numeric(data[[2]])

    ct<-(sum(v[2,])^2/((length(unique(A))*(r))))
    st<-sum(v[2,])-ct
    sa<-sum(v[2,]^2)/r-ct
    se<-st-sa

    m<-anova(lm(formula))
    e<-NULL
    e<-m[c(1,2,3),]
    e[1,2]<-round(sa,2)
    e[1,3]<-e[1,2]/e[1,1]
    e[2,1]<-r*length(unique(A))-e[1,1]-1
    e[2,2]<-se
    e[2,3]<-e[2,2]/e[2,1]
    e[1,4]<-e[1,3]/e[2,3]
    e[2,4]<-""
    e[2,5]<-""
    e[3,1]<-r*length(unique(A))-1
    e[3,2]<-st
    e[3,3]<-""
    f<-as.numeric(e[1,4])
    g<-as.numeric(e[1,1])
    h<-as.numeric(e[2,1])
    e[1,5]<-1-pf(f,g,h)

    n<-NULL
    n[1]<- "A"
    n[2]<- "E"
    n[3]<- "T"
    rownames(e)<-n

    print(e)
  }else{
    ay<-as.numeric(data[[4]])
    v<-matrix(ay,i,j)
    print(v)

    A<-as.numeric(data[[1]])
    B<-as.numeric(data[[2]])

    ct<-sum(c(v[,2],v[,4],v[,6],v[,8]))^2/(length(unique(A))*length(unique(B))*r)
    st<-sum(c(v[,2],v[,4],v[,6],v[,8]))-ct
    sa<-sum(c(sum(v[,2]),sum(v[,4]),sum(v[,6]),sum(v[,8]))^2)/(r*length(unique(B)))-ct
    sb<-sum(sum(c(v[1,2],v[1,4],v[1,6],v[1,8]))^2,sum(c(v[2,2],v[2,4],v[2,6],v[2,8]))^2)/(r*length(unique(A)))-ct
    sab<-sum(v[1,2]^2,v[1,4]^2,v[1,6]^2,v[1,8]^2,v[2,2]^2,v[2,4]^2,v[2,6]^2,v[2,8]^2)/r-ct
    se1<-sab-sa-sb
    se2<-st-sab
    se22<-st-sa-sb

    m<-anova(lm(formula))
    e<-NULL
    e<-m[c(1,2,3,4),]
    e[1,2]<-round(sa,3)
    e[1,3]<-e[1,2]/e[1,1]
    e[2,2]<-round(sb,3)
    e[2,3]<-e[2,2]/e[2,1]
    e[3,1]<-(length(unique(A))-1)*(length(unique(B))-1)
    e[3,2]<-se1
    e[3,3]<-e[3,2]/e[3,1]
    e[1,4]<-e[1,3]/e[3,3]
    e[2,4]<-e[2,3]/e[3,3]
    e[4,1]<-(r*length(unique(A))*length(unique(B))-1-e[1,1]-e[2,1]-e[3,1])
    e[4,2]<-se2
    e[4,3]<-e[4,2]/e[4,1]
    e[3,4]<-e[3,3]/e[4,3]

    f<-as.numeric(e[1,4])
    l<-as.numeric(e[2,4])
    p<-as.numeric(e[3,4])
    g<-as.numeric(e[1,1])
    j<-as.numeric(e[2,1])
    h<-as.numeric(e[3,1])
    o<-as.numeric(e[4,1])

    e[1,5]<-1-pf(f,g,h)
    e[2,5]<-1-pf(l,j,h)
    e[3,5]<-1-pf(p,h,o)
    n<-NULL
    n[1]<- "A"
    n[2]<- "B"
    n[3]<- "E1(A*B)"
    n[4]<- "E2"
    rownames(e)<-n

    if(e[3,5]<0.1){
      print(e)
      cat("\n")
    }else{
      za<-anova(lm(ay~A+B))
      az<-NULL
      az<-za[c(1,2,3),]
      az[1,1]<-length(unique(A))-1
      az[1,2]<-round(sa,3)
      az[1,3]<-az[1,2]/az[1,1]
      az[2,2]<-round(sb,3)
      az[2,3]<-az[2,2]/az[2,1]
      az[3,1]<-(r*length(unique(A))*length(unique(B))-1-e[1,1]-e[2,1])
      az[3,2]<-se22
      az[3,3]<-az[3,2]/az[3,1]
      az[1,4]<-az[1,3]/az[3,3]
      az[2,4]<-az[2,3]/az[3,3]

      f1<-as.numeric(az[1,4])
      l1<-as.numeric(az[2,4])
      g1<-as.numeric(az[1,1])
      j1<-as.numeric(az[2,1])
      h1<-as.numeric(az[3,1])
      az[1,5]<-1-pf(f1,g1,h1)
      az[2,5]<-1-pf(l1,j1,h1)
      print(az)
    }
  }

}


setwd("/home/remoteuser/Code/ROnAzure")
source("SetComputeContext.r")

.libPaths(c(file.path(Sys.getenv("SPARK_HOME"), "R", "lib"), .libPaths()))

library(SparkR)

sparkEnvir <- list(spark.executor.instances = '10',
                   spark.yarn.executor.memoryOverhead = '8000')

sc <- sparkR.init(
  sparkEnvir = sparkEnvir,
  sparkPackages = "com.databricks:spark-csv_2.10:1.3.0"
)

sqlContext <- sparkRSQL.init(sc)

airPath <- file.path(fullDataDir, "AirlineSubsetCsv")

# create a SparkR DataFrame for the airline data
airDF <- read.df(sqlContext, airPath, source = "com.databricks.spark.csv",
                 header = "true", inferSchema = "true")

################################################
# Data Cleaning and Transformation
################################################

airDF <- SparkR::rename(airDF,
                        ArrDel15 = airDF$ARR_DEL15,
                        Year = airDF$YEAR,
                        Month = airDF$MONTH,
                        DayofMonth = airDF$DAY_OF_MONTH,
                        DayOfWeek = airDF$DAY_OF_WEEK,
                        Carrier = airDF$UNIQUE_CARRIER,
                        OriginAirportID = airDF$ORIGIN_AIRPORT_ID,
                        DestAirportID = airDF$DEST_AIRPORT_ID,
                        CRSDepTime = airDF$CRS_DEP_TIME,
                        CRSArrTime =  airDF$CRS_ARR_TIME
)

# Select desired columns from the flight data.
varsToKeep <- c("ArrDel15", "Year", "Month", "DayofMonth", "DayOfWeek", "Carrier", "OriginAirportID", "DestAirportID", "CRSDepTime", "CRSArrTime")
airDF <- select(airDF, varsToKeep)

# Round down scheduled departure time to full hour.
airDF$CRSDepTime <- floor(airDF$CRSDepTime / 100)

################################################
# Output to CSV
################################################

# Increase numCSVs when working with larger data
# on a larger cluster
numCSVs <- 2 # write.df below will produce this many CSV files
airDF <- repartition(airDF, numCSVs)

# write result to directory of CSVs
write.df(airDF, file.path(fullDataDir, "airDFCsvSubset"), "com.databricks.spark.csv", "overwrite", header = "true")

# We can shut down the SparkR Spark context now
sparkR.stop()

# remove non-data files
if (is(rxOptions()$fileSystem, "RxHdfsFileSystem"))
{
  rxHadoopRemove(file.path(fullDataDir, "airDFCsvSubset/_SUCCESS"))
} else
{
  file.remove(Sys.glob(file.path(dataDir, "airDFCsvSubset/.*.crc")))
  file.remove(Sys.glob(file.path(dataDir, "airDFCsvSubset/_SUCCESS")))
}

################################################
# Import to compressed, binary XDF format
################################################

colInfo <- list(
  ArrDel15 = list(type="numeric"),
  Year = list(type="factor"),
  Month = list(type="factor"),
  DayofMonth = list(type="factor"),
  DayOfWeek = list(type="factor"),
  Carrier = list(type="factor"),
  OriginAirportID = list(type="factor"),
  DestAirportID = list(type="factor"),
  CRSDepTime = list(type="integer"),
  CRSArrTime = list(type="integer")
)

airDFTxt <- RxTextData(file.path(dataDir, "airDFCsvSubset"),
                       colInfo = colInfo)

finalData <- RxXdfData(file.path(dataDir, "airDFXDFSubset"))

# For local compute context, skip the following line
startRxSpark()

rxImport(inData = airDFTxt, finalData, overwrite = TRUE)

system('hadoop fs -ls /user/RevoShare/remoteuser/Data')

rxGetInfo(finalData, getVarInfo = T)
# File name: /user/RevoShare/remoteuser/Data/airDFXDFSubset
# Number of composite data files: 2
# Number of observations: 1900875
# Number of variables: 10
# Number of blocks: 4
# Compression type: zlib
# Variable information:
#   Var 1: ArrDel15, Type: numeric, Low/High: (0.0000, 1.0000)
# Var 2: Year
# 2 factor levels: 2011 2012
# Var 3: Month
# 2 factor levels: 2 1
# Var 4: DayofMonth
# 31 factor levels: 13 17 21 25 1 ... 2 26 29 30 31
# Var 5: DayOfWeek
# 7 factor levels: 7 4 1 5 2 6 3
# Var 6: Carrier
# 17 factor levels: AA AS B6 CO DL ... US WN XE YV VX
# Var 7: OriginAirportID
# 295 factor levels: 12478 12892 13830 11298 12173 ... 11699 14955 13139 10728 10577
# Var 8: DestAirportID
# 295 factor levels: 12892 12478 11298 13830 14771 ... 15048 13139 10728 11699 14955
# Var 9: CRSDepTime, Type: integer, Low/High: (0, 23)
# Var 10: CRSArrTime, Type: integer, Low/High: (1, 2400)

# For local compute context, skip the following line
rxSparkDisconnect(rxGetComputeContext())

Applied Machine Learning for Developers/R server Tools for scaling R using Azure/code/ROnAzure/1-Clean-Subset.r


subroutine inddup(x,y,n,rw,frac,dup)
implicit double precision(a-h,o-z)
logical dup(n)
dimension x(n), y(n), rw(4)

xtol = frac*(rw(2)-rw(1))
ytol = frac*(rw(4)-rw(3))

dup(1) = .false.
do i = 2,n {
	dup(i) = .false.
	do j = 1,i-1 {
		dx = abs(x(i)-x(j))
		dy = abs(y(i)-y(j))
		if(dx < xtol & dy < ytol) {
			dup(i) = .true.
			break
		}
	}
}

return
end


# Figure 3: Estimates of parliamentary polarization, by session.
rm(list=ls())

wd <- getwd() # assumes this is run from the replication folder, with data in a subdirectory.
data.dir <- paste0(wd, "/data/")

out<- read.csv(paste0(data.dir, "acc_j27_allmembers.csv"))

dat <- read.csv(paste0(data.dir, "years_session_index.csv"))
#dat <- read.csv(paste0(data.dir, "years_d4.csv"))

#colors and pch
ps <-  as.character(dat$partypm)
cols<- ps
cols[ps=="con"] <- "lightblue"
cols[ps=="lab"] <- "red"
cols[ps=="war"] <- "gray"
cols[ps=="coalition"] <- "cadetblue2"

pchs <- ps
pchs[ps=="con"] <- 21
pchs[ps=="lab"] <- 22
pchs[ps=="war"] <- 23
pchs[ps=="coalition"] <- 24
pchs <- as.numeric(pchs)

out$max.mean <- apply(out[,3:6], FUN=max, MARGIN=1)
out$max.median <-  apply(out[,7:10], FUN=max, MARGIN=1)

require(strucchange)
bp <- breakpoints(out$max.mean~1)
elections <- which( dat$ge==1 )

x11()
par(bg='cornsilk1', las=2)
plot(1:length(out$max.mean), out$max.mean,  axes=F, type="b", lwd=2, xlab="election (year-month)", ylab="accuracy", pch=pchs, col='black',
     bg=cols, cex=2)
abline(v=bp$breakpoints, lwd=2, col="darkgreen")

axis(1, at=c(1, bp$breakpoints, elections, nrow(out)  ),
     labels=out$yrmth[c(1, bp$breakpoints, elections, nrow(out))], cex.axis=.7 )
axis(2)
box()

legend("topleft", pch=c(21, 22, 23, 24), col=c('black'), pt.bg=c('lightblue', 'red', 'gray', 'cadetblue2'), legend=c("Conservative", "Labour", "War", "Coalition") ,
       cex=1.5, bty="n")


format.crude.odds = function(r) {
    dec = 2
   r$Odd = paste( round(r$OddsRatio,dec), " (", round(r$Lower95CI,dec), " - ", round(r$Upper95CI,dec), " )", sep="")

   r$Level2 = r$Level
   for ( i in 1:nrow(res) ) {
     r$Level[i] = sub(r$Covariate[i], "",  r$Level2[i], fixed=T )
   }

   output=r[, c("Covariate", "Level", "Nlevel", "Odd", "Chisq.Pvalue") ]
   return(output)
}


#============== libraries ======================================================

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

#================= sample loading normalization ================================

SL_Norm <- function(df, color = NULL, plot = TRUE) {
    # This makes each channel sum to the average grand total
        # df - data frame of TMT intensities
        # returns a new data frame with normalized values

    # compute scaling factors to make colsums match the average sum
    norm_facs <- mean(c(colSums(df))) / colSums(df)
    cat("SL Factors:\n", sprintf("%-5s -> %f\n", colnames(df), norm_facs))
    df_sl  <- sweep(df, 2, norm_facs, FUN = "*")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(df_sl), col = color, notch = TRUE, main = "SL Normalized data")
    }
    df_sl
}

# ================== TMM normalization from DGEList object =====================

apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

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

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors
    cat("Overall Factors (lib.size+TMM):\n", sprintf("%-5s -> %f\n",
                                                     colnames(y$counts), norm_facs))

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

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(tmt_tmm), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    tmt_tmm
}

# ============== CV function ===================================================

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

# =========== Boxplot with median label ========================================

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

# ================= reformat edgeR test results ================================

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

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

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

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

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

    temp # return the data frame
}

# =============== p-value plots ================================================

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

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

# ============= log2 fold-change distributions =================================

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

# ========== Setup for MA and volcano plots ====================================

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

    df # return the data frame
}

# ========== MA plots using ggplot =============================================

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

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

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

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

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

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

# ========== Scatter plots using ggplot ========================================

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

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

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

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

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

# ========== Volcano plots using ggplot ========================================

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

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

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

# ============== individual protein expression plots ===========================

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_candidates <- function(proteins, nleft, nright, show_these = c("high", "med", "low")) {
    num_col <- ncol(proteins)
    width <- options()$repr.plot.width
    height <- options()$repr.plot.height
    set_plot_dimensions(6, 4)
    proteins <- proteins %>%
        filter(candidate %in% show_these) %>% arrange(candidate)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[4:num_col]))
        names(vec) <- colnames(row[4:num_col])
        title <- str_c(row$identifier, ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3), ", ", row$candidate)
        barplot(vec, col = color, main = title)
    }
    set_plot_dimensions(width, height)
}

plot_top_tags <- function(proteins, nleft, nright, top_tags) {
    num_col <- ncol(proteins)
    width <- options()$repr.plot.width
    height <- options()$repr.plot.height
    set_plot_dimensions(6, 4)
    top_identifiers <- get_identifier(top_tags)
    proteins <- proteins %>%
        filter(identifier %in% top_identifiers) %>%
        arrange(desc(FDR))

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[4:num_col]))
        names(vec) <- colnames(row[4:num_col])
        title <- str_c(row$identifier, ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3), ", ", row$candidate)
        barplot(vec, col = color, main = title)
    }
    set_plot_dimensions(width, height)
}
# set up data frame
candidates <- data.frame(identifier = get_identifier(results$Acc), candidate = results$candidate,
                       FDR = results$FDR, tmt_tmm[left], tmt_tmm[right])
plot_candidates(candidates, length(left), length(right), c("high", "med", "low"))
plot_top_tags(candidates, length(left), length(right), top_tags$genes)

THESE WORK WITH RESULTS FRAMES

# ============== individual protein expression plots ===========================

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_candidates <- function(results, nleft, nright, show_these = c("high", "med", "low")) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot

    # get desired candidates
    proteins <- proteins %>%
        filter(candidate %in% show_these) %>% arrange(candidate)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3), ", ", row$candidate)
        barplot(vec, col = color, main = title)
    }
}

plot_top_tags <- function(results, nleft, nright, top_tags) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top ipregulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}
# plot the top 25 up and 20 down proteins
set_plot_dimensions(6, 3.5)
plot_top_tags(gal_glu, 3, 3, 20)
set_plot_dimensions(7, 7)


#R-code for the BSCAM&D logo
#BSCAM&D: Bayesian Statistical Catch Age Model & Diagnostics
graphics.off()
quartz("SCAM logo", width=6, height=3)

logo <- function()
{
	set.seed(42008)
	n=5000; f=20; j=200; sd=0.4
	px = (1:n)/(2*n)
	ht = -.05 + (.05+.05)* sin((1:n-1)/(n-1)*12*pi)
	i=rnorm(n, 0.3, sd*px)
	s=rnorm(n, 0.2, sd*px)
	c=rnorm(n, 0.1, sd*px)
	a=rnorm(n, 0.0, sd*px)
	m=rnorm(n, -.1, sd*px)

	shift=0.1*n
	x = cbind(1:n, 1:n+shift, 1:n+2*shift, 1:n+3*shift, 1:n+4*shift)
	y = cbind(i, s, c, a, m)

	par(mfcol=c(1, 1),
		xaxt="n", yaxt="n", mar=rep(0.25, length=4), oma=rep(0, length=4))

	matplot(x, y+ht, lty=1, type="l",col=1:4,  ylim=c(-0.75, 0.75), bty="n", ylab="", xlab="", xlim=c(-10, 0.5*n))

	id <- c(1:3, 5)
	text(x[1, id]-0.01*n, y[1, id]-.12, c("i", "S", "C", "M"), srt=0, col=1:3, cex=2, font=2)
	text(x[1, 4]-0.01*n, y[1, 4]-.12, c("A"), srt=180, col=4, cex=2, font=2)
}

# Encapsulate postscript file for conversion to png
logo()
dev.copy2eps(file="iscamLogo.eps", width=6, height=3)
dev.off()

#png(file="iScamLogo.png", bg="transparent")
#png(file="iScamLogo.png", bg="transparent",width=100, height=50, pointsize=6)
# png(file="iscamLogo.png", bg="transparent", width=440, height=220, res=220)
# par(mfcol=c(1, 1),
# 	xaxt="n", yaxt="n", mar=rep(0.25, length=4), oma=rep(0, length=4))
# logo()
#
# dev.off()
system("convert iscamLogo.eps -strip iscamLogo.png")
system("convert iscamLogo.eps -resize 300x150 -strip iscamLogoSmall.png")
system("convert iscamLogo.eps -resize 300x150 -strip iscamLogo.gif")


precision_recall <- read.csv("C:/Users/gaya/prog/workspace/TutorialRecommender/joda-prec-recall.csv")

pdf("C:/Users/gaya/Dropbox/project/thesis/pics/joda_similarity_r.pdf")

plot(precision_recall$threshold,precision_recall$precision, "l", col = "red",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylab = "Precision-Recall",
     xlab="Threshold");

lines(precision_recall$threshold,precision_recall$recall, "l", col = 'green');

legend("topright",legend=c("Precision","Recall"), col=c("red","green"),
       text.col=c("red","green"), lty=1,
       inset=0.01)
dev.off()

# precision-recall curve
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/joda_prec-rec_r.pdf")
plot(precision_recall$recall,precision_recall$precision,  col = 'red', "o",
     ylim = c(-0.1, 1.04), cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5,
     ylab = "Precision", xlab="Recall");
text(precision_recall$recall,precision_recall$precision, precision_recall$threshold, cex = 0.8, pos = "3", offset = 0.2)
dev.off()

# math library
precision_recall <- read.csv("C:/Users/gaya/prog/workspace/TutorialRecommender/math-prec-recall.csv")
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/math_similarity_r.pdf")
plot(precision_recall$threshold,precision_recall$precision, "l", col = "red",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylab = "Precision-Recall",
     xlab="Threshold");

lines(precision_recall$threshold,precision_recall$recall, "l", col = 'green');

legend("topright",legend=c("Precision","Recall"), col=c("red","green"),
       text.col=c("red","green"), lty=1,
       inset=0.01)

dev.off()

# precision-recall curve
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/math_prec-rec_r.pdf")
plot(precision_recall$recall,precision_recall$precision,  col = 'red', "o",
     ylim = c(-0.1, 1.04), cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5,
     ylab = "Precision", xlab="Recall");
text(precision_recall$recall,precision_recall$precision, precision_recall$threshold, cex = 0.8, pos = "3", offset = 0.2)
dev.off()

# java tutorials
precision_recall <- read.csv("C:/Users/gaya/prog/workspace/TutorialRecommender/col-prec-recall.csv")
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/col_similarity_r.pdf")
plot(precision_recall$threshold,precision_recall$precision, "l", col = "red",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylab = "Precision-Recall",
     xlab="Threshold");

lines(precision_recall$threshold,precision_recall$recall, "l", col = 'green');

legend("topright",legend=c("Precision","Recall"), col=c("red","green"),
       text.col=c("red","green"), lty=1,
       inset=0.01)

dev.off()

# precision-recall curve
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/col_prec-rec_r.pdf")
plot(precision_recall$recall,precision_recall$precision,  col = 'red', "o",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylim = c(-0.1, 1.04),
     ylab = "Precision", xlab="Recall");
text(precision_recall$recall,precision_recall$precision, precision_recall$threshold, cex = 0.8, pos = "3", offset = 0.2)
dev.off()

# java tutorials - Jankov
precision_recall <- read.csv("C:/Users/gaya/prog/workspace/TutorialRecommender/jcol-prec-recall.csv")
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/jcol_similarity_r.pdf")
plot(precision_recall$threshold,precision_recall$precision, "l", col = "red",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylab = "Precision-Recall",
     xlab="Threshold");

lines(precision_recall$threshold,precision_recall$recall, "l", col = 'green');

legend("topright",legend=c("Precision","Recall"), col=c("red","green"),
       text.col=c("red","green"), lty=1,
       inset=0.01)

dev.off()

# precision-recall curve
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/jcol_prec-rec_r.pdf")
plot(precision_recall$recall,precision_recall$precision,  col = 'red', "o",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylim = c(-0.1, 1.04),
     ylab = "Precision", xlab="Recall");
text(precision_recall$recall,precision_recall$precision, precision_recall$threshold, cex = 0.8, pos = "3", offset = 0.2)
dev.off()

# Smack
precision_recall <- read.csv("C:/Users/gaya/prog/workspace/TutorialRecommender/smack-prec-recall.csv")
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/smack_similarity_r.pdf")
plot(precision_recall$threshold,precision_recall$precision, "l", col = "red",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylab = "Precision-Recall",
     xlab="Threshold", main="Precision and Recall curves with Verious thresholds\nSmack");

lines(precision_recall$threshold,precision_recall$recall, "l", col = 'green');

legend("topright",legend=c("Precision","Recall"), col=c("red","green"),
       text.col=c("red","green"), lty=1,
       inset=0.01)

dev.off()

# precision-recall curve
pdf("C:/Users/gaya/Dropbox/project/thesis/pics/smack_prec-rec_r.pdf")
plot(precision_recall$recall,precision_recall$precision,  col = 'red', "o",
     cex.main = 1.7, cex.lab = 1.5, cex.axis = 1.5, ylim = c(-0.1, 1.04),
     ylab = "Precision", xlab="Recall", main="Precision-Recall\nSmack");
text(precision_recall$recall,precision_recall$precision, precision_recall$threshold, cex = 0.8, pos = "3", offset = 0.2)
dev.off()


#= Purpose is to prepare the test data in for use in Julia =#
require(MASS)
require(data.table)

source("/home/chib/code/glmSolver/r/paths.r")
source(rCodeFolder %+% "binaryIO.r")

# Read and prep data then write out

# Energy data
energyData = fread(paste0(dataFolder, "modelFrame.csv"))
# Format the data
energyData[, Year := factor(Year)]
energyData[, Day := factor(Day)]
energyData[, HourFactor := factor(HourFactor)]
energyData[, MonthName := factor(MonthName)]

modelFormula1 = formula(paste0("~ ", paste0(c("Year", "Day", "HourFactor",
                       "MonthName", paste0("EnergyLag", 24:47)), collapse = " + ")))
energyX = model.matrix(modelFormula1, data = data.frame(energyData))
energyY = model.matrix(~ EnergyMegaWattHours - 1, data = data.frame(energyData))

# Write as text files
fwrite(data.table(energyX), file = paste0(dataFolder, "energyX.csv"), sep = ",", col.names = FALSE)
fwrite(data.table(energyY), file = paste0(dataFolder, "energyY.csv"), sep = ",", col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "energyX.bin", energyX, 8)
write2DArray(dataFolder %+% "energyY.bin", energyY, 8)
# write1DArray(dataFolder %+% "energyY.bin", as.vector(energyY), 8)

# Write Matrix as block
write2DBlock(dataFolder %+% "energyBlockX", matrixToBlock(energyX, 1000))
write2DBlock(dataFolder %+% "energyBlockY", matrixToBlock(energyY, 1000))

# Function to scale non zero variables to (0,1] scale
nonZeroScale = function(x)
{
  return(x/max(x))
}

# Scaled X Matrix
scaledMatrix = cbind(energyX[,1], scale(energyX[,-1]))
write2DArray(dataFolder %+% "energyScaledX.bin", scaledMatrix, 8)
write2DBlock(dataFolder %+% "energyScaledBlockX", matrixToBlock(scaledMatrix, 1000))

scaledY = matrix(nonZeroScale(energyY[,1]))
write2DArray(dataFolder %+% "energyScaledY.bin", scaledY, 8)
write2DBlock(dataFolder %+% "energyScaledBlockY", matrixToBlock(scaledY, 1000))

# Motor insurance data
insuranceX = model.matrix(~ Kilometres + Zone + Bonus + Make + Insured, data = faraway::motorins)
insuranceY = model.matrix(~ Claims - 1, data = faraway::motorins)

# Write to file
fwrite(data.table(insuranceX), file = paste0(dataFolder, "insuranceX.csv"), sep = ",", col.names = FALSE)
fwrite(data.table(insuranceY), file = paste0(dataFolder, "insuranceY.csv"), sep = ",", col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "insuranceX.bin", insuranceX, 8)
write2DArray(dataFolder %+% "insuranceY.bin", insuranceY, 8)
# write1DArray(dataFolder %+% "insuranceY.bin", as.vector(insuranceY), 8)

# Write Matrix as block
write2DBlock(dataFolder %+% "insuranceBlockX", matrixToBlock(insuranceX, 20))
write2DBlock(dataFolder %+% "insuranceBlockY", matrixToBlock(insuranceY, 20))

# Scaled
scaledMatrix = cbind(insuranceX[,1], scale(insuranceX[,-1]))
write2DArray(dataFolder %+% "insuranceScaledX.bin", scaledMatrix, 8)
write2DBlock(dataFolder %+% "insuranceScaledBlockX", matrixToBlock(scaledMatrix, 20))

scaledY = matrix(nonZeroScale(insuranceY[,1]))
write2DArray(dataFolder %+% "insuranceYScaledY.bin", scaledY, 8)
write2DBlock(dataFolder %+% "insuranceYScaledBlockY", matrixToBlock(scaledY, 20))

# Credit fraud data
cfData = fread(paste0(dataFolder, "creditfraudModelFrame.csv"))
# Basic test for Binomial Model
creditX = model.matrix(Class ~ ., data = cfData)
creditY = model.matrix(~ Class - 1, data = cfData)

# Write to file
fwrite(data.table(creditX), file = paste0(dataFolder, "creditX.csv"), sep = ",", col.names = FALSE)
fwrite(data.table(creditY), file = paste0(dataFolder, "creditY.csv"), sep = ",", col.names = FALSE)
# fwrite(data.table(creditY), file = paste0(dataFolder, "creditY.csv"), sep = ",", col.names = FALSE)

# Write as binary files
write2DArray(dataFolder %+% "creditX.bin", creditX, 8)
write2DArray(dataFolder %+% "creditY.bin", creditY, 8)
# write1DArray(dataFolder %+% "creditY.bin", as.vector(creditY), 8)

# Write Matrix as block
write2DBlock(dataFolder %+% "creditBlockX", matrixToBlock(creditX, 200))
write2DBlock(dataFolder %+% "creditBlockY", matrixToBlock(creditY, 200))

binaryScale = function(x)
{
  x[x == 0] = -1
  return(x)
}

# Scaled X Matrix
scaledMatrix = cbind(creditX[,1], scale(creditX[,-1]))
write2DArray(dataFolder %+% "creditScaledX.bin", scaledMatrix, 8)
write2DBlock(dataFolder %+% "creditScaledBlockX", matrixToBlock(scaledMatrix, 200))

scaledY = matrix(binaryScale(creditY[,1]))
write2DArray(dataFolder %+% "creditScaledY.bin", scaledY, 8)
write2DBlock(dataFolder %+% "creditScaledBlockY", matrixToBlock(scaledY, 200))

# GPA data
gpaData = fread(paste0(dataFolder, "gpaData.csv"))
gpaData[, rank := factor(rank)]

# GPA Data Model Matrices
gpaX = model.matrix(admit ~ ., data = gpaData)
gpaY = model.matrix(~ admit - 1, data = gpaData)

# Write to file
fwrite(data.table(gpaX), file = paste0(dataFolder, "gpaX.csv"), sep = ",", col.names = FALSE)
fwrite(data.table(gpaY), file = paste0(dataFolder, "gpaY.csv"), sep = ",", col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "gpaX.bin", gpaX, 8)
write2DArray(dataFolder %+% "gpaY.bin", gpaY, 8)
# write1DArray(dataFolder %+% "gpaY.bin", as.vector(gpaY), 8)

# Scaled X Matrix
scaledMatrix = cbind(gpaX[,1], scale(gpaX[,-1]))
write2DArray(dataFolder %+% "gpaScaledX.bin", scaledMatrix, 8)

# Write the cars data to file
Cars = data.table(mtcars)
Cars[, cyl := factor(cyl)]
Cars[, vs := factor(vs)]
Cars[, am := factor(am)]
Cars[, gear := factor(gear)]
Cars[, carb := factor(carb)]
carsX = model.matrix(mpg ~ ., data = mtcars)
carsY = model.matrix(~ mpg - 1, data = mtcars)

# Write data to file
fwrite(data.table(carsX), file = paste0(dataFolder, "carsX.csv"), col.names = FALSE)
fwrite(data.table(carsY), file = paste0(dataFolder, "carsY.csv"), col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "carsX.bin", carsX, 8)
write2DArray(dataFolder %+% "carsY.bin", carsY, 8)
# write1DArray(dataFolder %+% "carsY.bin", as.vector(carsY), 8)

# Scaled X Matrix
scaledMatrix = cbind(carsX[,1], scale(carsX[,-1]))
write2DArray(dataFolder %+% "carsScaledX.bin", scaledMatrix, 8)
write2DBlock(dataFolder %+% "carsBlockY", matrixToBlock(carsY, 5))
write2DBlock(dataFolder %+% "carsScaledBlockX", matrixToBlock(scaledMatrix, 5))

# For negative binomial distribution
quineX = model.matrix(Days ~ ., data = quine[quine$Days > 0,])
quineY = model.matrix(~ Days - 1, data = quine[quine$Days > 0,])

# Write data to file
fwrite(data.table(quineX), file = paste0(dataFolder, "quineX.csv"), col.names = FALSE)
fwrite(data.table(quineY), file = paste0(dataFolder, "quineY.csv"), col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "quineX.bin", quineX, 8)
write2DArray(dataFolder %+% "quineY.bin", quineY, 8)
# write1DArray(dataFolder %+% "quineY.bin", as.vector(quineY), 8)

# Scaled X Matrix
write2DArray(dataFolder %+% "quineScaledX.bin", cbind(quineX[,1], scale(quineX[,-1])), 8)

# For binomial model
education = fread(paste0(dataFolder, "education.csv"), sep = ",")
educationX = model.matrix( ~ age + education + wantsMore, data = education)
educationY = model.matrix(~ cbind(using, notUsing) - 1, data = education)

# Write data to file
fwrite(data.table(educationX), file = paste0(dataFolder, "educationX.csv"), col.names = FALSE)
fwrite(data.table(educationY), file = paste0(dataFolder, "educationY.csv"), col.names = FALSE)
# Write as binary files
write2DArray(dataFolder %+% "educationX.bin", educationX, 8)
write2DArray(dataFolder %+% "educationY.bin", educationY, 8)
# write1DArray(dataFolder %+% "educationY.bin", as.vector(educationY), 8)

# Write Matrix as block
write2DBlock(dataFolder %+% "educationBlockX", matrixToBlock(educationX, 8))
write2DBlock(dataFolder %+% "educationBlockY", matrixToBlock(educationY, 8))

# Scaled X Matrix
scaledMatrix = cbind(educationX[,1], scale(educationX[,-1]))
write2DArray(dataFolder %+% "educationScaledX.bin", scaledMatrix, 8)
write2DBlock(dataFolder %+% "educationScaledBlockX", matrixToBlock(scaledMatrix, 8))


rm(list = ls(all.names = TRUE))

library(ape)
library(xml2)

set.seed(44)
x <- rtree(4)
x$node.label <- letters[1:Nnode(x)]
plot(x, show.node.label = TRUE)

ans <- getseq(x)
ans$po
str(ans$off)

ans <- as_phyloxml(x)

f <- tempfile()
xml2::write_xml(ans, f, options = c("format"))
cat(readLines(f), sep="\n")

# Validating the document
xml2::xml_validate(xml2::read_xml(f), xml2::read_xml("inst/phyloxml/phyloxml.xsd"))


#' Create a plot.
#'
#' @export
#' @import ggplot2
#' @examples
#' plot(my_plot())
my_plot <- function() {
  df <- data.frame(x = 1:10, y = sample(10), z = runif(1))

  ggplot(df) + geom_point(aes_string(x = "x", y = "y", colour = "z"))

}


context("%(笑)%: one-argument function alternatives.")

test_that("%(笑)% works as expected with and without parentheses and placeholder", {

  expect_that(1:100 %(笑)% sin %(笑)% abs,       is_identical_to(abs(sin(1:100))))
  expect_that(1:100 %(笑)% sin() %(笑)% abs(),   is_identical_to(abs(sin(1:100))))
  expect_that(1:100 %(笑)% sin(.) %(笑)% abs(.), is_identical_to(abs(sin(1:100))))

  expect_that(iris %(笑)% head, is_identical_to(head(iris)))

  dnormsd <- function(sd) function(x) dnorm(x, sd = sd)
  some_x  <- rnorm(20)
  expect_that(some_x %(笑)% dnormsd(5)(.), is_identical_to(dnormsd(5)(some_x)))
  expect_that(some_x %(笑)% (dnormsd(5)), is_identical_to(dnormsd(5)(some_x)))

  expect_that(some_x %(笑)% dnormsd(5), throws_error())
  expect_that(some_x %(笑)% function(x) {x} %(笑)% sin, throws_error())
})


quantileDesnityPoly <- function(x, y, xlim = range(x, na.rm = TRUE), nbins = 100,
								quantiles = c(0.01, 0.05, 0.1, 0.5, 0.9, 0.95, 0.99),
								ymin = 0.000001, xlog = FALSE, col = make.transparent('black', 0.7), between = FALSE) {#seq(0.01, 0.99, 0.01)
	x0 = x; y0 = y

	if (xlog) {
		if (xlim[1] < 0.00001) xlim[1] = 0.00001
		bins = 10^(seq(log10(xlim[1]), log10(xlim[2]), length.out = nbins + 1))
	}else
		bins = seq(xlim[1], xlim[2], length.out = nbins + 1)

	vx = x[]
	vy = y[]
	findBinRanges <- function(x1, x2)
		quantile(vy[vx < x2 & vx > x1], quantiles, na.rm = TRUE)

	y = mapply(findBinRanges, head(bins, -1), bins[-1])
	x = bins[-1] - diff(bins)/2
	mask = !(apply(is.na(y), 2, any) | (apply(y, 2, sum) == 0))
	y[y < ymin] = ymin
	y = y[, mask]
	x = x[mask]

	if (between) {
		ploygonQs <- function(y1, y2)
			polygon(c(x, rev(x)), c(y1, rev(y2)), border = NA, col = col)
		for (i in 1:(floor(nrow(y))/2)) ploygonQs(y[i,], y[nrow(y) - i + 1,])
	} else {
		ploygonQs <- function(qy)
			polygon(c(x, rev(x)), c(qy, rep(ymin, length(x))), border = NA, col = col)
		apply(y, 1, ploygonQs)
	}
}


  nodes2matrix = function(x, cl) {

    nx = names(x)

    ageclass = cl$yclass
    cats = cl$cats
    varmap = cl$varmap

    n.age = length( ageclass )
    n.cats = length( cats )

    ageclass.indices =  c( 1:n.age )

    M = array( data=0, dim=c(n.age, n.cats), dimnames=list(ageclass, cats) )

    for ( ac in 1:n.age ) {
    for ( vn in 1:n.cats ) {
      vname = i = NULL
      vname = paste( cats[vn], ageclass[ac], sep=".")
      i = which( nx==vname )
      if (length(i) == 0) next
      if (length(i) > 1) {
          print (paste ( "Problem (duplication): ", ageclass[ac], cats[vn] ))
          print (x[i,])
          break
      }
      M[ac, vn] = x[i]
      }}

      M[!is.finite(M)] = 0

  return (M)

  }


#' @title Regresja pierwszego rodzaju.
#' @description
#' Funkcja wylicza regresję pierwszego rodzaju (inaczej mówiąc, parametry
#' warunkowe), domyślnie średnich.
#' @param zmZal ciąg znaków - nazwa zmiennej zależnej
#' @param zmNZal wektor tekstowy z nazwami zmiennych niezależnych
#' @param dane ramka danych zawierająca zmienne występujące w formule
#' @param FUN funkcja służąca do wyliczeniu parametrów warunkowych
#' @details
#' Funkcja \code{FUN} powinna zwracać pojedynczą wartość liczbową i przyjmować
#' argument \code{na.rm}.
#' @return data frame
#' @import plyr
#' @export
regr_pierw_rodz = function(zmZal, zmNZal, dane, FUN = mean) {
	stopifnot(is.data.frame(dane), is.function(FUN),
						is.character(zmZal ), length(zmZal ) == 1,
						is.character(zmNZal), length(zmNZal) >  0
	)
	stopifnot(zmZal %in% names(dane), all(zmNZal %in% names(dane)))
	temp = ddply(dane, zmNZal,
							 function(x, y, FUN) {
							 	return(do.call(FUN, list(x = x[, y], na.rm = TRUE)))
							 },
							 y = zmZal, FUN = FUN
	)
	names(temp)[ncol(temp)] = zmZal
	return(temp)
}
#' @title Regresja nieparametryczna.
#' @description
#' Funkcja przy pomocy funkcji \code{\link[stats]{loess}} wylicza dopasowanie
#' nieparametryczne i przetwarza wyniki w formę zdatnę do łatwego rysowania.
#' @details
#' Funkcja wywołuje \code{\link[stats]{loess}} z parametrami ustawionymi tak,
#' aby nie liczyło się to za długo. Przy tym troszeczkę dopasowuje dokładność
#' (konkretnie parametr \code{cell} do liczby obserwacji, żeby nie przesadzić
#' z upraszczaniem.)
#' @param formula formuła z modelem zależności
#' @param data ramka danych zawierająca zmienne występujące w formule
#' @param degree parametr sterujący wygładzaniem (p. \code{\link[stats]{loess}})
#' @param span parametr sterujący wygładzaniem (p. \code{\link[stats]{loess}})
#' @param control lista zwrócona przez funkcję \code{\link[stats]{loess.control}}
#' @return ramka danych zawierająca zmienne 'x' (wartości zm. niezależnej) i 'y'
#' (przewidywanie)
#' @seealso \code{\link[stats]{loess}}, \code{\link[stats]{loess.control}}
#' @examples
#' x=runif(100000) * 4 - 2
#' y=x+rnorm(100000)
#' z=x+rnorm(100000)
#' plot(z, y, pch='.', cex=0.5)
#' grid(col=grey(0.5))
#' lines(przew_npar(y~z, data.frame(z, y)), col=2, lwd=2)
#' @export
#' @importFrom stats loess
przew_npar = function(formula, data, degree = 2, span = 0.5, control = NULL) {
  stopifnot(
    "formula" %in% class(formula), is.data.frame(data) | is.matrix(data),
    degree %in% c(0,1,2), is.numeric(span), is.null(control) | is.list(control)
  )
  stopifnot(span > 0, all( all.vars(formula) %in% colnames(data) ))

  # w zależności od liczby obserwacji dopasowujemy prametr 'cell'
  # aby dla dużych nie liczyło się za długo, a dla krótkich nie liczyło się zbyt zgrubnie
  if (is.null(control)) {
    if (nrow(data) > 100000) {
      cell = 1
    } else if (nrow(data) > 10000) {
      cell = 0.5
    } else {
      cell = 0.2
    }
    control = loess.control(surface = "interpolate", statistics = "approximate",
                            trace.hat = "approximate", cell = cell)
  }
  # sama estymacja i obróbka wyniku
  przewNpar = loess(formula, data, degree = degree, span = span, control = control)
  przewNpar = unique(setNames(
    as.data.frame(przewNpar[c("x", "fitted")]),
    c("x", "y")
  ))
  return(przewNpar[order(przewNpar$x), ])
}
#' @title Regresja nieparametryczna.
#' @description
#' Funkcja powiela działanie funkcji \code{\link{przew_npar}} i jest uruchamiana
#' z parametrami funkcji \code{\link{regr_pierw_rodz}}.
#' @param zmZal ciąg znaków - nazwa zmiennej zależnej
#' @param zmNZal wektor tekstowy z nazwami zmiennych niezależnych
#' @param dane ramka danych zawierająca zmienne występujące w formule
#' @param przew_nparPar lista z dodatkowymi parametrami dla funkcji przew_npar.
#' @return ramka danych zawierająca zmienne 'x' (wartości zm. niezależnej) i 'y'
#' (przewidywanie)
#' @export
#' @importFrom stats as.formula
przew_npar_rpr = function(zmZal, zmNZal, dane, przew_nparPar = NULL){
  if (is.null(przew_nparPar)) {
    przew_nparPar = list()
  }
  przew_nparPar$formula = as.formula(paste0(zmZal, "~", zmNZal))
  przew_nparPar$data = dane
  przewNPar = do.call(przew_npar, przew_nparPar)
  return(przewNPar)
}


# Script to download GLSDEM and calculate terrestrial metrics

library(raster)
library(gdalUtils)
source("pixel-based/utils/load-sampling-data.r")

# GLSDEM files are 1x1 degree. Downloading it is already implemented for the tile processing chain.
# For pixels, we need to figure out which tiles we need.
# Tiles are in LYYYLXXX, where XXX and YYY are the bottom(!)-left coordinates.

OutputDEMDir = "../../userdata/master-classification/dem/glsdem/" # GLSDEM_n055e020.tif
OutputCSVDir = "../data/pixel-based/covariates/"

ReferenceData = LoadGlobalValidationData()

# Figure out the tiles we need
XIDs = floor(ReferenceData$x) # Floor due to this being the lower-left corner
YIDs = floor(ReferenceData$y)

Tiler = function(i)
{
    # Ignore everything that is not Africa right now
    if (XIDs[i] < -19 || XIDs[i] > 51 || YIDs[i] > 37 || YIDs[i] < -35)
        return(NA)

    XLetter = ifelse(XIDs[i] >= 0, "e", "w")
    YLetter = ifelse(YIDs[i] >= 0, "n", "s")
    return(sprintf("%s%03d%s%03d", YLetter, abs(YIDs[i]), XLetter, abs(XIDs[i])))
}

TileIDs = sapply(1:length(XIDs), Tiler)
UniqueTiles = na.omit(unique(TileIDs))

GLSDEMDownloader = function(TileID)
{
    DEMBaseFilename = paste0("GLSDEM_", TileID)
    TileID_Y = substr(TileID, 1, 4)
    url = paste0("ftp://ftp.glcf.umd.edu/glcf/GLSDEM/Degree_tiles/", TileID_Y, "/",DEMBaseFilename, "/", DEMBaseFilename, ".tif.gz")
    outfile = paste0(OutputDEMDir, "/", DEMBaseFilename, ".tif")
    outfilegz = paste0(outfile, ".gz")
    if(!file.exists(outfilegz) && !file.exists(outfile))
        try(download.file(url, outfilegz, "wget"))
    if(file.exists(outfilegz) && file.size(outfilegz) > 0)
        R.utils::gunzip(outfilegz, remove=TRUE)
    if(file.exists(outfile) && file.size(outfile) > 0)
        return(outfile)
    return(NA)
}

DownloadedTiles = sapply(UniqueTiles, GLSDEMDownloader)

# Write the list to a file (too long to fit on a command line)
write(DownloadedTiles, file.path(OutputDEMDir, "AfricaElevation.txt"), sep="\n")
# The DEM has no NA values, because there are simply no NAs (water is 0, after all).
# Some tiles are missing because they are sea; this implies that they should be set to 0.
gdalbuildvrt(input_file_list=file.path(OutputDEMDir, "AfricaElevation.txt"), output.vrt=file.path(OutputDEMDir, "AfricaElevation.vrt"), verbose=TRUE)
CreationOptions = c("COMPRESS=DEFLATE", "BIGTIFF=YES", "ZLEVEL=9", "NUM_THREADS=ALL_CPUS")
gdaldem("slope", file.path(OutputDEMDir, "AfricaElevation.vrt"), file.path(OutputDEMDir, "AfricaSlope.tif"), s=111120, co=CreationOptions)
# Aspect is set to NA if Slope = 0. We replace it with 0 down the line for RF.
gdaldem("aspect", file.path(OutputDEMDir, "AfricaElevation.vrt"), file.path(OutputDEMDir, "AfricaAspect.tif"), co=CreationOptions)
gdaldem("TPI", file.path(OutputDEMDir, "AfricaElevation.vrt"), file.path(OutputDEMDir, "AfricaTPI.tif"), co=CreationOptions)
gdaldem("TRI", file.path(OutputDEMDir, "AfricaElevation.vrt"), file.path(OutputDEMDir, "AfricaTRI.tif"), co=CreationOptions)
gdaldem("roughness", file.path(OutputDEMDir, "AfricaElevation.vrt"), file.path(OutputDEMDir, "AfricaRoughness.tif"), co=CreationOptions)

Elevation = raster(file.path(OutputDEMDir, "AfricaElevation.vrt"))
Slope = raster(file.path(OutputDEMDir, "AfricaSlope.tif"))
Aspect = raster(file.path(OutputDEMDir, "AfricaAspect.tif"))
TPI = raster(file.path(OutputDEMDir, "AfricaTPI.tif"))
TRI = raster(file.path(OutputDEMDir, "AfricaTRI.tif"))
Roughness = raster(file.path(OutputDEMDir, "AfricaRoughness.tif"))
TerrainIndices = stack(Elevation, Slope, Aspect, TPI, TRI, Roughness)
names(TerrainIndices) = c("elevation", "slope", "aspect", "tpi", "tri", "roughness")
TerrainMatrix = extract(TerrainIndices, ReferenceData)
rownames(TerrainMatrix) = ReferenceData$location_id
TerrainMatrix[,"aspect"][is.na(TerrainMatrix[,"aspect"])] = 0 # Replace NA aspect with 0, otherwise can't use RF
write.csv(TerrainMatrix, file.path(OutputCSVDir, "terrain-validation.csv"))


#Density plots of variable importance.
rm(list=ls())
source('paths.r')
library(mgcv)

#set output path.----
#output.path <- 'test.png'
#output.path <- ITS_variable.imp_all_fungi.path

#load variable importance data.----
pl <- readRDS(NEON_var_importance_data_ddirch_16S.path)
#pl <- readRDS(NEON_var_importance_data_ddirch_16S.path) # i think this is on the SCC, which is down right now...

#Get a matrix where columns are variables, rows are fungal groups, entries are variable importance scores.----
all <- list()
for(i in 1:length(pl)){all[[i]] <- pl[[i]]$mean}
all <- do.call(cbind, all)
#all <- cbind(fg$mean,all)
all <- all[,-grep('other',colnames(all))] #drop 'other' category.
all <- t(all)
#all <- log(all)
#get density.
d <- list()
for(i in 1:ncol(all)){
  to.dens <- all[,i]
  #to.dens <- to.dens[to.dens < 2]
  to.dens <- log10(to.dens)
  d[[i]] <- density(to.dens)
}

#get predictor names
#namey <- c('%C','C:N','pH','NPP','MAT','MAP','Forest (0-1)','Conifers (0-1)','% ECM Trees')
namey <- colnames(all)
#get common x and y limits.----
xmin <- list()
xmax <- list()
ymax <- list()
for(i in 1:length(d)){
  xmin[[i]] <- min(d[[i]]$x)
  xmax[[i]] <- max(d[[i]]$x)
  ymax[[i]] <- max(d[[i]]$y)
}
limx <- c(min(unlist(xmin)), max(unlist(xmax)))
limy <- c(0, max(unlist(ymax)))

#begin plot.----
#png setting.
png(filename=output.path,width=8,height=8,units='in',res=300)

#global plot settings.
trans <- 0.3 #shading transparency.
o.cex <- 1.3 #outer label size.
shade_col <- 'green'

par(mfrow = c(3,3),
    mar = c(5,1,1,1),
    oma = c(4,2.75,1,1))
for(i in 1:length(d)){
  dens <- d[[i]]
  plot(dens, xlim = limx, bty = 'n', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0, axes=F)
  axis(1, pos = 0)
  polygon(dens, col = adjustcolor(shade_col,trans))
  mtext(namey[i], side = 1, line = 2.8, cex = o.cex)
}
#outer labels.
mtext(expression(paste('log' ['10'],' effect size')), side = 1, outer = T, cex = 1.8, line = 2)
mtext(expression(paste('Relative Density')), side = 2, outer = T, cex = 1.8, line = -1.5)

#end plot.
dev.off()

#Single panel, overlapping.
#cols <- RColorBrewer::brewer.pal(9, 'Pastel1')
#par(mfrow=c(1,1))
#plot(dens, xlim = c(-2.5,0.5), ylim = limy, bty = 'n', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0, axes=F)
#hist(log10(all[,i]), xlim = c(-2.5,0.5), bty = 'n', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1)
#axis(1, pos = 0)
#axis(2, at=limx, labels=c("",""), lwd.ticks=0)
#axis(2, las = 1)
#for(i in 1:length(d)){
#  polygon(d[[i]], col = adjustcolor(cols[i],trans))
#}
#mtext('effect size', side = 1, line = 2.5, cex = o.cex)


#############################################################################################################################
dev.off()
rm(list=ls())
library(tidyverse)
library(dplyr)
library(eurostat)
library(pals)
library(ggrepel)
library(ggpubr)
library(ggplot2)

data.dir <- "C:\\Users\\Magdalena\\demography\\education\\data\\shareedu"
data.out <- "C:\\Users\\Magdalena\\demography\\education\\data\\ready"
setwd(data.dir)

femall <- read.table(file="BL_F.csv", sep=",", header=TRUE)
maleall <- read.table(file="BL_M.csv", sep=",", header=TRUE)

setwd(data.out)
countrylist <- read.table(file="countrylist.csv", sep=",")

edu3544 <- femall %>%
  filter(country %in% t(countrylist), agefrom==35) %>%
  mutate(high=lh, sex="f") %>%
  select(sex,country,year,high) %>%
  bind_rows(maleall %>%
              filter(country %in% t(countrylist), agefrom==35) %>%
              mutate(high=lh, sex="m") %>%
              select(sex,country,year,high))
mean3544 <- edu3544 %>%
  group_by(sex,year) %>%
  dplyr::summarize(country=1,high=mean(high))

dev.off()
pdf(file = "C:/Users/Magdalena/demography/education/figures/eduexpansion.pdf",  width = 6, height = 8, onefile=FALSE)

ggarrange(ggplot(NULL, aes(x=year, y=high, group=country))  +
            theme(legend.position="none") +
            geom_line(data=(edu3544 %>% filter(sex=="f")), col="grey90") +
            geom_line(data=(mean3544%>% filter(sex=="f")),col="black")+
            geom_line(data=(edu3544%>% filter(sex=="f",country=="Italy")),col="black", lty=3)+
            geom_line(data=(edu3544%>% filter(sex=="f",country=="Canada")),col="black", lty=3)+
            annotate("text", x=2005, y=65, label= "Canada") +
            annotate("text", x=2005, y=10, label= "Italy") +
  theme(plot.margin = unit(c(0.5,0.5,1,1), "lines"))+
  theme(
    panel.background = element_rect(fill = "transparent",colour = NA),
    plot.background = element_rect(fill = "transparent",colour = NA),
    axis.line = element_line(colour = "black", size = 0.2, linetype = "solid"))+
    scale_x_continuous(name="Year", limits=c(1950,2015), breaks=c(seq(from=1950,to=2010,by=10),2015), labels=c(seq(from=1950,to=2010,by=10),2015))+
    scale_y_continuous(name="in %", limits=c(0,68))+
  ggtitle("Female") + theme(plot.title = element_text(face="bold")),
ggplot(NULL, aes(x=year, y=high, group=country))  +
         theme(legend.position="none") +
         geom_line(data=(edu3544 %>% filter(sex=="m")), col="grey90") +
         geom_line(data=(mean3544%>% filter(sex=="m")),col="black")+
         geom_line(data=(edu3544 %>% filter(sex=="m", country=="Italy")),col="black", lty=3)+
         geom_line(data=(edu3544 %>% filter(sex=="m", country=="Canada")),col="black", lty=3)+
         annotate("text", x=2005, y=60, label= "Canada") +
         annotate("text", x=2005, y=10, label= "Italy") +
         theme(plot.margin = unit(c(0.5,0.5,1,1), "lines"))+
         theme(
           panel.background = element_rect(fill = "transparent",colour = NA),
           plot.background = element_rect(fill = "transparent",colour = NA),
           axis.line = element_line(colour = "black", size = 0.2, linetype = "solid"))+
         scale_x_continuous(name="Year", limits=c(1950,2015), breaks=c(seq(from=1950,to=2010,by=10),2015), labels=c(seq(from=1950,to=2010,by=10),2015))+
         scale_y_continuous(name="in %", limits=c(0,68))+
  ggtitle("Male") + theme(plot.title = element_text(face="bold")),
nrow=2,ncol=1,common.legend = TRUE, legend="bottom")

dev.off()


#######################
# Written by: Stephanie Chen (stchen3@ncsu.edu)
# Purpose: Example code for implementation of bootstrap, direct, and multivariate tests

# This code gives an example of generating data using the 'gen.data' function, based on
# the simulation study in the main paper. See the function for a description
# of inputs. The function outputs a data.frame of functional data that can be directly
# input into any of the testing function. The second example using the DTI dataset
# from the refund package.
#
# The functions 'bootstrap.test', 'direct.test', and 'multivariate.test' can be called
# to perform the corresponding test for the inputted dataset. Note that the multivariate'
# test can only be applied to dense (balanced) data where all subjects have the same
# time points. See the relevant function for information about changing default settings.
#
# Each testing function takes the two inputs inputs:
# 1) data: data.frame with 3 columns: .value, .index, .id; do not included missing observations
# .value: Functional predictor, does not need to be demeaned
# .index: Observed timepoints, from -1 to 1
# .id: Subject ids, must be in sequentially order beginning from 1, with no missing subjects
# 2) times: vector of all possible timepoints from -1 to 1, in sequential order
#
# Each testing function returns the null and alternative model fits, test statistic,
# and p-value. See the individual function pages for details.
#######################
library(devtools)
devtools::load_all()

# libraries
library(nlme)
library(MASS)
library(refund)
library(matrixcalc)
library(mgcv)
library(Matrix)
library(Bolstad)
library(splines)

type_1(seed = 2021087, k = 1, n = 100, m = 7, L = 10, mixed = T,
trunc.eig = F, #"equally-spaced"
center.bs = F, off_diag = F, no.pen = T)

# Example 1. Simulated data from null model, with 100 subjects and 80 obs/subj
RNGkind("L'Ecuyer-CMRG", sample.kind = "Rej")
set.seed(2021085)
data <- gen.data(deviation = "trigonometric", nsubj = 100, r = 0, M = 7, mixed_m = T)
times <- seq(-1, 1, length.out = 80) # all possible time points
m_cov_truth <- 1 + tcrossprod(times) - 0.5 * times - 0.5 * matrix(rep(times, 80), 80, byrow = T)
set.seed(2021085)
# Implement the tests
system.time(face.b <- bootstrap.face(data, nbs = 1000, argvals.new = times,
center.bs = T, no.pen = F, trunc.eig = 2))

face.b$p
face.b$bs.approx
face.b$Tn
norm(face.b$C.null - m_cov_truth, type = "F")
norm(face.b$C.alt - m_cov_truth, type = "F")
mean((face.b$sigma2 - 1)^2)
# v_rand <- c()
# for(i in 1:10) {
#     v_rand <- c(v_rand, rnorm(1))
# }
# v_rand
# Comparison methods
system.time(fit.b <- bootstrap.test(data, times, nbs = 10)) # pilot bootstrap test with 10 resamples
# fit.b<-bootstrap.test(data,times,nbs=1000) # full bootstrap test with 1000 resamples
fit.d <- direct.test(data, times) # direct test
fit.m <- multivariate.test(data, times) # multivariate test (note: data must be dense, ie M=80)

## deviation from null
f_devnull <- function (r, deviation = "trigonometric", n=1e5) {
    grid <- seq(-1, 1, length.out = n)
    var_z <- switch(
        deviation,
        "quadratic" = r^2 * grid^4,
        "trigonometric" = r^2 * (sin(2 * pi * grid) ^2 + sin(4 * pi * grid) ^2)
    )
    mean(var_z / (1 + grid^2 + var_z))
}

dev_grid <- seq(0, 0.99, length.out = 5)
r_grid_quad <- sapply(dev_grid, function(t) {
                uniroot(function(x) f_devnull(x, "quadratic") - t,
                c(0, 1e5))$root})
r_grid_trig <- sapply(dev_grid, function(t) {
                uniroot(function(x) f_devnull(x) - t,
                c(0, 1e5))$root})

# Example 2. DTI data from "refund" package
nsub.full <- 382
times <- round(seq(-1, 1, length.out = 93), digits = 5)

data.full <- data.frame(.value = c(t(DTI$cca)), .index = rep(times, nsub.full), .id = rep(DTI$ID, each = 93), case = rep(DTI$case, each = 93), visit = rep(DTI$visit.time, each = 93))
data.full <- subset(data.full, case == 1 & visit == 0) # limit to patients w/ MS, baseline only
data.full <- data.full[complete.cases(data.full$.value), ] # no missing data

# Clean data of subjects w/ missing obs and renumber subjs sequentially
delete.subj <- NULL
data <- NULL # final dataset
new.subj <- 1
for (i in unique(data.full$.id)) {
    subj <- subset(data.full, .id == i)
    if (nrow(subj) < 93) {
        delete.subj <- c(delete.subj, i)
    }
    else {
        subj$.id <- new.subj
        data <- rbind(data, subj)
        new.subj <- new.subj + 1
    }
}

# Implement the tests
fit.b <- bootstrap.test(data, times, nbs = 10) # pilot bootstrap test with 10 resamples
# fit.b<-bootstrap.test(data,times,nbs=1000) # full bootstrap test with 1000 resamples
fit.d <- direct.test(data, times) # direct test
fit.m <- multivariate.test(data, times) # multivariate test (note: data must be dense)

# CD4 count
times <- round(seq(-1, 1, length.out = ncol(cd4)), digits = 5)
# Clean data of subjects w/ missing obs and renumber subjs sequentially
delete.subj <- NULL
data <- NULL # final dataset
value <- NULL; id <- NULL; index <- NULL; count <- NULL
new.subj <- 1

for (i in seq_len(nrow(cd4))) {
  subj.idx <- which(!is.na(cd4[i, ]))
  subj.value <- cd4[i, subj.idx]
  subj.index <- times[subj.idx]
  subj.count <- length(subj.idx)
  if (subj.count < 1) {
    delete.subj <- c(delete.subj, i)
  }
  else {
    id <- c(id, rep(new.subj, subj.count))
    value <- c(value, subj.value)
    index <- c(index, subj.index)
    count <- c(count, subj.count)
    new.subj <- new.subj + 1
  }
}
mean(count)
min(count)
max(count)

# No log-transform stepface
data <- data.frame(y = value, argvals = index, subj = id)
system.time(face.b1 <- bootstrap.face(data, nbs = 1000, argvals.new = times,
trunc.eig = T, center.bs = T, off_diag = T, no.pen = F))

face.b1$p
# log-transform stepface
data <- data.frame(y = log(value), argvals = index, subj = id)
system.time(face.b2 <- bootstrap.face(data, nbs = 1000, argvals.new = times,
fast.tn = F, trunc.eig = T, center.bs = F, off_diag = F, lambda = NULL))
face.b2$p