setwd(".")

# Always generate the same data
set.seed(111)

# Number of samples
sample_size = 1500
training_size = 0.8
validation_size = 0.1
test_size = 0.1

###################################################################
# To generate the waveform data we use mlbench
# mlbench uses Breiman's original waveform source modified for R
library(mlbench)
waves = mlbench.waveform(sample_size)
data = data.frame(cbind(waves$x, waves$class))
###################################################################

###################################################################
# Divide the vectors according to the classes
w1 = data[data$X22 == 1, ]

# Create training, test and validation sets for w1
w1_validation_size = floor(nrow(w1) * validation_size)
w1_test_size = floor(nrow(w1) * test_size)
w1_training_size = nrow(w1) - w1_test_size - w1_validation_size

w1_training = w1[1:w1_training_size, ]
w1_validation = w1[(w1_training_size + 1):(w1_training_size + w1_validation_size), ]
w1_test = w1[(w1_training_size + w1_validation_size + 1):(w1_training_size + w1_validation_size + w1_test_size), ]

###################################################################
# Divide the vectors according to the classes
w2 = data[data$X22 == 2, ]

# Create training, test and validation sets for w2
w2_validation_size = floor(nrow(w2) * validation_size)
w2_test_size = floor(nrow(w2) * test_size)
w2_training_size = nrow(w2) - w2_test_size - w2_validation_size

w2_training = w2[1:w2_training_size, ]
w2_validation = w2[(w2_training_size + 1):(w2_training_size + w2_validation_size), ]
w2_test = w2[(w2_training_size + w2_validation_size + 1):(w2_training_size + w2_validation_size + w2_test_size), ]

###################################################################
# Divide the vectors according to the classes
w3 = data[data$X22 == 3, ]

# Create training, test and validation sets for w3
w3_validation_size = floor(nrow(w3) * validation_size)
w3_test_size = floor(nrow(w3) * test_size)
w3_training_size = nrow(w3) - w3_test_size - w3_validation_size

w3_training = w3[1:w3_training_size, ]
w3_validation = w3[(w3_training_size + 1):(w3_training_size + w3_validation_size), ]
w3_test = w3[(w3_training_size + w3_validation_size + 1):(w3_training_size + w3_validation_size + w3_test_size), ]
###################################################################


fn test
    x = 3
    y = 5 * 1 + 2

    z = "hello world"
    aasdf = "test "

    print(x + y - 3)
    print("testing hello world")
    print(aasdf + z)
endfn

fn main
    x = 3
    y = 4

    if x > y
        test
    else
        if x < y
            test
        else
            print("NOPE2")
        endif

        print("NOPE")
    endif
endfn


#!/usr/bin/env Rscript
#	Making figures for AGU Fall Meeting presentation 9 Dec 2019
#	Eric Barefoot
#	Dec 2019

# load packages

library(tidyverse)
library(here)
library(broom)
library(lme4)
library(devtools)  # for the next thing
library(colorspace)
library(paleohydror)
library(purrr)
library(rsample)
library(segmented)

if (interactive()) {
    require(colorout)
}

# establish directories

figdir = here('figures', 'outputs', 'agu_2019_talk')

# load data

chamb_data = readRDS(file = here('data','derived_data', 'chamberlin_model_data.rds'))
chamb_model = readRDS(file = here('data','derived_data', 'chamberlin_stat_model.rds'))
model = readRDS(file = here('data','derived_data','piceance_3d_model_data.rds'))
field = readRDS(file = here('data','derived_data','piceance_field_data.rds'))
combined = readRDS(file = here('data', 'derived_data', 'piceance_field_model_data.rds'))
barpres = readRDS(file = here('data', 'derived_data', 'piceance_bar_preservation.rds'))
strat_model_data = readRDS(here('data', 'derived_data', 'strat_model_results_20191202.rds'))

# Define a color palette for the stratigraphy.

cpal = hcl(h = c(80, 120, 240), c = rep(100, 3), l = c(85, 65, 20))

# Get data from field organized into tables for plotting

field_depths = field %>% filter(structure %in% c('bar','channel') & meas_type %in% c('thickness', 'dimensions')) %>% mutate(meas_a = case_when(meas_type == 'thickness' ~ meas_a, meas_type == 'dimensions' ~ meas_b))

model_depths = model %>% filter(interpretations %in% c('full'))

all_depths = bind_rows(field_depths, model_depths, .id = 'data_source') %>% mutate(data_source = recode(.$data_source, `1` = 'field', `2` = 'model'))

all_depths = all_depths %>% mutate(formID = case_when(formation == 'ohio_creek' ~ 3, formation == 'atwell_gulch' ~ 2, formation == 'molina' ~ 1, formation == 'shire' ~ 0))

legend_ord = levels(with(all_depths, reorder(formation, formID)))

formation_labeller = as_labeller(c(`0` = 'Shire', `1` = 'Molina', `2` = 'Atwell Gulch'))
source_labeller = as_labeller(c('field' = 'Field Data', 'model' = '3D Model Data'))

bedloadSamples = field %>%
filter(meas_type == 'sample' & !(structure %in% c('outcrop', 'formation', 'bar_drape')) & meas_a < 2000) %>%
mutate(D50 = meas_a * 1e-6) %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0))

legend_ord = levels(with(bedloadSamples, reorder(formation, formID)))

samples_for_slope = bedloadSamples %>% select(set_id, D50, textures, composition, samp_ind, samp_code, samp_description)
depths_for_slope = all_depths %>% filter(data_source == 'field') %>% select(-c(textures, composition, samp_ind, samp_code, samp_description))

paleohydroset = inner_join(samples_for_slope, depths_for_slope, by = 'set_id') %>%
mutate(S = trampush_slp(D50, meas_a))

# modify and model data from suite of model runs.

strat_model_dataFilt = strat_model_data %>%
filter(between(IR, 0.3, 0.55)) %>%
filter(most_common_avulsion == 'compensational') %>%
mutate(datatype = 'Model Run')

strat_model_dataFilt2 = strat_model_dataFilt %>% mutate(presInv = 1 / (pres_percents-1.01), n2gInv = 1/n2g)

n2gMod = lm(n2gInv ~ presInv + latmob + IR, data = strat_model_dataFilt2, weight = 1-pres_percents)

n2gModSimple = lm(n2gInv ~ presInv, data = strat_model_dataFilt2, weight = 1-pres_percents)

reworkingMod = lm(reworking ~ pres_percents + latmob + IR, data = strat_model_dataFilt2)
reworkingModSeg = segmented(reworkingMod, seg.Z = ~pres_percents)

reworkingModSimple = lm(reworking ~ pres_percents, data = strat_model_dataFilt2)
reworkingModSegSimple = segmented(reworkingModSimple, seg.Z = ~pres_percents)

strat_model_dataFilt3 = strat_model_dataFilt2 %>% mutate(n2gPred = 1/predict(n2gModSimple)) %>%
mutate(reworkingPred = predict(reworkingModSegSimple))

avul = rep('compensational', nrow(barpres))
IR = rnorm(nrow(barpres), 0.4, 0.05)
latmob = rnorm(nrow(barpres), 8, 2)

barpres2 = bind_cols(barpres, tibble(avul, latmob, IR))

barpres3 = barpres2 %>% rename(pres_percents = 'perc_full') %>%
mutate(formation = recode(formation, shire = 'atwell_gulch', atwell_gulch = 'shire'), presInv = 1 / (pres_percents-1.01)) %>% ungroup()

barpres_pred = barpres3 %>% mutate(n2g = 1/predict(n2gMod, newdata = .), reworking = predict(reworkingModSeg, newdata = .)) %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0))

barpres_pred_means = barpres_pred %>% group_by(formation) %>% summarize(mean_reworking = mean(reworking), mean_elems = mean(pres_percents)) %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0))

d = barpres_pred_means

ann_data = tibble(x = c(rep(0,3), d$mean_elems), y = c(d$mean_reworking, rep(0.2,3)), xend = rep(d$mean_elems,2), yend = rep(d$mean_reworking,2), formation = rep(d$formation,2), formID = rep(d$formID,2))

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

start_theme = theme_get()

pres_theme = theme_update(#line = element_line(color = '#bdbdbd'),
panel.background = element_rect(fill = '#bdbdbd', color = '#bdbdbd'),
legend.key = element_rect(fill = '#bdbdbd', color = '#bdbdbd'),
panel.grid = element_line(color = '#a79c99'),
strip.background = element_blank(),
strip.text.x = element_blank(),
plot.background = element_rect(fill = "transparent", color = 'transparent'),
legend.background = element_rect(fill = "transparent"))

depth_freq_field = ggplot() +
stat_bin(aes(x = meas_a, y = ..density.., fill = reorder(formation, formID)), geom = 'bar', position = "identity", bins = 20, data = filter(all_depths, data_source == 'field'), color = 'black', size = 0.5) +
scale_fill_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
labs(x = 'Flow Depth (m)', y = 'Probability Density') +
facet_wrap(vars(formID), ncol = 1, labeller = formation_labeller)

slope_freq = paleohydroset %>% ggplot() + stat_bin(aes(x = S, y = ..density.., fill = reorder(formation, formID)), geom = 'bar', position = 'identity', bins = 8, color = 'black', size = 0.5) +
scale_x_log10(breaks = c(1e-04, 2e-04, 5e-04, 0.001, 0.003), labels = c(expression(10^-4), expression(2%*%10^-4), expression(5%*%10^-4), expression(10^-3), expression(3%*%10^-3))) +
scale_fill_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
labs(x = 'Slope (-)', y = 'Probability Density') +
facet_wrap(vars(formID), ncol = 1)

plot_width = 5

ggsave(plot = slope_freq, filename = "petm_slope_piceance_frequency.png", path = figdir, width = plot_width, height = plot_width, units = "in", bg = 'transparent')

ggsave(plot = depth_freq_field, filename = "petm_depth_piceance_frequency.png", path = figdir, width = plot_width, height = plot_width, units = "in", bg = 'transparent')

strat_model_runs = ggplot(aes(x = pres_percents, y = reworking), data = strat_model_dataFilt3) +
geom_point() +
xlim(0,1) + ylim(0.4,1) +
scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
scale_fill_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
labs(x = '% fully preserved bars', y = '% undisturbed stratigraphy')

