############################################################
# R script 3 of: Birds exposed to physiological stress     #
# post-breeding engage in stress-reducing social           #
# interactions in winter flocks                            #

# Running the permutation analysis                         #
# note that due to the large files and large computing     #
# time needed to conduct these analysis
# author: Lionel Hertzog                                   #
############################################################

# set wd to local location of the github repo
setwd("~/PostDoc_Ghent/Feeder_stuff/network_stress/")

# load libraries
library(plyr)
library(asnipe)
library(igraph)
library(tidyverse)
library(broom)

# 1. generate the permutations
gmm_d <- readRDS("data/gmmevent_out_2016_2017.rds")

net_orig <- get_network(gmm_d$gbi)

## permutation within days within feeder
infos <- gmm_d$metadata
gbi <- gmm_d$gbi
days <- ceiling(infos$Start / 86400) # set days as integers
days[days==0] <- 1
n_perm <- 10000
# the next command take time and potentially lots of RAM, consider running it in HPC settings
net_rand <- network_permutation(gbi, association_matrix = net_orig, permutations = n_perm,
                                locations = infos$Location, within_location = TRUE, # permutate within feeder
                                days = days, within_day = TRUE) # permutate within days

# now derive some network values
gg_li <- apply(net_rand, 1, function(net) graph_from_adjacency_matrix(net,mode="undirected",weighted = TRUE))

net_val <- lapply(gg_li, function(net) data.frame(betw = betweenness(net, directed = FALSE),
                                                  close = closeness(net, mode = "all", normalized = TRUE),
                                                  eigen = eigen_centrality(net)$vector,
                                                  deg = degree(net, mode = "all"),
                                                  strength = strength(net),
                                                  bird_tag = colnames(net_orig),
                                                  stringsAsFactors = FALSE))

# put this in a data frame
net_df <- rbind.fill(net_val)
net_df$perm <- rep(1:n_perm, each = ncol(net_orig))

# add to these the stress / feather data
cent_perm <- read.csv("data/stress_info.csv")

net_stress <- full_join(net_df, cent_perm, by = "bird_tag")
# save this file
# write.table(net_stress, "data/net_stress_perm.csv",sep = ",", row.names = FALSE)
# read - in the saved file
# net_stress <- read.csv("data/net_stress_perm.csv")

# 2. permutation on the network centrality ~ cort_orig models
# re-load the models
m_orig <- readRDS("models/m_orig.rds")

