#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 10, 2016
# clear; Rscript rdataframe.r; rm *~
# ref: http://www.programiz.com/r-programming/data-frame
# 5 data types in R : vectors, matrix, list, data frame and a factor

#########################################################################################################
#   DATA-FRAME CREATION
#########################################################################################################
cat("\nWe can create a data frame using the data.frame() function \n")
x <- data.frame("SN"=1:2,"Age"=c(21,15),"Name"=c("John","Dora"))
str(x)
typeof(x[,1])

cat("\nNotice above that the third column, Name is of type factor, instead of a character vector")
cat("\nTo suppress this behavior, we can pass the argument stringsAsFactors=FALSE.\n")
x <- data.frame("SN"=1:2,"Age"=c(21,15),"Name"=c("John","Dora"),stringsAsFactors=FALSE)
str(x)    # now the third column is a character vector

cat("\nMany data input functions of R like, read.table(), read.csv(), read.delim(), read.fwf() also read data into a data frame.")

#########################################################################################################
#   DATA-FRAME COMPONENT ACCESSING (access like a list and access like matrix)
#########################################################################################################
cat("\nAccessing Components in Data Frame \n")
cat("\nAccessing like a list \n")
x["Name"]    # Name 1 John 2 Dora
x$Name       # [1] "John" "Dora"
x[["Name"]]  # [1] "John" "Dora"
x[[3]]       # [1] "John" "Dora"

cat("\nAccessing like a matrix \n")
cat("library(help = 'datasets')\n")
str(trees)
cat("We can see that trees is a data frame with 31 rows and 3 columns\n")
head(trees,n=3)
trees[2:3,]    # select 2nd and 3rd row
y <- trees[trees$Height > 82 || trees$Girth > 13,]    # selects rows with Height greater than 82
print(y)
cat("rows 10,11,12 values of column 2 as a vector\n")
trees[10:12,2]
cat("rows 10,11,12 values of column 2 as a matrix\n")
trees[10:12,2, drop=FALSE]

#########################################################################################################
#   DATA-FRAME MODIFICATION (adding component, deleting component)
#########################################################################################################
cat("\nModifying a Data Frame\n")
x
x[1,"Age"] <- 20; x

cat("\nAdding Components \n")
rbind(x,list(1,16,"Paul"))
cbind(x,State=c("NY","FL"))
x$State <- c("NY","FL"); x

cat("\nDeleting Component \n")
cat("Data frame columns can be deleted by assigning NULL to it. \n")
x$State <- NULL; x
cat("\nSimilarly, rows can be deleted through reassignments. \n")
x <- x[-1,];x
########################################################


library(ggplot2)
library("dplyr")
library("tidyr")
library(patchwork)
library("igraph")
library(calibrate)
library("umap")

library(viridis)

#########################################################################
### REACTOME & viridis color

a = read.table('data/Hippocampus_community.txt', header=T, sep="\t")

ggplot(data.frame(a), aes(x=reorder(gsub("Homo.*","",Term), -P.value), y=-log10(P.value)))  +
theme(panel.background = element_rect(fill="grey", color="black"), panel.grid.major = element_line(color="grey90"), panel.grid.minor = element_line(color="grey90")) +
theme(axis.text=element_text(size=22), axis.title=element_text(size=30), text=element_text(size=22))   + xlab(expression("Reactome")) +
  geom_bar(stat="identity", fill="darkgreen") + ylab(expression("-log(P-value)")) +
  geom_col(aes(fill = Adjusted_P.value)) +
	scale_fill_viridis() +
coord_flip() + geom_hline(yintercept=-log10(0.05), color="red") +guides(fill = guide_legend(reverse = FALSE)) + labs(fill="Adjusted P-value")

#########################################################################
### Correlation plot
b = read.table('data/15_member_hippocampal_community.v1.txt', header=T)
rownames(b) = b[,1]

b[is.na(b)] <- 0

c = ( b[,-1] + t(b[,-1]) )
c[c >1.98] = Inf

c$y = rownames(c)
c <- c %>% gather(x, value, colnames(c)[1:15])

# centered vjust = 0.5
ggplot(c, aes(x, y, fill=value)) + theme(axis.text=element_text(size=20), axis.title=element_text(size=30), text=element_text(size=22))  +
   xlab(expression(bold(""))) + ylab(expression(bold(""))) +
  geom_tile() + # scale_fill_gradient(low = "white", high = "orange") +
theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5)) + # labs(tag = "B")
  scale_fill_viridis()

#########################################################################
### Network

c = ( b[,-1] + t(b[,-1]) )
c[c >1.98] = 1

mat = data.matrix(c)

mat[mat < 0.8] <- 0

network = graph_from_adjacency_matrix( mat, mode="undirected", diag=F, weighted=T)

plot(network, vertex.size=30,  vertex.label.font=1,   vertex.color="yellow" ,layout=layout_with_kk,
 vertex.label.color = "darkgreen", vertex.label.cex=1.3, vertex.label.pos=5, vertex.shape="circle", edge.width=6)

#########################################################################
### Stats on communities

a = read.table('data/CommunitySize.txt', header=T, sep="\t")

wilcox.test(a[c(7:19),]$std, a[-c(7:19),]$std)

par(mar=c(5,6,4,1)+.1)

par(mfrow=c(1,2))
hist(a$n_comm, main="", cex=2.0, cex.lab=2.0, cex.axis=2.0, xlab="Number of Communities", col="darkgreen", xlim=c(0, 260), breaks=20)
#plot(a$mean, a$std, main="", cex=2.0, cex.lab=2.0, cex.axis=2.0, xlab="Mean", ylab="Standard Deviation", col="red")
plot(a$n_comm, a$mean, main="", cex=2.0, cex.lab=2.0, cex.axis=2.0, xlab="Number of Communities", ylab="Mean Community Size", col="red", ylim=c(0, 9), xlim=c(25,300))
textxy(a$n_comm, a$mean, labs=ifelse((a$n_comm > 150) | (a$mean > 7.25), as.character(a$Tissue), ""), col="blue", cex=1.2, pos=3)

###########################################################################
### Summary data on communities

d = read.table('data/CommunitySize.txt', header=T, sep="\t")

p1 = ggplot(data.frame(d), aes(n_comm)) +
    geom_histogram(data = data.frame(d),  binwidth=10, fill="darkgreen", col="black") +
    xlab(expression("Number of Communities")) + ylab(expression("Frequency")) +
    theme(plot.title = element_text(hjust = 0.5),  axis.title=element_text(size=30), text=element_text(size=30), panel.background = element_rect(fill="white"), panel.grid.major = element_line(color="white"), panel.grid.minor = element_line(color="white")) + labs(tag = expression("a")) + theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid")) +
	xlim(c(25, 300))

p2 = ggplot(data.frame(d), aes(x=n_comm, y=mean)) + geom_point(size=6, col="darkgreen") + geom_text(aes(label=ifelse((n_comm > 150) , as.character(Tissue), "")),hjust=1, vjust=1, size=8) + xlab(expression("Number of Communities")) + ylab(expression("Mean Size")) +
    theme(legend.position="none", plot.title = element_text(hjust = 0.5), axis.title=element_text(size=30), text=element_text(size=30), panel.background = element_rect(fill="white"), panel.grid.major = element_line(color="white"), panel.grid.minor = element_line(color="white")) +
 xlim(c(25, 300)) + ylim(c(0, 8)) + labs(tag=expression("b")) + theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid"))

# p1+p2