ggsave(plot = strat_model_runs, filename = "strat_model_runs.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

strat_model_runs_trend = strat_model_runs +
geom_line(aes(x = pres_percents, y = reworkingPred), data = strat_model_dataFilt3, color = 'red3', size = 1.5)

ggsave(plot = strat_model_runs_trend, filename = "strat_model_runs_trend.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

strat_model_runs_overlay = strat_model_runs +
geom_point(aes(x = pres_percents, y = reworking, color = formation), data = barpres_pred) +
theme(legend.position="none")

ggsave(plot = strat_model_runs_overlay, filename = "strat_model_runs_overlay.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

strat_model_runs_overlay_legend = strat_model_runs +
geom_point(aes(x = pres_percents, y = reworking, color = formation), data = barpres_pred)

ggsave(plot = strat_model_runs_overlay_legend, filename = "strat_model_runs_overlay_legend.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

bootstrap_plot = ggplot(aes(y = ..density.., fill = reorder(formation, formID)), data = barpres_pred) +
scale_fill_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
facet_wrap(vars(formID), ncol = 1)

petm_bar_preservation = bootstrap_plot +
stat_bin(aes(x = pres_percents, color = reorder(formation, formID)), bins = 20, geom = 'bar', size = 0.5, alpha = 0.4) +
geom_vline(aes(xintercept = mean_elems, color = reorder(formation, formID)), data = d, size = 2) +
labs(x = '% fully preserved bars', y = 'Probability Density', color = 'Member')

ggsave(plot = petm_bar_preservation, filename = "petm_bar_preservation.png", path = figdir, width = plot_width*1.3, height = plot_width, units = "in", bg = 'transparent')

petm_sediment_retention = bootstrap_plot +
stat_bin(aes(x = reworking, color = reorder(formation, formID)), data = barpres_pred, bins = 20, geom = 'bar', size = 0.5, alpha = 0.4) +
geom_vline(aes(xintercept = mean_reworking, color = reorder(formation, formID)), data = d, size = 2) +
labs(x = '% undisturbed stratigraphy', y = 'Probability Density', color = 'Member')

ggsave(plot = last_plot(), filename = "petm_sediment_retention.png", path = figdir, width = plot_width*1.3, height = plot_width, units = "in", bg = 'transparent')

strat_model_runs_n2g = ggplot(aes(x = pres_percents, y = n2g), data = strat_model_dataFilt3) +
geom_point() +
xlim(0,1) + ylim(0,1) +
scale_color_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
scale_fill_manual(values = cpal, name = 'Member', labels = c('Shire','Molina','Atwell Gulch'), breaks = legend_ord) +
labs(x = '% fully preserved bars', y = '% Sand')

ggsave(plot = strat_model_runs_n2g, filename = "strat_model_runs_n2g.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

strat_model_runs_n2g_trend = strat_model_runs_n2g +
geom_line(aes(x = pres_percents, y = n2gPred), data = strat_model_dataFilt3, color = 'red3', size = 1.5)

ggsave(plot = strat_model_runs_n2g_trend, filename = "strat_model_runs_n2g_trend.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

############### BONUS SLIDES ###############

strat_model_runs_n2g_overlay = strat_model_runs_n2g +
geom_point(aes(x = pres_percents, y = n2g, color = formation), data = barpres_pred) +
theme(legend.position="none")

ggsave(plot = strat_model_runs_n2g_overlay, filename = "strat_model_runs_n2g_overlay.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')

stratFilt = strat_model_data %>%
filter(between(IR, 0.3, 0.55))

reworking_by_avulsion_type = ggplot(aes(x = pres_percents, y = reworking, color = most_common_avulsion), data = stratFilt) +
geom_point() +
geom_line(aes(x = pres_percents, y = reworkingPred), data = strat_model_dataFilt3, color = '#009e2f', size = 1.5) +
xlim(0,1) + ylim(0.4,1) +
geom_abline() +
labs(x = '% fully preserved bars', y = '% undisturbed stratigraphy', color = 'Avulsion Rule')

ggsave(plot = reworking_by_avulsion_type, filename = "reworking_by_avulsion_type.png", path = figdir, width = 7, height = 5, units = "in", bg = 'transparent')


construct.knots <- function(argvals, knots, knots.option, p) {
  if (length(knots) == 1) {
    allknots <- select.knots(argvals, knots, p = p, option = knots.option)
  }

  if (length(knots) > 1) {
    K <- length(knots) - 1
    knots_left <- 2 * knots[1] - knots[p:1 + 1]
    knots_right <- 2 * knots[K] - knots[K - (1:p)]
    if (p > 0) allknots <- c(knots_left, knots, knots_right)
    if (p == 0) allknots <- knots
  }

  return(allknots)
} # wrapper for select.knots


#Comparing tedersoo vs. neonCV fits to core and plot scale data.
rm(list=ls())
source('paths.r')

#load forecasts, reformat for analyses.----
neo.core.cast <- readRDS(core.CV_NEON_fcast.path)
neo.plot.cast <- readRDS(plot.CV_NEON_fcast.path)
ted.cast <- readRDS(NEON_dmulti.ddirch_fcast_fg.path)

#break apart ted.cast to match NEON organization.
ted.core.cast <- list()
ted.plot.cast <- list()
for(i in 1:length(ted.cast)){
 ted.core.cast[[i]] <- list(ted.cast[[i]]$core.fit, ted.cast[[i]]$core.preds, ted.cast[[i]]$core.sd)
 ted.plot.cast[[i]] <- list(ted.cast[[i]]$plot.fit, ted.cast[[i]]$plot.preds, ted.cast[[i]]$plot.sd)
 names(ted.core.cast[[i]]) <- c('core.fit','core.preds','core.sd')
 names(ted.plot.cast[[i]]) <- c('plot.fit','plot.preds','plot.sd')
}
names(ted.core.cast) <- names(ted.cast)
names(ted.plot.cast) <- names(ted.cast)

#Load observed core and plot scale data, reformat for analysis.----
core.dat <- readRDS(core.CV_NEON_cal.val_data.path)
plot.dat <- readRDS(plot.CV_NEON_cal.val_data.path)

#Massage into nested by phylo/function level format.
neo.core.dat <- list()
neo.plot.dat <- list()
ted.core.dat <- list()
ted.plot.dat <- list()
for(i in 1:length(core.dat$cal$y.cal)){
  cal.core <- core.dat$cal$y.cal[[i]]$rel.abundances
  val.core <- core.dat$val$y.val[[i]]$rel.abundances
  cal.plot <- plot.dat$cal$y.cal[[i]]$mean
  val.plot <- plot.dat$val$y.val[[i]]$mean
  rownames(cal.core) <- gsub('-GEN','',rownames(cal.core))
  rownames(val.core) <- gsub('-GEN','',rownames(val.core))
  ted.core.dat[[i]] <- rbind(cal.core, val.core)
  ted.plot.dat[[i]] <- rbind(cal.plot, val.plot)
  neo.core.dat[[i]] <- val.core
  neo.plot.dat[[i]] <- val.plot
}
names(ted.core.dat) <- names(ted.cast)
names(ted.plot.dat) <- names(ted.cast)
names(neo.core.dat) <- names(ted.cast)
names(neo.plot.dat) <- names(ted.cast)

#Make model and data lists.
cast <- list(neo.core.cast, neo.plot.cast, ted.core.cast, ted.plot.cast)
data <- list(neo.core.dat , neo.plot.dat , ted.core.dat , ted.plot.dat )
names(cast) <- c('neo.core.cast','neo.plot.cast','ted.core.cast','ted.plot.cast')

#Get observed ~ predicted R2-best and R2-1:1 for each set of models.----
all.rsq <- list()
for(i in 1:length(cast)){
  this.cast <- cast[[i]]
  this.data <- data[[i]]
  this.rsq  <- list()
  for(j in 1:length(this.cast)){
    y <- this.data[[j]]
    x <- this.cast[[j]][[1]]$mean
    #make sure rownames are in same order
    x <- x[rownames(x) %in% rownames(y),]
    x <- x[order(match(rownames(x), rownames(y))),]
    #calculate R2 values
    rsq <- list()
    for(k in 1:ncol(x)){
      mod <- lm(y[,k] ~ x[,k])
      #rsq of best fit line.
      rsq.b <- summary(mod)$r.squared
      #resq of 1:1 line.
      rss <- sum((x[,k] -      y[,k])  ^ 2)  ## residual sum of squares
      tss <- sum((y[,k] - mean(y[,k])) ^ 2)  ## total sum of squares
      rsq.1 <- 1 - rss/tss
      rsq.1 <- ifelse(rsq.1 < 0, 0, rsq.1)
      return <- c(rsq.b, rsq.1)
      rsq[[k]] <- return
    }
    rsq <- do.call(rbind, rsq)
    rownames(rsq) <- colnames(x)
    colnames(rsq) <- c('rsq.b','rsq.1')
    this.rsq[[j]] <- rsq
  }
  names(this.rsq) <- names(this.cast)
  all.rsq[[i]] <- this.rsq
}
names(all.rsq) <- names(cast)

#Visualize differences in R2 by function/phylo group, scale (core vs. plot) and forecast (tedersoo vs. NEON.cv).-----
to_plot.rsq <- list()
for(i in 1:length(all.rsq)){
  this.rsq <- all.rsq[[i]]
  rsq.sum <- list()
  for(k in 1:length(this.rsq)){
   rsq.sum[[k]] <- mean(this.rsq[[k]][,1], na.rm = T)
  }
  rsq.sum <- unlist(rsq.sum)
  names(rsq.sum) <- names(this.rsq)
  to_plot.rsq[[i]] <- rsq.sum
}
names(to_plot.rsq) <- names(all.rsq)


#=============================================================
# c:/1work/Modelling/QFC_workshop/examples/extract_data/slh_whitefish.r
# Created: 11 Nov 2013 13:56:36

#
# DESCRIPTION:
#
#
#
# A. Cottrill
#=============================================================

# LIBRARIES:

library(RODBC)
library(reshape2)

# OTHER SCRIPTS:
#source("")

#=============================================================

dbase <- c("E:/Data Warehouse/Merged Datasets/Species_Databases/Lake_Whitefish/091_United.mdb")

qmas <- "'6-1'"
#qmas <- "'5-8','5-9'"
yr <- 2002
basin <- switch(qmas,
                "'6-1'"='nc',
                "'4-5'"='smb',
                'gb')

sql <-
"SELECT AGE, FLEN FROM All_BioData
INNER JOIN [LOCATION with LATLONG] ON All_BioData.GRID = [LOCATION with LATLONG].GRID
WHERE ((([LOCATION with LATLONG].QUOTA_ZONE) IN (qmas)) AND ((All_BioData.YEAR)='yr') AND ((All_BioData.AGE) Is Not Null) AND ((All_BioData.FLEN) Is Not Null))
ORDER BY All_BioData.AGE, All_BioData.FLEN;"

sql <- gsub('yr', yr,  sql)
sql <- gsub('qmas', qmas,  sql)

DBConnection <- odbcConnectAccess(dbase,uid = "", pwd = "")
data <- sqlQuery(DBConnection, sql)
    head(data)
    str(data)
    nrow(data)
odbcClose(DBConnection)

N <- 10
ages <-  unique(data$AGE)
selected <- subset(data, data$AGE<0)

for (i in seq(along=ages)){
    sub <- subset(data, data$AGE==ages[i])
    if (nrow(sub) <= N){
        selected <- rbind(selected, sub)
    } else {
        selected <- rbind(selected, sub[sample(nrow(sub),N,replace=F),])
    }
}

outdir <- 'c:/1work/Modelling/QFC_workshop/examples/extract_data/'
fname <-paste0(outdir,'whitefish-',basin,'-', yr, '.csv')

jj <- selected[with(selected, order('AGE', 'FLEN')),]
write.csv(selected, fname,row.names=FALSE)

f <- function()
{
  ## Purpose:
  ## ----------------------------------------------------------------------
  ## Arguments:
  ## ----------------------------------------------------------------------
  ## Author: , Date:  5 Dec 2013, 14:54
}

library(reshape2)

#fit the model and predicte size at age
start = list('Linf'=max(data$FLEN), 't0'=0.0, 'k'=0.25)
vonB <- nls(FLEN ~ Linf * (1 - exp(-k * (AGE - t0))),
    data=data, start=start)

summary(vonB)

predicted <- data.frame('AGE' = seq((min(ages) -1),
                           max(ages) + 1, by=0.1), 'FLEN'=0)

predicted$FLEN <- predict(vonB,newdata=predicted)

#make a plot
plot(data$AGE, data$FLEN, xlab="Age",
      ylab="Fork Length (mm)")
lines(predicted$AGE, predicted$FLEN, col='blue')

#calculate mean size at age
mu <- cast(data, AGE~., value='FLEN', fun=mean)
names(mu) <- c('Age','Observed')
mu$Predicted <- predict(vonB, newdata=data.frame('AGE'=ages))


# nocov start
fgcodes <- c(paste0('\x1b[38;5;', 0:255, 'm'), '\x1b[39m')
bgcodes <- c(paste0('\x1b[48;5;', 0:255, 'm'), '\x1b[49m')

rgb_index <- 17:232
gray_index <- 233:256
reset_index <- 257
#nocov end

ansi256 <- function(rgb, bg = FALSE, grey = FALSE) {
  codes <- if (bg) bgcodes else fgcodes
  if (grey) {
    ## Gray
    list(
      open = codes[gray_index][scale(rgb[1], to = c(0, 23)) + 1],
      close = codes[reset_index]
    )

  } else {
    ## Not gray
    list(
      open = codes[ansi256_rgb_index(rgb[1L], rgb[2L], rgb[3L])],
      close = codes[reset_index]
    )
  }
}

## This is based off the algorithm in the ruby "paint" gem, as
## implemented in rainbowrite.
ansi256_rgb_index <- function(red, green, blue) {
  gray_possible <- TRUE
  sep <- 42.5
  while (gray_possible) {
    if (red < sep || green < sep || blue < sep) {
      gray <- red < sep && green < sep && blue < sep
      gray_possible <- FALSE
    }
    sep <- sep + 42.5
  }

  ## NOTE: The +1 here translates from base0 to base1 for the index
  ## that does the same.  Not ideal, but that does get the escape
  ## characters in nicely.
  if (gray) {
    232 + round((red + green + blue) / 33) + 1
  } else {
    16 + sum(floor(6 * c(red, green, blue) / 256) * c(36, 6, 1)) + 1
  }
}


rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(readxl)

setwd("/Users/ChatNoir/Projects/Squam/Graphs/")

# Read in data
mid <- read_excel("/Users/chatnoir/Projects/Squam/Graphs/Tables/AllSchmoosh.xlsx")
load("/Users/chatnoir/Projects/Squam/scripts_ch1/Graphing/DataFiles/corsubsample")
totalLoci <- max(mid$Loci)
# Remove non subsampled values
mid <- mid %>% filter(Sample != "all")
results <- results %>% filter(Sample != "all")

# Edit dataframes
mid <- mid %>% filter(Sample == "sig80m" | Sample == "sig60m") %>% mutate(Sample = sub('sig', '', Sample))
mid$Subsample <- paste(mid$Hypothesis,mid$Sample,sep = " - ")
# factor
mid$Subsample <- factor(mid$Subsample, levels = c("AIvSA - 80m", "AIvSI - 80m", "SAvSI - 80m", "AIvSA - 60m",  "AIvSI - 60m", "SAvSI - 60m"))
# add proportion of loci in subsample
mid$propLoci <- mid$Loci/totalLoci

# Select null distributions for 2k-4k
null2k4k <- results %>% filter(Loci >= 2000)
null4k <- results %>% filter(Loci >= 4000)
null2k <- results %>% filter(Loci >= 2000) %>% filter(Loci <= 4000)

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Pvals ---------------------------------------------- Pvals --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------
h <- 'TvS'
n <- null2k %>% filter(Hypothesis == h)
s <- '80m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
s <- '60m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
h <- 'AIvSA'
n <- null2k %>% filter(Hypothesis == h)
s <- '80m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
s <- '60m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
h <- 'AIvSA'
n <- null2k %>% filter(Hypothesis == h)
s <- '80m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
s <- '60m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
h <- 'AIvSI'
n <- null2k %>% filter(Hypothesis == h)
s <- '80m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
s <- '60m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
h <- 'SAvSI'
n <- null2k %>% filter(Hypothesis == h)
s <- '80m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s
s <- '60m'
m <- mid %>% filter(Hypothesis == h) %>% filter(Sample == s)
e <- m$corr.eff
p.s <- sum(abs(n$corr.eff) >= abs(e)) / length(n$corr.eff)
p.s

# all p = 1, ie all sim cor eff are higher than emp vals. all of them.

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Histogram ---------------------------------------------- Histogram --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

H <- function(df,xval,cc,hbin,xlab){
  ggplot(data=df, aes(x=xval)) +
  geom_histogram(aes(y=..count../sum(..count..)),bins=hbin, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1) +
  #geom_histogram(breaks=brx, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1)+
  #geom_histogram(binwidth = max(abs(xval))*0.01, alpha=1, position="dodge",color="grey", fill=cc, size=0.1)+
  theme_classic() +
  theme(plot.title = element_text(hjust = 0.5, size=10),
        axis.text = element_text(size=6, color="black"),
        text = element_text(size=6),
        legend.title = element_text(size = 6),
        legend.text = element_text(size = 6),
        panel.border = element_blank(),
        panel.background = element_rect(fill = "transparent"), # bg of the panel
        plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
        panel.grid = element_blank()) +
  labs(y="Proportion of Loci",x=xlab) +
    coord_cartesian(xlim = c(0,1))
  }

quartz()

# Set up numbers - TOX
df <- results %>% filter(Loci >= 4000) %>% filter(Hypothesis != "TvS")
#d <- null2k4k %>% filter(Hypothesis != "TvS")
m <- mid %>% filter(Hypothesis != "TvS")

x.val <- df$corr.eff
# 95% pval
h05 <- unlist(df %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.975,0.0275))))
h01 <- unlist(df %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.995,0.005))))

lines <- m$corr.eff

# Graph
h.bin <- 20
cc <- 'grey'
max.x <- round_any(max(abs(x.val)),10,f=ceiling)

gl <- H(df,x.val,cc,h.bin,'Correlation coefficient') + geom_vline(xintercept=h01,color=c("black"), linetype="dashed", size=0.2)

title <- "4000 loci"

g <- gl + geom_point(m, mapping = aes(x=corr.eff, y=p, color=Subsample), position = position_dodge(width = 0.01)) +
  ggtitle(title)
g

# Set up numbers - TVS
dft <- results %>% filter(Loci == 2000) %>% filter(Hypothesis == "TvS")
mt <- mid %>% filter(Hypothesis == "TvS")
mt$Subsample <- paste(mt$Hypothesis,mt$Sample,sep = " - ")
# factor
mt$Subsample <- factor(mt$Subsample, levels = c("TvS - 80m", "TvS - 60m"))
x.val <- dft$corr.eff
# 95% pval
h05 <- unlist(dft %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.975,0.0275))))
h01 <- unlist(dft %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.995,0.005))))