## the betwenness model
orig_b <- data.frame(term = c("(Intercept)","cort_orig","ageAD","sexm","barl_orig"), estimate = coef(m_orig$betw))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(betw ~ barl_orig + age + sex + cort_orig, .[-c(153, 160),]))) %>%
  left_join(orig_b, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_betw

## the eigen model
orig_e <- data.frame(term = c("(Intercept)","cort_orig","ageAD","sexm","barl_orig"), estimate = coef(m_orig$eigen))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(eigen ~ barl_orig + age + sex + cort_orig, .[-153,]))) %>%
  left_join(orig_e, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_eigen

## the degree model
orig_d <- data.frame(term = c("(Intercept)","cort_orig","ageAD","sexm","barl_orig"), estimate = coef(m_orig$degree))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(deg ~ barl_orig + age + sex + cort_orig, .[-153,]))) %>%
  left_join(orig_d, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_degree

## the strength model
orig_s <- data.frame(term = c("(Intercept)","cort_orig","ageAD","sexm","barl_orig"), estimate = coef(m_orig$strength))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(strength ~ barl_orig + age + sex + cort_orig, .[-153,]))) %>%
  left_join(orig_s, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_strength

# 3. the same models but this time without the pullis
# re-load the models
m_orig_ad <- readRDS("models/m_orig_ad.rds")

## the betwenness model
orig_b <- data.frame(term = c("(Intercept)","cort_orig","sexm","barl_orig"), estimate = coef(m_orig_ad$betw))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(betw ~ barl_orig + sex + cort_orig, .[-153,], subset = age == "AD"))) %>%
  left_join(orig_b, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_betw

## the eigen model
orig_e <- data.frame(term = c("(Intercept)","cort_orig","sexm","barl_orig"), estimate = coef(m_orig_ad$eigen))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(eigen ~ barl_orig + sex + cort_orig, .[-153,], subset = age == "AD"))) %>%
  left_join(orig_e, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_eigen

## the degree model
orig_d <- data.frame(term = c("(Intercept)","cort_orig","sexm","barl_orig"), estimate = coef(m_orig_ad$degree))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(deg ~ barl_orig + sex + cort_orig, .[-153,], subset = age == "AD"))) %>%
  left_join(orig_d, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_degree

## the strength model
orig_s <- data.frame(term = c("(Intercept)","cort_orig","sexm","barl_orig"), estimate = coef(m_orig_ad$strength))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(strength ~ barl_orig + sex + cort_orig, .[-153,], subset = age == "AD"))) %>%
  left_join(orig_s, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_strength

# 4. now accounting for feeding frequency effects
network_dat <- read.csv("data/network_dat.csv")
# re-load the models
m_orig_feeding <- readRDS("models/m_orig_feeding.rds")
net_stress <- merge(net_stress, network_dat[,c("BIRD_ID", "feeding_freq")], by = "BIRD_ID")

## the betwenness model
orig_b <- data.frame(term = c("(Intercept)","cort_orig","sexm", "ageAD","barl_orig", "feeding_freq"),
                     estimate = coef(m_orig_feeding$betw))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(betw ~ barl_orig + sex + age + cort_orig + feeding_freq, .[-153,]))) %>%
  left_join(orig_b, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_betw

## the eigen model
orig_e <- data.frame(term = c("(Intercept)","cort_orig","sexm", "ageAD","barl_orig", "feeding_freq"), estimate = coef(m_orig_feeding$eigen))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(eigen ~ barl_orig + sex + age + cort_orig + feeding_freq, .[-153,]))) %>%
  left_join(orig_e, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_eigen

## the degree model
orig_d <- data.frame(term = c("(Intercept)","cort_orig","sexm", "ageAD","barl_orig", "feeding_freq"),
                     estimate = coef(m_orig_feeding$degree))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(deg ~ barl_orig + sex + age + cort_orig + feeding_freq, .[-153,]))) %>%
  left_join(orig_d, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_degree

## the strength model
orig_s <- data.frame(term = c("(Intercept)","cort_orig","sexm","ageAD","barl_orig", "feeding_freq"), estimate = coef(m_orig_feeding$strength))

net_stress %>%
  filter(!is.na(betw)) %>%
  group_by(perm) %>%
  do(tidy(lm(strength ~ barl_orig + sex + age + cort_orig + feeding_freq, .[-153,]))) %>%
  left_join(orig_s, by = "term") %>%
  group_by(term) %>%
  summarise(p_perm = sum(estimate.x > estimate.y) / n_perm) %>%
  mutate(p_perm = ifelse(p_perm > 0.5, 1 - p_perm, p_perm)) -> dd_strength


pdf_file<-"pdf/networks_barchart_multiple.pdf"
cairo_pdf(bg="grey99", pdf_file,width=10,height=12)

library(igraph)
library(RColorBrewer)

# Import data and prepare chart

df0 <- read.csv("myData/reg_flow.csv", stringsAsFactors=FALSE)
df1 <- read.csv("myData/reg_plot.csv", stringsAsFactors=FALSE)

net <- graph_from_data_frame(d=df0, vertices=df1, directed=T)
netm <- get.adjacency(net, attr="flow", sparse=F)

maxvalue<-max(netm)
n<-nrow(netm)
m<-n
par(mfrow=c(n,m), omi=c(1,4,4,2), mai=c(0,0,0,0), family="Lato Light")

mycolor1<-rgb(255,0,210,maxColorValue=255)
mycolor2<-rgb(0,208,226,maxColorValue=255)

# Create chart

for(i in 1:n)
{
for(j in 1:m)
{
plot(1:1, xlim=c(0,1), ylim=c(0,1), type="n", axes=F)
if(i<j) mycolor<-mycolor1
if(i==j) mycolor<-"grey80"
if(i>j) mycolor<-mycolor2

if (i==1) text(0.5,1.2, df1$region[j], cex=2, xpd=NA, adj=0, srt=45, col=mycolor1)
if (j==1) text(-0.1,0.5, df1$region[i], cex=2, xpd=NA, adj=1, col=mycolor2)

rect(0,0,1,1, col="grey95", border=NA)
rect(0,0,1,netm[i,j]/maxvalue, col=mycolor, border=NA)
text(0.5, 0.5, format(round(netm[i,j], 2), nsmall=2), cex=1.5, col="grey40")
}
}

# Titling

mtext("Migration to:", side=3, outer=T, cex=2.5, line=14, col=mycolor1, adj=0)
mtext("Migration from:", side=2, outer=T, cex=2.5, line=25, col=mycolor2, srt=90)
mtext("Migration 2010-2015", side=3, outer=T, cex=3, adj=1, at=0.4, , line=22, col="grey50", family="Lato Black")
mtext("All figures in millions. Data Source: https://github.com/cran/migest/tree/master/inst/vidwp",1,line=2.5, adj=1, at=0.6, font=3, outer=T)

dev.off()


=begin
= Changes
== 0.71(2005.07.26)
* MPolynomial#derivate
* MPolynomial#map_to

== 0.70(2005.02.02)
* id => object_id

== 0.69(2004.10.15)
* MRationalFunctionField
* MPolynomial#gcd
* SquareMatrix#inverse depends on ufd?

== 0.68(2004.07.28)
* fix Mpolynomial#to_s (for tex)

== 0.67(2004.06.10)
* need_paren_in_coeff?
* Matrix: entries are regulated.
* Matrix: type*type is due to wedge.
* AlgebraicSystem: wedge, superior?
* Polynomial#sub, MPolynomial#sub
* SquareMatrix.determinant
* fix MPolynomial#to_s
* fix Factors#normalize!
* (Co)Vector#norm2, inner_product

== 0.66(2004.06.05)
* fix _hensel_lift (add param 'where')
* sample-geometry01.rb
* title of docs

== 0.65(2004.06.04)
* Polynomial#factor over Polynomial
* reverse var's order in value_on & convert_to in polynomial-convert.rb

== 0.64(2004.03.01)
* return value of SquareMatrix#diagonalize is Strut

== 0.63(2004.01.08)
* fix matrix[i, j] = x

== 0.62(2003.11.13)
* allow f.gcd_coeff_all()

== 0.61(2003.11.06)
* corrected Enumerable#any? in finite-set.rb

== 0.60(2003.07.28)
* AlgebraMatrix(cofactor, cofactor_matrix, adjoint)

== 0.59(2003.07.28)
* adapted to the version 1.8.0(preview 4)
* include installer

== 0.58(2002.04.00)
* AlgebraicExtensionField#[n] is lift[n]
* abolish the field of 'poly_exps' of the splitting field' and add 'proots'
* MatrixAlgebra#rank
* Raise Exception for the inverse of the non invertible square matrix
* Use "import-module" for monomial order (0.57.18.01)

== 0.57 (2002.03.16)
* New class
  * Set
  * Map
  * Group
  * PermuationGroup
  * AlgebraicExtensionField
* New methods
  * Galois#group
  * Polynomial#splitting_field
* Rename MinimalDecompositionField to decompose
* Move *.rb to lib/
* Define Polynomial.to_ary and MPolynomial.to_ary

== 0.56 (2002.02.06)
* MPolynomial#with_ord
* Orderings belong to MPolynomial.
* MIndex is not a subclass of Array, now.
* "Integer < Numeric" ==> "Integer"

== 0.55 (2001.11.15)
* Improve Algorithm of Factorization over algebraic fields

== 0.54 (2001.11.05)
* Elementary Divisor
* Jordan Form
* Minimal Decomposition Field

== 0.53 (2001.10.03)

* move "MatrixAlgebra" to "Algebra::MatrixAlgebra"
* move "MatrixAlgebra::Vector" to "Algebra::Vector"
* move "MatrixAlgebra::Covector" to "Algebra::Covector",
* move "MatrixAlgebra::SquareMatrix" to "Algebra::SquareMatrix"

== 0.52 (2001.09.22)

* One-variate polynomial
  * Fundamental operations (addition, multiplication, quotient/remainder, ...)
  * factorization
* Multi-variate polynomial
  * Fundamental operations (addition, multiplication, ...)
  * factorization
  * Creating Groebner-basis, quotient/remainder by Groebner-basis.
* Algebraic systems
  * Creating quotient fields
  * Creating residue class fields
  * Operating matrices.
* Linear Algebra
  * Diagonalization of Symmetrix Matrix

== 0.40 (2001.03.03)

* Initial Version

=end


#!/usr/bin/env Rscript

######## BEGIN FUNCTION BLOCK ##########
make_image<-function(d,outfile,input_width,text_adjust) {
  # decide output type
  filex = substr(outfile,nchar(outfile)-2,nchar(outfile))
  if(filex=="pdf") {
    pdf(outfile,bg="#FFFFFF",height=4.5,width=7)
  } else if (filex=="png") {
    png(outfile,bg="#FFFFFF",width=480,height=240)
  } else {
    stop("Unsupported type for output file.\n",call.=FALSE)
  }

  recwid = input_width
  axcex = text_adjust

  par(oma=c(0.5,0.5,0.5,0.5))
  par(mar=c(4,5,2,0))

  logtrans<-function(num) {
    if(num==0) {
      return(0)
    }
    if(num==1) {
      return(1)
    }
    return(log(num,2)+1)
  }
  untrans<-function(num) {
    if(num==0) {
      return(0)
    }
    if(num==1) {
      return(1)
    }
    return(2^(num-1))
  }
  neglogtrans<-function(num,lowest) {
    tymin = -1*log(lowest,2)
    return(-1*(-tymin+-1*log(num,2))/tymin)
  }

  # plot by exon distribution
  #find biggest
  maxexon = 20
  biggest = 0
  for(i in seq(1,maxexon,1)) {
    currsize = length(d[d[,2]==i,1])
    if(currsize > biggest) { biggest = currsize }
  }
  currsize = length(d[d[,2]>=maxexon,1])
  if(currsize > biggest) { biggest = currsize }

  endspace = 4
  plot(1,type="n",xlim=c(0,maxexon+endspace),ylim=c(0,logtrans(biggest*2)+1),ylab="Number of Reads",bty="n",xlab="Exon Count",xaxt='n',yaxt='n',yaxs='i',cex.lab=axcex,yaxt='n')
  axispoints = seq(0,logtrans(biggest*2),1)
  axis(2,at=axispoints,labels=lapply(axispoints,untrans),cex.axis=axcex,lwd=recwid)
  axis(1,at=seq(1,maxexon,1),labels=seq(1,maxexon,1),cex.axis=axcex,lwd=recwid)
  mtext(paste(">",maxexon),side=1,at=maxexon+endspace-1.5,line=1,cex=axcex)
  for(i in seq(1,maxexon)) {
    exon = length(d[d[,2]==i,1])
    rect(i+0.1-0.5,0,i+0.8-0.5,logtrans(exon),col="#777777",lwd=recwid)
  }
  # get the longest pooled
  exon = length(d[d[,2]>maxexon,1])
  rect(maxexon+endspace-1+0.1-0.5,0,maxexon+endspace-1+0.8-0.5,logtrans(exon),col="#777777",lwd=recwid)
  dev.off()
}

args=commandArgs(trailingOnly=TRUE)
if(length(args)<2) {
  stop("Must supply input and output\n",call.=FALSE)
}
infile = args[1]
outfile = args[2]
infilex = substr(infile,nchar(infile)-1,nchar(infile))
if(infilex=="gz") {
  d<-read.csv(infile,sep="\t",header=FALSE)
} else {
  d<-read.csv(gzfile(infile),sep="\t",header=FALSE)
}
input_width = 3
if(length(args) > 2) {
  input_width = args[3]
}
text_adjust = 1.25
if(length(args) > 3) {
  text_adjust = args[4]
}
make_image(d,outfile,input_width,text_adjust)


#' ---
#' 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/conferences_talks/_2015/5_berkeley/")
source("rscripts/helpers.r")

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

# 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/12_sinking-marbles-prior15/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")

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")

library(dplyr)
library(plyr)
# plot expectations for best basic model:
toplot = droplevels(subset(mp, 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 = some
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")

load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/mp-uniform.RData")

# plot expectations for best basic model:
toplot = droplevels(subset(mp, Quantifier == "some" & WonkyWorldPrior == .5 & State == 15))
nrow(toplot)

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

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
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("darkred",wes_palette("Darjeeling")[1])) +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior mean all-state probability") +
  scale_y_continuous(limits=c(0,1), name="Predicted posterior all-state probability")
p_probs
ggsave("pred_probs.pdf")

p_probs = ggplot(toplot_r, 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("darkred")) +
  #  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="Posterior all-state probability")
p_probs
ggsave("pred_prob_rsa.pdf")

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

# plot expectations for best basic model:
toplot = droplevels(subset(mp, Quantifier == "some" & WonkyWorldPrior == .5))
nrow(toplot)

pexpectations = ddply(toplot, .(Item, SpeakerOptimality,PriorExpectation), 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_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_r$PriorExpectation = toplot_r$PriorExpectation_smoothed*15
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_exps = ggplot(toplot, aes(x=PriorExpectation, 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("darkred",wes_palette("Darjeeling")[1])) +#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 mean number of objects") +
  scale_y_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Predicted posterior number of objects")
p_exps
ggsave("pred_exps.pdf")

p_exps = ggplot(toplot_r, aes(x=PriorExpectation, 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("darkred")) +#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 expectation") +
  scale_y_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Posterior expectation")
p_exps
ggsave("pred_exps_rsa.pdf")

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.pdf",width=12,height=4.9)
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()

# 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)

min(agr[agr$quantifier == "Some",]$ProportionResponse)
max(agr[agr$quantifier == "Some",]$ProportionResponse)
agr$Quantifier = factor(x=agr$quantifier, levels=c("Some","All","None","long_filler","short_filler"))

p_eexps = ggplot(agr, aes(x=PriorExpectationProportion*15, y=ProportionResponse*15, color=Quantifier, shape=Quantifier)) +
  geom_point() +
  #geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_smooth(method="lm") +
  scale_color_manual(values=c(wes_palette("Darjeeling")[1:3],"black","gray40")) +#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")
p_eexps
ggsave(file="empirical_exps.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)
ub$Quantifier = factor(x=ub$quantifier, levels=c("Some","All","None","long_filler","short_filler"))

p_eprobs = ggplot(ub, aes(x=AllPriorProbability, y = normresponse, color=Quantifier, shape=Quantifier)) +
  geom_point() +
  geom_smooth(method="lm") +
  scale_color_manual(values=c(wes_palette("Darjeeling")[1:3],"black","gray40")) +#values=c("#F8766D", "black", "#00BF7D", "gray30", "#00B0F6"),breaks=levels(agr$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")
p_eprobs
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=12,height=4.9)
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()

load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/data/wr-uniform.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))
nrow(toplot)
head(toplot)
#toplot$quantifier = capitalize(as.character(toplot$Quantifier))
toplot$Quantifier = factor(toplot$Quantifier, levels=c("some","all","none"))

p_wmodel = ggplot(toplot, aes(x=PriorExpectation, y=PosteriorProbability,color=Quantifier,shape=Quantifier)) +
  geom_point() +
  geom_smooth() +
  scale_color_manual(values=c(wes_palette("Darjeeling")[1:3],"black","gray40")) +
  #scale_color_manual(values=c("#F8766D","#00BF7D","#00B0F6")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior mean number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Predicted posterior wonkiness probability") +
  theme(plot.margin=unit(c(0,0,0,0),units="cm"))
p_wmodel
ggsave("model-wonkiness-uniform.pdf",width=6.8,height=5)#,width=30,height=10)

############
# 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)

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
toplot$quantifier = capitalize(as.character(toplot$Quantifier))
toplot$Quantifier = factor(toplot$quantifier, levels=c("Some","All","None"))

p_wempirical = ggplot(toplot, aes(x=PriorExpectation, y=response, color=Quantifier,shape=Quantifier)) +
  geom_point() +
  geom_smooth() +
  scale_color_manual(values=c(wes_palette("Darjeeling")[1:3],"black","gray40")) +
  scale_x_continuous(breaks=seq(1,15,by=2),name="Prior mean number of objects") +
  scale_y_continuous(breaks=seq(0,1,by=.25),name="Mean empirical wonkiness probability")  +
  theme(plot.margin=unit(c(0,0,0,0),units="cm"))
p_wempirical
ggsave(file="empirical-wonkiness.pdf",width=6.8,height=5)

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()


#' Write out a graphic to a png file
#'
#' Write a ggplot object to a .png file. Defaults to 300dpi resolution on
#' "letter" sized paper in portrait orientation with standard margins.
#' Automatically adds a ".png" suffix to the provided filename.
#' @param object to plot (usually generated by ggplot)
#' @param fn file name (without .png suffix)
#' @param x horizontal dimensions of default graphic (defaults to 6.5)
#' @param y vertical dimensinos of default graphic (defaults to 4.875)
#' @param uni units of measurement for the dimension (defaults to "in")
#' @param rez resolution of output graphic (pixels per unit)
#' @seealso \code{\link{png}}, \code{\link{pdf}}, \code{\link{jpeg}},
#' \code{\link{dev.off}}
#' @export
ggpng <- function(P, fn, x=6.5, y=6.5 * 3/4, uni="in", rez=300,
                  gdir=NULL) {
    if (is.null(gdir)) {
        gdir <- graphics
    }
    fname <- paste0(graphics, fn, ".png")
    png(fname, x, y, units=uni, res=rez)
    print(P)
    dev.off()
}

#' display the size of an R object in appropirate units
#'
#' Display the size of an R object in scale-appropriate units. Sometimes
#' useful for deciding if a particular object should be re-generated as
#' needed or saved and loaded on repeat analysis.
#' @param x an object in the environment
#' @export
sizeof <- function(x) {
    print(object.size(x), units="auto")
}

#' Turn dashes to zeros
#'
#' Take a character vector of numbers where dashes indicate negligible
#' values, and return a numeric vector where dashes have been set to 0.
#' @param x a character vector to be cleaned
#' @export
dash20s <- function(x) {
  x[x=="-"] <- "0"
  return(as.numeric(x))
}

#' Possibly output a timestamp
#'
#' If the value passed is greater than the threshold, call the timestamp()
#' function.
#' @param noisy a flag, set to differing values depending upon how many
#' timestamps you want
#' @param trigger if the flag is greater than this value call
#' timestamp(). Defautls to zero.
#' @export
ntimestamp <- function(noisy, trigger=0) {
  if (noisy > trigger)
    timestamp()
}
#' Possibly output a status message
#'
#' If the value passed is greater than the threshold, pass the remaining
#' arguments to cat() to be sent to the output stream. Useful for tracking
#' progress of a long script with tuneable feedback.
#' @param noisy a flag, set to differing values depending upon how many
#' output you want
#' @param trigger if the flag is greater than this value call
#' cat(). Defautls to zero.
#' @export
ncat <- function(noisy, trigger=0, ...) {
  if (noisy > trigger)
    cat(..., sep="")
}

#' Greatest common denominator
#'
#' Find the greatest common denominator of two integers
#' @param x the first integer. Must be the larger of the two.
#' @param y the second integer.
#' @export
gcd <- function(x, y) {
    r <- x %% y
    return(ifelse(r, gcd(y, r), y))
}


library(ggplot2)
library(zoo)
library(lubridate)
library(stringr)
library(dplyr)

# Carregando dataset
dengue_dataset = read.csv("~/Pessoal/tcc/casos-dengue2016.csv", sep = ";")

raca_labels <- c("Branca", "Preta", "Amarela", "Parda", "Indígena")
raca <- data.frame(raca = raca_labels, tp_raca_cor = c(1, 2, 3, 4, 5))

# Usando filtros e programação funcional para contar quais raças foram informadas
quantidade_por_raca <- filter(dengue_dataset, tp_raca_cor != "") %>%
  filter(., tp_raca_cor != "9") %>%
  count(., tp_raca_cor, sort = TRUE)

# Transformando uma tabela em dataframe
quantidade_por_raca <- data.frame(quantidade_por_raca)

# Fazendo merge entre a descrição e os códigos
quantidade_por_raca <- merge(quantidade_por_raca, raca)

# Exibindo um summário
summary(quantidade_por_raca)
quantidade_por_raca

# Fazendo um plot com linha
ggplot(data = quantidade_por_raca) +
  geom_line(data = quantidade_por_raca, aes(x = raca, y = n, col = quantidade_por_raca$raca, group = 1)) +
  xlab("Raças") +
  ylab("Quantidade")

# Fazendo plot com barras
qplot(data = quantidade_por_raca, x = raca,
      weight = n, fill = raca, geom = "bar",
      group = 1)


# setwd("/home/anacarla/Dropbox/Papers/Writing/FGCS/analysis/")

##############################
#
# Required Packages
#
require(rpart)
require(rpart.plot)

##############################
#
# Loading data
#
load("data/intel.mrt.rda")
load("data/amd.mrt.rda")
load("data/both.mrt.rda")

inch2cm <- function(x) x / 2.54

pdf("../images/RT_INTEL.pdf", width = inch2cm(5), height = inch2cm(5))

rpart.plot(intel.mrt, cex = .5)

dev.off()

pdf("../images/RT_AMD.pdf", width = inch2cm(8), height = inch2cm(5))

rpart.plot(amd.mrt, cex = .5)

dev.off()

pdf("../images/RT_BOTH.pdf", width = inch2cm(5), height = inch2cm(3))

rpart.plot(both.mrt, cex = .5)

dev.off()


\name{densityHeatmap}
\alias{densityHeatmap}
\title{
Visualize Density Distribution by Heatmap
}
\description{
Visualize Density Distribution by Heatmap
}
\usage{
densityHeatmap(data,
    density_param = list(na.rm = TRUE),

    col = rev(brewer.pal(11, "Spectral")),
    color_space = "LAB",
    ylab = deparse(substitute(data)),
    column_title = paste0("Density heatmap of ", deparse(substitute(data))),
    title = column_title,
    ylim = NULL,
    range = ylim,

    title_gp = gpar(fontsize = 14),
    ylab_gp = gpar(fontsize = 12),
    tick_label_gp = gpar(fontsize = 10),
    quantile_gp = gpar(fontsize = 10),
    show_quantiles = TRUE,

    column_order = NULL,
    column_names_side = "bottom",
    show_column_names = TRUE,
    column_names_max_height = unit(6, "cm"),
    column_names_gp = gpar(fontsize = 12),
    column_names_rot = 90,

    cluster_columns = FALSE,
    clustering_distance_columns = "ks",
    clustering_method_columns = "complete",
    mc.cores = 1,

    ...)
}
\arguments{

  \item{data}{A matrix or a list. If it is a matrix, density is calculated by columns.}
  \item{density_param}{Parameters send to \code{\link[stats]{density}}, \code{na.rm} is enforced to be \code{TRUE}.}
  \item{col}{A vector of colors that density values are mapped to.}
  \item{color_space}{The color space in which colors are interpolated. Pass to \code{\link[circlize]{colorRamp2}}.}
  \item{ylab}{Label on y-axis.}
  \item{column_title}{Title of the heatmap.}
  \item{title}{Same as \code{column_title}.}
  \item{ylim}{Ranges on the y-axis.}
  \item{range}{Same as \code{ylim}.}
  \item{title_gp}{Graphic parameters for title.}
  \item{ylab_gp}{Graphic parameters for y-labels.}
  \item{tick_label_gp}{Graphic parameters for y-ticks.}
  \item{quantile_gp}{Graphic parameters for the quantiles.}
  \item{show_quantiles}{Whether show quantile lines.}
  \item{column_order}{Order of columns.}
  \item{column_names_side}{Pass to \code{\link{Heatmap}}.}
  \item{show_column_names}{Pass to \code{\link{Heatmap}}.}
  \item{column_names_max_height}{Pass to \code{\link{Heatmap}}.}
  \item{column_names_gp}{Pass to \code{\link{Heatmap}}.}
  \item{column_names_rot}{Pass to \code{\link{Heatmap}}.}
  \item{cluster_columns}{Whether cluster columns?}
  \item{clustering_distance_columns}{There is a specific distance method \code{ks} which is the Kolmogorov-Smirnov statistic between two distributions. For other methods, the distance is calculated on the density matrix.}
  \item{clustering_method_columns}{Pass to \code{\link{Heatmap}}.}
  \item{mc.cores}{Multiple cores for calculating ks distance.}
  \item{...}{Pass to \code{\link{Heatmap}}.}

}
\details{
To visualize data distribution in a matrix or in a list, we normally use
boxplot or violinplot. We can also use colors to map the density values and
visualize distribution of values through a heatmap. It is useful if you have
huge number of columns in \code{data} to visualize.

The density matrix is generated with 500 rows ranging between the maximun
and minimal values in all densities.
}
\value{
A \code{\link{Heatmap-class}} object. It can oly add other heatmaps/annotations vertically.
}
\seealso{
\url{https://jokergoo.github.io/ComplexHeatmap-reference/book/other-high-level-plots.html#density-heatmap}
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
matrix = matrix(rnorm(100), 10); colnames(matrix) = letters[1:10]
densityHeatmap(matrix)

lt = list(rnorm(10), rnorm(10))
densityHeatmap(lt)

ha = HeatmapAnnotation(points = anno_points(runif(10)),
    anno = rep(c("A", "B"), each = 5), col = list(anno = c("A" = "red", "B" = "blue")))
densityHeatmap(matrix, top_annotation = ha)
densityHeatmap(matrix, top_annotation = ha) \%v\% Heatmap(matrix, height = unit(6, "cm"))
}


system.time(m <- matrix(rnorm(10000^2), ncol=10000))
m
system.time(m[lower.tri(m)] <- 0)
system.time(sum(m))


# 3. faza: Vizualizacija podatkov
require(dplyr)
require(tidyr)
require(readr)
require(reshape2)

library(rgdal)
library(maptools)
library(ggpubr)  # 'ggpubr' provides some easy-to-use functions for creating and customizing ggplot2
library(ggplot2)

#Število dobitkov JACKPOT in 5+1 v zadnjih letih
u <- tabela3[c(1,3)]
u$Datum<-gsub("-([[:digit:]]{1,2})-([[:digit:]]{1,2})","", u$Datum) #rabim samo leta
t <- rbind(u %>% filter(Dobitek == 'JACKPOT') %>% group_by(Datum) %>%
             summarise(Stevilo = sum(Dobitek == 'JACKPOT' )) %>% mutate(Kategorija="JACKPOT"),
           u %>% filter(Dobitek == '5+1') %>% group_by(Datum) %>% summarise(Stevilo = sum(Dobitek == '5+1' )) %>% mutate(Kategorija="5+1"))
t$Datum <- as.factor(t$Datum)

graf_dobitki <- ggplot(data = t, aes(x = Datum, y = Stevilo, fill= Kategorija))+ geom_col(position = "dodge") +
  xlab("Leto") + ylab("Število dobitkov") +
  scale_fill_manual("Kategorija",values = c('darkblue', 'lightblue')) +
  labs(title ="Število dobitkov") + theme(plot.title = element_text(hjust = 0.5))

#Pogostost glavnih številk
prvih<- tabela2 %>% filter(Tip == 'prvih_pet') %>% count(Stevilka)
prvih$n <- prvih$n/50
theme_set(theme_bw())
pogostost_prvih <- ggplot(prvih, aes(x=Stevilka, y= n)) +
  geom_point(aes(col=Stevilka, size=n)) +
  labs(title="Frekvenca glavnih številk",
       y="Frekvenca",
       x="Številka")
pogostost_prvih<- pogostost_prvih + scale_x_discrete(limits=c((1:50),2))+ theme(axis.text.x=element_text(size= 7))

#Pogostost euro(zadnjih dveh) številk
zadnje<- tabela2 %>% filter(Tip == 'zadnje_dve') %>% count(Stevilka)
zadnje$n <- zadnje$n/10
theme_set(theme_bw())
pogostost_zadnjih <- ggplot(zadnje, aes(x=Stevilka, y= n)) +
                              geom_point(aes(col=Stevilka, size=n)) +
                              labs(title="Frekvenca euro številk", y="Frekvenca",x="Številka")
pogostost_zadnjih<- pogostost_zadnjih + scale_x_discrete(limits=c(1:10))

#višina dobitka po letih
visina <- tabela3
options(scipen=999)
visina$Vrednost <- visina$Vrednost/1000000
visina_jackpot <- ggplot(visina, aes(x=Datum, y= Vrednost)) +
  geom_point(aes(col=Dobitek)) +
  labs(title="Višina dobitkov v mio €",
       y="mio €",
       x="Leto")

#Koliko denarja letno izplača Eurojackpot

denar <- tabela3[c(1,2)]
denar$Datum<-gsub("-([[:digit:]]{1,2})-([[:digit:]]{1,2})","", u$Datum)
denar <- denar %>% group_by(Datum) %>% summarise(Vsota = sum(Vrednost))
denar$Vsota <- denar$Vsota /1000000
denar$Datum <- as.factor(denar$Datum)

graf<- ggplot(data = denar, aes(x = Datum, y =Vsota, fill ='lightpink'))+
  geom_col() +
  xlab("Leto") + ylab("Vsota dobitkov v mio €") +
  labs(title ="Vsota dobitkov po letih") + theme(plot.title = element_text(hjust = 0.5))

# Uvozimo zemljevid.
source("https://raw.githubusercontent.com/jaanos/APPR-2018-19/master/lib/uvozi.zemljevid.r")

zemljevid <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
                             "ne_50m_admin_0_countries", mapa = "zemljevidi", pot.zemljevida = "", encoding = "UTF-8") %>%
  fortify() %>% filter(CONTINENT == "Europe" | SOVEREIGNT %in% c("Cyprus"), long < 45 & long > -20 & lat > 30 & lat < 75)
colnames(zemljevid)[11] <- 'drzava'
zemljevid$drzava <- as.character(zemljevid$drzava)

#Zemljevid dobljenih jackpotov po državi

zadetki_po_drzavah <- tabela4 %>% filter(Dobitek == 'jackpot')
zadetki_po_drzavah <- zadetki_po_drzavah %>% group_by(Drzava) %>% summarise(Stevilo = sum(Dobitek == 'jackpot' ))
zadetki_po_drzavah$Drzava <- gsub("Češka", "Czechia", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Danska", "Denmark", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Finska", "Finland", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Hrvaška", "Croatia", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Italija", "Italy", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Madžarska", "Hungary", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Nemčija", "Germany", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Nizozemska", "Netherlands", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Norveška", "Norway", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Slovenija", "Slovenia", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Španija", "Spain", zadetki_po_drzavah$Drzava)
zadetki_po_drzavah$Drzava <- gsub("Švedska", "Sweden", zadetki_po_drzavah$Drzava)

zemljevid_zadetki_jackpot <- ggplot() +
  geom_polygon(data = zadetki_po_drzavah %>% right_join(zemljevid, by = c("Drzava" = "drzava")),
               aes(x = long, y = lat, group = group, fill = Stevilo), alpha = 0.8, color = "black")+
  scale_fill_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 7) +
  xlab("") + ylab("") + ggtitle("Jackpot zadetki po državah")+
  guides(fill=guide_legend(title="Število zadetkov")) + theme(plot.title = element_text(hjust = 0.5))

#zemljevid_zadetki_jackpot

#Število zadetkov '5+1' po državah
zadetki_po_drzavah2 <- tabela4 %>% filter(Dobitek == '5+1')
zadetki_po_drzavah2 <- zadetki_po_drzavah2 %>% group_by(Drzava) %>% summarise(Stevilo = sum(Dobitek == '5+1' ))
zadetki_po_drzavah2 <- zadetki_po_drzavah2[-c(12,13),]
zadetki_po_drzavah2$Drzava <- gsub("Češka", "Czechia", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Danska", "Denmark", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Finska", "Finland", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Hrvaška", "Croatia", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Italija", "Italy", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Madžarska", "Hungary", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Nemčija", "Germany", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Nizozemska", "Netherlands", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Norveška", "Norway", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Slovenija", "Slovenia", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Španija", "Spain", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Švedska", "Sweden", zadetki_po_drzavah2$Drzava)

zadetki_po_drzavah2$Drzava <- gsub("Slovaška", "Slovakia", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Poljska", "Poland", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Litva", "Lithuania", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Latvija", "Latvia", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Islandija", "Iceland", zadetki_po_drzavah2$Drzava)
zadetki_po_drzavah2$Drzava <- gsub("Estonija", "Estonia", zadetki_po_drzavah2$Drzava)

zemljevid_zadetki_pet <- ggplot() +
  geom_polygon(data = zadetki_po_drzavah2 %>% right_join(zemljevid, by = c("Drzava" = "drzava")),
               aes(x = long, y = lat, group = group, fill = Stevilo), alpha = 0.8, color = "black")+
  scale_fill_gradient2(low = "pink", mid = "yellow", high = "red", midpoint = 10) +
  xlab("") + ylab("") + ggtitle("Zadetki 5+1 po državah")+
  guides(fill=guide_legend(title="Število zadetkov")) + theme(plot.title = element_text(hjust = 0.5))

#zemljevid_zadetki_pet


#name: RNaiveBayesApply
#meta.mlname: RNaiveBayes
#meta.mlrole: apply
#description: Custom R Apply func for Naive Bayes
#language: r
#input: blob model
#input: dataframe df
#input: string namesKeys [original features' names]
#input: string namesValues [new features' names]
#output: dataframe data_out

#>>> Load necessary packages
library(caret)
library(e1071)
#install.packages("naiveBayes")
#library(naiveBayes)
#library(naivebayes)

#>>> If original(namesKeys) and new(namesValues) passed, map original names to new
namesKeys = strsplit(namesKeys, ',')[[1]]
namesValues = strsplit(namesValues, ',')[[1]]
if (length(namesKeys) > 0) {
  featuresNames = names(df)
  for (n in 0:length(namesKeys))
    names(df)[featuresNames == namesValues[n]] = namesKeys[n]
}

#>>> Retrieve saved/trained model
trained_model = readRDS(model)

#>>> Predict using trained model
predY = predict(trained_model, df)
data_out = data.frame(predY)

#x1<-rep(c(1),each=nrow(df))
#data_out = data.frame(x1)


library(jsonlite)
library(ontologySimilarity)

data(gene_GO_terms) # Gene Ontology annotation of genes
gene_json_data <- jsonlite::fromJSON('landmark_genes.json')
gene_symbols <- gene_json_data["gene_symbol"][[1]]
landmark_genes_GO_terms <- gene_GO_terms[gene_symbols]

# gather all go terms for the lm genes
all_landmark_genes_go_terms_vector <- c()
for (i in (1:length(gene_symbols) )){
  go_selected <- landmark_genes_GO_terms[[i]]
  all_landmark_genes_go_terms_vector <- c(all_landmark_genes_go_terms_vector, go_selected)
}
all_unique_landmark_genes_go_terms <- sort(unique(all_landmark_genes_go_terms_vector))

# get go terms that are attributed to by more than 3 landmark genes
common_go_terms <- c()
for (i in (1:length(all_unique_landmark_genes_go_terms))){
  lm_go_term<-all_unique_landmark_genes_go_terms[[i]]
  count <- 0
  for (j in (1:length(gene_symbols))){
    lm_gene_go_terms <- landmark_genes_GO_terms[[j]]
    if (any(lm_gene_go_terms==lm_go_term)){
      count <- count+1
    }
    if (count > 3){
      common_go_terms <- c(common_go_terms, lm_go_term)
      break
    }
  }
}

# descriptors binary occurency vector
gene_go_fingerprint <- matrix(0,length(gene_symbols),length(common_go_terms))
for (i in (1:length(common_go_terms))){
  for (j in (1:length(gene_symbols))){
    if (length(which(landmark_genes_GO_terms[[j]] == common_go_terms[[i]])) == 1){
      gene_go_fingerprint[j,i] <- 1
    }
  }
}

rownames(gene_go_fingerprint) <- gene_symbols
colnames(gene_go_fingerprint) <- common_go_terms
write.csv(gene_go_fingerprint,file="go_fingerprints.csv", quote=FALSE)


if (!exists("nsamples") || !(is.numeric(nsamples))) stop("nsamples must be set")

age_limits <- seq(0, 20, by = 5)
targets <- list(current = c(0.85, 0.9, 0.95, 0.95, 0.95),
                increase_infant = c(0.9, 0.9, 0.95, 0.95, 0.95),
                fewer_infants_catchup_kids = c(0.8, 0.9, 0.95, 0.95, 0.95),
                catchup_kids = c(0.85, 0.95, 0.95, 0.95, 0.95),
                increase_infant_and_catchup_kids = c(0.9, 0.95, 0.95, 0.95, 0.95),
                all_95 = c(0.95, 0.95, 0.95, 0.95, 0.95),
                current_less_teenagers = c(0.85, 0.9, 0.9, 0.95, 0.95),
                catchup_kids_less_teenagers = c(0.85, 0.95, 0.9, 0.95, 0.95),
                current_even_less_teenagers = c(0.85, 0.9, 0.85, 0.95, 0.95),
                catchup_kids_even_less_teenagers = c(0.85, 0.95, 0.85, 0.95, 0.95),
                current_less_adolescents = c(0.85, 0.9, 0.95, 0.90, 0.95),
                catchup_kids_less_adolescents = c(0.85, 0.95, 0.95, 0.90, 0.95),
                current_even_less_adolescents = c(0.85, 0.9, 0.95, 0.85, 0.95),
                catchup_kids_even_less_adolescents = c(0.85, 0.95, 0.95, 0.85, 0.95),
                current_less_older = c(0.85, 0.9, 0.95, 0.95, 0.90),
                catchup_kids_less_older = c(0.85, 0.95, 0.95, 0.95, 0.90),
                current_even_less_older = c(0.85, 0.9, 0.95, 0.95, 0.85),
                catchup_kids_even_less_older = c(0.85, 0.95, 0.95, 0.95, 0.85))
targets <- lapply(targets, function(x) { names(x) = age_limits; x })

data(polymod)

## Uganda and SMILI contact data available upon request from the original authors
zimbabwe <- get_survey("https://doi.org/10.5281/zenodo.1127693")
peru <- get_survey("https://doi.org/10.5281/zenodo.1095664")
france <- get_survey("https://doi.org/10.5281/zenodo.1157918")
hongkong <- get_survey("https://doi.org/10.5281/zenodo.1165561")

surveys <- list(polymod=polymod,
                zimbabwe=zimbabwe,
                peru=peru,
                france=france,
                hongkong=hongkong)

datasets <-
  tibble(survey=names(surveys)) %>%
  rowwise %>%
  mutate(settings=
             list(c("all", unique(surveys[[survey]][["participants"]][["setting"]]))),
         country=list(c(survey_countries(surveys[[survey]], quiet=TRUE)))) %>%
  unnest(settings, .preserve = c(survey, country)) %>%
  unnest(country, .preserve=survey)

base_parameters <-
    list(age.limits=age_limits, symmetric=TRUE, weigh.dayofweek=TRUE,
         sample.all.age.groups=TRUE, estimated.contact.age="sample",
         missing.participant.age="remove", missing.contact.age="sample",
         quiet=TRUE, n=nsamples)

R <- tibble(scenario=names(targets)) %>%
    rowwise() %>%
    mutate(immunity=list(targets[[scenario]])) %>%
    ungroup() %>%
    crossing(datasets) %>%
    arrange(survey, settings, country, scenario)

matrix_options <- R %>%
    group_by(settings, survey, country) %>%
    summarise() %>%
    rowwise() %>%
    mutate(country_parameters = list(list(countries=country)),
           filter_parameters =
               if_else(settings=="all",
                       list(list()),
                       list(list(filter=list(setting=settings)))),
           options=list(c(base_parameters, country_parameters, filter_parameters,
                          list(survey=surveys[[survey]]))))

country_matrices <- matrix_options %>%
    rowwise %>%
    mutate(matrix_ret=list(do.call(contact_matrix, options)),
           matrix=list(matrix_ret$matrices),
           demography=list(matrix_ret$demography$proportion)) %>%
    ungroup

scenarios_adjImm <- R %>%
    left_join(country_matrices, by = c("settings", "survey", "country")) %>%
    unnest(matrix, .preserve=c(demography, immunity)) %>%
    rowwise %>%
    mutate(adjusted_immunity=
               adjust_immunity(mixing=matrix, immunity=unlist(immunity)),
           mean_immunity= sum(demography * immunity) / sum(demography)) %>%
    ungroup %>%
    select(-survey, -matrix, -demography)


library(myfibo)

f1 = Fibo(50)
invisible(f1$display(FALSE))
f2 = Fibo(100, "Test 100")
invisible(f2$display())
vec = fib(40)
print(vec)


rankall2 <- function(outcome, num = "best") {
      ## Read outcome data
      x <- read.csv("outcome-of-care-measures.csv", colClasses = "character")

      ## Check that state and outcome are valid
      colNum <- c('heart attack'=11, 'heart failure'=17, 'pneumonia'=23)[outcome]
      if (is.na(colNum)) {
	stop('invalid outcome')
      }
      x[, colNum] <- suppressWarnings(as.numeric(x[, colNum]))
      nameCol <- 2

      ## For each state, find the hospital of the given rank
      hospitalList <- lapply (split(x, x$State), function(x){
			    unordered <- x[!is.na(x[colNum]),] # unordered can have no rows
			    ordered <- unordered[order(unordered[colNum],unordered[nameCol]),]

			    position <- c('best'=1, 'worst'= nrow(unordered))[num]
			    if (is.na(position)) {position <- num}

			    ordered[position, nameCol]
			  }
      )

      ## Return a data frame with the hospital names and the
      ## (abbreviated) state name
      data.frame(hospital=unlist(hospitalList), state=names(hospitalList))
}


## Load libraries

library(tidyverse)
library(motus)

library(geosphere)
library(circular)

library(mgcv)
library(gamm4)
library(lmtest)

library(RNCEP) # weather data
library(survival) # survival (proportional hazards)

library(itsadug)

source("loadMotusData.r")
source("latLonDist.r")

########
### Import datasets into list
########

# Set viewport to 2 x 2 grid
par(mfrow=c(2,2))

# Set timezone to GMT
Sys.setenv(TZ = 'GMT')

# Define Project ID
projectID <- 109

# Local address of database
subfolder <- "data/"

# Create a new SQLITE database?
newDatabase <- F

# Load tag hits
tagHits <- loadMotusData(projectID, subfolder)

# Create a vectors of BP and Seal sites
bpsites <- c('BPHill','BPhill','BPLH','BPwestomni', 'BPLab', 'BPNorth', 'BPnorthomni', 'BPnorthyagi')
sealsites <- c('SealSouth','Seal South','SealWest','SealNorth')
shitsites <- read_csv(paste0(subfolder, '109-shitSites.csv', collapse = ''), col_names = 'site')

fixedHits <- tagHits %>%
#  rename(recvDeployName = recvDepName)  %>%
  filter(runLen > 2,
         !recvDeployName %in% shitsites$site,
         !is.na(tagDeployID) & motusTagID != 21273,
         !is.na(lat),
         !is.na(lon)
         ) %>%
  mutate(recvDeployName = ifelse(recvDeployName %in% bpsites, 'Bon Portage', ifelse(recvDeployName %in% sealsites, 'Seal Island', recvDeployName)))

# Remove the unnecessary and HUGE dataframe
rm(tagHits)
# Clear out the memory of unnecessary garbage
gc()

# Get list of ages
tagMeta <- fixedHits %>%
  mutate(bandsite = ifelse(depLat > 43.45, 'BP', 'SEAL')) %>%
  group_by(markerNumber, tagDeployID) %>%
  summarise(age = as.factor(age[1]), bandsite = as.factor(bandsite[1]), tagDeployStart = tagDeployStart[1])

#write_rds(tagMeta, 'tagMeta.rds')

################## Departures

# Load list of flight runIDs
flights.raw <- read_csv(paste0(subfolder, "Project109-sigplots-Flights.csv", collapse = ''))

flights.raw <- flights.raw %>%
  mutate(depRunID = ifelse(is.na(depRunID), max(flights.raw[flights.raw$markerNumber == markerNumber, 5:16]), depRunID))

# Get flight meta data
flight.meta <- flights.raw %>% select(bandsite, markerNumber, depRunID)

# Select all hits which correspond to each flight runID
flights.df <- fixedHits[fixedHits$runID %in% as.numeric(unlist(flights.raw[5:16])),]

# Group flights by runID and select hitID and ts that corresponds to max signals strength during that run
flights <- flights.df %>%
  group_by(runID) %>%
  summarise(ts = ts[which.max(sig)], markerNumber = markerNumber[1])

# Create a new tibble of just departure flights and join it with flight meta data
depFlights <- flights %>%
  left_join(flight.meta, by = 'markerNumber') %>%
  group_by(markerNumber) %>%
  summarise(depRunID = ifelse(is.na(depRunID), runID[which.max(ts)], max(depRunID))[1],
            ts.dep = ts[runID==depRunID])# %>%
  select(markerNumber, ts.dep = ts)

################## END Departures

# Create a list of sites each bird located outside of their natal island
sitesVisited <- fixedHits %>%
  filter(
    lat > 42, lon > -71 & lon < 0,
    (lat <  43.39 | lat > 43.48) &
      (lon < -66.03 | lon > -65.74) &
      !recvDeployName %in% c('Bon Portage', 'Seal Island', 'Shag Harbour 2')
  ) %>%
  filter(spEN == "Swainson's Thrush") %>%
  left_join(depFlights, by = "markerNumber")  %>%
  filter(year(ts) == year(ts.dep)) %>%
  group_by(markerNumber) %>%
  summarise(nSites = length(unique(recvDeployName)),
            siteNames = paste0(unique(recvDeployName), collapse = ', ')) %>%
  left_join(tagMeta, by = 'markerNumber')

# Get some stats on the sites visited
sitesVisited %>%
  group_by(bandsite) %>%
  #group_by(age) %>%
  #group_by(age, bandsite) %>%
  summarise(mean = mean(nSites), sd = sd(nSites), n = n()) %>% View()

sitesVisited %>%
  ggplot(aes(nSites)) +
  geom_histogram()

sitesVisited %>%
  mutate(bandsite = ifelse(bandsite == 'SEAL', 'SI', 'BP')) %>%
  ggplot(aes(bandsite, nSites)) +
  geom_boxplot() +
  ylab('Number of sites visited')+
  xlab('Banding site')+
  facet_grid(age~.)

# Test: does the number of sites visited differ among ages and/or band site?

glm0 <- sitesVisited %>% glm(formula = (nSites) ~ age * bandsite, family = poisson)

plot(glm0)

summary(glm0)

anova(glm0, test = "Chisq")

glm0 <- sitesVisited %>% filter(bandsite == 'SEAL') %>% glm(formula = (nSites) ~ age, family = poisson)

plot(glm0)

summary(glm0)

anova(glm0, test = "Chisq")

glm0 <- sitesVisited %>% filter(bandsite == 'BP') %>% glm(formula = (nSites) ~ age, family = poisson)

plot(glm0)

summary(glm0)

anova(glm0, test = "Chisq")

# Create a new tibble of site transitions
allSites <- fixedHits %>%
  filter(#lat > 25, lon < 0
         lat > 42, lon > -71 & lon < 0
         ) %>%
  left_join(depFlights, by = "markerNumber")  %>%
  filter(recvDeployName != 'Shag Harbour 2', ts >= ts.dep, year(ts) == year(ts.dep)) %>%
  siteTrans(latCoord = 'lat', lonCoord = 'lon') %>%
  arrange(tagDeployID, ts.x) %>%
  left_join(tagMeta, by = "tagDeployID")
  #mutate(bandsite = ifelse(depLat > 43.45, 'BP', 'SEAL'))

gc()

#%>%
#  mutate(
#    isSimultaneous = (
#      recvDeployName.y == lag(recvDeployName.x) &
#      recvDeployName.x == lag(recvDeployName.y) &
#      recvDeployName.y == lead(recvDeployName.x) &
#      recvDeployName.x == lead(recvDeployName.y) &
#      tagDeployID == lag(tagDeployID),
#    )
#  )

# Plot of latitude over julian date
allSites %>%
  ggplot(aes(as.integer(format(ts.y, "%j")), lat.y, group = markerNumber, color = age)) +
  geom_line() +
  scale_x_continuous()+
  xlab('Julian Date')+
  ggtitle('Latitude by julian date')

# Plot julian date over longitude
allSites %>%
  ggplot(aes(lon.y, as.integer(format(ts.y, "%j")), group = markerNumber, color = age)) +
  geom_line() +
  scale_y_continuous()+
  ylab('Julian Date')+
  ggtitle('Julian date by longitude')

# Plot latitude date over longitude
allSites %>%
  ggplot(aes(lon.y, lat.y, group = markerNumber, color = age)) +
  geom_line() +
  ggtitle('Latitude by longitude')+
  coord_cartesian()

# Create new dataframe and calculate cumulative and net displacement
displacement <- allSites %>%
 # filter(is.na(isSimultaneous) | !isSimultaneous) %>% #View()
  group_by(tagDeployID) %>%
  summarise(distCumulative = sum(dist),
            lat.x = lat.x[which.min(ts.x)],
            lon.x = lon.x[which.min(ts.x)],
            lat.y = lat.y[which.max(ts.y)],
            lon.y = lon.y[which.max(ts.y)],
            recvDeployName.x = recvDeployName.x[which.min(ts.x)],
            recvDeployName.y = recvDeployName.y[which.max(ts.y)],
            ts.x = min(ts.x),
            ts.y = max(ts.y),
            ts.diff = difftime(max(ts.y), min(ts.x), units = 'hours')) %>%
  rowwise() %>%
  mutate(distNet = latLonDist(lat.x, lon.x, lat.y, lon.y),
         netVCum = distNet/distCumulative,
         rate = distNet/as.integer(ts.diff)) %>%
  filter(
    !is.na(rate) & rate != Inf,
    recvDeployName.x != recvDeployName.y,
    netVCum <= 1
  ) %>%
  left_join(tagMeta, by = 'tagDeployID')

# Net v. cumulative displacement

displacement %>%
  ggplot(aes(netVCum)) +
  geom_histogram()

displacement %>%
#  filter(!is.na(age)) %>%
  ggplot(aes(netVCum, group = age, color = age)) +
  geom_density() +
  facet_grid(.~bandsite)

displacement %>%
  filter(!is.na(age)) %>%
  ggplot(aes(bandsite, netVCum)) +
  geom_boxplot() +
  facet_grid(age~.)

displacement %>%
  filter(!is.na(age)) %>%
  ggplot(aes(bandsite, distNet)) +
  geom_boxplot() +
  facet_grid(age~.)

displacement %>%
  filter(!is.na(age)) %>%
  ggplot(aes(bandsite, distCumulative)) +
  geom_boxplot() +
  facet_grid(age~.)

displacement %>%
  group_by(age) %>%
  summarise(mean.n = mean(distNet), sd.n = sd(distNet),
            mean.c = mean(distCumulative), sd.c = sd(distCumulative),
            mean.nvc = mean(netVCum), sd.nvc = sd(netVCum)) %>%
  View()

displacement %>%
  group_by(bandsite) %>%
  summarise(mean.n = mean(distNet), sd.n = sd(distNet),
            mean.c = mean(distCumulative), sd.c = sd(distCumulative),
            mean.nvc = mean(netVCum), sd.nvc = sd(netVCum)) %>%
  View()

##
## Models
##

# Test: does net v. cumulative displacement differ among ages and/or band site?

glm1 <- displacement %>% glm(formula = log(netVCum) ~ age * bandsite, family = gaussian)

plot(glm1)

summary(glm1)

anova(glm1, test = "F")

# Test: does net displacement differ among ages and/or band site?

glm1.2 <- displacement %>% glm(formula = log(distNet) ~ age * bandsite, family = gaussian)

plot(glm1.2)

summary(glm1.2)

anova(glm1.2, test = "F")

# Test: does cumulative displacement differ among ages and/or band site?

glm1.3 <- displacement %>% glm(formula = log(distCumulative) ~ age * bandsite, family = gaussian)

plot(glm1.3)

summary(glm1.3)

anova(glm1.3, test = "F")

# Make new tibble with rate of displacement using departure time as start time
displacementRate <- displacement %>%
  left_join(depFlights, by = 'markerNumber') %>%
  mutate(rate = distNet/as.integer(difftime(ts.y, ts.dep, unit = 'hours'))) %>%
  filter(year(ts.dep) == year(ts.y))

# Rate (log)

displacementRate %>%
  ggplot(aes(log(rate))) +
  geom_histogram()

displacementRate %>%
  filter(!is.na(age)) %>%
  ggplot(aes(log(rate), group = age, color = age)) +
  geom_density() +
  facet_grid(.~bandsite)

displacementRate %>%
  filter(!is.na(age)) %>%
  ggplot(aes(bandsite, log(rate))) +
  geom_boxplot() +
  facet_grid(age~.)

displacementRate %>%
  group_by(age) %>%
  summarise(mean = mean(rate), sd = sd(rate)) %>%
  View()

displacementRate %>%
  group_by(bandsite) %>%
  summarise(mean = mean(rate), sd = sd(rate)) %>%
  View()

# Test: does rate of movement differ among ages and/or band site

glm4 <- displacementRate %>% glm(formula = log(rate) ~ age * bandsite, family = Gamma)

plot(glm4)

summary(glm4)

anova(glm4, test = "F")

# Make a new tibble of displacement rates for each movement made between sites
rateFromDeparture <- allSites %>%
  left_join(depFlights, by = "markerNumber")  %>%
#  left_join(select(displacementRate, markerNumber, age, bandsite, ts.dep, tagDeployID), by = "tagDeployID") %>%
  ungroup() %>%
  mutate(ts.dep.diff = as.integer(difftime(ts.x, ts.dep, units = 'hours')), tagDeployID = as.factor(tagDeployID)) %>%
#         age = ifelse(age == 'Adult', 1, 0),
#         bandsite = ifelse(bandsite == 'BP', 1, 0)) %>%
  filter(rate < 25, !is.na(age), !is.na(bandsite))

# Visualise smooth functions
  #geom_point(aes(color = age))+
  #    geom_line(aes(color = age, group = markerNumber))+
  #geom_smooth(aes(color = age, group = age))+
  #geom_smooth(aes(color = bandsite, group = bandsite))

rateFromDeparture %>% select(ts.dep.diff, age, bandsite, rate) %>% filter(ts.dep.diff<=671)

# Make generalized additive mixed models for each variable

gamm1 <- gamm(rate ~ s(ts.dep.diff), data = rateFromDeparture)

gamm2 <- gamm(rate ~ s(ts.dep.diff, age, bs = 'fs'), data = rateFromDeparture)

gamm3 <- gamm(rate ~ s(ts.dep.diff, age, bs = 'fs') + bandsite, data = rateFromDeparture)

gamm4 <- gamm(rate ~ s(ts.dep.diff, bandsite, bs = 'fs'), data = rateFromDeparture)

gamm5 <- gamm(rate ~ s(ts.dep.diff, bandsite, bs = 'fs') + age, data = rateFromDeparture)

# Set viewport to 2 x 2 grid
par(mfrow=c(2,3))
par(mfrow=c(1,1))

p.gamm <- rateFromDeparture %>%
#  ggplot(aes(ts.dep.diff, rate))
  ggplot(aes(ts.dep.diff, rate, color = age))

p.gamm +
  geom_point() +
  geom_smooth(method = 'gam', formula = y ~ s(x))

p.gamm +
  stat_smooth(method = 'gam', formula = y ~ s(x, age, bs = 'fs'))

summary(gamm2$gam)

plot(gamm1$gam, xlab = 'Time (hours since departure)', ylab = 's(Time)')
#mtext(text = "b)", side = 3, adj = 0, at = c(-150))

title(main = 'gamm1')

plot(gamm2$gam)
title(main = 'gamm2')

plot(gamm3$gam)
title(main = 'gamm3')

plot(gamm4$gam)
title(main = 'gamm4')

plot(gamm5$gam)
title(main = 'gamm5')

# Compare linear mixed-effects of models with log-ratio test
lrtest(gamm1$lme, gamm2$lme)
lrtest(gamm2$lme, gamm3$lme)
lrtest(gamm1$lme, gamm4$lme)
lrtest(gamm4$lme, gamm5$lme)
lrtest(gamm2$lme, gamm5$lme)

gamm4.1 <- gamm4(rate ~ s(ts.dep.diff), data = rateFromDeparture)

gamm4.2 <- gamm4(rate ~ s(ts.dep.diff, age, bs = 'fs'), data = rateFromDeparture)

gamm4.3 <- gamm4(rate ~ s(ts.dep.diff, age, bs = 'fs') + s(ts.dep.diff, bandsite, bs = 'fs'), data = rateFromDeparture)

# Compare linear mixed-effects of models with log-ratio test
lrtest(gamm4.1$mer, gamm4.2$mer)
lrtest(gamm4.2$mer, gamm4.3$mer)
lrtest(gamm4.1$mer, gamm4.3$mer)


## -----------------------------------------------------------------------------------------------------------------
#
# Amelia Bertozzi-Villa, Institute for Disease Modeling, University of Oxford
# September 2019
#
# For temperature and rainfall, this script extracts covariate-specific
# data from ERA5 netCDF files an dtransforms them into a panel dataset
## -----------------------------------------------------------------------------------------------------------------------
rm(list=ls())
library(stringr)
library(data.table)
library(rasterVis)
library(raster)
library(ncdf4)

root_dir <- Sys.getenv("HOME")
in_dir <- file.path(root_dir,
                      "temp_rainfall")
#in_dir <- file.path(base_dir, "era5_raw_data")
#template <- raster(file.path(in_dir, "MAP_Regions_Pf_5k.tif"))
input_files <- list.files(in_dir)[list.files(in_dir) %like% paste0("\\.nc$")]
source(file.path(in_dir, "extraction_functions.r"))

### INPUTS: change these as desired #####----------------------------------------------------------------------------------------------------------------------------------

# please make your own output folder to avoid overwriting someone's work
out_dir <- file.path(in_dir, "output")

# set years_to_keep to NULL if you would like to keep all years
years_to_keep <- NULL

# if synoptic==T, take the mean across years. Otherwise save a raster for every year-month
synoptic <- F

# if resample==T, change the resolution and extent of the rasters to match the "template" object above
resample <- F

# if you add any continent other than "global", you must have a raster named "mask.tif" in each
# of your output directories. The global raster is cropped and masked to the "mask" file.
continents_to_keep <- c("global")

# NOT RECOMMENDED IF SYNOPTIC==F: writes a big file
# if save_to_csv==T, all the values in the rasters will also be saved as a .csv in long format,
# one per input file, where "id" refers to the cell number to which that value corresponds
save_to_csv <- F

### Main extraction loop #####----------------------------------------------------------------------------------------------------------------------------------

for (this_input_file in input_files){

  # load raw ERA5 data
  cov_name <- gsub("\\.nc", "", this_input_file)
  print(paste("Extracting ERA5 for", cov_name))

  all_layers <- brick(file.path(in_dir, this_input_file))

  name_pattern <- "X([0-9]{4})\\.([0-9]{2}).*"
  names(all_layers) <- gsub(name_pattern, paste0(cov_name, "_year_", "\\1", "_month_", "\\2"), names(all_layers))

  # subset to the years of interest, if supplied
  if (length(years_to_keep)>0){
    names_to_keep <- unlist(lapply(years_to_keep, function(year){
      names(all_layers)[names(all_layers) %like% year]
    }))
    all_layers <- all_layers[[names_to_keep]]
  }

  # take the mean across years, if requested
  if (synoptic){
    print("Finding synoptic values")
    synoptic_layers <- lapply(1:12, function(this_month){
      print(this_month)
      month_str <- str_pad(as.character(this_month), width=2, side="left", pad="0")
      stack_names <- names(all_layers)[names(all_layers) %like% paste0("month_", month_str)]

      this_stack <- all_layers[[stack_names]]
      synoptic_mean <- max(calc(this_stack, fun=mean), 0) # find mean, remove negative values
      names(synoptic_mean) <- paste0(cov_name, "_month_", month_str)
      return(synoptic_mean)
    })
    final_layers <- stack(synoptic_layers)
  }else{
    final_layers <- all_layers
  }

  # rotate from 0,360 to -180, 180
  print("rotating")
  new_extent <- extent(c(0, 360, ymin(extent(final_layers)), ymax(extent(final_layers))))
  extent(final_layers) <- new_extent
  final_layers <- rotate(final_layers)

  print("converting units")
  if (cov_name %like% "temperature"){
    # convert from kelvin to celsius
    final_layers <- final_layers - 273.15
  }else if (cov_name %like% "rainfall"){
    # each monthly value should be multiplied by the number of days in the month
    month_durations <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

    # extend to the length of all_layers. NOTE: this won't work correctly if you year doesn't start in January
    if (!names(final_layers)[[1]] %like% "month_01"){
      stop("Your time series doesn't start in January! Adjust the values of month_durations")
    }
    month_durations <- rep(month_durations, round(nlayers(final_layers)/12))[1:nlayers(final_layers)]

    # convert from m/day to mm/month
    final_layers <- final_layers * month_durations * 1000
  }

  # move to "template" resolution, if desired
  if (resample){
    print("resampling")
    # resample to match MAP resolution
    final_layers <- align_res(final_layers, template)
  }

  # crop to each continent; save
  for (this_continent in continents_to_keep){
    print(paste("saving for continent:", this_continent))
    this_out_dir <- file.path(out_dir, this_continent, cov_name)
    dir.create(this_out_dir, showWarnings=F, recursive=T)
    extraction_fname <- file.path(this_out_dir, paste0(cov_name, "_vals.csv"))

    # save rasters
    if (this_continent=="global"){
      writeRaster(final_layers, file.path(this_out_dir, paste0(names(final_layers), ".tif")), bylayer=T, overwrite=T)
      vals <- as.matrix(final_layers)
    }else{
      mask_layer <- raster(file.path(this_out_dir, "../mask.tif"))
      cropped_layers <- crop_raster(final_layers, mask = mask_layer,
                                    out_fname = file.path(this_out_dir, paste0(names(final_layers), ".tif"))
      )
      vals <- as.matrix(cropped_layers)
      rm(cropped_layers); gc()
    }

    # save as .csv, if desired
    if(save_to_csv){
      vals <- data.table(vals,
                         id=1:nrow(vals))
      print("reshaping and formatting columns")
      if(!synoptic){
        vals <- melt(vals, id.vars = "id", variable.name="variable_val")
        vals <- vals[, list(cov=cov_name,
                            year=as.integer(gsub(".*_year_([0-9]{4}).*", "\\1", variable_val)),
                            month=as.integer(gsub(".*_month_([0-9]{2})", "\\1", variable_val)),
                            id,
                            value
        )]
      }else{
        names(vals) <- gsub(paste0(cov_name, "_month_"), "", names(vals))
        vals <- vals[!is.na(vals[["01"]])]
        vals <- melt(vals, id.vars = "id", variable.name="variable_val")
        vals <- vals[, list(cov=cov_name,
                            variable_name="month",
                            variable_val,
                            id,
                            value
        )]

      }
      print("saving extracted values")
      write.csv(vals, file=extraction_fname, row.names=F)
    }

  }
  rm("vals","all_layers", "final_layers"); gc()
}