p3 = ggplot(d, aes(x = Tissue, y = 18365 - ngenes_no_comm)) + geom_bar(stat="identity", aes(fill=  18365 - ngenes_no_comm)) + scale_fill_viridis() + theme_minimal() +  labs(tag=expression("c")) +
    theme(panel.border = element_blank(), legend.position="none", plot.title = element_text(hjust = 0.5), axis.title=element_text(size=30), text=element_text(size=26), panel.background = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +
   theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid")) +
  xlab(expression("Tissue")) + ylab(expression("Frequency")) +  theme(axis.text.x = element_text(angle = 60, hjust = 1))

(p1 + p2) / p3

###########################################################################
####  Variational Autoencoder results

clin.tcga = read.table('data/clinical_data.TCGA.tsv', header=T, fill=T, sep="\t")
enc  = read.table('data/encoded_rnaseq_onehidden_warmup_batchnorm.tsv', fill=T, sep="\t")
comb=merge(clin.tcga, enc, by.x=1, by.y=2)

####  Metastasis analysis

comb1 = subset(comb, comb[,9] %in% c("Metastatic", "Additional Metastatic", "Primary Tumor", "Solid Tissue Normal"))

vaeplot<-ggplot(data=comb1, aes(x=sample_type, y=V6)) + geom_boxplot(aes(fill="darkgreen")) + geom_point() + theme_minimal() +  labs(tag=expression(bold("C"))) +
    theme(panel.border = element_blank(), legend.position="none", plot.title = element_text(hjust = 0.5), axis.title=element_text(size=22), text=element_text(size=18), panel.background = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +
   theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid")) +
 theme(axis.text.x = element_text(angle = 30, hjust = 1)) + xlab("Sample Type") + ylab("Latent Feature 4 Activation") +
	scale_fill_brewer(palette="Dark2") # + geom_jitter(shape=16, position=position_jitter(0.2))

vaeplot

### Compare
wilcox.test(comb1[comb1$sample_type=="Primary Tumor",]$V6, comb1[comb1$sample_type=="Metastatic",]$V6)

# data:  comb1[comb1$sample_type == "Primary Tumor", ]$V6 and comb1[comb1$sample_type == "Metastatic", ]$V6
# W = 632560, p-value < 2.2e-16
# alternative hypothesis: true location shift is not equal to 0

wilcox.test(comb1[comb1$sample_type=="Solid Tissue Normal",]$V6, comb1[comb1$sample_type=="Metastatic",]$V6)

# data:  comb1[comb1$sample_type == "Solid Tissue Normal", ]$V6 and comb1[comb1$sample_type == "Metastatic", ]$V6
# W = 64866, p-value < 2.2e-16
# alternative hypothesis: true location shift is not equal to 0

###########################################################################
### Stemness

stem = read.table('data/VAE_with_StemnessScore.v1.txt', header=T, sep="\t")

stemness =  ggplot(stem, aes(x=log2(X4), y=log2(DNAss) )) + geom_point(size=6, col="yellow")  + xlab(expression("Latent Feature 4 Activation")) + ylab(expression("Stemness Index")) +
    theme(legend.position="none", plot.title = element_text(hjust = 0.5), axis.title=element_text(size=22), text=element_text(size=18), panel.background = element_rect(fill="white"), panel.grid.major = element_line(color="white"), panel.grid.minor = element_line(color="white")) +
  labs(tag=expression(bold("D"))) + theme( axis.line = element_line(colour = "grey90", size = 2, linetype = "solid")) +
#  stat_summary(fun.data=mean_cl_normal) +
  geom_smooth(method='lm', formula= y~x, col="darkgreen")


options(repr.plot.width = 7, repr.plot.height = 6)
options(jupyter.plot_mimetypes = c('application/pdf', 'image/png'))
set.seed(1)

library(destiny)  # load destiny…
data(guo)         # …and sample data

old <- options(repr.plot.height = 2)
par(mar = rep(0, 4))
graph <- igraph::graph_from_literal(
    data -+ 'transition probabilities' -+ DiffusionMap,
    'transition probabilities' -+ DPT)
plot(
    graph, layout = igraph::layout_as_tree,
    vertex.size = 50,
    vertex.color = 'transparent',
    vertex.frame.color = 'transparent',
    vertex.label.color = 'black')
options(old)

dm <- DiffusionMap(guo)
dpt <- DPT(dm)

plot(dpt, pch = 20)  # “pch” for prettier points

old <- options(repr.plot.height = 3)

par(mfrow = c(1,2), pch = 20, mar = c(2,2,0,1))
plot(dpt, col_by = 'DPT3')
plot(dpt, col_by = 'Gata4', pal = viridis::magma)

options(old)

plot(dpt, root = 2, paths_to = c(1,3), col_by = 'branch', pch = 20)

plot(dpt, col_by = 'branch', divide = 3, dcs = c(-1,3,-2), pch = 20)


# écriture de stochastic_model sans array
# avec output true

# modèle simplifié

# écart de production -------------------
og <- lagog + dog
dog <- og_lag * (lagog - lag2og) +
  - og_mce * (lagog - 0) +
  og_k * ib + og_noise

update(lagog) <- og
update(lag2og) <- lagog
update(og_noise) <- ogn_ar * og_noise + rnorm(0, ogn_sigma)

# dette ------------
dette <- lagdette + ddette
update(lagdette) <- dette
update(lag2dette) <- lagdette
ddette <- lagrho*lagdette - surplus

# rho écart critique
rho <- lagrho + drho
update(lagrho) <- rho
drho <- -rho_mce*(lagrho - rhostar) + rho_d*(lagdette - dstarr)

# surplus
surplus <- lagsurplus + sur_og * (og - lagog) - ib
update(lagsurplus) <- surplus
update(lag2surplus) <- lagsurplus

# règle budgétaire --------------
sstar <- rhostar*dstar

ib <- tpo_sstar * (lagsurplus - sstar ) + tpo_1sstar * (lagsurplus - lag2surplus) + tpo_sstar2 * (lagsurplus - sstar)^2 +
      tpo_dstar * (lagdette - dstar) + tpo_1dstar * (lagdette - lag2dette) + tpo_dstar2 * (lagdette - dstar)^2 +
      tpo_og*(lagog) + tpo_og2*(lagog)^2 + tpo_1og*(lagog - lag2og) +
      tpo_rho*(rho - rhostar) +
      phi[step]

# fonction de perte ----------------------
# utilisée pour la partie optimisation
update(loss_d_only) <- loss_d_only + loss_d * (step >= loss_t)*(lagdette - dstar)^2
initial(loss_d_only) <- 0
update(loss_no_d) <- loss_no_d + og^2/(1+loss_df)^(step-1) + loss_dog * (og-lagog)^2 + loss_ib * (ib)^2
initial(loss_no_d) <- 0

# sorties ------

update(dettep_o) <- dette
update(og_o) <- og
update(surplus_o) <- surplus
update(ib_o) <- ib
update(rho_o) <- rho
update(loss_o) <- loss_no_d + loss_d_only
update(loss_nd_o) <- loss_no_d

initial(surplus_o) <- 0
initial(og_o) <- 0
initial(dettep_o) <- 0
initial(ib_o) <- 0
initial(rho_o) <- 0
initial(loss_o) <- 0
initial(loss_nd_o) <- 0

# init ----------------
i_lagog <- user(0)
i_lag2og <- user(0)
i_lagrho <- user(0)
i_lagdette <- user(1)
i_lagsurplus <- user(-0.01)
i_lag2surplus <- user(-0.01)
i_lag2dette <- user(1)

## Initial conditions
# initial(og) <- init_og
initial(lagog) <- i_lagog
initial(lag2og) <- i_lag2og
initial(og_noise) <- i_ogn
initial(lagrho) <- i_lagrho
initial(lagdette) <- i_lagdette
initial(lag2dette) <- i_lag2dette
initial(lagsurplus) <- i_lagsurplus
initial(lag2surplus) <- i_lag2surplus

# params -------------
periods <- user(50)

## parameters
og_lag   <- user(0)
og_mce   <- user(0.15)
og_k <- user(0.7)
rho_d <- user(0.01)
rho_mce <- user(0.15)
dstar <- user(0.6)
dstarr <- user(0.6)
tpo_sstar <- user(0.4)
tpo_dstar <- user(-0.1)
tpo_sstar2 <- user(0)
tpo_1sstar <- user(0)
tpo_dstar2 <- user(0)
tpo_1dstar <- user(0)
tpo_1og <- user(0)
tpo_og <- user(0)
tpo_og2 <- user(0)
tpo_rho <- user(0)
loss_df <- user(0.02)
loss_ib <- user(0)
ogn_ar <- user(0)
ogn_sigma <- user(0.005)
rhostar <- user(-0.015)
i_ogn <- user(0.005)
sur_og <- user(0.5)

# loss
loss_dog <- user(0)
loss_d <- user(0.5)
loss_t <- user(20)

# controls&exogenes -----------
phi[] <- user(0)

dim(phi) <- periods


# take input from the user
num = as.integer(readline(prompt = "Enter a number: "))
if(num < 0) {
print("Enter a positive number")
} else {
sum = 0
# use while loop to iterate until zero
while(num > 0) {
sum = sum + num
num = num - 1
}
print(paste("The sum is", sum))
}


# 4. faza: Analiza podatkov

#LINEARNA REGRESIJA

library(ggplot2)
library(GGally)

g <- ggplot(tabela_tri_zdruzene, aes(x=skupaj.x, y=skupaj.y)) + geom_point()
graf13 <- g + geom_smooth(method="lm", formula=y ~ x) + labs(x = "Število prebivalcev (v stotisočicah)", y = "Število dijakov", title = "Število dijakov v Sloveniji na leto  \nglede na število prebivalcev v istem letu")

p <- ggplot(tabela_tri_zdruzene, aes(x=skupaj.x, y=skupaj)) + geom_point()
graf14 <- p + geom_smooth(method="lm", formula=y ~ x)+ labs(x = "Število prebivalcev (v stotisočicah)", y = "Število diplomantov", title = "Število diplomantov v Sloveniji na leto  \nglede na število prebivalcev v istem letu")


rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)
library(reshape)
library(xlsx)

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation

emptyFrame <- function(h,s){
  c.d <- data.frame("test"=c("emp.spearman","emp.pearson"),
                    "sample"=c(s,s),
                    "hypothesis"=c(h,h),
                    "Correlation"=c(NA,NA),
                    "emp"=c(NA,NA),
                    "p0.975"=c(NA,NA),
                    "p0.95"=c(NA,NA),
                    "p0.05"=c(NA,NA),
                    "p0.025"=c(NA,NA))
  return(c.d)
}

corTest <- function(d,h,s){

  # Create two datasets, one to add permutation columns to, one to pull from. because that's how I coded it?
  a <- d %>% filter(variable == h)
  perms <- d %>% filter(variable == h)
  nloci <- length(a$Locus)
  maxB <- max(a$BF)
  minB <- min(a$BF)
  maxG <- max(a$GL)
  minG <- min(a$GL)
  #print(length(a$Locus))

  # Safety check for if a subset of data has too few observations
  if(length(a$Locus) < 1){
    c.d <- emptyFrame(h,s)
    return(c.d)
  }

  # Define which column numbers to test for correlation

  b <- match('BF',names(a))
  g <- match('GL',names(a))

  # Permute BF values in 1,000 seperate columns, could permute BF or GL doesnt matter.

  for (n in 1:1000) {
    newcolname1 <- paste('BF',n,sep='')
    perms[, newcolname1] <- sample(a[[b]], replace = FALSE)
    #newcolname2 <- paste('GL',n,sep='')
    #null[, newcolname2] <- sample(a[[g]], replace = FALSE)
  }

  # Create new dataset to add null rank coefficients to

  assign('null', setNames(data.frame(1:1000), "replicate"))

  # Add bf gl

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1.s <- cor(perms[,'GL'],perms[,colname1],method="spearman")
    null[n,'null.spearman'] <- cc1.s
    cc1.p <- cor(perms[,'GL'],perms[,colname1],method="pearson")
    null[n,'null.pearson'] <- cc1.p
  }

  # Dataframe for emp scores
  emp <- data.frame(TestType=character(),
                    corr.eff=integer(),
                    p=integer(),
                    p0.975=integer(),
                    p0.95=integer(),
                    p0.05=integer(),
                    p0.025=integer(),stringsAsFactors=FALSE)

  # Designate which row is for which test

  emp[1,'TestType'] <- 'emp.spearman'
  emp[2,'TestType'] <- 'emp.pearson'

  # Calculate correlation stats from emperical data,  add to df

  e.s <- cor(a[[b]],a[[g]],method="spearman")
  e.p <- cor(a[[b]],a[[g]],method="pearson")

  emp[1,'corr.eff'] <- e.s
  emp[2,'corr.eff'] <- e.p

  # Calculate 2 sided p values

  p.s <- sum(abs(null$null.spearman) >= abs(e.s)) / length(null$null.spearman)
  p.p <- sum(abs(null$null.pearson) >= abs(e.s)) / length(null$null.pearson)

  emp[1,'p'] <- p.s
  emp[2,'p'] <- p.p

  # Add rows for quantile cut offs

  emp[1,'p0.025'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[1,'p0.975'] <- quantile(null$null.spearman, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[1,'p0.05'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[1,'p0.95'] <- quantile(null$null.spearman, c(0.05, 0.95),na.rm = TRUE)[[2]]
  emp[2,'p0.025'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[1]]
  emp[2,'p0.975'] <- quantile(null$null.pearson, c(0.025, 0.975),na.rm = TRUE)[[2]]
  emp[2,'p0.05'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[1]]
  emp[2,'p0.95'] <- quantile(null$null.pearson, c(0.05, 0.95),na.rm = TRUE)[[2]]

  # Add significance yes/no and other data

  corr.data <- emp %>%
    mutate_if(is.numeric,round,2) %>%
    add_column(Hypothesis = h, .after = "TestType") %>%
    add_column(Sample = s, .after = "TestType") %>%
    add_column(Loci = nloci, .after = "p") %>%
    add_column(minG = minG, .after = "Loci")%>%
    add_column(maxG = maxG, .after = "Loci")%>%
    add_column(minB = minB, .after = "Loci")%>%
    add_column(maxB = maxB, .after = "Loci")

  return(corr.data)
}

##################################################################################################
## set dataset
##################################################################################################

dataset <- "Reeder"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS")) %>%
  mutate_if(is.numeric,round,2)
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF")) %>%
  mutate_if(is.numeric,round,2)

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10
mLBF[7:10] <- mLBF[7:10]/2

# Transform datasets - stack two comparisons, and add column for bf and gl
# Each dataset one hypothesis

B <- mLBF %>%
  select(c("Locus","supportType","AIvSA","AIvSI","SAvSI","TvS")) %>%
  melt(id=c("Locus","supportType"))

G <- mLGL %>%
  select(c("Locus","supportType","AIvSA","AIvSI","SAvSI","TvS")) %>%
  melt(id=c("Locus","supportType"))

# Smoosh together again
all <- bind_rows(B,G)

# Originally ran with threshold of dGLS being 0.5, 2x = 1, 4x=2
# trying again with 2, 2x=4, 4x=8

all.e <- left_join(G,B,by=c("Locus","variable"), suffix = c(".g", ".b"))
all.exp <- all.e %>% dplyr::rename(BF = value.b,GL = value.g) %>% select(-c("supportType.b","supportType.g"))

all.60m <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.2),quantile(all.exp$GL, 0.8)) |
           between(BF,quantile(all.exp$BF,0.2),quantile(all.exp$BF, 0.8)))

all.80m <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.1),quantile(all.exp$GL, 0.9)) |
           between(BF,quantile(all.exp$BF,0.1),quantile(all.exp$BF, 0.9)))

# both within - gl AND bf within
all.60mb <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.2),quantile(all.exp$GL, 0.8)) ,
         between(BF,quantile(all.exp$BF,0.2),quantile(all.exp$BF, 0.8)))

all.80mb <- all.exp %>% group_by(variable) %>%
  filter(between(GL,quantile(all.exp$GL,0.1),quantile(all.exp$GL, 0.9)) ,
         between(BF,quantile(all.exp$BF,0.1),quantile(all.exp$BF, 0.9)))

##################################################################################################
## run tests
##################################################################################################

tvs <- corTest(all.exp,"TvS","all")
aivsa <- corTest(all.exp,"AIvSA","all")
aivsi <- corTest(all.exp,"AIvSI","all")
savsi <- corTest(all.exp,"SAvSI","all")

tvs.60m <- corTest(all.60m,"TvS","sig60m")
aivsa.60m <- corTest(all.60m,"AIvSA","sig60m")
aivsi.60m <- corTest(all.60m,"AIvSI","sig60m")
savsi.60m <- corTest(all.60m,"SAvSI","sig60m")

tvs.80m <- corTest(all.80m,"TvS","sig80m")
aivsa.80m <- corTest(all.80m,"AIvSA","sig80m")
aivsi.80m <- corTest(all.80m,"AIvSI","sig80m")
savsi.80m <- corTest(all.80m,"SAvSI","sig80m")

tvs.60mb <- corTest(all.60mb,"TvS","quant60mb")
aivsa.60mb <- corTest(all.60mb,"AIvSA","quant60mb")
aivsi.60mb <- corTest(all.60mb,"AIvSI","quant60mb")
savsi.60mb <- corTest(all.60mb,"SAvSI","quant60mb")

tvs.80mb <- corTest(all.80mb,"TvS","quant80mb")
aivsa.80mb <- corTest(all.80mb,"AIvSA","quant80mb")
aivsi.80mb <- corTest(all.80mb,"AIvSI","quant80mb")
savsi.80mb <- corTest(all.80mb,"SAvSI","quant80mb")

results <- bind_rows(tvs,aivsa,aivsi,savsi,
                        tvs.80m,aivsa.80m,aivsi.80m,savsi.80m,
                        tvs.60m,aivsa.60m,aivsi.60m,savsi.60m,
                        tvs.80mb,aivsa.80mb,aivsi.80mb,savsi.80mb,
                        tvs.60mb,aivsa.60mb,aivsi.60mb,savsi.60mb) %>% filter(TestType == "emp.spearman")

# output excel sheet

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/Tables/Correlation_datasets_mb_121420.xlsx",sep='')

write.xlsx2(as.data.frame(results), file=fname, sheetName=dataset, row.names=FALSE,append=TRUE)


#Liste des RGB
#Colonne vide=que des 0
png("#43_RGB_colors.png" , width = 480, height = 480 )

par(mfrow=c(2,3) , mar=c(2,2,2,1) , oma=c(4,5,1,1) )

line=6
col=6
red=sort(rep(c(0,0.2,0.4,0.6,0.8,1),col))
green=rep(c(0,0.2,0.4,0.6,0.8,1),line)
num=0

for(i in seq(0,1,0.2)){
	num=num+1
	plot(0, 0, type = "n", xlim = c(0, 1), ylim = c(0, 1), axes = FALSE, xlab = "", ylab = "" )
	colors=rgb(red,green,i,1)
	mtext(paste("blue = ",i,sep="") , side=3 , line=0.15 , col="blue" , font=2)
	rect(  rep((0:(col - 1)/col),line) ,  sort(rep((0:(line - 1)/line),col),decreasing=T)   ,   rep((1:col/col),line) , sort(rep((1:line/line),col),decreasing=T),  border = "light gray" , col=colors)
	axis(2 , at=c(17,14,11,8,5,2)/18-0.035 , labels=c("0","0.2","0.4","0.6","0.8","1") , tick=F , lty=6 , pos=0.01)
	axis(3 , at=c(1.5 , 3.5 , 5.5 , 7.5 , 9.5 , 11.5)/12-0.045 , labels=c("0","0.2","0.4","0.6","0.8","1") , tick=F , pos=-0.15)
	}

mtext("Quantity of red", side=2 , line=34 , col="red" , font=2 , at=1.2)
mtext("Quantity of green", side=1 , line=3 , at=-0.8 , col="forestgreen" , font=2)

dev.off()


# Run the code below to set up the data

library(tidyverse)
library(babynames)
y2015 <- filter(babynames, year==2015)
y2015

# Create a histogram of the number of babies with a name in 2015
# Pick an appropriate number of bins (no right answer)
# Log the x axis
# Facet the graph by sex
# Set the axis labels and title appropriately

# Note: there are a lot of names; it could take a second to plot

# Bonus: Change the facet labels to Female and Male