lines <- mt$corr.eff

# Graph
h.bin <-40
cc <- 'grey'
max.x <- round_any(max(abs(x.val)),10,f=ceiling)

gl2 <- H(dft,x.val,cc,h.bin,'Correlation coefficient') + geom_vline(xintercept=h01,color=c("black"), linetype="dashed", size=0.2)

title <- "2000 loci"

g2 <- gl2 + geom_point(mt, mapping = aes(x=corr.eff, y=p, color=Subsample), position = position_dodge(width = 0.01)) +
  ggtitle(title)

gg <- ggarrange(g,g2, ncol=2, nrow=1,align="hv", common.legend = F, legend = "right")

ggsave("CorrcoeffNull_all.pdf", plot=gg,width = 7, height = 2, units = "in", device = 'pdf',bg = "transparent")

#------------------------------------------------------------------------------------------------------------------------------------------------------

# two types subsample -----------------------------------------------------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

setwd("/Users/ChatNoir/Projects/Squam/Graphs/")

# Read in data
mid <- read_excel("/Users/chatnoir/Projects/Squam/Graphs/Tables/AllSchmoosh_mb.xlsx")
load("/Users/chatnoir/Projects/Squam/scripts_ch1/Graphing/DataFiles/corsubsample")
totalLoci <- max(mid$Loci)
# Remove non subsampled values
mid <- mid %>% filter(Sample != "all")
results <- results %>% filter(Sample != "all")

# Edit dataframes
mid <- mid %>%  mutate(Sample = sub('quant', '', Sample))
mid$Subsample <- paste(mid$Hypothesis,mid$Sample,sep = " - ")
# factor
mid$Subsample <- factor(mid$Subsample, levels = c("AIvSA - 80m",  "AIvSI - 80m", "SAvSI - 80m",
                                                  "AIvSA - 80mb",  "AIvSI - 80mb", "SAvSI - 80mb",
                                                  "AIvSA - 60m",  "AIvSI - 60m", "SAvSI - 60m",
                                                  "AIvSA - 60mb",  "AIvSI - 60mb", "SAvSI - 60mb"))
# add proportion of loci in subsample
mid$propLoci <- mid$Loci/totalLoci

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Histogram ---------------------------------------------- Histogram --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

quartz()

# Set up numbers - TOX
df <- results %>% filter(Loci >= 4000) %>% filter(Hypothesis != "TvS")
#d <- null2k4k %>% filter(Hypothesis != "TvS")
m <- mid %>% filter(Hypothesis != "TvS")

x.val <- df$corr.eff
# 95% pval
h05 <- unlist(df %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.975,0.0275))))
h01 <- unlist(df %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.995,0.005))))

lines <- m$corr.eff

# Graph
h.bin <- 20
cc <- 'grey'
max.x <- round_any(max(abs(x.val)),10,f=ceiling)

gl <- H(df,x.val,cc,h.bin,'Correlation coefficient') + geom_vline(xintercept=h01,color=c("black"), linetype="dashed", size=0.2)

title <- "Null correlation coefficient distribution for random subsample of 4k loci"

g <- gl + geom_point(m, mapping = aes(x=corr.eff, y=p, color=Subsample), position = position_dodge(width = 0.01)) +
  ggtitle(title)
g
#ggsave("CorrcoeffNull_tox_all4k_mb.pdf", plot=g,width = 6, height = 4, units = "in", device = 'pdf',bg = "transparent")

# Set up numbers - TVS

dft <- results %>% filter(Loci == 1000) %>% filter(Hypothesis == "TvS")
mt <- mid %>% filter(Hypothesis == "TvS")
mt$Subsample <- paste(mt$Hypothesis,mt$Sample,sep = " - ")
# factor
mt$Subsample <- factor(mt$Subsample, levels = c("TvS - 80m","TvS - 80mb", "TvS - 60m", "TvS - 60mb"))
x.val <- dft$corr.eff
# 95% pval
h05 <- unlist(dft %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.975,0.0275))))
h01 <- unlist(dft %>% summarise(Bin_q.95 = quantile(corr.eff, c(0.995,0.005))))

lines <- mt$corr.eff

# Graph
h.bin <-40
cc <- 'grey'
max.x <- round_any(max(abs(x.val)),10,f=ceiling)

gl <- H(dft,x.val,cc,h.bin,'Correlation coefficient') + geom_vline(xintercept=h01,color=c("black"), linetype="dashed", size=0.2)

title <- "Null correlation coefficient distribution for random subsample of 1k loci"

g <- gl + geom_point(mt, mapping = aes(x=corr.eff, y=p, color=Subsample), position = position_dodge(width = 0.01)) +
  ggtitle(title)
g

#ggsave("CorrcoeffNull_tvs_all1k_mb.pdf", plot=g,width = 6, height = 4, units = "in", device = 'pdf',bg = "transparent")


#' Parse data for deep learning model training
#'
#' @importFrom recipes all_predictors
#' @importFrom recipes all_outcomes
#'
#' @param input_data A dataframe containing the input data.
#' @param partitioning_type A character string indicating the desired spatial data partitioning method. Can be "default", "block", "checkerboard1", or "checkerboard2".
#'
#' @return A dataframe containing the prepared data.
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # transform benchmarking data into a format suitable for deep learning
#' # if you have previously used a partitioning method you should specify it here
#' benchmarking_data_dl <- prepare_dl_data(input_data = benchmarking_data$df_data,
#'                                        partitioning_type = "default")
#'
#' # perform sanity check on the transformed dataset
#' # for the training set
#' head(benchmarking_data_dl$train_tbl)
#' table(benchmarking_data_dl$y_train_vec)
#'
#' # for the test set
#' head(benchmarking_data_dl$test_tbl)
#' table(benchmarking_data_dl$y_test_vec)
#'}
#'@export
prepare_dl_data <- function(input_data, partitioning_type) {
    if (partitioning_type %in% c("checkerboard1", "checkerboard2")) {
        input_data$grp_checkerboard <- NULL
        input_data$label <- as.integer(input_data$label)

        # fix coercion error (for plotting)
        input_data$label <- ifelse(input_data$label == 2, 1, 0)
    }

    input_data$grp <- NULL

    input_data <- input_data %>%
        tidyr::drop_na() %>%
        dplyr::select(label, dplyr::everything())

    train_test_split <- rsample::initial_split(input_data, prop = 0.8)
    train_tbl <- rsample::training(train_test_split)
    test_tbl <- rsample::testing(train_test_split)

    # create a recipe for centering and scaling
    rec_obj <- recipes::recipe(label ~ ., data = train_tbl) %>%
        recipes::step_center(all_predictors(),
        -all_outcomes()) %>%
        recipes::step_scale(all_predictors(), -all_outcomes()) %>%
        recipes::prep(data = train_tbl)

    # use recipe
    x_train_tbl <- recipes::bake(rec_obj, new_data = train_tbl) %>%
        dplyr::select(-label)
    x_test_tbl <- recipes::bake(rec_obj, new_data = test_tbl) %>%
        dplyr::select(-label)

    y_train_vec <- train_tbl$label
    y_test_vec <- test_tbl$label

    result_list <- list(train_tbl = x_train_tbl,
                        test_tbl = x_test_tbl,
                        y_train_vec = y_train_vec,
                        y_test_vec = y_test_vec,
                        rec_obj = rec_obj)

    return(result_list)
}


times <- function (x, y) {
  return (x*y)
}


#Replicating UNIX assignment in R

### Data Inspection
geno<-read.table("fang_et_al_genotypes.txt", header=T,stringsAsFactors = F)
snp<-read.delim("snp_position.txt",header=T,stringsAsFactors = F)         #ooohhhh it's tab deliminated and not a table/csv......

#"Fang_et_al_genotypes.txt"Inspection
class(geno)
attributes(geno)
colnames(geno[1:10])
row.names(geno)
dim(t(snp))

#snp_position Inspection
class(snp)
colnames(snp)
row.names(snp) #Rows = SNP_ID
attributes(snp)
dim(snp)

### Extracting and Processing Data
maize_geno <- geno[(geno$Group == "ZMMIL")|(geno$Group == "ZMMLR")|(geno$Group =="ZMMMR"),]
teo_geno<- geno[(geno$Group == "ZMPBA")|(geno$Group == "ZMPIL")|(geno$Group == "ZMPJA"),]

#Transpose each of the genotype files
tmaize_geno<- t(maize_geno)
tteo_geno<- t(teo_geno)

#Merge genotype files with snp data
tmaize_joined<- merge(snp, tmaize_geno, by.x = "SNP_ID",by.y = "row.names")
tteo_joined<- merge(snp, tteo_geno, by.x = "SNP_ID",by.y = "row.names")

#Find dimensions of file to extract columns needed
dim(tmaize_joined)
cut_maize<-tmaize_joined[,c(1,3,4,16:1588)]

dim(tteo_joined)
cut_teo<-tteo_joined[,c(1,3,4,16:990)]

#Sort the joined files by snp position.
cut_maize[order(as.numeric(as.character(cut_maize$Position))),]->maize_increasing_snps
cut_maize[order(as.numeric(as.character(cut_maize$Position)),decreasing = T),]->maize_decreasing_snps

cut_teo[order(as.numeric(as.character(cut_teo$Position))),]->teo_increasing_snps
cut_teo[order(as.numeric(as.character(cut_teo$Position)),decreasing=T),]->teo_decreasing_snps

#Changing out '?' for '-' for decreasing position files

maize_dashes <- maize_decreasing_snps
maize_dashes[maize_dashes == "?/?"] <- "-/-"

teo_dashes <- cut_teo
teo_dashes[teo_dashes == "?/?"] <- "-/-"

#Making Folders for the four chromosome sets
dir.create("maize_chr_increasing")
dir.create("maize_chr_decreasing")
dir.create("teosinte_chr_increasing")
dir.create("teosinte_chr_decreasing")

#Extracting data for each chromosome and writing files
for (i in 1:10) {
  maize_chr_loop <- maize_increasing_snps[maize_increasing_snps$Chromosome == i,]
  write.csv(maize_chr_loop, sprintf("maize_chr_increasing/maize_chromosome_%d_increasing_snps", i), row.names = F)
}

for (i in 1:10) {
  maize_chr_loop <- maize_dashes[maize_dashes$Chromosome == i,]
  write.csv(maize_chr_loop, sprintf("maize_chr_decreasing/maize_chromosome_%d_decreasing_snps", i), row.names = F)
}

for (i in 1:10) {
  teo_chr_loop <- teo_increasing_snps[teo_increasing_snps$Chromosome == i,]
  write.csv(teo_chr_loop, sprintf("teosinte_chr_increasing/teosinte_chromosome_%d_increasing_snps", i), row.names = F)
}

for (i in 1:10) {
  teo_chr_loop <- teo_dashes[teo_dashes$Chromosome == i,]
  write.csv(teo_chr_loop, sprintf("teosinte_chr_decreasing/teosinte_chromosome_%d_decreasing_snps", i), row.names = F)
}


#' Experimental package to learn how to create packages in R.
#'
#' myFirstRPackage package has two functions:
#' euclidean() and dijkstra().
#'
#' @section euclidean():
#' Computes the greatest common divisor (GCD) of two integers (numbers).
#'
#' @section dijkstra():
#' Finds the shortest paths between nodes in a graph
#'
#' @docType package
#' @name myFirstRPackage
NULL
#> NULL


plot(1:10, main="My Graph", xlab="The x-axis", ylab="The y-axis",
     col="red",
     type="l",
     lwd = 2,
     cex = 1,
     pch = 20)


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  m = 10
  x = matrix(1:20, m)
  y = matrix(1:30, m)
  z = matrix(1:10, m)
  c = cbind(x, y, z)
} else {
  x = NULL
  y = NULL
  z = NULL
}

dx = expand(x)
dy = expand(y)
dz = expand(z)

dc = cbind(dx, dy, dz)
c_test = collapse(dc)

comm.print(all.equal(c, c_test))

finalize()


#' Correlation Animated Bubble plot.
#'
#' anibubble function will draw  Animated Bubble plot for correlation analysis.
#' @param data input data.frame
#' @param x x variable
#' @param y y variable
#' @param col.var color variable
#' @param size.var size variable
#' @param frame.var frame variable
#' @param fps frame change per second
#' @param width width plot size
#' @param height height plot size
#' @param title main title
#' @param subtitle subtitle
#' @param xtitle x axis title
#' @param ytitle y axis title
#' @param caption caption
#' @return An object of class \code{ggplot}
#' @examples
#' plot<- anibubble(data=gapminder,x="gdpPercap",y="lifeExp",
#'                  col.var="continent",size.var = "pop", frame.var = "year")
#' plot
#'
#' @import ggplot2
#' @import scales
#' @import reshape2
#' @import ggthemes
#' @import gganimate
#' @import gapminder
#' @import ggalt
#' @import ggExtra
#' @import ggcorrplot
#' @import dplyr
#' @import treemapify
#' @import ggfortify
#' @import zoo
#' @import ggdendro
#' @export
anibubble<-function(data,x,y,col.var,size.var,frame.var,
                     fps=5,width= 1900, height=1068.75,
                     title=NULL,subtitle=NULL,xtitle=NULL,ytitle=NULL,caption=NULL){
  df<- data
  x<- x
  y<- y
  color<- col.var
  size<- size.var
  frame<-frame.var

  #animate par
  fps<- fps
  width<- width
  height<- height

  p <- ggplot(df, aes_string(x, y, col=color, size=size, frame=frame)) +
    geom_point() +
    transition_states(year) +
    theme_fivethirtyeight() +
    theme(axis.title = element_text(),
          legend.title = element_text(face = 4,size = 10),
          legend.direction = "horizontal", legend.box = "horizontal") +
    scale_color_tableau() +
    labs(subtitle=paste(subtitle,"{closest_state}"),
         y=ytitle,
         x=xtitle,
         title=title,
         caption = caption)

  return(p)

}


context("compute_density")

test_that("compute_density respects arguments", {
  # Uses n
  res <- mtcars %>% compute_density(~mpg, n = 10)
  expect_equal(10, nrow(res))

  # When trim = FALSE (default), result goes past bounds of original data
  expect_true(min(res$pred_) < min(mtcars$mpg) && max(res$pred_) > max(mtcars$mpg))

  # When trim = TRUE, bounds of result match bounds of original data
  res <- mtcars %>% compute_density(~mpg, n = 10, trim = TRUE)
  expect_true(all(range(res$pred_) == range(mtcars$mpg)))
})

test_that("Zero-row inputs", {
  res <- mtcars[0,] %>% compute_density(~mpg)
  expect_equal(nrow(res), 0)
  expect_true(setequal(names(res), c("pred_", "resp_")))

  # Grouped
  res <- mtcars %>% group_by(cyl) %>% dplyr::filter(FALSE) %>% compute_density(~mpg)
  expect_equal(nrow(res), 0)
  expect_true(setequal(names(res), c("cyl", "pred_", "resp_")))
})


library(rlist)
library(nloptr)
library(tictoc)
library(future.apply)
library(doParallel)
library(rjson)

#setwd("scripts/funciones")
source("f_get_expected.r", encoding = "UTF-8")
source("f_fit.r", encoding = "UTF-8")
source("f_Rcaso.r", encoding = "UTF-8")
source("f_bootstrap_IC.r", encoding = "UTF-8")

## Load Data ##
#currently working on dummy data.
result <- fromJSON(file = "../case_study/fitted_models.json")
ajuste_procesoAnalitico = list("beta"=result$poisson_exp$beta_mode,
                                "N0"= 81.11421,
                                "tau1"=1.632911,
                                "tau2"=0.123283)

#incidences
ColombiaB = list("newCases"=result$I)
#### Ajustes Ygorro y tiempos ----
Ygorro <- get_expected(beta = ajuste_procesoAnalitico$beta,
                       N0   = ajuste_procesoAnalitico$N0,
                       tau1 = ajuste_procesoAnalitico$tau1,
                       tau2 = ajuste_procesoAnalitico$tau2)$NN
tiempos <- length(ajuste_procesoAnalitico$beta)

#### Corroboración por suma de cuadrados ----

prueba <- data.frame(Ygorro, newCases = ColombiaB$newCases)

scm <-  sum( ( prueba$Ygorro - mean(prueba$Ygorro) )^2 )
sct <-  sum( ( prueba$newCases - mean(prueba$newCases) )^2 )

print("sanity check R^2:", 1 - scm/sct)
### Número de iteracacciones ----

num_iteracciones <- 1000
#This has to be adjusted according to JF experiment
ejecucionCastigo <- 2^12

bootstrap_distribucion_NumCasos <- bootstrap_samples( expected_I = Ygorro,
                              observed_I = ColombiaB$newCases[1:tiempos],
                              number_samples = num_iteracciones , # Aumentar a minimo 1000
                              window_size=4 , use_wa = FALSE,
                              beta = 0.9)

bootstrap_distribucion_NumCasos[ bootstrap_distribucion_NumCasos < 0 ] <- NA

for( j in 1:ncol(bootstrap_distribucion_NumCasos) ){
  temp_j <- bootstrap_distribucion_NumCasos[ , j ]
  temp_j[is.na(temp_j)] <- median(temp_j, na.rm = T )
  bootstrap_distribucion_NumCasos[ , j ] <- temp_j
}

# #### Do Parallel ------
#beta_ultimo <- rep(ajuste_procesoAnalitico$beta[length( ajuste_procesoAnalitico$beta)], length( ajuste_procesoAnalitico$beta))
beta_ultimo <- ajuste_procesoAnalitico$beta
X   <- 1:nrow(bootstrap_distribucion_NumCasos)
tmp <- vector( length = nrow(bootstrap_distribucion_NumCasos) , mode = "list" )

F_INC_SHAPE = 3.16
F_INC_RATE = 5.16
F_INF_SCALE = 24.2
tau1 = 1 / (F_INC_SHAPE / F_INC_RATE)
tau2 = 1/8.111421 # 1 / MEAN_INFECTIOUS_TIME
A0 = ColombiaB$newCases[1] / pexp(1, rate=tau1)
N0_max = A0*pexp(1, rate=tau1)/(1 * tau2) # A0 = A0*(1 - pexp(1, rate=tau1)) + N0*beta0
N0_min = A0*pexp(1, rate=tau1)/(2 * tau2)

cl   <- parallel::makeCluster( detectCores()-1 )
doParallel::registerDoParallel(cl)

tic()
lista_OptimizacionBetas <- foreach( i = X ) %dopar% {
  library(nloptr)
  # setwd(ruta_proyecto)
  # source( "scripts/funciones/f_fit.R", encoding = "UTF-8" )

  cat(i, " ")
  tmp2 <- fit(observed_I = as.numeric(as.matrix(bootstrap_distribucion_NumCasos[i,1:(tiempos)])),
             beta0 = beta_ultimo,
             beta_min = 0.6 * tau2, beta_max = 2.75 * tau2,
             tau10 = tau1, tau1_min = tau1,
             tau1_max = tau1,
             tau20 = tau2, tau2_min = tau2,
             tau2_max = tau2,
             N00 = N0_min, N0_min = N0_min, N0_max = N0_max,
             Castigo = ejecucionCastigo, ignore_beta_diff = NULL,
             max_eval = 1000)
}
toc()

parallel::stopCluster(cl)

####
m_beta <- matrix(NA, nrow = nrow(bootstrap_distribucion_NumCasos),
                 ncol =  ncol(bootstrap_distribucion_NumCasos))

m_Rt   <- matrix(NA, nrow = nrow(bootstrap_distribucion_NumCasos),
                 ncol =  ncol(bootstrap_distribucion_NumCasos))

m_Rcaso <- matrix(NA, nrow = nrow(bootstrap_distribucion_NumCasos),
               ncol =  ncol(bootstrap_distribucion_NumCasos))

tic()
lags1 <- 7
par1_inf=1
distribucion_inf="gamma"
for(i in 1:nrow(bootstrap_distribucion_NumCasos)){
  par2_inf <- lista_OptimizacionBetas[[i]]$tau2
  m_beta[i,] <- lista_OptimizacionBetas[[i]]$beta
  m_Rt[i,] <- m_beta[i,] * (1 / lista_OptimizacionBetas[[i]]$tau2)
  omegas=weightConstructionIncubacionInfeccion(lags1, par1_inf, par2_inf, distribucion_inf )
  m_Rcaso[i,] <- R_caso(lista_OptimizacionBetas[[i]]$beta, omegas)
  rm(omegas)
 }

# Rt = beta ¨(1/ tau2)

toc();

colnames(m_beta) <- colnames(bootstrap_distribucion_NumCasos)
colnames(m_Rt) <- colnames(bootstrap_distribucion_NumCasos)
colnames(m_Rcaso) <- colnames(bootstrap_distribucion_NumCasos)

######################## Intervalos de confianza ##############
confianza <- 0.95
alpha <- 1 - confianza

# Beta
Limite_inferior_Beta <- apply(m_beta, 2, FUN = quantile, probs = alpha/2)
Beta_puntual <- colMeans(m_beta)
Limite_superior_Beta <- apply(m_beta, 2, FUN = quantile, probs = 1-alpha/2)

df_estimaIC_Beta <- data.frame(LI_beta = Limite_inferior_Beta,
                               Beta_estima = Beta_puntual,
                               LS_beta = Limite_superior_Beta)

# Rt
Limite_inferior_Rt <- apply(m_Rt, 2, FUN = quantile, probs = alpha/2)
Rt_puntual <- colMeans(m_Rt)
Limite_superior_Rt <- apply(m_Rt, 2, FUN = quantile, probs = 1-alpha/2)

df_estimaIC_Rt <- data.frame(LI_Rt = Limite_inferior_Rt,
                             Rt_estima = Rt_puntual,
                             LS_Rt = Limite_superior_Rt)

print(df_estimaIC_Rt)

# # Rt Caso
Limite_inferior_RtCaso <- apply(m_Rcaso, 2, FUN = quantile, probs = alpha/2)
RtCaso_puntual <- colMeans(m_Rcaso)
Limite_superior_RtCaso <- apply(m_Rcaso, 2, FUN = quantile, probs = 1-alpha/2)

df_estimaIC_RtCaso <- data.frame(LI_RtCaso = Limite_inferior_RtCaso,
                                 RtCaso_estima = RtCaso_puntual,
                                 LS_RtCaso = Limite_superior_RtCaso)

print(df_estimaIC_RtCaso)

saveRDS(df_estimaIC_Rt, "df_estimaIC_Rt_procesoAnalitico_.rds")
saveRDS(df_estimaIC_RtCaso, "df_estimaIC_RtCaso_procesoAnalitico_.rds")


#' Bin and summarise in 2d (rectangle & hexagons)
#'
#' `stat_summary_2d()` is a 2d variation of [stat_summary()].
#' `stat_summary_hex()` is a hexagonal variation of
#' [stat_summary_2d()]. The data are divided into bins defined
#' by `x` and `y`, and then the values of `z` in each cell is
#' are summarised with `fun`.
#'
#' @section Aesthetics:
#'  - `x`: horizontal position
#'  - `y`: vertical position
#'  - `z`: value passed to the summary function
#' @section Computed variables:
#' \describe{
#'   \item{x,y}{Location}
#'   \item{value}{Value of summary statistic.}
#' }
#' @seealso [stat_summary_hex()] for hexagonal summarization.
#'   [stat_bin2d()] for the binning options.
#' @inheritParams layer
#' @inheritParams geom_point
#' @inheritParams stat_bin_2d
#' @param drop drop if the output of `fun` is `NA`.
#' @param fun function for summary.
#' @param fun.args A list of extra arguments to pass to `fun`
#' @export
#' @examples
#' d <- ggplot(diamonds, aes(carat, depth, z = price))
#' d + stat_summary_2d()
#'
#' # Specifying function
#' d + stat_summary_2d(fun = function(x) sum(x^2))
#' d + stat_summary_2d(fun = ~ sum(.x^2))
#' d + stat_summary_2d(fun = var)
#' d + stat_summary_2d(fun = "quantile", fun.args = list(probs = 0.1))
#'
#' if (requireNamespace("hexbin")) {
#' d + stat_summary_hex()
#' d + stat_summary_hex(fun = ~ sum(.x^2))
#' }
stat_summary_2d <- function(mapping = NULL, data = NULL,
                            geom = "tile", position = "identity",
                            ...,
                            bins = 30,
                            binwidth = NULL,
                            drop = TRUE,
                            fun = "mean",
                            fun.args = list(),
                            na.rm = FALSE,
                            show.legend = NA,
                            inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatSummary2d,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      bins = bins,
      binwidth = binwidth,
      drop = drop,
      fun = fun,
      fun.args = fun.args,
      na.rm = na.rm,
      ...
    )
  )
}