#' Calculate TSI values from input data
#'
#' This function calculates TSI values according to Utah's IR methods from input data containing values for of chlorophyll, total phosphorus, and secchi disk depth.
#' Note that inputs for these parameters must be specified in units of ug/L, mg/L, and meters, respectively.
#' @param x Input dataset
#' @param in_format One of "wide" or "flat" to specify data input format. Note that only wide format inputs are currently supported.
#' @param chl_ugL Name of chlorophyll-a variable in ug/L
#' @param TP_mgL Name of total phosphorus variable in mg/L
#' @param SD_m Name of secchi disk depth variable in m
#' @examples
#' data(ul_trophic)
#' head(ul_trophic)
#' tsi=calcTSI(ul_trophic,chl_ugL="ChlA",TP_mgL="Phosphate.phosphorus.Total",SD_m="Depth.Secchi.disk.depth")
#' head(tsi)
#' plot(TSIchl~ChlA,tsi)

#' @export
calcTSI=function(x,in_format="wide",chl_ugL="Chlorophyll a",TP_mgL="Phosphate-phosphorus",SD_m="Depth, Secchi disk depth", value_var='ResultMeasureValue', param_var='CharacteristicName'){
#x=trophic_data
#x=within(x, {
#	IR_Value[IR_Value == 0] = 0.001
#})
#any(x[,'IR_Value'] == 0, na.rm=T)
#chl_ugL="Chlorophyll a"
#TP_mgL="Phosphate-phosphorus"
#SD_m="Depth, Secchi disk depth"
#value_var='IR_Value'
#param_var='CharacteristicName'

#default input units: chla (ug/L), TP (mg/L), SD (m)
	if(in_format=="wide"){
		TSIchl=9.81*log(x[,chl_ugL])+30.6
		TSItp=14.2*log(x[,TP_mgL]*1000)+4.15
		TSIsd=60-14.41*log(x[,SD_m])
		tsi=cbind(x, TSIchl, TSItp, TSIsd)
	}
	if(in_format=="flat"){
		x$TSI=NA
		x$TSI[x[,param_var] == chl_ugL] = 9.81*log(x[x[,param_var]==chl_ugL,value_var])+30.6
		x$TSI[x[,param_var] == TP_mgL] =14.2*log(x[x[,param_var]==TP_mgL,value_var]*1000)+4.15
		x$TSI[x[,param_var] == SD_m] = 60-14.41*log(x[x[,param_var]==SD_m,value_var])
		tsi=x
	}
	return(tsi)
}


#' f_smoothh1
#'
#' Construct the $K_\tau K_1$ vector $h_1$
#'
#' @param n1 matrix n1 output from f_n1
#' @param g1 $G_1$ diagonal matrix
#' @param g2 $G_2$ diagonal matrix
#' @param sigmatau $\Sigma_tau$ diagonal matrix
#'
#'
#' @return $K_\tau K_1$ vector $H_1$
#'
#' @examples
#' \dontrun{
#' devtools::load_all()
#'k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; n <- 400
#' v_dim <- c(ktau + mtau, k1 + m1)
#' v_x <- runif(n); v_y <- log(v_x); sigma <- 0.4 * (0.5 + v_x)
#' n1 <- f_n1(v_x, k1, m1); beta <- rnorm(prod(v_dim[1], v_dim[2]))
#' m_sigmatau <- f_sigmatau(v_dim[1])
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' #h1
#' m_h1 <- f_smoothh1(n1, m_g1, m_g2, m_sigmatau)
#' m_h1$h1
#' m_h1$h0
#' }
f_smoothh1 <- function(n1, g1, g2, sigmatau) {
    #form N^{m_tau+1}(1) and N^{m_tau+2}(\tau)|_0^1
    nm1 <- rep(0, nrow(sigmatau)); nm1[nrow(sigmatau)] <- 1
    h_1 <- nm1 - tcrossprod(g2, sigmatau) %*% nm1
    h_1 <- tcrossprod(g1, sigmatau) %*% h_1
    h_1 <- kronecker(h_1, t(n1))
    h_1 <- rowSums(h_1)

    h_0 <- tcrossprod(g1, sigmatau) %*% nm1
    h_0 <- kronecker(h_0, t(n1))
    h_0 <- 0.5 * rowSums(h_0) - h_1
    return(list(h1 = h_1,
                h0 = h_0))
}

#' f_smoothres
#'
#' Construct the $n n_tau$ residual vector
#'
#' @param ndesign   design matrix $n n_\tau \times K_\tau K_1$ $N(\tau, x)$
#' @param v_y       vector of observations y_i
#' @param sigma  $\Sigma$ diagonal matrix
#' @param til_beta  tilde_beta coefficients
#'
#' @param h         bandwidth value
#' @return $n n_tau$ residual vector
#'
#'
#' @examples
#' \dontrun{
#' s_ntau <- 500; v_taus <- seq(0, 1, length.out = s_ntau)
#' m_ndesign <- kronecker(f_ntau(v_taus, ktau, mtau), n1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' til_beta <- tilde_beta(beta, k1 + m1)
#' h <- max((((log(n) + 1) / n) ^ 0.4), 0.05)
#' v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta)
#' }
f_smoothres <- function(ndesign, v_y, sigma, til_beta, h) {
    #Calculate the residual
    c(ndesign %*% sigma %*% til_beta - v_y) / h
}

#' f_smoothhtau
#'
#' Construct the $K_\tau K_1$ vector $h_\tau$
#'
#' @param ndesign   design matrix $n n_\tau \times K_\tau K_1$ $N(\tau, x)$
#' @param pres  error function of the $K_\tau n_tau$ residual vector devided by h
#' @param s_ntau    number of taus values
#'
#'
#' @return $K_\tau K_1$ vector $h_\tau$
#'
#'
#' @examples
#' \dontrun{
#' s_ntau <- 500; v_taus <- seq(0, 1, length.out = s_ntau)
#' m_ndesign <- kronecker(f_ntau(v_taus, ktau, mtau), n1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' til_beta <- tilde_beta(beta, k1 + m1)
#' h <- max((((log(n) + 1) / n) ^ 0.4), 0.05)
#'
#' ptm <- proc.time()# Start the clock!
#' v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta)
#' print(proc.time() - ptm)# Stop the clock
#' #Using the Gaussian kernel
#' v_pres <- pnorm(v_res)
#' m_htau <- f_smoothhtau(m_ndesign, v_pres, h, s_ntau)
#' }
f_smoothhtau <- function(ndesign, pres, s_ntau) {
    c(crossprod(pres, ndesign) / s_ntau)
}

#' f_smoothderiv
#'
#' Construct the $K_\tau K_1$ gradient vector for the loss
#'
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param v_dim vector contain the dimension of covariates
#'             $(K_\tau, K_1, K_2, K_3, \cdots)$
#'
#' @param m_sigma $K_\tau K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_\tau K_1K_2$ vector
#' @param h2 $K_\tau K_1K_2$ vector
#'
#'
#' @return the $K_\tau K_1$ gradient vector for the loss
#'
#' @examples
#' \dontrun{
#' f_smoothderiv(til_beta, v_dim, m_sigma, m_htau, m_h1)
#' }
f_smoothderiv <- function(til_beta, v_dim, m_sigma, htau, h1) {
    m_c <- f_matc(v_dim, til_beta)
    lossderiv <- m_c %*% crossprod(m_sigma, (htau - h1))
    return(c(lossderiv))
}

#' f_smoothgrad
#'
#' Construct the $K_\tau K_1K_2$ gradient vector for $\beta$
#'
#' @param beta the current estimation fro $\beta$
#' @param loss_deriv the derivative of the loss
#' @param s $K_\tau K_1K_2 \times K_1K_2$ $S$ matrix
#'
#'
#' @return the $K_\tau K_1K_2$ gradient vector for $\beta$
#'
#' @examples
#' \dontrun{
#' f_grad(beta, v_lossderiv, m_s)
#' }
f_smoothgrad <- function(beta, loss_deriv, s) {
    loss_deriv + c(s %*% beta)
}

#' f_smoothloss
#'
#' Return the quantile loss criteria
#'
#' @param res   $K_\tau n_tau$ residual vector
#' @param pres  error function of the $K_\tau n_tau$ residual vector devided by h
#' @param h0sig    $K_\tau K_1$ vector $H_0$ times m_sigma
#' @param til_beta  estimation for $\tilde{\beta}$
#'
#' @param s_ntau    number of taus values
#' @param h bandwidth value
#' @param s_n number of observation
#'
#' @return the smooth quantile loss
#'
f_smoothloss <- function(res, pres, h0sig, til_beta,
                        s_ntau, h, s_n) {
    loss <- crossprod(h0sig, til_beta)
    resloss <- h / 2 * sqrt(2 / pi) * sum(exp(- (- res / 2)^2))
    resloss <- resloss - crossprod(res, (1 - 2 * pres))
    loss <- loss + resloss / s_ntau
    return(c(loss) / s_n)
}

#' f_smoothcrit
#'
#' Return the smooth QR criteria
#'
#' @param res   $n n_tau$ residual vector
#' @param pres  error function of the $K_\tau n_tau$ residual vector devided by h
#' @param h0sig    $K_\tau K_1$ vector $H_0$ times m_sigma
#' @param til_beta  estimation for $\tilde{\beta}$
#' @param beta the current estimation for $\beta$
#'
#' @param s_ntau    number of taus values
#' @param h bandwidth value
#' @param s_n number of observation
#' @param s $K_1K_2 \times K_1K_2$ $S$ matrix
#'
#' @return the smooth quantile criteria
#'
f_smoothcrit <- function(res, pres, h0sig, til_beta, beta,
                        s_ntau, h, s_n, s) {
    loss <- f_smoothloss(res, pres, h0sig, til_beta, s_ntau, h, s_n)
    criteria <- loss + crossprod(beta, s %*% beta)
    return(c(criteria))
}

#' f_smoothbbgd
#'
#' The descent algorithm using bb stepsize
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#'
#' @param init initialization for $\beta$
#' @param h     bandwidth value
#' @param s_ntau    number of taus for numerical integration
#' @param v_smooth  vector of smoothing parameters
#' @param maxit maximum number of iterations
#' @param eps   stopping critria threshhold
#' @param eta   stopping criteria for gradient size
#' @param trace indicator whether to plot trace
#'
#'
#' @return the estimated $\beta$
#'
f_smoothbbgd <- function(v_y, v_x, v_k0, v_m, init = NULL,
                        v_smooth = rep(1, 3),
                        h=max((((log(length(v_y))+1)/length(v_y))^0.4), 0.05),
                        s_ntau = 200,
                        maxit = 1e4, eps = 1e-3, eta = 1e-3,
                        trace = NULL, echostep = F) {

#-------------------------------------------------------
##### set up #####
#-------------------------------------------------------
    function_call <- match.call()
    x_ord <- order(v_x)
    v_x <- v_x[x_ord]
    v_y <- v_y[x_ord]
    s_center <- mean(v_x)
    s_sd <- sd(v_x)
    v_x <- c(scale(v_x))
    iter <- 0L
    converge <- F
    s_n <- length(v_y)
    #Define dimensions
    k1 <- v_k0[2]; ktau <- v_k0[1]; m1 <- v_m[2]; mtau <- v_m[1]
    v_dim <- v_k0 + v_m
    #Require
    m_n1 <- f_n1(v_x, k1, m1)
    m_g1 <- f_g1(ktau, mtau)
    m_g2 <- f_g2(ktau, mtau)
    m_sigmatau <- f_sigmatau(v_dim[1])
    m_sigma <- f_sigma(v_dim[1], v_dim[2])
    m_s <- f_mats(v_dim[1], v_dim[2], v_smooth)
    # Set up design matrix
    v_taus <- seq(0, 1, length.out = s_ntau)
    m_ndesign <- kronecker(f_ntau(v_taus, ktau, mtau), m_n1)

    #Precalculate h1, h0, h0 * Sigma
    m_h1 <- f_smoothh1(m_n1, m_g1, m_g2, m_sigmatau)
    m_h0 <- m_h1$h1
    m_h1 <- m_h1$h1
    v_h0sig <- c(crossprod(m_h0, m_sigma))

    #Initialization
    if (is.null(init)) {
        init <- f_init(v_y, v_x, m_sigma, m_n1, v_k0, v_m, m_s)
    }
    til_beta0 <- init
    v_beta0 <- og_beta(til_beta0, v_dim[1], v_dim[2])
    v_grad0 <- 0

    #Calculate v_res (most time consuming)
    v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta0, h)
    #Using the Gaussian kernel for h_\tau
    v_pres <- pnorm(v_res)
    m_htau <- f_smoothhtau(m_ndesign, v_pres, s_ntau)

    ##Loss
    s_loss <- f_smoothcrit(v_res, v_pres, v_h0sig, til_beta0, v_beta0,
                            s_ntau, h, s_n, m_s)

    ##trace
    if (!is.null(trace)) {
        v_taus <- trace
        con_quan <- list(x = v_x, y = v_y, center = s_center, sd = s_sd,
                    v_k0 = v_k0, v_m = v_m, m_sigma = m_sigma, n1 = m_n1,
                    til_beta = til_beta0)
        sub <- paste("Iter:", iter, ", Error=", round(s_loss, 3))
        main <- paste("Smoothing:", v_smooth[1:2], "dim:", v_dim)
        cq_plot(trace, con_quan, sub = sub, main = main)
    }

    #Standard gradient updates
    v_deriv <- f_smoothderiv(til_beta0, v_dim, m_sigma, m_htau, m_h1)
    v_grad1 <- f_smoothgrad(v_beta0, v_deriv / s_n, m_s)

    #Calculate new coefficients
    v_beta1 <- v_beta0 - v_grad1
    til_beta1 <- tilde_beta(v_beta1, v_dim[2])
    new_loss <- f_smoothcrit(v_res, v_pres, v_h0sig, til_beta1, v_beta1,
                            s_ntau, h, s_n, m_s)

    #Repeat
    while (maxit > iter) {
        iter <- iter + 1

        #Calculate difference
        v_delta <- v_beta1 - v_beta0
        v_gdiff <- v_grad1 - v_grad0

        #bb stepsize
        s_delgrad <- crossprod(v_delta, v_gdiff)
        if (s_delgrad < 0) {
            if (echostep) print(s_delgrad)
            s_step <- 1
        } else  {
            step1 <- crossprod(v_delta) / s_delgrad
            step2 <- s_delgrad / crossprod(v_gdiff)
            s_step <- min(step1, step2, 10)
            if (echostep) print(s_step)
        }

        #update v_beta0, til_beta0, v_grad0, s_loss
        v_beta0 <- v_beta1
        til_beta0 <- til_beta1
        v_grad0 <- v_grad1
        s_loss <- new_loss

        #Calculate v_res (most time consuming)
        v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta0, h)
        #Using the Gaussian kernel for h_\tau
        v_pres <- pnorm(v_res)
        m_htau <- f_smoothhtau(m_ndesign, v_pres, s_ntau)

        #Calculate gradient
        v_deriv <- f_smoothderiv(til_beta0, v_dim, m_sigma, m_htau, m_h1)
        v_grad1 <- f_smoothgrad(v_beta0, v_deriv / s_n, m_s)

        #Update v_beta1, til_beta1
        v_beta1 <- v_beta0 - s_step * v_grad1
        til_beta1 <- tilde_beta(v_beta1, v_dim[2])
        new_loss <- f_smoothcrit(v_res, v_pres, v_h0sig, til_beta1, v_beta1,
                            s_ntau, h, s_n, m_s)

        ##trace
        if (!is.null(trace)) {
            con_quan$til_beta <- til_beta1
            sub <- paste("Iter:", iter, ", Error=", round(new_loss, 3))
            cq_plot(trace, con_quan, sub = sub, main = main)
        }

        #Check stop criterion
        if (is.null(eta)) {
            converge <- (abs(new_loss - s_loss) <= eps * abs(s_loss))
        } else {
            converge <- (norm_2(v_grad1) / norm_2(v_beta0) <= eta)
        }

        #If gradient size criteria
        if (is.na(converge)) {
            converge <- F
            break
        }
        if (converge) break

    }