#' @export
#' @rdname stat_summary_2d
#' @usage NULL
stat_summary2d <- function(...) {
  message("Please use stat_summary_2d() instead")
  stat_summary_2d(...)
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSummary2d <- ggproto("StatSummary2d", Stat,
  default_aes = aes(fill = after_stat(value)),

  required_aes = c("x", "y", "z"),

  compute_group = function(data, scales, binwidth = NULL, bins = 30,
                           breaks = NULL, origin = NULL, drop = TRUE,
                           fun = "mean", fun.args = list()) {
    origin <- dual_param(origin, list(NULL, NULL))
    binwidth <- dual_param(binwidth, list(NULL, NULL))
    breaks <- dual_param(breaks, list(NULL, NULL))
    bins <- dual_param(bins, list(x = 30, y = 30))

    xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x)
    ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y)

    xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE)
    ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE)

    fun <- as_function(fun)
    f <- function(x) {
      do.call(fun, c(list(quote(x)), fun.args))
    }
    out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop)

    xdim <- bin_loc(xbreaks, out$xbin)
    out$x <- xdim$mid
    out$width <- xdim$length

    ydim <- bin_loc(ybreaks, out$ybin)
    out$y <- ydim$mid
    out$height <- ydim$length

    out
  }
)

# Adaptation of tapply that returns a data frame instead of a matrix
tapply_df <- function(x, index, fun, ..., drop = TRUE) {
  labels <- lapply(index, ulevels)
  out <- expand.grid(labels, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)

  grps <- split(x, index)
  names(grps) <- NULL
  out$value <- unlist(lapply(grps, fun, ...))

  if (drop) {
    n <- vapply(grps, length, integer(1))
    out <- out[n > 0, , drop = FALSE]
  }

  out
}


library("factoextra")
library("reshape2")

podatki <- dcast(cetrtatabela, DRZAVA + LETO ~ NAMENPORABEGDP)
podatki <- subset(podatki, DRZAVA=="Slovenija"|DRZAVA=="Velika Britanija"|DRZAVA=="Luksemburg"|
                     DRZAVA=="Švedska"|DRZAVA=="Estonija"|DRZAVA=="Turčija"|DRZAVA=="Litva"|
                     DRZAVA=="Bolgarija"|DRZAVA=="Hrvaška"|DRZAVA=="Nemčija"|DRZAVA=="Španija"|
                     DRZAVA=="Francija"|DRZAVA=="Romunija"|DRZAVA=="Nizozemska"|DRZAVA=="Italija")
rownames(podatki) <- paste(podatki$DRZAVA, podatki$LETO, sep =", ")
podatki <- na.omit(podatki)[-c(1,2)]
podatki$`DELEŽ BDP, NAMENJEN VAROVANJU OKOLJA` <- podatki$`DELEZ BDP, NAMENJEN VAROVANJU OKOLJA V OKVIRU JAVNEGA SEKTORJA` + podatki$`DELEZ BDP, NAMENJEN VAROVANJU OKOLJA V OKVIRU INDUSTRIJE`
podatki$`DELEŽ BDP, NAMENJEN INVESTICIJAM V VAROVANJE OKOLJA` <- podatki$`DELEZ BDP, NAMENJEN INVESTICIJAM ZA VAROVANJE OKOLJA, PORABLJENIM V JAVNEM SEKTORJU` + podatki$`DELEZ BDP, NAMENJEN INVESTICIJAM ZA VAROVANJE OKOLJA, PORABLJENIM V INDUSTRIJI`
podatki <- podatki[-c(1,2,3,4)]

fviz_nbclust(podatki, kmeans, method = "gap_stat")
neki <- kmeans(podatki, 3)
graf4 <- fviz_cluster(neki, data = podatki, main = "DELEŽ GDP, NAMENJEN VAROVANJU OKOLJA IN INVESTICIJAM VANJ",
             ellipse.type = "convex",
             ggtheme = theme_minimal())

tabela <- na.omit(tabela1)
graf5 <- ggplot(tabela) + aes(x=LETO, y=`EMISIJE TOPLOGREDNIH PLINOV V TONAH`) + geom_point() + geom_smooth(method = "lm")


#
# This (currently incomplete) R script is intended to extract equations
# from the BIOPAK equation library, parse them into executable R
# functions, and apply them appropriately to the individual tree records
# in the "FIA_indivtrees.csv" file.
#
# The code is mostly working (in prototype fashion), but some issues
# are:
# - Matching up of species codes in the FIA data and in the equation
#   library is imperfect. Several issues still to work out here.
# - In cases where there are more than one equation for the same quantity
#   for a particular tree species, the code currently just takes the
#   mean of the different outputs
# - Parts of the code might break if you change things like column
#   headers, etc. This could be handled easily enough with function
#   arguments, but for the most part isn't yet.
# - Speed problems: The cast/melt statement that converts the final list
#   into a table is slooooooowwwww on the full 230k+ record FIA dataset.
#   Note that everything before that happens in <10 minutes, which is
#   not great but probably fast enough. Almost certainly can do some
#   things to make the code faster if necessary. Also note that
#   performance would probably get worse if you wanted more advanced
#   logic about which equation to use in particular cases.
#
# Note: the "reshape" package is currently required, although this may
# change
#
# Author: Jim Regetz, with David LeBauer (Functional Ecology DGS)
# Created on 28-Mar-2008
# NCEAS

library(reshape)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function definitions

# Formula generator. Takes a character string of a BIOPAK equation, and
# converts the right hand side of the equation into an executable R
# expression. This expression is returned as a function. Currently only
# works if the RHS of the equation only has numeric constants, standard
# math operators, and the variable "DBH". If the equation give the LHS
# as ln(varname), the result is exponentiated.
getEquation <- function(equation) {

 equation <- as.character(equation)
 ln <- log

 eq.split <- strsplit(equation, " = ")[[1]]

 LHS <- eq.split[1]
 responseName <- gsub("^ln\\(([[:alpha:]]*)\\)", "\\1", LHS)

 RHS <- eq.split[2]

 function(DBH) {
   ans <- eval(parse(text=RHS))
   if (substr(LHS, 1, 2)=="ln") ans <- exp(ans)
   names(ans) <- responseName
   return(ans)
 }

}

# Function to apply the equations to each tree (row) of an input
# dataframe that contains (at least) a "spp" column (4-letter species
# codes used in the BIOPAK equation library) and a "dbh" column
# (numeric dbh values)
runEquations <- function(dat, sp.col, dbh.col) {
 mapply(function(id, spp, dbh) sapply(equation[[spp]],
   function(calc) calc(dbh)), id=seq_len(nrow(dat)),
   spp=as.character(dat[,sp.col]), dbh=dat[,dbh.col], SIMPLIFY=FALSE)
}

# Function to take the mean of calculated variables in cases where more
# than one equation is used for the same outcome variable
getMeans <- function(listOfVals) {
 lapply(listOfVals, function(x) tapply(x, names(x), mean))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# Read in some input data
eqlib <- read.csv("biolib10.csv")
fiadb <- read.csv("FIA_individtrees.csv", row.names=1)
spcodes <- read.csv("spcodes.csv", fill=TRUE)
spcodes$autocode <- toupper(paste(substr(spcodes$Genus, 1, 2),
 substr(spcodes$Species, 1, 2), sep=""))

# --- TEMPORARY --- #
# Add a new column for 4-letter species code by automatically combining
# the first 2 letters of the genus name with the first two letters with
# the species name (both as given in Table 4 of [whatever it is].
fiadb <- merge(fiadb, spcodes[c("FIA.ID", "autocode")], by.x="FIA.SPCD",
 by.y="FIA.ID", sort=FALSE, all.x=TRUE)
# ----------------- #

# Reduce equation library to the relevant subset of equations
responses <- c("BAT", "BBD", "BBL", "BBT", "BFN", "BFT", "BRT", "BSB",
 "BST", "BSW", "PFT")
eqlib.sub <- subset(eqlib, LIFEFORM=="T" & PA1_CODE=="DBH" & is.na(PA2_CODE) &
 BIO_COMP %in% responses)
eqlib.sub$SPP_CODE <- as.character(eqlib.sub$SPP_CODE)
eqlib.sub$BPK_EQFM <- as.character(eqlib.sub$BPK_EQFM)

# Parse the equations for each species into executable R functions
# stored in a list
equation <- sapply(unique(eqlib.sub$SPP_CODE), function(sp)
 lapply(eqlib.sub$BPK_EQFM[eqlib.sub$SPP_CODE==sp], getEquation))

# Generate fake data
#numInd <- 1000
#testdata <- data.frame(
#  id=seq_len(numInd),
#  spp=sample(eqlib.sub$SPP_CODE, numInd, replace=TRUE),
#  DBH=runif(numInd, 1, 100)
#)

# Run the equations on each individual. Then in cases where there are
# multiple estimated values for a given variable (b/c multiple equations
# in the equation library for this species), take the mean
allVals <- runEquations(fiadb, sp.col="autocode", dbh.col="FIA.DIA")

# TEMPORARY HACK? #
# This deals with null elements that arise in the allVals when running
# the code on the FIA data. My UNCONFIRMED suspicion is that these nulls
# arise when species codes in the data are not matched by any species
# codes in the equations list. Obviously this should be handled in the
# "runEquations" functions, but isn't yet.
allVals <- allVals[sapply(allVals, function(x) length(x)>0)]
#-----------------#

meanVals <- getMeans(allVals) # Turn the ragged list above into a dataframe, and clean up
meanValsDF <- cast(melt(meanVals), L1 ~ indicies)

#---THIS LAST STEP TAKES A LONG TIME WITH THE FULL FIA DATA---#:w
# Merge calculated values with the original FIA table
# next line gets error "Error in as.data.frame(y) : object "meanValsDF" not found" :

# result <- merge(fiadb, meanValsDF, by.x=0, by.y="L1", sort=FALSE)


## # Gene expression analysis
##
## Perform a (fairly meaningless) gene expression analysis on some samples. The
## data comes from [Rudolph, Schmitt *& al.* (2016)][@Rudolph2016]. The full
## data can be found [on
## figshare](https://dx.doi.org/10.6084/m9.figshare.2056227.v1).

#+ packages, echo=FALSE, message=FALSE
box::use(
    dplyr[...],
    ggplot2[...],
    knitr,
    readr,
    tibble
)

options(readr.num_columns = 0)

#+ load-data
expression_data = readr$read_tsv(box::file('data/rnaseq-vst.tsv'))
library_design = readr$read_tsv(box::file('data/rnaseq-design.tsv'), col_names = c('ID', 'Condition'))

linkify = function (gene_id) {
    sprintf('%s', gene_id, gene_id)
}

top_genes = readr$read_tsv(box::file('data/rnaseq-top-10-genes.tsv')) %>%
    mutate(Gene = linkify(Gene))

## To verify that biological replicates cluster together, we can perform a PCA:

#+ prcomp
expr_matrix = expression_data %>%
    as.data.frame() %>%
    tibble$column_to_rownames('Gene') %>%
    as.matrix()
pca = prcomp(t(expr_matrix))
pcx = pca$x %>%
    as.data.frame() %>%
    tibble$rownames_to_column('Library') %>%
    inner_join(library_design, by = c('Library' = 'ID'))

var_expl = function (pca, axis) {
    vars = pca$sdev ^ 2
    (vars / sum(vars))[axis] * 100
}

#+ pca-scatter-plot, fig.width=4, fig.height=4
ggplot(pcx) +
    aes(x = PC1, y = PC2, color = Condition) +
    geom_point() +
    labs(
        x = sprintf('PC1 (%0.0f%% variance explained)', var_expl(pca, 1)),
        y = sprintf('PC2 (%0.0f%% variance explained)', var_expl(pca, 2))
    ) +
    theme_minimal()

## Here’s a table of the top `r nrow(top_genes)` genes:

#+ top-genes, echo=FALSE, results='asis'
knitr$kable(top_genes)

## [@Rudolph2016]: http://dx.doi.org/10.1371/journal.pgen.1006024 "Rudolph, Schmitt & al., Codon-Driven Translational Efficiency Is Stable across Diverse Mammalian Cell States. PLoS Genet; 2016"


require('hash')

#define hash to lookup column numbers using strings
outcome_hash <- hash()
outcome_hash["heart attack"] <-  11
outcome_hash["heart failure"] <-  17
outcome_hash["pneumonia"] <-  23

rankall <- function(outcome, num = "best") {
	data = read.csv("./rprog-data-ProgAssignment3-data/outcome-of-care-measures.csv", colClasses = "character")

	#validations

	#check if the outcome is correct
	if (!has.key(outcome,outcome_hash)){
		stop("invalid outcome")
	}

	#extract the rows for the state we need, and keep the columns for hospital, state and userdefined mortality
	df = data[ , c(2,7, outcome_hash[[outcome]]) ]

	#assign friendly names to columns
	colnames(df) <- c('hospital','state','mortality')

	#convert the mortality column into numeric type
	df$mortality = as.numeric(as.character(df$mortality))

	#removed rows where mortality is NA
	df = na.omit(df)

	#order the dataframe by mortality and then by hospital
	df = df[order(df$state, df$mortality, df$hospital), ]

	#Split the dataframe based on state
	df_list <- split( df , df$state )

	#return the first row as result

	if(num == "best") num <- 1

	if(num == "worst"){
		as.data.frame(do.call(rbind,  lapply(df_list, function(x){ x[ nrow(x) ,]} ) ))
	}
	else{
		as.data.frame(do.call(rbind,  lapply(df_list, function(x){ x[num,]} ) ))
	}
}

head(rankall("heart attack", 20), 10)
#tail(rankall("pneumonia", "worst"), 3)
#tail(rankall("heart failure"), 10)


################################################################################
# hapDistMatrix_withinBetweenComplete function  - (matrix)
#
# Author: Heidi Lischer
# Date: 10.2008
################################################################################

hapDistMatrix_withinBetweenComplete <- function(hapDistMatrixLabels,
                                hapDistMatrix, absHapMatrix, timeAttr, outfile){

 #get pop names, hap names and absHapFrequeny matrix
 popNames <- absHapMatrix[1, 2:ncol(absHapMatrix)]
 hapNames <- absHapMatrix[2:nrow(absHapMatrix), 1]
 hapNames <- gsub(" ", "", hapNames)   # trim white space
 absHapFreq <- absHapMatrix[2:nrow(absHapMatrix), 2:ncol(absHapMatrix)]

 #get list of all haplotypes in all populations --------------------------------
 popSizeList <- list()
 hapList <- c(NULL)
 s <- 1
 for ( i in 1:ncol(absHapFreq)){
    popSize <- 0
    for(n in 1:length(absHapFreq[,i])){
      absFreq <- as.numeric(absHapFreq[n, i])
      if(absFreq != 0){
        for(t in 1: absFreq){
          hapList[s] <- hapNames[n]
          s <- s + 1
          popSize <- popSize + 1
        }
      }
    }
    popSizeList[[i]] <- popSize
 }

  # get whole DistanceMatrix (upper and under) ---------------------------------
  dimnames(hapDistMatrix) <- list(hapDistMatrixLabels, hapDistMatrixLabels)

  wholeDistanceMatrix <- hapDistMatrix
  for(x in 1:ncol(wholeDistanceMatrix)){
   twholeDistanceMatrix <- t(wholeDistanceMatrix)
   wholeDistanceMatrix[x,(x:ncol(wholeDistanceMatrix))]<-twholeDistanceMatrix[x,
                                                  (x:ncol(wholeDistanceMatrix))]
  }

  #get complete distance matrix (all populations included) ---------------------
  Length <- length(hapList)

  #get all rows
  distanceMatrix <- wholeDistanceMatrix[hapList[1],]
  for(i in 2:Length){
    distanceMatrix <- rbind(distanceMatrix, wholeDistanceMatrix[hapList[i],])
  }

  #get all columns and include only half matrix
  distanceMatrixComplete <- distanceMatrix[, hapList[1]]
  for(i in 2:Length){
    nextCol <- as.matrix(distanceMatrix[i:Length,hapList[i]])
    distanceMatrixComplete <- cbind(distanceMatrixComplete, rbind( matrix(NA,
                                                 ncol=1, nrow=(i-1)), nextCol))
  }

  #draw graphic ----------------------------------------------------------------
  # Mirror matrix (left-right)----
  mirror.matrix <- function(x) {
    xx <- as.data.frame(x);
    xx <- rev(xx);
    xx <- as.matrix(xx);
    xx;
  }

  # Rotate matrix 270 clockworks----
  rotate270.matrix <- function(x) {
    mirror.matrix(t(x))
  }

  distanceMatrixComplete <- rotate270.matrix(distanceMatrixComplete)

  # draw matrix -------------------------------
   ColorRamp <- colorRampPalette(c("white", "steelblue1", "blue3"))

   nCol <- ncol(distanceMatrixComplete)
   nRow <- nrow(distanceMatrixComplete)

   outfileGraphic <- paste(outfile, "hapDistMatrix_withinBetweenComplete ",
                             timeAttr, ".png", sep="")

   #save graphic
   png(outfileGraphic, width=1300, height=1300, res=144)

      smallplot <- c(0.874, 0.9, 0.18, 0.83)
      bigplot <- c(0.13, 0.85, 0.14, 0.87)

      old.par <- par(no.readonly = TRUE)

        #draw legend -----------------------------------
        par(plt = smallplot)

        # get legend values
        Min <- min(distanceMatrixComplete, na.rm=TRUE)
        Max <- max(distanceMatrixComplete, na.rm=TRUE)
        binwidth <- (Max - Min) / 64
        y <- seq(Min + binwidth/2, Max - binwidth/2, by = binwidth)
        z <- matrix(y, nrow = 1, ncol = length(y))

        image(1, y, z, col = ColorRamp(64),xlab="", ylab="", axes=FALSE)

            #adjust axis if only one value exists
            if(Min == Max){
              axis(side=4, las = 2, cex.axis=0.8, at=Min, labels=round(Min, 2))
            } else {
              axis(side=4, las = 2, cex.axis=0.8)
            }

            box()
            mtext(text="Number of pairwise differences", side=4,line=2.2,font=2)

        #draw main graphic -----------------------------
        par(new = TRUE, plt = bigplot)

        image(c(1:nCol), c(1:nRow), distanceMatrixComplete, col=ColorRamp(64),
               main="Molecular distances within and between populations",
               ylab="", xlab="", axes=FALSE)

            box()

            # add lines which seperate the populations
            nRowShort <- 0
            for(i in 1: (length(popSizeList)-1)){
              nRowShort <- nRowShort + popSizeList[[i]]
              nRowLong <- nrow(distanceMatrixComplete) - nRowShort

              lines(c(0, nRowShort + 0.5),c(nRowLong + 0.5, nRowLong + 0.5), lty=2)
              lines(c(nRowShort + 0.5, nRowShort + 0.5),c(0, nRowLong + 0.5), lty=2)
            }

            lines(c(0, nrow(distanceMatrixComplete)),
                  c(nrow(distanceMatrixComplete), 0), lty=2)

            # add population indexes
            nRow <- 0
            Legend <- c(NULL)
            for(i in 1: length(popNames)){
              nRow2 <- popSizeList[[i]]
              rowText <- nRow + (nRow2 /2)
              nRow <- nRow + nRow2

              mtext(side = 1, at = rowText + 0.5, line = 0.5, text =popNames[i],
                     cex=0.8, las = 2)
              mtext(side = 2, at = nrow(distanceMatrixComplete) - rowText + 0.5,
                     line = 0.7, text = popNames[i], cex=0.8, las=2, , las = 2)

            }

        par(old.par)  #reset graphic parameters

   dev.off()

}


##' @title
##' Classification Optimal Cutoff
##'
##' @description Optimal cutoff
##'
##' @inheritParams classification_params
##' @param objective \code{[character]}
##' @return A scalar numeric output
##' @author An Chu
mtr_optimal_cutoff <- function(actual, predicted,
                               objective = c("positive_class", "negative_class",
                                             "both", "missclassified_error")) {

    check_equal_length(actual, predicted)
    check_binary(actual)

    objective <- match.arg(objective)
    thresholds <- seq(min(predicted), max(actual), 0.01)

    pos_idx <- which()
    neg_idx <- which()
    both_idx <- which()
    mce_idx <- which()

    optimal_cutoff <- switch(
        objective,
        positive_class = {thresholds[pos_idx]},
        negative_class = {thresholds[neg_idx]},
        both = {thresholds[both_idx]},
        missclassified_error = {thresholds[mce_idx]}
    )

    optimal_cutoff
}


# Run the code below to set up the data
# Change the plot to use a facet_wrap by name

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

# Change the plot to use a facet_wrap by name

ggplot(unisex_data, aes(x=Male, y=Female)) +
  geom_point() +
  theme_minimal() +
  facet_wrap(~name)

# Bonus: Reverse the order of the names in the facets

ggplot(unisex_data, aes(x=Male, y=Female)) +
  geom_point() +
  theme_minimal() +
  facet_wrap(~factor(name, levels=rev(unique(name))))


cube <- function(x) {
 x * x * x
}


#' Title
#'
#' @param HPOpatient
#'
#' @return
#' @export
#'
#' @examples
proteinScore<-function(HPOpatient)
{
    library(igraph)
    library(Matrix)

    HPO2genes<-HPO2genes
    treureHPO<-treureHPO
    HPOqueryGene<-HPOqueryGene
    total_unique<-total_unique

    g1<-as.undirected(g1)
    HPOpatient<-as.matrix(unique(HPOpatient))

    treureHPO <- paste(treureHPO,collapse="|")
    posTreure<-grep(treureHPO, HPO2genes[,2])
    if(length(posTreure)>0) HPO2genes<-HPO2genes[-posTreure,]

    # Delete some irrelevant HPOs
    posTreure<-grep(treureHPO, HPOpatient)
    if(length(posTreure)>0) HPOpatient<-HPOpatient[-posTreure]

    #create a subgraph with the expanded (1 order) patient HPOs
    HPOorig_expanded<-unique(unlist(sapply(HPOpatient, function (x) rownames(as.matrix(igraph::ego(g1, order = 1, x)[[1]])))))
    g.sub <- induced.subgraph(graph = g1, HPOorig_expanded)
    res<-cluster_edge_betweenness(g.sub)
    HPOorig_expanded<-cbind(res$names,res$membership)
    HPOorigGroups <<- HPOorig_expanded[match(HPOpatient,HPOorig_expanded[,1]),]

    genes <<- unique(HPO2genes[, 1]) #genes with HPO
    posGenes<-match(genes,rownames(HPOadj))
    acumulat<-Matrix(matrix(0,ncol = 1,nrow =length(rownames(HPOadj)[posGenes])))
    acumulatFreq<-acumulat

    for(z in 1:length(HPOpatient))
    {
      pos<-match(HPOpatient[z],colnames(HPOadj))
      HPOPatientItem = HPOdistance[pos,]
      column<-HPOadj[posGenes,] %*% HPOPatientItem
      acumulat<-cbind(acumulat,column)
    }
    acumulat<-acumulat[,-1]

    if(length(HPOorigGroups[,2])!=length(unique(HPOorigGroups[,2])))
    {
      memo = ""
      dupli =  unique(HPOorigGroups[duplicated(HPOorigGroups[,2]),2])
      for(i in 1:length(dupli))
      {
        pos<-which(HPOorigGroups[,2] == dupli[i])
        new<-Matrix::rowSums(acumulat[,pos])
        acumulat[,pos[1]]<-new
        memo<-c(memo,pos[-1])
      }
      memo <- memo[-1]
      acumulat<-acumulat[,-as.numeric(memo)]

    }

    acumulat = acumulat / acumulat
    acumulat[is.na(acumulat)]=0
    acumulat = Matrix(acumulat)
    HPOmatch_quant<-Matrix::rowSums(acumulat)

    q=HPOmatch_quant-1
    m=length(unique(HPOorigGroups[,2]))
    n=length(V(g1)$name)-length(unique(HPOorigGroups[,2]))
    k=as.matrix(HPOqueryGene)*10
        stats<-phyper(q,m,n,k,lower.tail = FALSE, log.p = FALSE)
    gc()
    stats[stats == -Inf] = 1
    stats[stats == 0] = 10^(log10(min(stats[stats != 0]))-1)
    testResult<-stats

    D = abs(log10(abs(testResult)))
    Dred <- as.numeric(D)
    pos <- match(genes, total_unique[,2])
    D <- matrix(0, nrow = length(total_unique[,2]))
    D[pos] <- Dred
    DNormed <- (D - min(D, na.rm = TRUE))/(max(D, na.rm = TRUE) - min(D, na.rm = TRUE))
    Y = 1/(1 + exp((DNormed * (-12)) + log(9999)))
    Y = as.numeric(Y)

   return(Y)
}


residplot <- function(residuals, xpos, ypos, maxsize = 0.25, poscol = 2, linecol = 1, lwd = 1,
                   n = 50, maxn, negcol, txt = FALSE, csi = 0.1, xlab = "", ylab = "", main="", axes = T,
                   arg = T, argcol = 20, arglty = 2, cn = c("x", "y", "z"), append = F,refdot=F,start.year=0,end.year=0)
{
    par(err = -1)
    if(is.data.frame(residuals)) {
        x <- residuals[, cn[1]]
        y <- residuals[, cn[2]]
        residuals <- residuals[, cn[3]]
    }
    else {
        residuals <- t(residuals)
        max.r <- max(abs(residuals), na.rm = T)

        if(missing(maxn))
            maxn <- max(abs(residuals), na.rm = T)
        if(missing(xpos))
            xpos <- 1:nrow(residuals)
        if(missing(ypos))
            ypos <- 1:ncol(residuals)
        x <- matrix(xpos, length(xpos), length(ypos))
        y <- matrix(ypos, length(xpos), length(ypos), byrow = T)
    }
    if(refdot) add.year<-6 else add.year<-2
    xx<-x;
    xx[1,1]<-min(x)-2
    if (start.year >0) xx[1,1]<-start.year
    xx[1,2]<-max(x)+add.year
    if (end.year>0)xx[1,2]<-end.year

    plot(xx, y, type = "n", xlab = xlab, ylab = ylab, axes = FALSE, main=main, las=1,ylim=c(min(y)-0.5,max(y)+0.5))
    axis(1)
    axis(2,min(ypos):max(ypos), tick=F,las=2)

    box()
    x.bck <- x
    y.bck <- y
    if(arg) {
        r <- x.bck - y.bck
        tmp <- unique(r)
        for(i in 1:length(tmp)) {
            j <- r == tmp[i]
            lines(x.bck[j], y.bck[j], col = argcol, lty = arglty)
        }
    }
    plt <- par()$pin
    xscale <- (par()$usr[2] - par()$usr[1])/plt[1] * maxsize
    yscale <- (par()$usr[4] - par()$usr[3])/plt[2] * maxsize
    rx <- c(unlist(sqrt(abs(residuals)/maxn) * xscale))
    ry <- c(unlist(sqrt(abs(residuals)/maxn) * yscale))
    theta <- seq(0, 2 * pi, length = n)
    n1 <- length(rx)
    theta <- matrix(theta, n1, n, byrow = T)
    x <- matrix(x, n1, n)
    y <- matrix(y, n1, n)
    rx <- matrix(rx, n1, n)
    ry <- matrix(ry, n1, n)
    x <- x + rx * cos(theta)
    y <- y + ry * sin(theta)
    x <- cbind(x, rep(NA, nrow(x)))
    y <- cbind(y, rep(NA, nrow(y)))
    x<-x
    i <- residuals > 0

    if(any(i)) {
        polygon(c(t(x[i,  ])), c(t(y[i,  ])), col = poscol)
        lines(c(t(x[i,  ])), c(t(y[i,  ])), col = linecol, lwd = lwd)
    }
    i <- residuals < 0
    if(any(i)) {
        if(!missing(negcol))
            polygon(c(t(x[i,  ])), c(t(y[i,  ])), col = negcol)
        lines(c(t(x[i,  ])), c(t(y[i,  ])), col = linecol, lwd = lwd)
    }
    if(txt)text(x.bck, y.bck, as.character(round(residuals)), csi = csi)

    if(refdot){
     # if (end.year==0) x <- max(xpos)+4 +xscale*cos(theta)
     # if (end.year>0)  x <- end.year-1 +xscale*cos(theta)
     if (end.year==0) x <- max(xpos)+4 +sqrt(max.r/maxn) * xscale*cos(theta)
     if (end.year>0)  x <- end.year-1  +sqrt(max.r/maxn) * xscale*cos(theta)

      #y <- max(max(ypos)%/%3+min(ypos),1) + yscale*sin(theta)
      y <- max(max(ypos)%/%3+min(ypos),1) +sqrt(max.r/maxn)* yscale*sin(theta)
      polygon(x, y, col = 7)
      if (end.year==0) text(max(xpos)+4, max(max(ypos)%/%3+min(ypos),1), as.character(round(max.r,digit=2)))
      if (end.year>0) text(end.year-1, max(max(ypos)%/%3+min(ypos),1), as.character(round(max.r,digit=2)))
    }
    return(invisible())
}


dest <- fread('c:/perforce/daniel/ex/orig_data/destinations.csv')

train_13[hotel_continent==2 & hotel_market==701 & srch_destination_id==8260][,.N,by=hotel_cluster][order(-N)][1:10]

train_13[hotel_continent==2 & hotel_market==628][,.N,by=srch_destination_id][order(+N)][1:10]

clusters <- kmeans(dest[,2:150,with=F],50000,iter.max=100)
dest$cluster <- clusters$cluster
destClusters <- dest[,c('srch_destination_id','cluster'),with=F]
write.csv(destClusters,'c:/perforce/daniel/ex/statistics/clusterByDest_50k.csv',row.names=F,quote=F)


load("temporal_edgelist.Rdata")

library(igraph)
library(plyr)
library(RColorBrewer)

n_slices <- 60

dseq <- seq(from=min(temporal_edgelist$time), to=max(temporal_edgelist$time), length.out = n_slices)
xseq <- seq(from=min(temporal_edgelist$time), to=max(temporal_edgelist$time), length.out = n_slices + n_slices - 1)
xseq <- xseq[!xseq %in% dseq]

temporal <- list()
aggregated <- list()
for(i in c(2:length(dseq)))
{
  tweets <- subset(temporal_edgelist, time >= dseq[i-1] & time <= dseq[i])
  a_tweets <- subset(temporal_edgelist, time <= dseq[i])
  temporal[[i-1]] <- graph.data.frame(tweets)
  aggregated[[i-1]] <- graph.data.frame(a_tweets)
}

complete <- graph.data.frame(temporal_edgelist)
complete_layout <- layout.fruchterman.reingold(complete, area = 50*vcount(complete)^2)
comms <- walktrap.community(complete, steps=10)

comm_color <- colorRampPalette(brewer.pal(10, 'Spectral'))(length(unique(comms$membership)))[comms$membership]

plot(complete, layout=complete_layout, vertex.label=NA, vertex.frame.color=NA, vertex.color=comm_color, edge.arrow.size=0, vertex.size=5)

# v_index <- c(1:vcount(complete))
# names(v_index) <- V(complete)$name
# png(file = "temp_%04d.png", width = 950, height = 950)
# for(i in c(1:length(temporal)))
# {
#   temp <- temporal[[i]]
#   plot(complete, layout=complete_layout,
#        rescale = FALSE,
#        xlim=range(complete_layout[,1]), ylim=range(complete_layout[,2]),
#        vertex.label=NA, vertex.size=2,
#        vertex.color='lightgrey',
#        vertex.frame.color='darkgrey',
#        edge.color='lightgrey',
#        edge.arrow.size=0)
#   title(xseq[i])
#   t_vertices <- v_index[V(temp)$name]
#   plot(temp, layout=complete_layout[t_vertices,],
#        add=TRUE, rescale=FALSE,
#        vertex.color='purple',
#        vertex.frame.color='purple',
#        vertex.size=5,
#        edge.arrow.size=0,
#        vertex.label=NA,
#        xlim=range(complete_layout[,1]), ylim=range(complete_layout[,2]),
#        edge.color='black')
# }
# dev.off()
#
# # The we use ImageMagick to convert all images to a gif file
# system("convert -delay 50 temp_*.png animation_esa.gif")
# # And remove the images
# file.remove(list.files(pattern = "temp_"))


library(shiny)
library(dygraphs)

# Define UI for application that draws a histogram
shinyUI(fluidPage(

  navbarPage(
    theme = "cerulean",  # <--- To use a theme, uncomment this
    "Aplicacion para Series de Tiempo",
    tabPanel("Cargar Serie",
             sidebarLayout(
               sidebarPanel(
                 fileInput('file1', 'Elija Archivo',
                           accept=c('text/csv',
                                    'text/comma-separated-values,text/plain',
                                    '.csv')),
                 checkboxInput('header', 'Cabecera', FALSE),
                 selectInput('sep', 'Separador',
                             c('Coma'=',',
                               'Punto y coma' =';',
                               'Tabulador' ='\t'),
                             '\t'),
                 selectInput('deci', 'Separador decimal',
                             c('Coma'=",",
                               'Punto'="."),
                             ","),
                 hr(),

                 selectInput('frec', 'Periodicidad:',
                             c('Diaria'="days",
                               'Mensual'="month",
                               'Trimestral'="quarter",
                               'Anual'="years"),
                             "Diario"),
                 dateInput("fecha", "Fecha Inicio:", value = "2017-09-29"),
                 div(strong("Desde: "), textOutput("from", inline = TRUE)),
                 div(strong("Hasta: "), textOutput("to", inline = TRUE)),
                 hr(),
                 selectInput('xcol', 'X Variable', "")

               ),
               mainPanel(
                 dygraphOutput("dygraph")
               )
             )

    ),
    tabPanel("Analisis Inicial",
             tabsetPanel(type = "tabs",
                         tabPanel("LM", sidebarPanel(
                           radioButtons("tipo", "Tipo:",
                                        c("Aditivo" = "Aditivos",
                                          "Multiplicativo" = "Multiplicativos"), "Aditivos"),
                           radioButtons("metodo", "Grado:",
                                        c("Lineal" = "Lineal",
                                          "Cuadratico" = "Cuadratico",
                                          "Cubico" = "Cubico",
                                          "Orden 4" = "Orden 4"), "Lineal"),
                           checkboxInput("est", "Estacionaria", FALSE),

                           br(),

                           checkboxInput("show.resid", "Show residuals", FALSE),

                           br(),

                           helpText("Texto de ayuda."),
                           br()),
                           mainPanel(
                             plotOutput("scatter"),
                             br(),
                             br(),
                             plotOutput("residuals")

                           )),
                         tabPanel("Holt-Winter", sidebarPanel(
                           radioButtons("tipohw", "Tipo:",
                                        c("Aditivo" = "Aditivos",
                                          "Multiplicativo" = "Multiplicativos"), "Aditivos"),

                           br(),

                           checkboxInput("show.resid", "Show residuals", FALSE),

                           br(),

                           helpText("Texto de ayuda."),
                           br()),
                           mainPanel(
                           plotOutput("scatter2"),
                           br(),
                           br(),
                           plotOutput("residuals2")

                            )),
                         tabPanel("Descomposicion y LOESS", sidebarPanel(
                           radioButtons("tipolo", "LOESS:",
                                        c("Lineal" = "Lineal",
                                          "Cuadratico" = "Cuadratico"), "Lineal"),
                           radioButtons("tipob", "Descomposicion:",
                                        c("Aditivo" = "Aditivos",
                                          "Multiplicativo" = "Multiplicativos"), "Aditivos"),

                           br(),

                           checkboxInput("show.resid", "Show residuals", FALSE),

                           br(),

                           helpText("Texto de ayuda."),
                           br()),
                           mainPanel(
                             plotOutput("scatter3"),
                             br(),
                             br(),
                             plotOutput("residuals3")

                           ))
             )
    ),
    tabPanel("Resultados", "Este panel muestra los resultados")
  )
))


context("cast")

s2 <- array(seq.int(3 * 4), c(3,4))
s2m <- melt(s2)
colnames(s2m) <- c("X1", "X2", "value")

s3 <- array(seq.int(3 * 4 * 5), c(3,4,5))
s3m <- melt(s3)
colnames(s3m) <- c("X1", "X2", "X3", "value")

test_that("reshaping matches t and aperm", {
  # 2d
  expect_equivalent(s2, acast(s2m, X1  ~  X2))
  expect_equivalent(t(s2), acast(s2m, X2  ~  X1))
  expect_equivalent(as.vector(s2), as.vector(acast(s2m, X2 + X1  ~  .)))

  # 3d
  expect_equivalent(s3, acast(s3m, X1  ~  X2  ~  X3))
  expect_equivalent(as.vector(s3), as.vector(acast(s3m, X3 + X2 + X1  ~  .)))
  expect_equivalent(aperm(s3, c(1,3,2)), acast(s3m, X1  ~  X3  ~  X2))
  expect_equivalent(aperm(s3, c(2,1,3)), acast(s3m, X2  ~  X1  ~  X3))
  expect_equivalent(aperm(s3, c(2,3,1)), acast(s3m, X2  ~  X3  ~  X1))
  expect_equivalent(aperm(s3, c(3,1,2)), acast(s3m, X3  ~  X1  ~  X2))
  expect_equivalent(aperm(s3, c(3,2,1)), acast(s3m, X3  ~  X2  ~  X1))
})

test_that("aggregation matches apply", {

  # 2d -> 1d
  expect_equivalent(colMeans(s2), as.vector(acast(s2m, X2  ~  ., mean)))
  expect_equivalent(rowMeans(s2), as.vector(acast(s2m, X1  ~  ., mean)))

  # 3d -> 1d
  expect_equivalent(apply(s3, 1, mean), as.vector(acast(s3m, X1  ~  ., mean)))
  expect_equivalent(apply(s3, 1, mean), as.vector(acast(s3m, .  ~  X1, mean)))
  expect_equivalent(apply(s3, 2, mean), as.vector(acast(s3m, X2  ~  ., mean)))
  expect_equivalent(apply(s3, 3, mean), as.vector(acast(s3m, X3  ~  ., mean)))

  # 3d -> 2d
  expect_equivalent(apply(s3, c(1,2), mean), acast(s3m, X1  ~  X2, mean))
  expect_equivalent(apply(s3, c(1,3), mean), acast(s3m, X1  ~  X3, mean))
  expect_equivalent(apply(s3, c(2,3), mean), acast(s3m, X2  ~  X3, mean))
})

names(ChickWeight) <- tolower(names(ChickWeight))
chick_m <- melt(ChickWeight, id=2:4, na.rm=TRUE)

test_that("aggregation matches table", {
  tab <- unclass(with(chick_m, table(chick, time)))
  cst <- acast(chick_m, chick  ~  time, length)

  expect_that(tab, is_equivalent_to(cst))
})

test_that("grand margins are computed correctly", {
  col <- acast(s2m, X1  ~  X2, mean, margins = "X1")[4, ]
  row <- acast(s2m, X1  ~  X2, mean, margins = "X2")[, 5]
  grand <- acast(s2m, X1  ~  X2, mean, margins = TRUE)[4, 5]

  expect_equivalent(col, colMeans(s2))
  expect_equivalent(row, rowMeans(s2))
  expect_equivalent(grand, mean(s2))
})
#
test_that("internal margins are computed correctly", {
  cast <- dcast(chick_m, diet + chick  ~  time, length, margins="diet")

  marg <- subset(cast, diet == "(all)")[-(1:2)]
  expect_that(as.vector(as.matrix(marg)),
    equals(as.vector(acast(chick_m, time  ~  ., length))))

  joint <- subset(cast, diet != "(all)")
  expect_that(joint,
    is_equivalent_to(dcast(chick_m, diet + chick  ~  time, length)))
})

test_that("missing combinations filled correctly", {
  s2am <- subset(s2m, !(X1 == 1 & X2 == 1))

  expect_equal(acast(s2am, X1  ~  X2)[1, 1], NA_integer_)
  expect_equal(acast(s2am, X1  ~  X2, length)[1, 1], 0)
  expect_equal(acast(s2am, X1  ~  X2, length, fill = 1)[1, 1], 1)

})

test_that("drop = FALSE generates all combinations", {
  df <- data.frame(x = c("a", "b"), y = c("a", "b"), value = 1:2)

  expect_that(as.vector(acast(df, x + y  ~  ., drop = FALSE)),
    is_equivalent_to(as.vector(acast(df, x  ~  y))))

})

test_that("aggregated values computed correctly", {
  ffm <- melt(french_fries, id = 1:4)

  count_c <- function(vars) as.table(acast(ffm, as.list(vars), length))
  count_t <- function(vars) table(ffm[vars], useNA = "ifany")

  combs <- matrix(names(ffm)[1:5][t(combn(5, 2))], ncol = 2)
  a_ply(combs, 1, function(vars) {
    expect_that(count_c(vars), is_equivalent_to(count_t(vars)),
      label = paste(vars, collapse = ", "))
  })

})

test_that("value.var overrides value col", {
  df <- data.frame(
    id1 = rep(letters[1:2],2),
    id2 = rep(LETTERS[1:2],each=2), var1=1:4)

  df.m <- melt(df)
  df.m$value2 <- df.m$value * 2
  expect_that(acast(df.m, id2 + id1  ~  ., value.var="value")[, 1],
    equals(1:4, check.attributes = FALSE))
  expect_that(acast(df.m, id2 + id1  ~  ., value.var="value2")[, 1],
    equals(2 * 1:4, check.attributes = FALSE))
})

test_that("labels are correct when missing combinations dropped/kept", {
  df <- data.frame(fac1 = letters[1:4], fac2 = LETTERS[1:4], x = 1:4)
  mx <- melt(df, id = c("fac1", "fac2"), measure.var = "x")

  c1 <- dcast(mx[1:2, ], fac1 + fac2 ~ variable, length, drop = F)
  expect_that(nrow(c1), equals(16))

  c2 <- dcast(droplevels(mx[1:2, ]), fac1 + fac2 ~ variable, length, drop = F)
  expect_that(nrow(c2), equals(4))

  c3 <- dcast(mx[1:2, ], fac1 + fac2 ~ variable, length, drop = T)
  expect_that(nrow(c3), equals(2))

})

test_that("factor value columns are handled", {
  df <- data.frame(fac1 = letters[1:4], fac2 = LETTERS[1:4], x = factor(1:4))
  mx <- melt(df, id = c("fac1", "fac2"), measure.var = "x")

  c1 <- dcast(mx, fac1 + fac2 ~ variable)
  expect_that(nrow(c1), equals(4))
  expect_that(ncol(c1), equals(3))
  expect_is(c1$x, "character")

  c2 <- dcast(mx, fac1 ~ fac2 + variable)
  expect_that(nrow(c2), equals(4))
  expect_that(ncol(c2), equals(5))
  expect_is(c2$A_x, "character")
  expect_is(c2$B_x, "character")
  expect_is(c2$C_x, "character")
  expect_is(c2$D_x, "character")

  c3 <- acast(mx, fac1 + fac2 ~ variable)
  expect_that(nrow(c3), equals(4))
  expect_that(ncol(c3), equals(1))
  expect_true(is.character(c3))

  c4 <- acast(mx, fac1 ~ fac2 + variable)
  expect_that(nrow(c4), equals(4))
  expect_that(ncol(c4), equals(4))
  expect_true(is.character(c4))

})

test_that("dcast evaluated in correct argument", {
  g <- c("a", "b")
  expr <- quote({
    df <- data.frame(x = letters[1:2], y = letters[1:3], z = rnorm(6))
    g <- c('b', 'a')
    dcast(df, y ~ ordered(x, levels = g))
  })

  res <- eval(expr, envir = new.env())
  expect_equal(names(res), c("y", "b", "a"))

})

test_that(". ~ . returns single value", {
  one <- acast(s2m, . ~ .,  sum)
  expect_equal(as.vector(one), 78)
  expect_equal(dimnames(one), list(".", "."))
})

test_that("drop = TRUE retains NA values", {
  df <- data.frame(x = 1:5, y = c(letters[1:4], NA), value = 5:1)
  out <- dcast(df, x + y ~ .)

  expect_equal(dim(out), c(5, 3))
  expect_equal(out$., 5:1)
})

test_that("useful error message if you use value_var", {
  expect_error(dcast(mtcars, vs ~ am, value_var = "cyl"),
    "Please use value.var", fixed = TRUE)
  expect_equal(dim(dcast(mtcars, vs ~ am, value.var = "cyl")), c(2, 3))

})

test_that("useful error message if value.var doesn't exist", {
  expect_error(dcast(airquality, month ~ day, value.var = "test"),
    "value.var (test) not found in input", fixed = TRUE)
})


library(tidyr)

stocks <- data.frame(
  time = as.Date('2009-01-01') + 0:1,
  X = rnorm(2, 0, 1),
  Y = rnorm(2, 0, 2),
  Z = rnorm(2, 0, 4)
)

# wide format data -> long format data
stocks_long <- gather(stocks, key, value, -time)
head(stocks_long)

# long format data -> wide format data
stocks_wide <- spread(stocks_long, key, value)
head(stocks_wide)


cat(sapply(as.numeric(readLines(tail(commandArgs(), n=1))), function(s) {
  a <- as.integer(s)
  r <- paste(toString(a), ".", sep="")
  s <- (s - a) * 60
  a <- as.integer(s)
  if (a < 10) { f <- "0" } else { f <- "" }
  r <- paste(r, f, toString(a), "'", sep="")
  s <- (s - a) * 60
  a <- as.integer(s)
  if (a < 10) { f <- "0" } else { f <- "" }
  r <- paste(r, f, toString(a), "\"", sep="")
  r
}), sep="\n")


##For non-split BiSSE
##Load dependencies
library(diversitree)
library(ape)
#For this analysis, we use a data file that's been made a little smaller than the 8000-taxon data set. Load it.
data <- read.csv('/home/april/projectfiles/squamates/squam/PyronParityData.csv', row.names=1)
# Initialize vectors. These will be used for formatting output.
output_vector <- vector()
ovip_root_vector <- vector()
vivp_root_vector <- vector()

#File currently set up to accept input from Make, or if trees in working directory
a<- list.files(path='./trees/', pattern="*.tre", full.names=TRUE)

#Main function to fit model to each tree in BS sample
model_fit <- function(tree_list){
for (x in tree_list){
	print(x)
#For each tree in our vector of trees, read it in and distill down the tree to the shared tips between it and the data set
	phy <- read.tree(x)
	pruned.tree<-drop.tip(phy, setdiff(phy$tip.label, row.names(data)))
	sorteddata <- data[phy$tip.label, ]
	no_na <- na.omit(sorteddata)
	names(no_na) <- pruned.tree$tip.label
  	pruned.tree <- multi2di(pruned.tree, random = TRUE)
	#Make the BiSSE function
	func <- make.bisse(pruned.tree, no_na)
	sp<-starting.point.bisse(pruned.tree)
	# Find MLE and use it to do ancestral state reconstruction
	fit_bisse <- find.mle(func, sp)
#	print(fit_bisse)
	st <- asr.marginal(func, coef(fit_bisse))
	#Add root states to a vector of states
	ovip_root_vector <- append(ovip_root_vector, c(st[,2][1], 'Oviparity'))
	vivip_root_vector <- append(ovip_root_vector, c(st[,2][2], 'Viviparity'))
	output_vector <- append(output_vector, c(fit_bisse$par[1:6], fit_bisse$lnLik))
	#Plot tree
	plot(pruned.tree, show.tip.label=FALSE)
	fit_plot <- nodelabels(pie=t(st), piecol=1:2, cex=.5)
	#Output various parameters: the model and ancestral states
}

	lapply(output_vector, write, "model_params.csv", append=TRUE, ncolumns=7)
	lapply(ovip_root_vector, write, "ovip_support.csv", append=TRUE,ncolumns=2)
	lapply(vivip_root_vector, write, "vivip_support.csv", append=TRUE, ncolumns=2)
}

#Call the function if you want
model_fit(a)


#THIS SCRIPT GENERATES THE PLOT FOR THE DIAGONAL K=1 IN THE CONFIGURATION TOTAL_TRIPLE_IN_WINDOW/EW PLOTTING THE FOUR BASELINES IN THE SAME FIGURE IN 4 DIFFERENT PLOTS
#IT USES LOG SCALING

log_plot_dash <- function(x,y,sdx,sdy, col, pch){

  lx <- log(x)
  ly <- log(y)

  par(new=TRUE)
  points(x = lx, y = ly, col=col, type = "p", pch=pch)
  #arrows(lx, log(y-sdy),lx,log(y+sdy),, length=0.05, angle=90, code=3, col="grey55")
  #arrows(log(sdx), ly,log(x+2*sdx),ly, length=0.05, angle=90, code=3, col="gray55")

}

log_dashboard<- function(a,b,c,d, xlim,ylim,ss = c(FALSE, FALSE, FALSE, FALSE, FALSE)){

  exp <- paste(lat_report_rhodf$STREAM[a], substr(lat_report_rhodf$REASONING[a], 0, 6))

  myxlim <- c(0.01, log(xlim[2]))
  myylim <- c(log(ylim[1])-1, log(ylim[2])+10)

  plot(seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.001),seq(min(xlim[1], ylim[1]),max(xlim[2], ylim[2]),0.001), log="xy",  type = "n", ylab = "Memory", xlab = "Latency", xlim=myxlim, ylim=myylim)

  abline( h = seq(0.001, 10, 0.1 ), lty = 3, col = colors()[ 440 ] )
  abline( v = seq(0.001, 10, 0.1 ), lty = 3, col = colors()[ 440 ] )

  z<-a
  if(ss[1]){
    pch <- 0
  }else{
    pch <- 15
  }
  pch_legend <- pch
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z],mem_report_rhodf$A.Dev.Std.SS[z], "red", pch)

  z<-b
  if(ss[2]){
    pch <- 1
  }else{
    pch <- 16
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "blue", pch)

  z<-c
  if(ss[3]){
    pch <- 2
  }else{
    pch <- 17
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "black", pch)

  z <- d
  if(ss[4]){
    pch <- 5
  }else{
    pch <- 18
  }
  pch_legend <- c(pch_legend,pch)
  log_plot_dash(lat_report_rhodf$Mean.SS[z], mem_report_rhodf$A..Mean.SS[z], lat_report_rhodf$Dev.StdSS[z], mem_report_rhodf$A.Dev.Std.SS[z], "chartreuse4", pch)

  legend(x=0.02,y=15,pch=pch_legend,bg = "white",bty="o", legend=c(
    paste( "K", lat_report_rhodf$K[a], "EW", lat_report_rhodf$EW[a]) ,
    paste( "K", lat_report_rhodf$K[b], "EW", lat_report_rhodf$EW[b]) ,
    paste( "K", lat_report_rhodf$K[c], "EW", lat_report_rhodf$EW[c]),
    paste( "K", lat_report_rhodf$K[d], "EW", lat_report_rhodf$EW[d])), cex=1 ,y.intersp=1, col=c("red","blue","black","chartreuse4", "purple"))
  title(exp, paste("ENs",  lat_report_rhodf$EN[a], lat_report_rhodf$EN[b], lat_report_rhodf$EN[c], lat_report_rhodf$EN[d]))

}