#-------------------------------------------------------
##### Output #####
#-------------------------------------------------------
    out <- list(
        beta = v_beta1,
        til_beta = til_beta1,
        gradient = v_grad1,
        converge = converge,
        grad_size = sum(v_grad1 ^ 2),
        iter = iter,
        loss = s_loss,
        x = v_x,
        y = v_y,
        center = s_center,
        sd = s_sd,
        v_k0 = v_k0,
        v_m = v_m,
        n1 = m_n1,
        m_sigma = m_sigma,
        mat_s = m_s,
        call = function_call)

    return(out)
}

#' f_smoothdescent
#'
#' The descent algorithm using back tracking line search stepsize
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#'
#' @param init initialization for $\beta$
#' @param alpha threshold $\alpha$, within $(0, 0.5)$.
#' @param bet   shrinkage rate $\bet$, within $(0, 1)$.
#' @param v_smooth  vector of smoothing parameters
#' @param maxit maximum number of iterations
#' @param eps   stopping critria threshhold
#' @param eta   stopping criteria for gradient size
#' @param trace indicator whether to plot trace
#'
#'
#' @return the estimated $\beta$
#'
f_smoothdescent <- function(v_y, v_x, v_k0, v_m, init = NULL,
                        alpha = 0.3, bet = 0.8, v_smooth = rep(1, 3),
                        h=max((((log(length(v_y))+1)/length(v_y))^0.4), 0.05),
                        s_ntau = 200,
                        maxit = 1e4, eps = 1e-3, eta = NULL, trace = NULL) {

#-------------------------------------------------------
##### set up #####
#-------------------------------------------------------
    function_call <- match.call()
    x_ord <- order(v_x)
    v_x <- v_x[x_ord]
    v_y <- v_y[x_ord]
    s_center <- mean(v_x)
    s_sd <- sd(v_x)
    v_x <- c(scale(v_x))
    iter <- 0L
    converge <- F
    s_n <- length(v_y)
    #Define dimensions
    k1 <- v_k0[2]; ktau <- v_k0[1]; m1 <- v_m[2]; mtau <- v_m[1]
    v_dim <- v_k0 + v_m
    #Require
    m_n1 <- f_n1(v_x, k1, m1)
    m_g1 <- f_g1(ktau, mtau)
    m_g2 <- f_g2(ktau, mtau)
    m_sigmatau <- f_sigmatau(v_dim[1])
    m_sigma <- f_sigma(v_dim[1], v_dim[2])
    m_s <- f_mats(v_dim[1], v_dim[2], v_smooth)
    # Set up design matrix
    v_taus <- seq(0, 1, length.out = s_ntau)
    m_ndesign <- kronecker(f_ntau(v_taus, ktau, mtau), m_n1)

    #Precalculate h1, h0, h0 * Sigma
    m_h1 <- f_smoothh1(m_n1, m_g1, m_g2, m_sigmatau)
    m_h0 <- m_h1$h1
    m_h1 <- m_h1$h1
    v_h0sig <- c(crossprod(m_h0, m_sigma))

    #Initialization
    if (is.null(init)) {
        init <- f_init(v_y, v_x, m_sigma, m_n1, v_k0, v_m, m_s)
    }
    til_beta <- init
    v_beta <- og_beta(til_beta, v_dim[1], v_dim[2])
    v_grad <- 0

    #Calculate v_res (most time consuming)
    v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta, h)
    #Using the Gaussian kernel for h_\tau
    v_pres <- pnorm(v_res)
    m_htau <- f_smoothhtau(m_ndesign, v_pres, s_ntau)

    ##Loss
    s_loss <- f_smoothcrit(v_res, v_pres, v_h0sig, til_beta, v_beta,
                            s_ntau, h, s_n, m_s)

    ##trace
    if (!is.null(trace)) {
        v_taus <- trace
        con_quan <- list(x = v_x, y = v_y, center = s_center, sd = s_sd,
                    v_k0 = v_k0, v_m = v_m, m_sigma = m_sigma, n1 = m_n1,
                    til_beta = til_beta)
        sub <- paste("Iter:", iter, ", Error=", round(s_loss, 3))
        main <- paste("alpha=", alpha, "beta=", bet,
                "Smoothing:", v_smooth[1:2], "dim:", v_dim)
        cq_plot(trace, con_quan, sub = sub, main = main)
    }

    #Repeat
    while (maxit > iter) {
        iter <- iter + 1
        #Calculate gradient
        v_deriv <- f_smoothderiv(til_beta, v_dim, m_sigma, m_htau, m_h1)
        v_grad <- f_smoothgrad(v_beta, v_deriv / s_n, m_s)
        grad_size <-  sum(v_grad ^ 2)
        #backtracking line search
        t <- 1
        repeat{
            new_beta <- v_beta - t * v_grad
            new_tilbeta <- tilde_beta(new_beta, v_dim[2])
            new_loss <- f_smoothcrit(v_res, v_pres, v_h0sig,
                                new_tilbeta, new_beta,
                                s_ntau, h, s_n, m_s)
            t <- bet * t
            if (new_loss <= (s_loss - alpha * t * grad_size) || t < 1e-4) {
                break
            }
        }

        #Update v_beta
        v_beta <- new_beta
        til_beta <- new_tilbeta

        #Calculate v_res (most time consuming)
        v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta, h)
        #Using the Gaussian kernel for h_\tau
        v_pres <- pnorm(v_res)
        m_htau <- f_smoothhtau(m_ndesign, v_pres, s_ntau)

        ##trace
        if (!is.null(trace)) {
            con_quan$til_beta <- til_beta
            sub <- paste("Iter:", iter, ", Error=", round(new_loss, 3))
            cq_plot(trace, con_quan, sub = sub, main = main)
        }

        #Check stop criterion
        if (is.null(eta)) {
            converge <- (abs(new_loss - s_loss) <= eps * abs(s_loss))
        } else {
            converge <- (sqrt(grad_size) / norm_2(v_beta) <= eta)
        }

        s_loss <- new_loss
        #If gradient size criteria
        if (is.na(converge)) {
            converge <- F
            break
        }
        if (converge) break

    }

#-------------------------------------------------------
##### Output #####
#-------------------------------------------------------
    out <- list(
        beta = v_beta,
        til_beta = til_beta,
        gradient = v_grad,
        converge = converge,
        grad_size = sum(v_grad ^ 2),
        iter = iter,
        loss = s_loss,
        x = v_x,
        y = v_y,
        center = s_center,
        sd = s_sd,
        v_k0 = v_k0,
        v_m = v_m,
        n1 = m_n1,
        m_sigma = m_sigma,
        mat_s = m_s,
        alpha = alpha,
        bet = bet,
        call = function_call)

    return(out)
}


out_file = 'P0_1_inner_distance'
pdf('P0_1_inner_distance.inner_distance_plot.pdf')
fragsize=rep(c(-247.5,-242.5,-237.5,-232.5,-227.5,-222.5,-217.5,-212.5,-207.5,-202.5,-197.5,-192.5,-187.5,-182.5,-177.5,-172.5,-167.5,-162.5,-157.5,-152.5,-147.5,-142.5,-137.5,-132.5,-127.5,-122.5,-117.5,-112.5,-107.5,-102.5,-97.5,-92.5,-87.5,-82.5,-77.5,-72.5,-67.5,-62.5,-57.5,-52.5,-47.5,-42.5,-37.5,-32.5,-27.5,-22.5,-17.5,-12.5,-7.5,-2.5,2.5,7.5,12.5,17.5,22.5,27.5,32.5,37.5,42.5,47.5,52.5,57.5,62.5,67.5,72.5,77.5,82.5,87.5,92.5,97.5,102.5,107.5,112.5,117.5,122.5,127.5,132.5,137.5,142.5,147.5,152.5,157.5,162.5,167.5,172.5,177.5,182.5,187.5,192.5,197.5,202.5,207.5,212.5,217.5,222.5,227.5,232.5,237.5,242.5,247.5),times=c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,49,631,549,590,635,692,778,1071,1614,2465,3806,5816,8908,13172,18969,24197,30844,36163,40376,44034,48169,48409,49763,49067,48145,45688,43583,40757,37829,34103,30658,28172,24919,22333,20079,17237,15273,13537,11985,10332,9010,7835,6913,5920,5326,4521,3905,3490,2885,2652,2307,2049,1916,1683,1583,1441,1345,1232,1141))
frag_sd = sd(fragsize)
frag_mean = mean(fragsize)
frag_median = median(fragsize)
write(x=c("Name","Mean","Median","sd"), sep="	", file=stdout(),ncolumns=4)
write(c(out_file,frag_mean,frag_median,frag_sd),sep="	", file=stdout(),ncolumns=4)
hist(fragsize,probability=T,breaks=100,xlab="mRNA Insert Size (bp)",main=paste(c("Density Analysis Insert Size Between Two Paired RNA Reads \n","Mean=",frag_mean,";","SD=",frag_sd),collapse=""),border="blue", cex.lab=1.5, cex.axis=1.5, cex.main=1, cex.sub=1.5)
lines(density(fragsize,bw=10),col='red')
dev.off()


#' Calculate pooled dispersion via MMAD distribution or median
#'
#' \code{distE.mmad} calculates the maximum absolute difference within
#' two groups and returns the dispersion vector as a result.
#' @param x A vector of numbers for the first distribution
#' @param y A vector of numbers for the second distribution
#' @param mid Toggles whether to give the distribution or the median
#' @export distE.mmad
#' @import Rfast

# returns a vector of differences between groups
# recycles if x,y are different sizes
distE.mmad <- function(x,y, mid=FALSE){
  if(length(x) < 9 || length(y) < 9){ base::warning('x or y contain less than 10 values')}
  if(is.numeric(x) & is.numeric(y)){
  if(mid == FALSE){
      return( pmax(abs(x - sample(x)), abs(y - sample(y))) )
  } else {
      return( Rfast::med(pmax(abs(x - sample(x)), abs(y - sample(y))) ) )
  }
  } else {
    stop('x and y must be numeric vectors')
  }
}


 ZPBCON Example Program Results

 Estimate of condition number =  1.32E+02


# An introduction to R programming
# NDSU Analysis of Ecosystems
# Devan Allen McGranahan (devan.mcgranahan@ndsu.edu)

# Lesson 2: Introduction to R, continued
# More functions for managing data + basic plotting with plot()

##
## S T A R T  H E R E

# Install and load packages used in this session

install.packages("pacman")
library(pacman)

# You will need the mtcars2 file we made last time.
# Hopefully you saved it; use these lines to load it.
# (If you didn't save it, go back to script file
# "1-1_intro-R_basic-functions.r" and re-do it.)

# Set working directory:
setwd("E:/R/")

# Load file:
load("./data/mtcars2.Rdata")
# or
load(file.choose())

# Calculate descriptive statistics

# function aggregate() uses standard R formula format (y ~ x, data)
# to define relationships between variables one wants to calculate.
# This function is analogous to making a PivotTable in Excel.

aggregate(hp ~ cyl, data=mtcars, FUN=mean)
options(digits=3) # Set sig. figs. for session
aggregate(hp ~ origin + cyl, data=mtcars2, FUN=mean)
aggregate(cbind(mpg, hp) ~ origin + cyl, data=mtcars2, FUN=mean)

# function ddply in the plyr package is another option.
# it is preferred because it is vectorized but note:
# plyr functions use the tidyverse grammar:

pacman::p_load(plyr)

ddply(mtcars2, .(origin, cyl), summarize, mean=mean(hp))

# ddply also has an advantage because it can do more at once:

# Mean and SD takes three steps with aggregate()...
(agg.example <- aggregate(hp ~ cyl + origin, data=mtcars2, FUN=mean) )
colnames(agg.example)[3] <- "hp.mean"
agg.example[,"hp.sd"] <- aggregate(hp ~ cyl + origin, data=mtcars2, FUN=sd)$hp
agg.example

# ... but ddply can combine the two:
ddply(mtcars2, .(cyl, origin), summarize, hp.mean=mean(hp), hp.sd=sd(hp))

# In some contexts the dplyr route is preferable:

pacman::p_load(dplyr)

mtcars2 %>%
  group_by(origin, cyl) %>%
  summarise(hp.mean = mean(hp),
            hp.sd = sd(hp))

Analysis of Ecosystems/02 - Rstudio + plotting/2-1_summary_stats.r


library(eurostat)
library(dplyr)
library(eurostat)

prebivalci <- get_eurostat('demo_pjan', time_format = "num", type = "label")
prebivalci <- subset(prebivalci, time > 2006)
prebivalci <- subset(prebivalci, sex == 'Total')
prebivalci <- subset(prebivalci, age == 'Total')
prebivalci <- prebivalci[,-c(1,2,3)]
names(prebivalci) <- (c("DRZAVA", "LETO", "STEVILO PREBIVALCEV"))

bdp <- get_eurostat("nama_10_gdp", time_format = "num", type = "label")
bdp <- subset(bdp, time > 2006)
bdp <- subset(bdp, na_item == "Gross domestic product at market prices")
bdp <- subset(bdp, unit == "Current prices, million euro")
bdp$geo <- gsub("Euro.*", "", bdp$geo)
bdp <- subset(bdp, geo != "")
bdp <- bdp[-c(1, 2)]
names(bdp) <- (c("DRZAVA", "LETO", "GDP V MILIJONIH EVROV"))

tabela2 <- inner_join(prebivalci, bdp)
tabela2$"GDP NA PREBIVALCA V EVRIH" <- tabela2$"GDP V MILIJONIH EVROV" /
tabela2$"STEVILO PREBIVALCEV" * 1000000

tabela2$DRZAVA <- replace(tabela2$DRZAVA, tabela2$DRZAVA=="Germany (until 1990 former territory of the FRG)", "Germany")

DRZAVA <- c(unique(tabela2$DRZAVA))
c2 <- c("Albanija", "Avstrija", "Belgija", "Bolgarija", "Švica", "Ciper",
        "Češka", "Nemčija", "Danska", "Estonija", "Grčija", "Španija",
        "Finska", "Francija", "Hrvaška", "Madžarska", "Irska", "Islandija",
        "Italija", "Litva", "Luksemburg", "Latvija", "Črna Gora", "Makedonija",
        "Malta", "Nizozemska", "Norveška", "Poljska", "Portugalska", "Romunija",
        "Srbija", "Švedska", "Slovenija", "Slovaška", "Turčija", "Velika Britanija",
        "Kosovo", "Lihtenštajn", "Bosna in Herzegovina")
c3 <- data.frame(DRZAVA,c2)
tabela2 <- left_join(tabela2, c3)
tabela2 <- tabela2[-c(1)]
tabela2 <- tabela2[c(5,1,2,3,4)]
names(tabela2)[1] <- "DRZAVA"
drugatabela <- tabela2


state_prediction <- function(obs,delta,gamma,lls,param_lls,h)
  {
  m <- ncol(gamma)
  n <- length(obs)

  p <- function(state, x){
    lls[[state]](x, param_lls[[state]])
  }
  p <- Vectorize(p)

  p_mat <- outer(1:m, obs, p)
  log_p_mat <- log(p_mat)

  log_delta <- log(delta)
  log_gamma <- log(gamma)
  log_alpha <- forward_logprobabilities(obs, gamma, p, delta)

  log_theta <- rep(NA, m)
  k <- max(log_alpha[, n])
  denominator <- k + log(sum(exp(log_alpha[, n] - k)))
  log_theta <- log_alpha[, n] - denominator

  log_gamma_power <- matrix(0, nrow = m, ncol = m)
  for(i in 1:h){
    log_gamma_power <- log_gamma + log_gamma_power
  }

  log_prob <- rep(NA, m)
  for(i in 1:m){
    temp <- log_gamma_power[,i] + log_theta
    k <- max(temp)
    log_prob[i] <- k + log(sum(exp(temp - k)))
  }

  exp(log_prob)
}


scenario <- "B"
source(paste("data_logistic_regression_scenario_", scenario, ".r", sep = ""))
summary(glm(y_0 ~  X_0, family = "binomial"))

###
J <- 20

load(paste("../../data/sensitivity_data/RegressionLogistic_logCA0_J=", J, "_scenario_", scenario, ".RData", sep = ""))

constant.data <- adaptive.ca0.estimates$result
maxA <- max(constant.data$a0)

#######
midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = constant.data)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J + 1), data = constant.data)

K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

gam.preds.list <- list(
  gam =  data.frame (a0 = pred_a0s, lca0 = preds.gam$mean, lwr = preds.gam$lwr,
                     upr = preds.gam$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, lwr = NA, upr = NA,
                           approximating_function = "gam-derivative", design = "adaptive_numerical")
)

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0,
          file = paste("../../data/constant_data/fitted_predictions_lca0_RegressionLogistic_J=", J, "_scenario_", scenario, ".csv", sep = ""),  row.names = FALSE)

###

library(ggplot2)

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = constant.data, mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p0

ggsave(p0,
       filename = paste("../figures/estimates_log_ca0_RegressionLogistic_J=", J, "_scenario_", scenario, ".pdf", sep = ""), dpi = 300)
####
## Sensitivity analysis
sens.analysis.dt <- do.call(rbind, lapply(1:length(adaptive.ca0.estimates$summaries), function(i) {
  y <- data.frame(adaptive.ca0.estimates$summaries[[i]])
  y$a_0 <- adaptive.ca0.estimates$result$a0[i]
  return(y)
})
)
sens.analysis.dt$parameter <- gsub("alpha\\[1\\]", "alpha", sens.analysis.dt$parameter)

p1 <- ggplot(data = sens.analysis.dt, aes(x = a_0, y = mean, fill = parameter, colour = parameter)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0), limit = c(0, 1)) +
  scale_y_continuous("", expand = c(0, 0)) +
  facet_grid(parameter~., labeller = label_parsed)+
  theme_bw(base_size = 20) +
  theme(legend.position = "none")
p1

ggsave(p1,
       filename = paste("../../figures/sensitivity_a0_RegressionLogistic_J=", J, "_scenario_", scenario, ".pdf", sep = ""), dpi = 300)


library(Boruta)
require(xgboost)
require(methods)
library(ggplot2)
library(readr)
library(Rtsne)

print("Preparing Data")

train <- read.csv('../Input/train.csv',header=TRUE,stringsAsFactors = F)
test <- read.csv('../Input/test.csv',header=TRUE,stringsAsFactors = F)

train$ID <- NULL

train = train[,-1]
test = test[,-1]

#shuffle
train <- train[sample(nrow(train)),]

y = train[,ncol(train)]
y = gsub('Class_','',y)
y = as.integer(y)-1 #xgboost take features in [0,numOfClass)

x = rbind(train[,-ncol(train)],test)
x = as.matrix(x)
x = matrix(as.numeric(x),nrow(x),ncol(x))
x = log(1 + x)
x = scale(x)
trind = 1:length(y)
teind = (nrow(train)+1):nrow(x)

print("Running Cross Validation")

# Set necessary parameter
#param <- list("objective" = "multi:softprob",
#              "eval_metric" = "mlogloss",
#              "num_class" = 9,
#              "gamma" = 1,
#              "nthread" = 6,
#              "eta" = .4,
#              "max_depth" = 25,
#              "min_child_weight" = 3,
#              "subsample" = .5,
#              "colsample_bytree" = .9,
#              "max_delta_step" = 3)
param <- list("objective" = "multi:softprob",
              "eval_metric" = "mlogloss",
              "num_class" = 9,
              "nthread" = 16,
              "bst:eta" = .3,
              "bst:max_depth" = 30,
              "lambda" = 1,
              "lambda_bias" = 0,
              "gamma" = 1,
              "alpha" = .8,
              "min_child_weight" = 4,
              "subsample" = .9,
              "colsample_bytree" = .9)

cv.nround = 91
bst.cv = xgb.cv(param=param, data = x[trind,], label = y, nfold = 5, nrounds=cv.nround)

print("Training the model")
# Train the model
nround = 91
bst = xgboost(param=param, data = x[trind,], label = y, nrounds=nround, verbose = 2)

# Get the feature real names
#names <- dimnames(myData[1:n.train, ])[[2]]

# Compute feature importance matrix
#importance_matrix <- xgb.importance(names, model = bst)

# Nice graph
#xgb.plot.importance(importance_matrix)
#print("Plotting feature tree")
#xgb.plot.tree(feature_names = names, model = bst)

print("Making prediction")
# Make prediction
pred = predict(bst,x[teind,])
pred = matrix(pred,9,length(pred)/9)
pred = t(pred)

print("Storing Output")
# Output submission
pred = format(pred, digits=2,scientific=F) # shrink the size of submission
pred = data.frame(1:nrow(pred),pred)
names(pred) = c('id', paste0('Class_',1:9))
write.csv(pred,file='../Output/otto-classifier.csv', quote=FALSE,row.names=FALSE)


pdf_file<-"pdf/maps_minard_napoleon_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=7.26)

par(omi=c(1,0.1,0.75,0.1),mai=c(0.25,0,3,0),lend=1,family="Felipa",las=1)
library(HistData); library(mapdata)

# Import data

#load("data/Minard.troops_de"); data(Minard.cities)
data(Minard.troops); data(Minard.cities)
towards_all<-subset(Minard.troops,direction=="A")
backwards_all<-subset(Minard.troops,direction=="R")

# Define chart and other elements

plot(Minard.troops$long,Minard.troops$lat,type="n",axes=F,xlab="",ylab="")
for (i in 1:3)
{
towards<-towards_all[towards_all$group==i,]
n<-nrow(towards)-1
for (j in 1:n)
{
z<-j+1
x<-towards[j:z,]
x
lines(x$long,x$lat,type="l",col="bisque2",lwd=x$survivors[1]/4500)
}
backwards<-backwards_all[backwards_all$group==i,]
n<-nrow(backwards)-1
for (j in 1:n)
{
backwards<-backwards_all[backwards_all$group==i,]
z<-j+1
x<-backwards[j:z,]
x
lines(x$long,x$lat,type="l",col="azure4",lwd=x$survivors[1]/4500)
}
}
attach(Minard.cities)
text(long,lat,city)
rivers<-map("rivers",plot=F,add=T)
points(rivers$x,rivers$y,col=rgb(0,0,255,120,maxColorValue=255),type="l")
par(xpd=T)
legend(32.5,54.15,c("300,000","200,000","100,000"),border=F,pch="|",col=c("bisque2","bisque2","bisque2"),bty="n",cex=1.3,pt.cex=c(3,2,1),xpd=NA,ncol=3)
legend(32.5,53.6,c("Campaign","Retreat"),border=F,pch=19,pt.cex=4,col=c("bisque2","azure4"),bty="n",cex=1.3,xpd=NA,ncol=3)
text(37.4,53.93,"Survivors",cex=1.1,xpd=T)
par(family="Dr Sugiyama")

# Titling

mtext("Carte figurative ",line=-0.5,adj=0.12,cex=3,col="azure4",outer=T)
mtext("des pertes ",line=-0.5,adj=0.80,cex=1.5,col="azure4",outer=T)
par(family="Lato Light")
mtext(side=1,adj=0,line=3,"Source: www.insee.fr/fr/ffc/docs_ffc/CS126L.PDF (Text); R library histdata (Data)",outer=T)
dev.off()


#' @title regkrige
#'
#' @description Regression kriging using a standardized variogram.
#'
#' @param check_data Locigal. Shall attributes, geometries and projections of
#' the input data (arguments x, y and z) be checked. Default = TRUE.
#'
#' @inheritParams mri
#'
#' @return A list with 1) a raster layer with predicted values and 2) a
#' SpatialPolygonsDataFrame with cross-validation data. For details, see
#' mri function.
#'
#' @details This is the regression kriging function called by the mri function.
#' For details, see documentation of the mri function.
#'
#' @export
regkrige<-function(x=NULL, y=NULL, z=NULL, field = NULL, edge = 0, filter = 1, resolution = NULL,
                    md = 'Sph', rg = NULL, ng = 0.1, check_data=T){
  #check input data
  if(check_data){
    a<-check(x=x, y=y, z=z, field=field, edge = edge, filter=filter, resolution=resolution)
    x<-a[[1]]; y<-a[[2]]; z<-a[[3]]; feedback<-a[[4]]
  }

  ##parameterize and apply linear regression model
  reg<-lm(obs~map, data= z)
  z$regpred<-predict(object=reg, newdata=z)

  ##compute residuals
  z$regres<-z$regpred-z$obs

  #compute range (argument rg) if not specified by user
  if(is.null(rg)) rg<-0.5*sqrt(area(y))

  ##parameterize standardized semivariogram model
  sill<-var(z$regres, na.rm=T)
  mod<- vgm(psill = (1-ng)*sill, model= md, range = rg,nugget= ng*sill)

  #cross validate
  for (i in 1:nrow(z)){
    regrespred<-krige(regres~1, locations=z[-i,], newdata=z[i,], model = mod, debug.level=0)
    z[i,'regkrig_cv']<-z@data[i,'regpred']-regrespred@data['var1.pred']
  }

  #ordinary kriging to raster
  crs(x)<-crs(z) #to fix a bug
  gsmod<-gstat(formula=regres~1, locations=z, model=mod)
  regkrig<-predict(x, reg)-interpolate(x, gsmod,  fun=predict, debug.level=0)

  #return objects
  return(list(regkrig, z))
}