png("DASHBOARD K=X EW=1 LOG DIAGONAL.png", 1000, 1000)

mem_report_rhodf <- mem_report_rhodf[with(mem_report_rhodf, order(EW)),]
lat_report_rhodf <- lat_report_rhodf[with(lat_report_rhodf, order(EW)),]

a <- 1
b <- a+1
c <- b+1
d <- c+1
split.screen(c(2,1))
split.screen(c(1,2), screen=1)

xlim <- c(min(lat_report_rhodf$Mean.SS), max(lat_report_rhodf$Mean.SS))
ylim <- c(sort(mem_report_rhodf$A..Mean.SS)[1], sort(mem_report_rhodf$A..Mean.SS, decreasing = TRUE)[1])

#INC GRAPH
screen(3)
log_dashboard(a,a+4,a+8,a+12,xlim,ylim, c(FALSE, TRUE, FALSE, FALSE, TRUE))
#INC STMT
screen(4)
log_dashboard(b,b+4,b+8,b+12,xlim,ylim, c(FALSE, TRUE, FALSE, FALSE, TRUE))
split.screen(c(1,2), screen=2)

#NAIVE GRAPH
screen(5)
log_dashboard(c,c+4,c+8,c+12,xlim,ylim, c(TRUE, TRUE, FALSE, FALSE, TRUE))
screen(6)
#NAIVE STMT
log_dashboard(d,d+4,d+8,d+12,xlim,ylim, c(FALSE, TRUE, FALSE, FALSE, TRUE))

dev.off()