unconditionalModels <- function(dependent.df, independent.list, timelevels, events) {

  require(dplyr)
  require(plm)
  require(lmtest)
  require(broom)
  # Table to store results:
  coefs.df <- tibble()
  resid.df <- tibble()
  vcov.list <- vector(mode = 'list', length = length(events))
  names(vcov.list) <- events

  for (event in events) {

    #### Create a model dataframe ####
    independent.list[[event]] %>%
      mutate_if(is.numeric, list(~replace_na(., 0))) -> X.df

    # Join and scale the dependent variable
    dependent.df %>%
      inner_join(X.df, by = c('xwaveid', 'wave')) %>%
      group_by(xwaveid) %>%
      mutate(Y = scale(Y)) %>% # scaling produces NaN when no variation
      ungroup() %>%            # so replace NaN with NA
      mutate(Y = ifelse(is.nan(Y), NA, Y)) -> vars.df

    vars.df %>%
      select(-wave, everything(), -xwaveid, -Y) %>%
      colnames() -> varnames

    #vars.df<-vars.df[sapply(vars.df, is.infinite)] <- NA
    #vars.df<-vars.df[sample(nrow(vars.df), 1500), ]
    formula1 <- as.formula(paste('Y ~', paste(varnames[-1], collapse =' + ')))
    # Get the Fixed Effect estimates
    fe <- plm(formula1, vars.df, index = c('xwaveid'), method = 'within')

    coefs.tb <- tidy(coeftest(fe, vcov. = vcovHC(fe, type = 'HC1')))

    # Add details to coefficient table
    n.tb <- tibble (n = colSums(vars.df[, 5:13]))
    n.tb$term <- colnames(vars.df[, 5:13])

    coefs.tb$df <- fe$df.residual
    coefs.tb %>%
      filter(term %in% timelevels) %>%
      left_join(n.tb, by = c("term")) %>%
      mutate(df = fe$df.residual,
             N = pdim(fe)$nT$n,
             #r2 = summary(fe)$r.squared[1],
             code = event) %>%
      bind_rows(coefs.df) -> coefs.df

    # Get the residuals
    .df <- na.omit(vars.df) # to match the dimensions
    .df$resid <- resid(fe)
    .df$pred <- predict(fe)
    .df %>%
      mutate(code = event) %>%
      select(xwaveid, wave, code, pred, resid) %>%
      bind_rows(resid.df) -> resid.df

    # Get the variance-covariance matrix
    # vcov.mat <- vcovHC(fe, type = "HC1")[1:9, 1:9]
    vcov.mat <- vcovHC(fe, type = "sss")[1:9, 1:9]
    vcov.list[[event]] <- vcov.mat

  }

  return(list(coefs = coefs.df, resids = resid.df, covar = vcov.list))

}


rubik <- function(moves) {

    cube <- list('U'=matrix('y', 3, 3),
        'D'=matrix('w', 3, 3),
        'F'=matrix('r', 3, 3),
        'R'=matrix('g', 3, 3),
        'B'=matrix('o', 3, 3),
        'L'=matrix('b', 3, 3)
    );

    moves <- unlist(strsplit(moves, '\\s'));
    for (i in 1:length(moves)) {
        cube <- rotatecube(cube, substr(moves[i],1,1));

        if (substr(moves[i],2,2) == '2') {
            cube <- rotatecube(cube, substr(moves[i],1,1));
        } else if (substr(moves[i],2,2) == '\'') {
            cube <- rotatecube(cube, substr(moves[i],1,1));
            cube <- rotatecube(cube, substr(moves[i],1,1));
        }
    }

    write.table(cube[['F']],row.names=F,col.names=F,sep="",quote=FALSE)
}

rotatecube <- function(cube, move) {
    cube[[move]] <- rot90(cube[[move]]);
    if (move == 'U') {
        tmp <- cube[['F']];
        cube[['F']][1,] <- cube[['R']][1,];
        cube[['R']][1,] <- cube[['B']][1,];
        cube[['B']][1,] <- cube[['L']][1,];
        cube[['L']][1,] <- tmp[1,];
    } else if (move == 'D') {
        tmp <- cube[['L']]
        cube[['L']][3,] <- cube[['B']][3,];
        cube[['B']][3,] <- cube[['R']][3,];
        cube[['R']][3,] <- cube[['F']][3,];
        cube[['F']][3,] <- tmp[3,];
    } else if (move == 'F') {
        tmp <- cube[['D']]
        cube[['D']][1,] <- rev(cube[['R']][,1]);
        cube[['R']][,1] <- cube[['U']][3,];
        cube[['U']][3,] <- rev(cube[['L']][,3]);
        cube[['L']][,3] <- tmp[1,];
    } else if (move == 'B') {
        tmp <- cube[['L']]
        cube[['L']][,1] <- rev(cube[['U']][1,]);
        cube[['U']][1,] <- cube[['R']][,3];
        cube[['R']][,3] <- rev(cube[['D']][3,]);
        cube[['D']][3,] <- tmp[,1];
    } else if (move == 'R') {
        tmp <- cube[['D']]
        cube[['D']][,3] <- rev(cube[['B']][,1]);
        cube[['B']][,1] <- rev(cube[['U']][,3]);
        cube[['U']][,3] <- cube[['F']][,3];
        cube[['F']][,3] <- tmp[,3];
    } else if (move == 'L') {
        tmp <- cube[['D']]
        cube[['D']][,1] <- cube[['F']][,1];
        cube[['F']][,1] <- cube[['U']][,1];
        cube[['U']][,1] <- rev(cube[['B']][,3]);
        cube[['B']][,3] <- rev(tmp[,1]);
    }

    return (cube);
}

rot90 <- function(mat) {
    t(mat[nrow(mat):1,,drop=FALSE])
}


# all rgl demos
demo(hist3d)
demo(abundance)
demo(regression)
demo(lsystem)
demo(subdivision)
# requires MASS library
demo(bivar)


model_deterministic_simulateR <- function(init_obs, period_start, times, pars, fix_pars){
  ode_solveR <- function(stage_pars, fix_pars, old_values) {
    ## stage pars
    b = stage_pars[1]
    r = stage_pars[2]
    ## fixed pars
    alpha_p = fix_pars[1]
    alpha_u = fix_pars[2]
    beta_1 = fix_pars[3]
    beta_2 = fix_pars[4]
    delta_1 = fix_pars[5]
    delta_2 = fix_pars[6]
    lambda = fix_pars[7]
    mu = fix_pars[8]
    mu_c = fix_pars[9]
    De = fix_pars[10]
    Dr = fix_pars[11]
    f = fix_pars[12]
    N = fix_pars[13]
    ## old values
    S = old_values[1]
    E = old_values[2]
    U = old_values[3]
    P = old_values[4]
    F = old_values[5]
    RU = old_values[6]
    RR = old_values[7]
    DU = old_values[8]
    DR = old_values[9]
    ## new values

    S_new = S - b * S * (alpha_p * P + alpha_u * U + F) / N + lambda * N - mu * S
    E_new = E + b * S * (alpha_p * P + alpha_u * U + F) / N - E / De - mu * E
    U_new = U + (1 - r) * E / De - U / (beta_1 * Dr) - delta_1 * mu_c * U - mu * U
    P_new = P + r * (1 - f) * E / De - P / Dr - mu_c * P - mu * P
    F_new = F + r * f * E / De - F * beta_2 / Dr - mu_c * F / delta_2 - mu * F
    RU_new <- RU + U / (beta_1 * Dr) + F * beta_2 / Dr - mu * RU
    RR_new <- RR + P / Dr - mu * RR
    DU_new <- DU + delta_1 * mu_c * U + mu_c * F / delta_2
    DR_new <- DR + mu_c * P
    est_P_new_n <- E
    est_P_new_prob <- r * (1 - f) / De
    est_RD_new_n <- P
    est_RD_new_prob_R <- 1 / Dr
    est_RD_new_prob_D <- mu_c

    return(c(S_new, E_new, U_new, P_new, F_new, RU_new, RR_new, DU_new, DR_new,
             est_P_new_n, est_P_new_prob,
             est_RD_new_n, est_RD_new_prob_R, est_RD_new_prob_D))
  }
  n_period = length(period_start)
  ymat = matrix(0, length(times), length(init_obs) + 6)
  ymat[, 1] = times

  colnames(ymat) <- c("time", names(init_obs), "est_p_n", "est_p_prob", "est_RD_n", "est_RD_prob_R", "est_RD_prob_D")

  which.period <- function(i, phase = period_start){ # function to determine which period i falls in
    sum(i >= phase)
  }

  for(i in 1:length(times)){
    stage_pars <- c(b = pars[which.period(i)], r = pars[n_period + which.period(i)])
    if(i == 1) {
      old_values <- init_obs
    } else {
      old_values <- ymat[i - 1, 2:10]
    }
    ymat[i, 2:15] <- ode_solveR(stage_pars = stage_pars, fix_pars = fix_pars, old_values = old_values)
  }

  return(ymat)
}


solution <- function(n){
    below <- abs(n-1)
    common <- below %/% 15
    c(below %/% 3 - common, below %/%5 - common, common)
}


#Matrix using vectors

M = matrix(c(1:16), nrow = 4, byrow = TRUE)
print("Original Matrix:")
print(M)


write(round(pnorm(19.5, 20, 2), 3), stdout())
write(round(pnorm(22, 20, 2) - pnorm(20, 20, 2), 3), stdout())


#' degtorad
#'
#' Conversion angles from decimal degrees to radians.
#'
#' @param angledeg numeric Angle in decimal degrees.
#' @return Angle in radians
#'
#'
#' @author  Istituto per la Bioeconomia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibe.cnr.it}
#' @keywords  degtorad
#'
#' @export
#'
#'
#'
#'

degtorad=function(angledeg) {
                         ct$assign("angledeg", as.array(angledeg))
                         ct$eval("var res=[]; for(var i=0, len=angledeg.length; i < len; i++){ res[i]=degToRad(angledeg[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#' radtodeg
#'
#' Conversion angles from radians of an angle in decimal degrees
#'
#' @param anglerad  numeric  Angle in radiands.
#' @return angledeg in degrees
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  radtodeg
#'
#' @export
#'
#'
#'
#'

radtodeg=function(anglerad) {
                         ct$assign("anglerad", as.array(anglerad))
                         ct$eval("var res=[]; for(var i=0, len=anglerad.length; i < len; i++){ res[i]=radToDeg(angleRad[i])};")
                         res=ct$get("res")
                         return(ifelse(!is.numeric(res),NA,res))
}


mydata <- read.csv('evals.csv')

a <- -11

# simple if
if(a > 0){
  print('positive')
}else if(a == 0){
  print('null')
}else{
  print('not positive')
}

# smart ifelse
ifelse(a > 0, 'positive','not positive')
#and vector too
a <- c(-1,1)
ifelse(a > 0, 'positive','not positive')

# simple for
for(i in 1:100){
  print(i)
}

for(i in 1:nrow(mydata)){
  print(mydata$score[i])
}

# for+if
for(i in 1:nrow(mydata)){
  if(mydata$gender[i] == 'male'){
    print(mydata$score[i])
  }
}

# for+if VS ifelse

mydata$quality <- rep(NA, nrow(mydata))

for(i in 1:nrow(mydata)){
  if(mydata$score[i] > 4){
    mydata$quality[i] <- 'good'
  }else mydata$quality[i] <- 'bad'
}

mydata$quality <- ifelse(mydata$score >4, 'good', 'bad')

# simple while
i <- 1
while(i < 51){
  print(mydata$score[i])
  i <- i+1
}

# №1

df <- mtcars

df$new_var <- ifelse(df$carb >= 4 | df$cyl > 6, 1,0)
print(df$new_var)

if(mean(my_vector) > 20){
  print('My mean is great')
}else{
  print('My mean is not so great')
}

# №2

ap <- AirPassengers
ap[144]
str(ap)

ap <- AirPassengers
ap[1]
lag(ap, -1)
ap[1]

now <- 0

ap <- AirPassengers

for(i in 2:144){
  #print(i)
  if(ap[i-1] < ap[i]){
    print(ap[i])
    #print(i)
  }
}

# №3

mean(ap[1]:ap[10])

ap <- AirPassengers
i <- 1
while(i+10 <= 145){
  print(mean(ap[i:(i+9)]))
  i=i+1;
}

print(mean(ap[i:(i+9)]))


# =============
# === Setup ===
# =============

# install packages from github
library(devtools)
#install_github("azure/razurebatch")
#install_github("azure/doazureparallel")

# import packages
library(doAzureParallel)

# set azure credentials
setCredentials("credentials.json")

# generate cluster config json file
# generateClusterConfig("cluster-caret.json")

# Creating an Azure parallel backend
cluster <- makeCluster(cluster = "cluster-caret.json")

# Register your Azure parallel backend to the foreach implementation
registerDoAzureParallel(cluster)

# ===================================================
# === Random Search w/ Cross Validation using Caret ===
# ===================================================

# For more details about using caret:
# https://topepo.github.io/caret/index.html
library(caret)

# Set your chunk size of your tasks to 8
# So that caret knows in group tasks into larger chunks
setChunkSize(8)

# install DAAG to download the dataset 'spam7'
#install.packages("DAAG")
library(DAAG)

# 'spam7' is a data set that consists of 4601 email items,
# of which 1813 items were identified as spam. This sample
# has 7 features, one of which is titled 'yesno'. In this
# example, we will be classifying our data into 'yesno' to
# identify which rows are spam, and which are not.

# split the data into training and testing
set.seed(998)
inTraining <- createDataPartition(spam7$yesno, p = .75, list = FALSE)
training <- spam7[ inTraining,]
testing  <- spam7[-inTraining,]

# Define the settings for the cv. Because we have already
# registered our parallel backend, Caret will know to use it
fitControl <- trainControl(## 10-fold cross validation
  method = "repeatedcv",
  number = 10,
  ## repeat 10 times
  repeats = 10,
  classProbs = TRUE,
  summaryFunction = twoClassSummary,
  search = "random",
  ## run on the parallel backend
  allowParallel = TRUE)

rf_fit <- train(## classification column
  yesno ~ .,
  ## dataframe to train on
  data = training,
  ## model to use - other models are also available (see caret documentation)
  method = "rf",
  ## the metric to use for evaluation
  metric = "ROC",
  ## # of random searches
  tuneLength = 30,
  ## tuning params
  trControl = fitControl)

# print results
rf_fit

# print best tuning parameters
rf_fit$bestTune

# de-provision your cluster in Azure
#stopCluster(cluster)


#   Copyright (C) 2019  Dr. Norbert Bátfai, nbatfai@gmail.com
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>

library(matlab)

stp <- function(x){

    primes = primes(x)
    diff = primes[2:length(primes)]-primes[1:length(primes)-1]
    idx = which(diff==2)
    t1primes = primes[idx]
    t2primes = primes[idx]+2
    rt1plust2 = 1/t1primes+1/t2primes
    return(sum(rt1plust2))
}

x=seq(13, 1000000, by=10000)
y=sapply(x, FUN = stp)
plot(x,y,type="b")


#' @title Fitting bivariate MGL copula models for two continuous data
#' @description \code{MGL.mle} is used to fit bivariate copula regression models via maximum likelihood (ML) method for two continuous variables.
#' @param U two-dimensional matrix with values in \eqn{[0,1]}.
#' @param copula copula 'MGL', 'MGL180', "MGL-EV", "MGL-EV180", "MGB2", "Normal" , "t".
#' @param hessian Logical. Should a numerically differentiated Hessian matrix be returned?
#' @param initpar Initial values for the parameters to be optimized over.
#' @param ... additional arguments, see \code{\link[stats]{nlm}} for more details.
#' @importFrom stats nlm
#' @md
#' @details
#' The estimation method is performed via \code{\link[stats]{nlm}} function.
#'
#' copula:
#' * "MGB2" is multivariate GB2.
#' * "Normal" and "t" denote the Gaussian copula and Student-t copula respectively.
#' * "MGL" and "MGL-EV" denote the MGL and MGL-EV copula respectively.
#' * "MGL180" and "MGL-EV180" denote the survival MGL and survival MGL-EV copula respectively.
#' * "Gumbel" is Gumbel copula.
#'
#' @return A list containing the following components:
#' * loglike: the value of the estimated maximum of the loglikelihood function.
#' * copula: the name of the fitted copula. "MGL180" and "MGL-EV180" denote the survival MGL and MGL-EV copula respectively.
#' * estimates: the point at which the maximum value of the loglikelihood is obtained.
#' * se: the standard errors of the estimators.
#' * AIC, BIC: the goodness fit of the regression models.
#' * hessian: the hessian at the estimated maximum of the loglikelihood (if requested).
#'
#' @references Zhang, F. Z. . "A generalized beta copula with applications in modeling multivariate long-tailed data." Insurance: Mathematics and Economics (2011).
#'
#' @examples
#'   library(rMGLReg)
#'   Usim <- rcMGL.bivar(n = 500, pars = 0.5)
#'   m.MGL <- MGL.mle(Usim,
#'   copula  = "MGL",
#'   initpar = c(2))
#'   # estimation results
#'   m.MGL
#' @export
#'
MGL.mle <- function(U, copula = c(
                      "MGL", "MGL180", "MGL-EV",
                      "MGL-EV180",
                      "Gumbel",
                      "Normal", "MGB2", "t"
                    ),
                    hessian = TRUE,
                    initpar, ...) {
  dnormcop <- function(U, param) {
    as.numeric(fCopulae::dellipticalCopula(U, rho = param[1], type = "norm"))
  } # normal copula

  dtcop <- function(U, param) {
    as.numeric(fCopulae::dellipticalCopula(U,
      rho = param[1], type = "t",
      param = param[2]
    ))
  } # t copula
  dgumcop <- function(U, param) {
    as.numeric(fCopulae::devCopula(U, type = "gumbel", param = param[1]))
  } # Bivariate Extreme

  dMGL <- function(U, param) {
    as.numeric(dcMGL.bivar(u1 = U[, 1], u2 = U[, 2], pars = param[1]))
  }

  dMGL180 <- function(U, param) {
    as.numeric(dcMGL180.bivar(u1 = U[, 1], u2 = U[, 2], pars = param[1]))
  }

  dMGB2 <- function(U, param) {
    as.numeric(dcMGB2.bivar(u1 = U[, 1], u2 = U[, 2], pars1 = param[1], pars2 = param[2], pars3 = param[3]))
  }

  dMGLEV <- function(U, param) {
    as.numeric(dcMGLEV.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])) # Bivariate Extreme
  }

  dMGLEV180 <- function(U, param) {
    as.numeric(dcMGLEV180.bivar(u1 = U[, 1], u2 = U[, 2], param = param[1])) # Bivariate Extreme
  }

  argnorm <- list(length = 1, lower = 0, upper = 1, name = "Gaussian")
  argt <- list(length = 2, lower = c(0, 0), upper = c(1, 100), name = "Student")
  arggum <- list(length = 1, lower = 1, upper = 50, name = "Gumbel")
  argMGB2 <- list(
    length = 3, lower = c(0, 0, 0), upper = c(50, 50, 50),
    name = "MGB2"
  )
  argMG180 <- list(length = 1, lower = 0, upper = 10, name = "MGL180")
  argMGLEV180 <- list(length = 1, lower = 0, upper = 10, name = "MGL-EV180")
  argMG <- list(length = 1, lower = 0, upper = 10, name = "MGL")
  argMGLEV <- list(length = 1, lower = 0, upper = 10, name = "MGL-EV")
  if (copula == "MGL") {
    dcop <- dMGL
    arg.cop <- argMG
  } else if (copula == "MGL180") {
    dcop <- dMGL180
    arg.cop <- argMG180
  } else if (copula == "MGL-EV") {
    dcop <- dMGLEV
    arg.cop <- argMGLEV
  } else if (copula == "MGL-EV180") {
    dcop <- dMGLEV180
    arg.cop <- argMGLEV180
  } else if (copula == "Gumbel") {
    dcop <- dgumcop
    arg.cop <- arggum
  } else if (copula == "Normal") {
    dcop <- dnormcop
    arg.cop <- argnorm
  } else if (copula == "t") {
    dcop <- dtcop
    arg.cop <- argt
  } else if (copula == "MGB2") {
    dcop <- dMGB2
    arg.cop <- argMGB2
  }

  # loglike.copula <- function(U, initpar, ...){
  copLogL <- function(x) {
    if (all(arg.cop$lower < x && arg.cop$upper > x)) {
      logL <- log(dcop(U, param = x))
      # res <- -sum((logL))
      remove.naninf <- function(z) z[!is.nan(z) & is.finite(z)]
      res <- -sum(remove.naninf(logL))
    } else {
      res <- 10000000000000
    }
    return(res)
  }
  # }

  resopt <- nlm(
    f = copLogL,
    p = initpar,
    hessian = hessian, ...
  )

  # results
  if (hessian == TRUE){
    out <-  list(
      loglike = -resopt$minimum,
      copula = list(name = arg.cop$name),
      estimates = resopt$estimate,
      se = sqrt(diag(solve(resopt$hessian))),
      hessian = -resopt$hessian,
      AIC = 2 * length(resopt$estimate) + 2 * resopt$minimum,
      BIC = log(nrow(U)) * length(resopt$estimate) + 2 * resopt$minimum
    )
  } else {
    out <-   list(
      loglike = -resopt$minimum,
      copula = list(name = arg.cop$name),
      estimates = resopt$estimate,
      AIC = 2 * length(resopt$estimate) + 2 * resopt$minimum,
      BIC = log(nrow(U)) * length(resopt$estimate) + 2 * resopt$minimum
    )
  }
  out
}


#checking phyla level prior fits.
rm(list=ls())
source('paths.r')

#load phyla fit.
d <- readRDS(ted_ITS.prior_phyla_JAGSfit)

fitted <- d$all.preds$predicted
obs <- d$all.preds$observed

#ascomycetes
par(mfrow=c(1,2))
plot(obs[,2] ~ fitted[,2])
mod <- lm(obs[,2] ~ fitted[,2])
rsq <- summary(mod)$r.squared
rsq <- round(rsq,2)
abline(0,1,lwd = 2)
abline(mod, lty =2 , col = 'purple')
mtext(paste0('R2=',rsq),side = 3, line = -2, adj=0.05)
mtext(colnames(obs)[2], side = 3)
#basidiomycetes
plot(obs[,3] ~ fitted[,3])
mod <- lm(obs[,3] ~ fitted[,3])
rsq <- summary(mod)$r.squared
rsq <- round(rsq,2)
abline(0,1,lwd = 2)
abline(mod, lty =2 , col = 'purple')
mtext(paste0('R2=',rsq),side = 3, line = -2, adj=0.05)
mtext(colnames(obs)[3], side = 3)


setwd('/Users/Cam/Desktop/ds_practice/faa-laser-incident-reports')
getwd()
ls()
options(prompt='R> ')
options(continue = '\t')

laser_dat = read.csv('adjusted_laser_data.csv')

head(laser_dat)

?table

laser_dat$day_of_week = factor(laser_dat$day_of_week,c('Monday','Tuesday','Wednesday','Thursday','Friday','Saturday','Sunday'))
day_breakdown = table(laser_dat$day_of_week)
day_breakdown
barplot(day_breakdown,ylim=c(0,3000))

results = chisq.test(day_breakdown)
summary(results)
results
results$observed
results$expected

holiday_breakdown = table(laser_dat$holidays)
holiday_breakdown
barplot(holiday_breakdown)


library(netdiffuseR)
library(netplot)

x <- igraph::graph_from_edgelist(
  matrix(
    c(1,2,2,1,3,4,4,3,4,4), ncol=2, byrow = TRUE
  )
)

layout <- matrix(c(
  1,1,2,2,3,3,4,4
), byrow = TRUE, ncol=2)

vertex.size <- c(.25, .25, .5, .5)
nplot(x, layout = layout, vertex.size = vertex.size, vertex.size.range = c(.1,.3))

nplot(netdiffuseR::diffnet_to_igraph(medInnovationsDiffNet)[[1]])

nplot(igraph::rewire(igraph::barabasi.game(200, m=2, power = .95), igraph::each_edge(.1)))


#' Susceptibility and Infection
#'
#' Calculates infectiousness and susceptibility for each node in the graph
#' @templateVar dynamic TRUE
#' @templateVar toa TRUE
#' @templateVar valued TRUE
#' @template graph_template
#' @param t0 Integer scalar. See \code{\link{toa_mat}}.
#' @param normalize Logical. Whether or not to normalize the outcome
#' @param K Integer scalar. Number of time periods to consider
#' @param r Numeric scalar. Discount rate used when \code{expdiscount=TRUE}
#' @param expdiscount Logical scalar. When TRUE, exponential discount rate is used (see details).
#' @param outgoing Logical scalar. When \code{TRUE}, computed using outgoing ties.
#' @family statistics
#' @aliases susceptibility
#' @keywords univar
#' @seealso The user can visualize the distribution of both statistics
#' by using the function \code{\link{plot_infectsuscep}}
#' @details
#'
#' Normalization, \code{normalize=TRUE}, is applied by dividing the
#' resulting number from the infectiousness/susceptibility stat
#' by the number of individuals who adopted the innovation at
#' time \eqn{t}.
#'
#' Given that node \eqn{i} adopted the innovation in time \eqn{t}, its
#' Susceptibility is calculated as follows
#'
#' \deqn{S_i = \frac{%
#' \sum_{k=1}^K\sum_{j=1}^n x_{ij(t-k+1)}z_{j(t-k)}\times \frac{1}{w_k}}{%
#' \sum_{k=1}^K\sum_{j=1}^n x_{ij(t-k+1)}z_{j(1\leq t \leq t-k)} \times \frac{1}{w_k} }\qquad \mbox{for }i,j=1,\dots,n\quad i\neq j}{%
#' S(i) = [\sum_k \sum_j (x(ij,t-k+1) * z(j,t-k))/w(k)]/[\sum_k \sum_j (x(ij,t-k+1) * z(j, 1<=t<=t-k))/w(k)]  for  j != i}
#'
#' where \eqn{x_{ij(t-k+1)}}{x(ij,t-k+1)} is 1 whenever there's a link from \eqn{i}
#' to \eqn{j} at time \eqn{t-k+1}, \eqn{z_{j(t-k)}}{z(j,t-k)}
#' is 1 whenever individual \eqn{j} adopted the innovation at time \eqn{t-k},
#' \eqn{z_{j(1\leq t \leq t-k)}}{z(j, 1<=t<=t-k)} is 1 whenever
#' \eqn{j} had adopted the innovation up to \eqn{t-k}, and \eqn{w_k}{w(k)} is
#' the discount rate used (see below).
#'
#' Similarly, infectiousness is calculated as follows
#'
#' \deqn{I_i = \frac{%
#' \sum_{k=1}^K \sum_{j=1}^n x_{ji(t+k-1)}z_{j(t+k)}\times \frac{1}{w_k}}{%
#' \sum_{k=1}^K \sum_{j=1}^n x_{ji(t+k-1)}z_{j(t+k\leq t \leq T)}\times \frac{1}{w_k} }\qquad \mbox{for }i,j=1,\dots,n\quad i\neq j}{%
#' I(i) = [\sum_k \sum_j (x(ji,t) * z(j,t+1))/w(k)]/[\sum_k \sum_j (x(ji,t) * z(j, t+1<=t<=T))/w(k)]   for  j != i}
#'
#' It is worth noticing that, as we can see in the formulas, while susceptibility
#' is from alter to ego, infection is from ego to alter.
#'
#' When \code{outgoing=FALSE} the algorithms are based on incoming edges, this is
#' the adjacency matrices are transposed swapping the indexes \eqn{(i,j)} by
#' \eqn{(j,i)}. This can be useful for some users.
#'
#' Finally, by default both are normalized by the number of individuals who
#' adopted the innovation in time \eqn{t-k}. Thus, the resulting formulas,
#' when \code{normalize=TRUE}, can be rewritten as
#'
#' \deqn{%
#' S_i' = \frac{S_i}{\sum_{k=1}^K\sum_{j=1}^nz_{j(t-k)}\times \frac{1}{w_k}} %
#' \qquad I_i' = \frac{I_i}{\sum_{k=1}^K\sum_{j=1}^nz_{j(t-k)} \times\frac{1}{w_k}}}{%
#' S(i)' = S(i)/[\sum_k \sum_j z(j,t-k)/w(k)]
#'
#' I(i)' = I(i)/[\sum_k \sum_j z(j,t-k)/w(k)]}
#'
#' For more details on these measurements, please refer to the vignette titled
#' \emph{Time Discounted Infection and Susceptibility}.
#'
#' @section Discount rate:
#'
#' Discount rate, \eqn{w_k}{w(k)} in the formulas above, can be either exponential
#' or linear. When \code{expdiscount=TRUE}, \eqn{w_k = (1 + r)^{k-1}}{w(k) = (1+r)^(k-1)}, otherwise
#' it will be \eqn{w_k = k}{w(k)=k}.
#'
#' Note that when \eqn{K=1}, the above formulas are equal to the ones presented
#' in Valente et al. (2015).
#'
#' @references
#' Thomas W. Valente, Stephanie R. Dyal, Kar-Hai Chu, Heather Wipfli, Kayo
#' Fujimoto Diffusion of innovations theory applied to global tobacco control
#' treaty ratification, Social Science & Medicine, Volume 145, November 2015,
#' Pages 89-97, ISSN 0277-9536
#' \doi{10.1016/j.socscimed.2015.10.001}
#'
#' Myers, D. J. (2000). The Diffusion of Collective Violence: Infectiousness,
#' Susceptibility, and Mass Media Networks. American Journal of Sociology, 106(1),
#' 173–208. \doi{10.1086/303110}
#'
#' @examples
#'
#' # Creating a random dynamic graph
#' set.seed(943)
#' graph <- rgraph_er(n=100, t=10)
#' toa <- sample.int(10, 100, TRUE)
#'
#' # Computing infection and susceptibility (K=1)
#' infection(graph, toa)
#' susceptibility(graph, toa)
#'
#' # Now with K=4
#' infection(graph, toa, K=4)
#' susceptibility(graph, toa, K=4)
#'
#' @export
#' @return A numeric column vector (matrix) of size \eqn{n} with either infection/susceptibility rates.
#' @author George G. Vega Yon
infection <- function(graph, toa, t0=NULL,
                      normalize=TRUE, K=1L, r=0.5, expdiscount=FALSE,
                      valued   = getOption("diffnet.valued", FALSE),
                      outgoing = getOption("diffnet.outgoing", TRUE)) {

  # Checking the times argument
  if (missing(toa))
    if (!inherits(graph, "diffnet")) {
      stop("-toa- should be provided when -graph- is not of class 'diffnet'")
    } else {
      toa <- graph$toa
      t0    <- min(graph$meta$pers)
    }

  # Checking baseline time
  if (!length(t0)) t0 <- min(toa, na.rm=TRUE)

  switch (class(graph),
    array = infection.array(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing),
    list = infection.list(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing),
    diffnet = infection.list(graph$graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing),
    stopifnot_graph(graph)
  )
}

# @rdname infection
# @export
infection.array <- function(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing) {
  toa <- toa - t0 + 1L
  t <- dim(graph)[3]
  n <- nrow(graph)
  ngraph <- vector("list", t)

  for(i in 1:t)
    ngraph[[i]] <- methods::as(graph[,,i], "dgCMatrix")

  out <- infection_cpp(ngraph, toa, normalize, K, r, expdiscount, n, valued, outgoing)

  # Naming
  rn <- rownames(graph)
  if (!length(rn)) rn <- 1:n
  structure(out, dimnames=list(rn, "infection"), dim=c(n,1))
}

# @rdname infection
# @export
infection.list <- function(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing) {
  t <- length(graph)
  n <- nrow(graph[[1]])
  toa <- toa - t0 + 1L

  out <- infection_cpp(graph, toa, normalize, K, r, expdiscount, n, valued, outgoing)

  # Naming
  rn <- rownames(graph[[1]])
  if (!length(rn)) rn <- 1:n

  structure(out, dimnames=list(rn, "infection"), dim=c(n,1))
}

#' @rdname infection
#' @export
susceptibility <- function(graph, toa, t0=NULL, normalize=TRUE, K=1L, r=0.5,
                           expdiscount=FALSE,
                           valued=getOption("diffnet.valued",FALSE),
                           outgoing=getOption("diffnet.outgoing",TRUE)) {
  # Checking the toa argument
  if (missing(toa))
    if (!inherits(graph, "diffnet")) {
      stop("-toa- should be provided when -graph- is not of class 'diffnet'")
    } else {
      toa <- graph$toa
      t0    <- min(graph$meta$pers)
    }

  # Checking baseline time
  if (!length(t0)) t0 <- min(toa, na.rm=TRUE)

  cls <- class(graph)

  if ("array" %in% cls) {
    susceptibility.array(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing)
  } else if ("list" %in% cls) {
    susceptibility.list(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing)
  } else if ("diffnet" %in% cls) {
    susceptibility.list(graph$graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing)
  } else
    stopifnot_graph(graph)

}

# @rdname infection
# @export
susceptibility.list <- function(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing) {
  t <- length(graph)
  n <- nrow(graph[[1]])
  toa <- toa - t0 + 1L

  out <- susceptibility_cpp(graph, toa, normalize, K, r, expdiscount, n, valued, outgoing)

  # Naming
  rn <- rownames(graph[[1]])
  if (!length(rn)) rn <- 1:n

  structure(out, dimnames=list(rn, "susceptibility"), dim=c(n,1))

}

# @rdname infection
# @export
susceptibility.array <- function(graph, toa, t0, normalize, K, r, expdiscount, valued, outgoing) {
  toa <- toa - t0 + 1L
  t <- dim(graph)[3]
  n <- nrow(graph)
  ngraph <- vector("list", t)

  for(i in 1:t)
    ngraph[[i]] <- methods::as(graph[,,i], "dgCMatrix")

  out <- susceptibility_cpp(ngraph, toa, normalize, K, r, expdiscount, n, valued, outgoing)

  # Naming
  rn <- rownames(graph)
  if (!length(rn)) rn <- 1:n
  structure(out, dimnames=list(rn, "susceptibility"), dim=c(n,1))
}


# 4. faza: Analiza podatkov

#linearni model s intervalom zaupanja

model1 <- lm(neto_izvoz ~ leto , data = pdf1)
prihodnost <- data.frame(leto = seq(2020,2024))

napoved1 <- prihodnost %>% mutate(neto_izvoz= predict(model1, .))

tabela.napoved1 <- bind_rows( (pdf1)[c(1,4)],napoved1)

graf.napoved1 <- ggplot(tabela.napoved1, aes(x = leto, y = neto_izvoz)) +
  geom_point() + scale_x_continuous(name = "Leto", breaks = seq(1950,2024,2)) + ylab("Neto izvoz") +
  ggtitle("Napoved gibanja neto izvoza-linearna") +
  geom_smooth(method = 'lm', formula = y ~ x,col="red") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1),
         panel.grid.minor = element_blank())+
  scale_y_continuous(labels=comma)+
  geom_point(data=napoved1, aes(x=leto, y=neto_izvoz), fill='yellow',shape=21, size=2)

#linearni model uvoz izvoz

model2 <- lm(izvoz ~ uvoz , data = pdf1)
novi.uvozi <- data.frame(uvoz = c(500000,1000000,1200000))

napoved2 <- novi.uvozi %>% mutate(izvoz= predict(model2, .))

tabela.napoved2 <- bind_rows( (pdf1)[c(2,3)],napoved2)

graf.napoved2 <- ggplot(tabela.napoved2, aes(x = uvoz, y = izvoz)) +
  geom_point() + scale_x_continuous(name = "Uvoz",labels = scales::comma, breaks = seq(0,1300000,100000)) + ylab("Izvoz") +
  ggtitle("Napoved gibanja izvoza glede na uvoz") +
  geom_smooth(method = 'lm', formula = y ~ x,col="red") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1),
        panel.grid.minor = element_blank())+
  scale_y_continuous(labels=comma)+
  geom_point(data=napoved2, aes(x=uvoz, y=izvoz), fill='yellow',shape=24, size=3.5)


library(stats)
library(lattice)

plotFunction <- function(expr, x1, x2) {
  svg()
  x <- seq(from = x1, to = x2, by = 0.01)
  y <- eval(parse(text=expr))
  print(xyplot(y ~ x, type="l"))
  grDevices:::svg.off()
}

export('plotFunction', plotFunction)


#Fit dirlichet models to all functional and phylogenetic groups at once.
#No hierarchy required, as everything is observed at the site level. Each observation is a unique site.
#Missing data are allowed.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/ddirch_site.level_JAGS.r')
source('NEFI_functions/tic_toc.r')

#detect and register cores.
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#set output path.----
output.path <- ted_ITS_prior_all.groups_JAGSfits.path

#load tedersoo data.----
d <- data.table(readRDS(tedersoo_ITS_clean_map.path))
y <- readRDS(tedersoo_ITS_common_phylo_groups_list_1k.rare.path)

#subset to predictors of interest, complete case the thing.
d <- d[,.(SRR.id,pC,cn,pH,NPP,map,mat,forest,conifer,relEM)]
#d <- d[,.(SRR.id,pC,cn,pH,NPP,map,mat,forest,conifer,relEM,P,K,Ca,Mg)] #with micronutrients.
d <- d[complete.cases(d),] #optional. This works with missing data.
d <- d[d$SRR.id %in% rownames(y[[1]]$abundances),]
#d <- d[1:35,] #for testing

#Drop in intercept, setup predictor matrix.
x <- d
rownames(x) <- x$SRR.id
x$SRR.id <- NULL
intercept <- rep(1, nrow(x))
x <- cbind(intercept, x)
#IMPORTANT: LOG TRANSFORM MAP.
#log transform map, magnitudes in 100s-1000s break JAGS code.
x$map <- log(x$map)

#fit model using function.
#for running production fit on remote.
cat('Begin model fitting loop...\n')
tic()
output.list<-
  foreach(i = 1:length(y)) %dopar% {
    y.group <- y[[i]]
    y.group <- y.group$abundances
    y.group <- y.group[rownames(y.group) %in% d$SRR.id,]
    y.group <- y.group + 1
    y.group <- y.group/rowSums(y.group)
    if(!sum(rownames(y.group) == d$SRR.id) == nrow(y.group)){
      cat('Warning. x and y covariates not in the same order!')
    }
    fit <- site.level_dirlichet_jags(y=y.group,x_mu=x,
                                     adapt = 200, burnin = 2000, sample = 1000,
                                     parallel = T, parallel_method = 'parallel') #setting parallel rather than rjparallel.
    return(fit)                                                                  #allows nested loop to work.
  }
cat('Model fitting loop complete! ')
toc()

#name the items in the list
names(output.list) <- names(y)

cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


dt <- 0.01
Nstep <- 10000
k1 <- 0.1
lambda1 <- 1.0
lambda2 <- 0.5
k2 <- 0.2
Ncell <- 600
F0 <- 0.1
p0 <- 0.7
## F0 <- 0.8
## p0 <- 0.8
ec <- 1.6
sig1 <- 0
sig2 <- 0
alpha <- 0.5
sig <- 0.0

thetabarList <- NULL
for (nsample in seq(1))
{
e <- seq(1.2, 1.2, length.out=Ncell)
theta <- runif(Ncell, -pi/2, pi/2)

output <- NULL

thetabar <- 0
for ( i in seq(Nstep) )
{
    if ( i %% 20 == 0 )
    {
        n <- cbind(cos(theta), sin(theta))
        Q <- cbind(n[,1]*n[,1]-0.5, n[,1]*n[,2], n[,2]*n[,1], n[,2]*n[,2]-0.5)
        M <- matrix(colMeans(Q), nrow=2, ncol=2, byrow=TRUE)
        eigenvec <- eigen(M)$vectors[,1]
        thetabar <- atan(abs(eigenvec[2])/pmax(0.000001, abs(eigenvec[1])))
    }
    F <- max(0, F0 - alpha * sig/(1+abs(sig)))
    S <- mean(cos(2.0*theta))
    e <- e + dt*(F*cos(theta) - lambda1*(e-1)) + k1*sqrt(dt)*rnorm(Ncell, mean=0, sd=1)
    e <- pmax(e, 1)
    theta <- theta - dt*lambda2*(e-1)*(theta - thetabar) + k2*sqrt(dt)*rnorm(Ncell, mean=0, sd=1)
    ##theta <- theta - dt*S*lambda2*(theta-thetabar) + k2*sqrt(dt)*rnorm(Ncell, mean=0, sd=1)
    ##theta <- atan(abs(sin(theta))/pmax(0.000001, abs(cos(theta))))
    #cat(i, S, '\n')

    if ( i%%10 == 0 )
    {
        theta1 <- theta
        theta1 <- atan(abs(sin(theta1))/pmax(0.000001, abs(cos(theta1))))
        ecut <- e < ec
        theta2 <- theta1 * (1 - ecut) + ecut * runif(Ncell, 0, pi/2)
        A1 <- mean(sin(theta1) - cos(theta1))
        A2 <- mean(sin(theta2) - cos(theta2))
        ES <- mean((1-p0)*cos(theta1) - p0*sin(theta1))
        #cat(A1, A2, S, ES, F, sig, thetabar*180/pi, '\n')

        divtheta <- sample(theta1, 1)
        sig1 <- sig1 + cos(divtheta)
        sig2 <- sig2 + sin(divtheta)
        sig <- ((1-p0)*sig1 - p0*sig2)

        output <- rbind(output, c(sig, F, A1, A2, ES, sig1, sig2, divtheta))
    }
}

cat(A1, A2, S, ES, F, sig, thetabar*180/pi, '\n')
thetabarList <- c(thetabarList, thetabar*180/pi)
}
##png("output1.png")
pdf("output1.pdf")
par(mfrow=c(2, 1))
par(mar=c(4,6,4,4))
plot(output[200:800,1], type='o', col='blue', ylim=c(-6, 6),
     xlab="Number of divisions",cex.lab=1.5, cex.axis=1.5,
     ylab="Signal")
abline(h=0, lty=2)
##lines(output[,2], col='green', lty=1)
##lines(output[,3], col='blue')
plot(output[200:800,5], col='red')
dev.off()

sig0 <- mean(output[,1])
F0rec = F0 - alpha * sig0/(1+abs(sig0))
## theta1 <- theta
## theta1 <- atan(abs(sin(theta1))/pmax(0.000001, abs(cos(theta1))))
## ecut <- e < ec
## theta2 <- theta1 * (1 - ecut) + ecut * runif(Ncell, 0, pi/2)
## A1 <- mean(sin(theta1) - cos(theta1))
## A2 <- mean(sin(theta2) - cos(theta2))
## A1List <- c(A1List, A1)
## A2List <- c(A2List, A2)
## cat(A1, A2, S, thetabar*180/pi, '\n')