ts_dat1 <- read.csv("~/Pending/ss3sim-ms/final_results_ts-run1.csv")
ts_dat2 <- read.csv("~/Pending/ss3sim-ms/final_results_ts.csv")
ts_dat <- rbind(ts_dat1, ts_dat2)
#ts_dat <- subset(ts_dat, replicate %in% 1:50)
scalar_dat1 <- read.csv("~/Pending/ss3sim-ms/final_results_scalar-run1.csv")
scalar_dat2 <- read.csv("~/Pending/ss3sim-ms/final_results_scalar.csv")
scalar_dat1$StartTime <- NULL
scalar_dat2$StartTime <- NULL
scalar_dat1$EndTime <- NULL
scalar_dat2$EndTime <- NULL
scalar_dat <- rbind(scalar_dat1, scalar_dat2)
#scalar_dat <- subset(scalar_dat, replicate %in% 1:50)
#save(ts_dat, file = "ts_dat.rda")
#save(scalar_dat, file = "scalar_dat.rda")

#load("../../vignettes/ts_dat.rda")
#load("../../vignettes/scalar_dat.rda")
ts_dat <- subset(ts_dat, D %in% c("D1", "D2"))
scalar_dat <- subset(scalar_dat, D %in% c("D1", "D2"))

f_merge <- subset(ts_dat, year == max(ts_dat$year))[,c("scenario", "replicate", "F_om", "F_em")]
scalar_dat <- join(scalar_dat, f_merge)

##

scalar_dat <- transform(scalar_dat,
  steep = (SR_BH_steep_om - SR_BH_steep_em)/SR_BH_steep_om,
  logR0 = (SR_LN_R0_om - SR_LN_R0_em)/SR_LN_R0_om,
  depletion = (depletion_om - depletion_em)/depletion_om,
  SSB_MSY = (SSB_MSY_em - SSB_MSY_om)/SSB_MSY_om,
  SR_sigmaR = (SR_sigmaR_em - SR_sigmaR_om)/SR_sigmaR_om,
  NatM =
    (NatM_p_1_Fem_GP_1_em - NatM_p_1_Fem_GP_1_om)/
     NatM_p_1_Fem_GP_1_om,
  Fmort = (F_em - F_om) / F_om)

# add a tiny bit of noise for violin plotting:
N <- length(scalar_dat[scalar_dat$E == "E0", "NatM"])
#scalar_dat[scalar_dat$E == "E0", "NatM"] <- rnorm(N, 0, 0.0001)
scalar_dat[scalar_dat$E == "E0", "NatM"] <- NA

ts_dat <- transform(ts_dat,
  SpawnBio = (SpawnBio_em - SpawnBio_om)/SpawnBio_om,
  Recruit_0 = (Recruit_0_em - Recruit_0_om)/Recruit_0_om)

#ts_dat <- merge(ts_dat, scalar_dat[,c("scenario", "replicate",
    #"max_grad")])

scalar_dat_det <- subset(scalar_dat, E %in% c("E100", "E101"))
scalar_dat_sto <- subset(scalar_dat, E %in% c("E0", "E1"))
ts_dat_det <- subset(ts_dat, E %in% c("E100", "E101"))
ts_dat_sto <- subset(ts_dat, E %in% c("E0", "E1"))
ts_dat_sto <- droplevels(ts_dat_sto)
scalar_dat_sto <- droplevels(scalar_dat_sto)

library(plyr)
quant_dat <- ddply(ts_dat_sto, c("D", "E", "year"), summarize,
  q05 = quantile(SpawnBio, probs = 0.05),
  q25 = quantile(SpawnBio, probs = 0.25),
  q50 = quantile(SpawnBio, probs = 0.50),
  q75 = quantile(SpawnBio, probs = 0.75),
  q95 = quantile(SpawnBio, probs = 0.95)
)

cols <- RColorBrewer::brewer.pal(8, "Blues")
levels(quant_dat$D) <- c("atop(sigma[survey]==0.1,
  Increased~survey~effort)", "atop(sigma[survey]==0.4,
  Decreased~survey~effort)")
levels(quant_dat$E) <- c("Fixed~italic('M')[historical]",
  "Estimated~italic('M')")

library(ggplot2)
p <- ggplot(quant_dat) +
  geom_ribbon(aes(year, ymax = q05, ymin = q95), fill = cols[4]) +
  geom_ribbon(aes(year, ymax = q25, ymin = q75), fill = cols[6]) +
  geom_line(aes(year, q50), colour = cols[8]) +
  facet_grid(D~E, labeller = label_parsed) +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    strip.background = element_rect(fill = NA, linetype = 0),
    axis.text = element_text(colour = "grey50"),
    axis.title = element_text(colour = "grey30"),
    axis.ticks = element_line(colour = "grey50"),
    strip.text = element_text(colour = "grey30")
    #plot.margin = grid::unit(c(.1,.1,.1,.1), "cm"),
    #panel.margin = grid::unit(0, "cm")
    ) +
  geom_hline(yintercept = 0, linetype = 3, colour = "#FFFFFF95") +
  ylab("Relative error in SSB") + xlab("Year")

ggsave(p, file = "spawnb-re-ts.pdf", width = 6, height = 4.25)

levels(scalar_dat_sto$D) <- c("atop(sigma[survey]==0.1,
  Increased~survey~effort)", "atop(sigma[survey]==0.4,
  Decreased~survey~effort)")
levels(scalar_dat_sto$E) <- c("Fixed~italic('M')[historical]",
  "Estimated~italic('M')")

p <- ggplot(scalar_dat_sto, aes(x = 0, y = depletion),
  labeller = label_parsed) +
  geom_violin(fill = cols[4], colour = cols[6]) +
  geom_jitter(position = position_jitter(height = 0, width = 0.05), alpha = 0.6, colour = cols[8], pch = 21, size = 1.5) +
  facet_grid(D~E, labeller = label_parsed) +
  geom_hline(yintercept = 0, linetype = 3)  +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    strip.background = element_rect(fill = NA, linetype = 0),
    axis.text = element_text(colour = "grey50"),
    axis.title = element_text(colour = "grey30"),
    axis.ticks = element_line(colour = "grey50"),
    strip.text = element_text(colour = "grey30"),
    axis.ticks.x = element_blank(),
    axis.text.x = element_blank()
    ) +
  ylab("Relative error in depletion") + xlab("")

ggsave(p, file = "depletion-re-scalar.pdf", width = 6, height = 4.25)

scalar_dat_sto <- subset(scalar_dat, E %in% c("E0", "E1"))
scalar_dat_long <- reshape2::melt(scalar_dat_sto[,c("scenario", "D",
    "E", "replicate", "max_grad", "depletion", "NatM", "SSB_MSY", "Fmort")],
 id.vars = c("scenario", "D", "E", "replicate", "max_grad"))
scalar_dat_long <- plyr::rename(scalar_dat_long,
  c("value" = "relative_error"))

scalar_dat_long <- droplevels(scalar_dat_long)
levels(scalar_dat_long$D) <- c("High", "Low")
levels(quant_dat$E) <- c("Fixed~italic('M')[historical]", "Estimated~italic('M')")
#levels(scalar_dat_long$variable) <- c("Depletion", "italic('M')")
levels(scalar_dat_long$variable) <- c("Depletion", "M", "SSB[MSY]", "F")

# p <- ggplot(scalar_dat_long, aes(x = D, y = relative_error),
#   labeller = label_parsed) +
#   geom_violin(fill = cols[4], colour = cols[6]) +
#   facet_grid(variable~E, labeller = label_parsed, scales = "free_y") +
#   geom_jitter(position = position_jitter(height = 0, width = 0.05), alpha = 0.6, colour = cols[8], pch = 21, size = 1.5) +
#   geom_hline(yintercept = 0, linetype = 3)  +
#   theme_bw() +
#   theme(panel.grid.major = element_blank(),
#     panel.grid.minor = element_blank(),
#     strip.background = element_rect(fill = NA, linetype = 0),
#     axis.text = element_text(colour = "grey50"),
#     axis.title = element_text(colour = "grey30"),
#     axis.ticks = element_line(colour = "grey50"),
#     strip.text = element_text(colour = "grey30")
#     ) +
#   ylab("Relative error") + xlab("Survey effort")

#ggsave(p, file = "depletion-re-scalar.pdf", width = 4, height = 4.25)

levels(scalar_dat_long$D) <- c("atop(sigma[survey]==0.1,
  Increased~survey~effort)", "atop(sigma[survey]==0.4,
  Decreased~survey~effort)")
levels(scalar_dat_long$E) <- c("Fixed~italic('M')[historical]", "Estimated~italic('M')")

p <- ggplot(scalar_dat_long, aes(x = variable, y = relative_error)) +
  geom_boxplot(aes(fill = variable), colour = "grey50", outlier.colour = "grey50", notch = TRUE, outlier.size = 1.5) +
  facet_grid(D~E, labeller = label_parsed)+
  geom_hline(yintercept = 0, linetype = 3)  +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    strip.background = element_rect(fill = NA, linetype = 0),
    axis.text = element_text(colour = "grey50"),
    axis.title = element_text(colour = "grey30"),
    axis.ticks = element_line(colour = "grey50"),
    strip.text = element_text(colour = "grey30"),
    legend.position = "none"
    ) +

  ylab("Relative error") + xlab("")
  #

ggsave(p, file = "scalar-boxplots.pdf", width = 6, height = 4.25)

#levels(scalar_dat_long$scenario) <- c("High survey effort, Fixed M", "High survey effort, Estimate M", "Low survey effort, Fixed M", "Low survey effort, Estimated M" )
#levels(scalar_dat_long$scenario) <- c("s_surv = 0.1, Fixed M", "s_surv = 0.1, Estimate M", "s_surv = 0.4, Fixed M", "s_surv = 0.4, Estimated M" )

#### put the same variable in the same panel:
p2 <- ggplot(scalar_dat_long, aes(x = scenario, y = relative_error)) +
  #geom_boxplot(aes(fill = variable), colour = "grey50", outlier.colour = "grey50", notch = TRUE, outlier.size = 1.5) +
  geom_violin(fill = cols[4], colour = cols[7]) +
  geom_jitter(position = position_jitter(height = 0, width = 0.05), alpha = 0.4, colour = cols[7], pch = 20, size = 1) +
  facet_grid(~variable, labeller = label_parsed, scales = "fixed")+
  geom_hline(yintercept = 0, linetype = 3)  +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    strip.background = element_rect(fill = NA, linetype = 0),
    axis.text = element_text(colour = "grey50"),
    axis.text.x = element_text(angle = 90, hjust = 1),
    axis.title = element_text(colour = "grey30"),
    axis.ticks = element_line(colour = "grey50"),
    strip.text = element_text(colour = "grey30"),
    legend.position = "none"
    ) +

  ylab("Relative error") + xlab("")
  print(p)
  #

#ggsave(p, file = "scalar-boxplots.pdf", width = 6, height = 4.25)

library(gridExtra)
p3 <- grid.arrange(p1, p2, ncol = 1, heights = c(1, 1))
print(p3)


#!/usr/bin/env Rscript

source("/tmp/class-libs.R")

class_name = "2022 Spring Stat 20"

class_libs = c(
    "fivethirtyeight", "0.6.2",
    "gapminder", "0.3.0",
    "googlesheets4", "1.0.0",
    "infer", "1.0.0",
    "janitor", "2.1.0",
    "openintro", "2.2.0",
    "pagedown", "0.16",
    "palmerpenguins", "0.1.0",
    "patchwork", "1.1.1",
    "patchwork", "1.1.1",
    "showtext", "0.9-4",
    "swirl", "2.4.5",
    "tidycensus", "1.1",
    "tidymodels", "0.1.4",
    "tigris", "1.5",
    "unvotes", "0.3.0",
    "xaringanthemer", "0.4.1"
)

class_libs_install_version(class_name, class_libs)

devtools::install_github("mdbeckman/dcData", ref="56888a6")
devtools::install_github("hadley/emo@3f03b11")
devtools::install_github("andrewpbray/boxofdata@8afd934")

file.symlink("/opt/shared/stat20/stat20data", "/usr/local/lib/R/site-library/stat20data")

print(paste("Done installing packages for",class_name))


writePlotToFile <- function(x, y, xLabel, yLabel, pathOutputFile){
	png(filename= pathOutputFile);
	plot(x, y, xlab=xLabel, ylab=yLabel);
	# This line draws a vertical,red line at position 5 on the x-axis
	# abline(v=5, col="red")
}

convertMsToMin <- function(ms){
	return(ms/60000)
}

args <- commandArgs(trailingOnly = TRUE)
argLength <- length(args)
if(argLength != 2){
 	cat("Usage: script <inputFile> <outputFile>\n")
	quit()
}

pathInputFile = args[1];
pathOutputFile = args[2];

operations <- read.csv(file=pathInputFile,head=TRUE,sep=",")
timepointsInMin <- convertMsToMin(operations$ms)
writePlotToFile(timepointsInMin, operations$latency, "Minuten", "Latency (µs)", pathOutputFile)


# random.org package tryout
setwd("~/3-Personal/blog/posts")
rm(list=ls())
library(random)
library(ggplot2)
library(scales)
?random

load("rndorg.Rdata")

# pull down the whole quotum
while (quotaCheck() == TRUE){
  rndorg <- rbind(rndorg,randomNumbers(n=10000, min = 0, max = 9))
}

save(rndorg, file = "rndorg.Rdata")

rndorgvec <- as.vector(rndorg)
rndorgraw <- as.raw(rndorg)
rndorggzip <- memCompress(rndorgraw, type = "gzip")
rndorgbzip <- memCompress(rndorgraw, type = "bzip2")
rndorgxz <- memCompress(rndorgraw, type = "xz")

runifvec <- as.integer(ceiling(runif(length(rndorgvec), min = -1, max = 9)))
runifraw <- as.raw(runifvec)
runifgzip <- memCompress(runifraw, type = "gzip")
runifbzip <- memCompress(runifraw, type = "bzip2")
runifxz <- memCompress(runifraw, type = "xz")

df <- data.frame(Source=rep(c("Random.org", "stats::runif"), each=3),
                 value=c(length(rndorggzip),
                         length(rndorgbzip),
                         length(rndorgxz),
                         length(runifgzip),
                         length(runifbzip),
                         length(runifxz)),
                 type=rep(c("gzip","bzip","xz"),2))

p <- ggplot(data=df, mapping=aes(x=type, y=value, fill=Source))+
  geom_bar(stat = "identity", position = "dodge") +
  scale_y_continuous(limits=c(min(df$value)-1000,max(df$value)+1000), oob = rescale_none) +
  labs(y = "Compressed size", x = "Compression type", title = paste("Compressing", length(runifvec), "integers"))


#' Matrix of SNP 'beta' values
#'
#' @param qc.objects List of objects obtained from \code{\link{meffil.qc}()}
#' or \code{\link{meffil.create.qc.object}()}.
#'
#' @export
meffil.snp.betas <- function(qc.objects) {
    stopifnot(sapply(qc.objects, is.qc.object))
    sapply(qc.objects, function(object) object$snp.betas)
}

#' Obtain the list of identifiers for the SNPs on the microarray.
#'
#' @param featureset Name from \code{\link{meffil.list.featuresets}()} (Default: "450k").
#' @export
meffil.snp.names <- function(featureset="450k") {
    features <- meffil.featureset(featureset)
    features$name[which(features$target == "snp")]
}

extract.snp.betas <- function(rg, probes, verbose=F) {
    msg(verbose=verbose)
    stopifnot(is.rg(rg))

    probes.M.R <- probes[which(probes$target == "M-snp" & probes$dye == "R"),]
    probes.M.G <- probes[which(probes$target == "M-snp" & probes$dye == "G"),]
    probes.U.R <- probes[which(probes$target == "U-snp" & probes$dye == "R"),]
    probes.U.G <- probes[which(probes$target == "U-snp" & probes$dye == "G"),]

    stopifnot(all(c(probes.M.R$address, probes.U.R$address) %in% rownames(rg$R)))
    stopifnot(all(c(probes.M.G$address, probes.U.G$address) %in% rownames(rg$G)))

    M <- c(rg$R[probes.M.R$address,"Mean"],
           rg$G[probes.M.G$address,"Mean"])
    U <- c(rg$R[probes.U.R$address,"Mean"],
           rg$G[probes.U.G$address,"Mean"])

    names(M) <- c(probes.M.R$name, probes.M.G$name)
    names(U) <- c(probes.U.R$name, probes.U.G$name)

    get.beta(M,U[names(M)])
}


#====================================================================
# Sarah Middleton
#
# graph_gc.r
#====================================================================

#get command line args
args<-commandArgs(TRUE)
inFile <- args[1]

# graph gc content
library('ggplot2')
tab <- read.table(inFile, header=T)

png('gc_content_dist.png')
ggplot(tab, aes(x=GC)) + geom_density() + ggtitle("Distribution of GC content across sequences")
dev.off()


my.plotcorr <- function (corr, outline = FALSE, col = "grey", upper.panel = c("ellipse", "number", "none"), lower.panel = c("ellipse", "number", "none"), diag = c("none", "ellipse", "number"), digits = 2, bty = "n", axes = FALSE, xlab = "", ylab = "", asp = 1, cex.lab = par("cex.lab"), cex = 0.75 * par("cex"), mar = 0.1 + c(2, 2, 4, 2), ...)
{
# this is a modified version of the plotcorr function from the ellipse package
# this prints numbers and ellipses on the same plot but upper.panel and lower.panel changes what is displayed
# diag now specifies what to put in the diagonal (numbers, ellipses, nothing)
# digits specifies the number of digits after the . to round to
# unlike the original, this function will always print x_i by x_i correlation rather than being able to drop it
# modified by Esteban Buz
  pdf("teste.pdf")
  if (!require('ellipse', quietly = TRUE, character = TRUE)) {
    stop("Need the ellipse library")
  }
  savepar <- par(pty = "s", mar = mar)
  on.exit(par(savepar))
  if (is.null(corr))
    return(invisible())
  if ((!is.matrix(corr)) || (round(min(corr, na.rm = TRUE), 6) < -1) || (round(max(corr, na.rm = TRUE), 6) > 1))
    stop("Need a correlation matrix")
  plot.new()
  par(new = TRUE)
  rowdim <- dim(corr)[1]
  coldim <- dim(corr)[2]
  rowlabs <- c(TeX('$l_1$'),TeX('$l_2$'),TeX('$l_3$'),TeX('$l_4$'), TeX('$l_5$'))
  collabs <- c(TeX('$\\alpha_1$'), TeX('$\\alpha_2$'),TeX('$\\alpha_3$'),TeX('$\\alpha_4$'),TeX('$\\alpha_5$'))
  if (is.null(rowlabs))
    rowlabs <- 1:rowdim
  if (is.null(collabs))
    collabs <- 1:coldim
  # rowlabs <- as.character(rowlabs)
  # print(rowlabs)
  # collabs <- as.character(collabs)
  col <- rep(col, length = length(corr))
  dim(col) <- dim(corr)
  upper.panel <- match.arg(upper.panel)
  lower.panel <- match.arg(lower.panel)
  diag <- match.arg(diag)
  cols <- 1:coldim
  rows <- 1:rowdim
  maxdim <- max(length(rows), length(cols))
  plt <- par("plt")
  xlabwidth <- max(strwidth(rowlabs[rows], units = "figure", cex = cex.lab))/(plt[2] - plt[1])
  xlabwidth <- xlabwidth * maxdim/(1 - xlabwidth)
  ylabwidth <- max(strwidth(collabs[cols], units = "figure", cex = cex.lab))/(plt[4] - plt[3])
  ylabwidth <- ylabwidth * maxdim/(1 - ylabwidth)
  plot(c(-xlabwidth - 0.5, maxdim + 0.5), c(0.5, maxdim + 1 + ylabwidth), type = "n", bty = bty, axes = axes, xlab = "", ylab = "", asp = asp, cex.lab = cex.lab, ...)
  text(rep(0, length(rows)), length(rows):1, labels = rowlabs[rows], adj = 1, cex = cex.lab)
  text(cols, rep(length(rows) + 1, length(cols)), labels = collabs[cols], srt = 90, adj = 0, cex = cex.lab)
  mtext(xlab, 1, 0)
  mtext(ylab, 2, 0)
  mat <- diag(c(1, 1))
  plotcorrInternal <- function() {
    if (i == j){ #diag behavior
      if (diag == 'none'){
        return()
      } else if (diag == 'number'){
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      } else if (diag == 'ellipse') {
        mat[1, 2] <- corr[i, j]
        mat[2, 1] <- mat[1, 2]
        ell <- ellipse(mat, t = 0.43)
        ell[, 1] <- ell[, 1] + j
        ell[, 2] <- ell[, 2] + length(rows) + 1 - i
        polygon(ell, col = col[i, j])
        if (outline)
          lines(ell)
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      }
    } else if (i >= j){ #lower half of plot
      if (lower.panel == 'ellipse') { #check if ellipses should go here
        mat[1, 2] <- corr[i, j]
        mat[2, 1] <- mat[1, 2]
        ell <- ellipse(mat, t = 0.43)
        ell[, 1] <- ell[, 1] + j
        ell[, 2] <- ell[, 2] + length(rows) + 1 - i
        polygon(ell, col = col[i, j])
        if (outline)
          lines(ell)
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      } else if (lower.panel == 'number') { #check if ellipses should go here
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      } else {
        return()
      }
    } else { #upper half of plot
      if (upper.panel == 'ellipse') { #check if ellipses should go here
        mat[1, 2] <- corr[i, j]
        mat[2, 1] <- mat[1, 2]
        ell <- ellipse(mat, t = 0.43)
        ell[, 1] <- ell[, 1] + j
        ell[, 2] <- ell[, 2] + length(rows) + 1 - i
        polygon(ell, col = col[i, j])
        if (outline)
          lines(ell)
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      } else if (upper.panel == 'number') { #check if ellipses should go here
        text(j+0.13, length(rows) + 1 - i, round(corr[i, j], digits=digits), adj = 1, cex = cex)
      } else {
        return()
      }
    }
  }
  for (i in 1:dim(corr)[1]) {
    for (j in 1:dim(corr)[2]) {
      plotcorrInternal()
    }
  }
  invisible()
  dev.off()
}


library(plotly)
dfree <- read.csv('https://raw.githubusercontent.com/plotly/datasets/master/2011_february_us_airport_traffic.csv')
head(dfree)

# geo styling
g <- list(
  scope = 'usa',
  projection = list(type = 'albers usa'),
  showland = TRUE,
  landcolor = toRGB("gray95"),
  subunitcolor = toRGB("gray85"),
  countrycolor = toRGB("gray85"),
  countrywidth = 0.5,
  subunitwidth = 0.5
)

p <- plot_geo(dfree, lat = ~lat, lon = ~long)
p

p <- add_markers(p,
    text = ~paste(airport, city, state, paste("Arrivals:", cnt), sep = "
"),
    color = ~cnt, symbol = I("square"), size = I(8), hoverinfo = "text"
  )
p

%>%
    colorbar(title = "Incoming flights
February 2011") %>%
  layout(
    title = 'Most trafficked US airports
(Hover for airport)', geo = g
  )
p

# Create a shareable link to your chart
# Set up API credentials: https://plot.ly/r/getting-started
chart_link = api_create(p, filename="maps-traffic")
chart_link

file.path <-"https://raw.githubusercontent.com/GitAMoveOn/DDP/gh-pages/nfl_draft.csv"
draft <- read.csv(file.path)

names(draft)
College

z<-getwd()
z
dir()
setwd(paste(z,"/9. Developing Data Products/",sep=""))
getwd()
dir()
setwd("./Week 4")
getwd()
dir()
setwd("./Project/app")
dir()
setwd('./data')
dir()
colleges <- read.csv('college_scorecard.csv')
head(colleges)

install.packages('fuzzyjoin')
library(fuzzyjoin)

head(draft)
names(draft)
#College.Univ
names(colleges)
#INSTNM
?fuzzy_left_join
zz <- stringdist_left_join(draft,colleges,c("College.Univ"="INSTNM"))
head(zz)
zz[zz$College.Univ=='Baylor',]

library(dplyr)
dd <- draft %>%
  group_by(College.Univ) %>%
  select(College.Univ)
dd<-unique(draft$College.Univ)
class(dd)
nfl.colleges<-as.data.frame(dd)
nfl.colleges
str(nfl.colleges)
zz <- stringdist_left_join(nfl.colleges,colleges,c("dd"="INSTNM"),method='lv',distance_col="SCORE")

head(zz[zz['dd']=='Washington',c('dd','INSTNM','SCORE')])

library(plotly)
library(ggplot2)
library(RColorBrewer)

file.path <-"https://raw.githubusercontent.com/GitAMoveOn/DDP/gh-pages/nfl_draft.csv"
draft <- read.csv(file.path)

draft <- draft %>%
  filter(Year<=2012) %>%
  filter(Year>=1994)

avg.4.AV.round <- draft %>%
  group_by(Rnd) %>%
  summarise(avg.F4.AV = mean(First4AV)) %>%
  arrange(Rnd)
# avg.4.AV.round

ct.4.AV.round <- draft %>%
  group_by(Rnd) %>%
  count(Rnd) %>%
  arrange(Rnd)
# ct.4.AV.round

tbl.round <- inner_join(avg.4.AV.round,ct.4.AV.round,by="Rnd")
# tbl.round

avg.4.AV.age <- draft %>%
  group_by(Age) %>%
  summarise(avg.F4.AV = mean(First4AV)) %>%
  arrange(Age)
# avg.4.AV.age

ct.4.AV.age <- draft %>%
  group_by(Age) %>%
  count(Age) %>%
  arrange(Age)
# ct.4.AV.age

tbl.age<- inner_join(avg.4.AV.age,ct.4.AV.age,by="Age")
# tbl.age

avg.4.AV.pos <- draft %>%
  group_by(Pos) %>%
  summarise(avg.F4.AV = mean(First4AV)) %>%
  arrange(Pos)
# avg.4.AV.pos

ct.4.AV.pos <- draft %>%
  group_by(Pos) %>%
  count(Pos) %>%
  arrange(Pos)
# ct.4.AV.pos

tbl.pos<- inner_join(avg.4.AV.pos,ct.4.AV.pos,by="Pos")
# tbl.pos

xx <- list(title = "Draft Round")
yy <- list(title = "AV over First 4 Years")

p1 <- plot_ly(tbl.round
             , x = ~Rnd
             , y = ~avg.F4.AV
             , color = ~n
             , type = "bar"
             , colors = brewer.pal(1, "Blues")
             , name = 'Draft Round' ) %>%
  layout(xaxis = xx, yaxis = yy)
# p1
p2 <- plot_ly(tbl.age
              , x = ~Age
              , y = ~avg.F4.AV
              , type = "bar"
              , color = ~n
              , colors = brewer.pal(1, "Greens")
              , name = 'Age' ) %>%
  layout(xaxis = xx, yaxis = yy)
# p2
p3 <- plot_ly(tbl.pos
              , x = ~Pos
              , y = ~avg.F4.AV
              , type = "bar"
              # , color = ~n
              , colors = brewer.pal(1, "Reds")
              , name = 'Position' ) %>%
  layout(xaxis = xx, yaxis = yy)
# p3
ps <-subplot(p1,p2,p3, shareX = FALSE, shareY = TRUE, nrows = 2) %>%
   layout(title = "4 Yr AV by Features")
ps
?subplot

file.path <-"https://raw.githubusercontent.com/GitAMoveOn/DDP/gh-pages/seahawks_results.csv"
sea.res <- read.csv(file.path)

colnames(sea.res)[1]<-"Round"
sea.res
library(DT)

dt.sea <- datatable(sea.res)
dt.sea


# filenames for input data
newCW<-'Total_catch_in_numbers_and_mean_weight_2011.csv'

first.year.out<-1991
last.year.out<-2011
n.season<-4

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

# WECA and WEST

a<-read.table(file=file.path(data.path,'Input',newCW),header=T,sep=',')
a[is.na(a$mw0),'mw0']<-0
b<-subset(a,select=c(year,quarter, mw0,mw1,mw2,mw3,mw4))
b
out<-file.path(data.path,"weca.in")
unlink(out)
for (y in(first.year.out:last.year.out)) {
  cat(paste("# year:",y,"\n"), file=out,append=TRUE)
    for (s in(1:n.season)){
     aa<-subset(b,year==y & quarter==s)
     cat(format(c(aa$mw0,aa$mw1, aa$mw2, aa$mw3, aa$mw4) ,format='fg',width=10,justify='right',digits=2,nsmall=5),file=out,append=T)
     cat("\n",file=out,append=T)
    }
}

file.copy(out, file.path(data.path,"west.in"), overwrite = TRUE)

# CANUM

a$n0<-round(a$n0,0)
a$n1<-round(a$n1,0)
a$n2<-round(a$n2,0)
a$n3<-round(a$n3,0)
a$n4<-round(a$n4,0)

b<-subset(a,select=c(year,quarter, n0,n1,n2,n3,n4))

out<-file.path(data.path,"canum.in")
unlink(out)
for (y in(first.year.out:last.year.out)) {
  cat(paste("# year:",y,"\n"), file=out,append=TRUE)
    for (s in(1:n.season)){
     aa<-subset(b,year==y & quarter==s)
     cat(format(c(aa$n0,aa$n1, aa$n2, aa$n3, aa$n4) ,format='fg',width=12,justify='right'),file=out,append=T)
     cat("\n",file=out,append=T)
    }
}

################################
# natural mortality
a<-read.table(file=file.path(data.path,'Input','m.csv'),header=T,sep=',')
m<-tapply(a$m,list(a$Quarter,a$Age),sum)
m[is.na(m)]<-0
m
m<-round(cbind(m,m[,'3']),2)

out<-file.path(data.path,'natmor.in')
cat("####################################\n","###  Sprat Natural Mortality\n",file=out,append=F)

for (y in (first.year.out:(last.year.out+1))) {
  cat("# ",y,'\n',    file=out,append=T)
  write.table(m,file=out,append=T,col.names=F,row.names=F)
}

################################
# maturity
a<-read.table(file=file.path(data.path,'Input','maturity.csv'),header=T,sep=',')
m<-round(tapply(a$m,list(a$quarter,a$age),sum),2)
m[is.na(m)]<-0
m
m<-matrix(rep(m,each=4),nrow=4)

out<-file.path(data.path,'propmat.in')
cat("####################################\n","###  Sprat Proportion mature\n",file=out,append=F)

for (y in (first.year.out:(last.year.out+1))) {
  cat("# ",y,'\n',    file=out,append=T)
  write.table(m,file=out,append=T,col.names=F,row.names=F)
}

##################################
# CPUE indeces

a<-read.table(file=file.path(data.path,'Input','ibtsq1_q3.csv'),header=T,sep=',')
head(a)
a$survey<-'IBTS'

b<-read.table(file=file.path(data.path,'Input','heras.csv'),header=T,sep=',')
b$survey<-'Heras'

ab<-rbind(a,b)
ab<-subset(ab,year>=1991)

a<-tapply(ab$n,list(ab$survey,ab$year,ab$quarter,ab$age),sum)
ftable(round(a,1))

a['IBTS','1995','3','0'] <- -a['IBTS','1995','3','0']
ftable(round(a,1))

out<-file.path(data.path,'fleet_catch.in')

cat("####################################\n","###  Sprat\n",file=out,append=F)

cat("####################################\n","###  IBTS Q1\n",file=out,append=T)
cat("# effort Age1 Age2 Age3 Age4\n",file=out,append=T)
x<-cbind(1E-4,round(a['IBTS',as.character(seq(first.year.out,last.year.out+1)),'1',c('1','2','3','4')],2))
write.table(x,file=out,append=T,col.names=F,row.names=F)

cat("####################################\n","###  IBTS Q3\n",file=out,append=T)
cat("# effort  Age1 Age2 Age3\n",file=out,append=T)
x<-cbind(1E-4,round(a['IBTS',as.character(seq(first.year.out,last.year.out)),'3',c('1','2','3')],2))
write.table(x,file=out,append=T,col.names=F,row.names=F)

cat("####################################\n","###  Heras Q2\n",file=out,append=T)
cat("# effort  Age1 Age2 Age3 \n",file=out,append=T)
x<-cbind(1E-3,a['Heras',as.character(seq(2003,last.year.out)),'2',c('1','2','3')])
write.table(x,file=out,append=T,col.names=F,row.names=F)


REBOL [
	Title:   "Generates Red float! tests"
	Author:  "Peter W A Wood"
	File: 	 %make-float-auto-test.r
	Version: 0.1.0
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

;; initialisations
tests: copy ""                          ;; string to hold generated tests
test-number: 0                          ;; number of the generated test
make-dir %auto-tests/
file-out: %auto-tests/float-auto-test.red

;; create a block of values to be used in the binary ops tests
test-values: [
	0.0
	-2147483648.0
	2147483647.0
	-1.0
	3.0
	-7.0
	5.0
	123456.7890
	1.222090944E+33
	9.99999E-45
	7.7E18
]

tol: 1e-4

;; create blocks of operators to be applied
test-binary-ops: [
	+
	-
	*
	/
;  //									;; not implemented fully yet
; "%"									;; not implemented fully yet
]

test-comparison-ops: [
	=
	<>
	<
	>
	>=
	<=
]

test-comparison-values: [
	-1E-13
	0.0
	+1E-13
]

;; create test file with header
append tests "Red [^(0A)"
append tests {  Title:   "Red auto-generated float! tests"^(0A)}
append tests {	Author:  "Peter W A Wood"^(0A)}
append tests {  File: 	 %float-auto-test.red^(0A)}
append tests {  License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"^(0A)}
append tests "]^(0A)^(0A)"
append tests "^(0A)^(0A)comment {"
append tests "  This file is generated by make-float-auto-test.r^(0A)"
append tests "  Do not edit this file directly.^(0A)"
append tests "}^(0A)^(0A)"
append tests join ";make-length:"
	[length? read %make-float-auto-test.r "^(0A)^(0A)"]
append tests "#include %../../../../quick-test/quick-test.red^(0A)^(0A)"
append tests {~~~start-file~~~ "Auto-generated tests for float"^(0A)^(0A)}
append tests {===start-group=== "Auto-generated tests for float"^(0A)^(0A)}

write file-out tests
tests: copy ""

;; binary operator tests - in global context
foreach op test-binary-ops [
	foreach operand1 test-values [
		foreach operand2 test-values [
			;; only write a test if REBOL produces a result
			if attempt [
				either op = "%" [
					expected: to decimal! do reduce [remainder operand1 operand2]
				][
					expected: to decimal! do reduce [operand1 op operand2]
				]
			][
				;; test with literal values
				test-number: test-number + 1
				append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
				append tests "  --assertf~= "
				append tests reform [expected " (" operand1 op operand2 ") " tol "^(0A)"]

				;; test with variables
				test-number: test-number + 1
				append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
				append tests join "      i: " [operand1 "^(0A)"]
				append tests join "      j: " [operand2 "^(0A)"]
				append tests rejoin ["      k:  i " op " j^(0A)"]
				append tests "  --assertf~= "
				append tests reform [expected " k " tol "^(0A)"]

				;; write tests to file
				write/append file-out tests
				tests: copy ""
			]
			recycle
		]
	]
]

;; binary operator tests - inside a function

;; write function spec
tests: {
float-auto-test-func: func [
	/local
	i [float!]
	j [float!]
	k [float!]
][
}

write/append file-out tests
tests: copy ""

foreach op test-binary-ops [
	foreach operand1 test-values [
		foreach operand2 test-values [
			;; only write a test if REBOL produces a result
			if attempt [expected: do reduce [operand1 op operand2]][

				expected: to decimal! expected

				;; test with variables inside the function
				test-number: test-number + 1
				append tests join {    --test-- "float-auto-} [test-number {"^(0A)}]
				append tests join "      i: " [operand1 "^(0A)"]
				append tests join "      j: " [operand2 "^(0A)"]
				append tests rejoin ["      k:  i " op " j^(0A)"]
				append tests "    --assertf~= "
				append tests reform [expected " k " tol "^(0A)"]

				;; write tests to file
				write/append file-out tests
				tests: copy ""
			]
			recycle
		]
	]
]

;; write closing bracket and function call
append tests "  ]^(0a)"
append tests "float-auto-test-func^(0a)"
write/append file-out tests
tests: copy ""

;; comparison tests
foreach op test-comparison-ops [
	foreach operand1 test-values [
		foreach oper2 test-comparison-values [
			;; only write a test if REBOL produces a result
			if all [
				attempt [operand2: operand1 + oper2]
				none <> attempt [expected: do reduce [operand1 op operand2]]
			][
				test-number: test-number + 1
				append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
				append tests "  --assert "
				append tests reform [expected " = (" operand1 op operand2 ")^(0A)"]

				;; write tests to file
				write/append file-out tests
				tests: copy ""
			]
		]
	]
]

;; write file epilog
append tests "^(0A)===end-group===^(0A)^(0A)"
append tests {~~~end-file~~~^(0A)^(0A)}

write/append file-out tests

print ["Number of assertions generated" test-number]


#' @title percentDifference
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
percentDifference <- function(x) {

	if(is.vector(x)) {
		n <- length(x)
	        x <- x[order(x)]
	        v <- (x[2:n]-x[1:n-1])/((x[2:n]+x[1:n-1])/2)*100

	} else {
		v <- (x[,1] - x[,2]) / ((x[,1]+x[,2])/2) * 100
}
        	return(v)

}


# color compensation / multi-channel deconvolution

# function: get cross-over constant matrix k
get_k <- function(
    db_conn, # MySQL database connection
    dcv_exp_info, # deconvolution experiment ids, i.e. the data in these experiments are for constructing deconvolution matrix. a named vector (by channel) where each element is the experiment id using the target dye of each channel
    well_proc='dim3' # options: 'mean', 'dim3'.
    ) {

    dei_names <- names(dcv_exp_info)
    channel_names <- dei_names[2:length(dei_names)]
    channels <- sapply(channel_names, function(channel_name) strsplit(channel_name, '_')[[1]][2])
    num_channels <- length(channels)
    names(channel_names) <- channels

    dcv_list <- get_full_calib_data(db_conn, dcv_exp_info)

    water_data <- dcv_list[['water']]
    well_nums <- colnames(water_data)
    num_wells <- length(well_nums)

    k_list_bydy <- lapply(channel_names, function(channel_name) dcv_list[[channel_name]] - water_data)
    names(k_list_bydy) <- channels

    dye_names <- paste('dye_', channels)

    k_inv_array <- array(
        0,
        dim=c(num_channels, num_channels, num_wells),
        dimnames=list(channels, dye_names, well_nums)
    )

    k_singular <- ''

    if (well_proc == 'mean') {
        k <- as.matrix(do.call(cbind, lapply(channels, function(channel) {
            k_data_1dye <- rowMeans(k_list_bydy[[channel]])
            k_data_1dye / sum(k_data_1dye)
        })))
        colnames(k) <- dye_names
        k_inv <- tryCatch(solve(k), error=err_e)
        if ('error' %in% class(k_inv)) {
            k_singular <- c('Well mean K matrix is singular. ')
        } else {
            for (well_num in well_nums) {
                k_inv_array[,,well_num] <- k_inv
            }
        }

    } else if (well_proc == 'dim3') {
        k <- k_inv_array
        k_singular_vec <- c()
        for (well_num in well_nums) {
            k_mtx <- as.matrix(do.call(cbind, lapply(channels, function(channel) {
                k_data_1dye <- k_list_bydy[[channel]][,well_num]
                k_data_1dye / sum(k_data_1dye)
            })))
            k[,,well_num] <- k_mtx
            k_inv <- tryCatch(solve(k_mtx), error=err_e)
            if ('error' %in% class(k_inv)) {
                k_singular_vec <- c(k_singular_vec, well_num)
            } else {
                k_inv_array[,,well_num] <- k_inv
            }
        }
        if (length(k_singular_vec) > 0) {
            k_singular <- sprintf(
                'Well-specific K matrix is singular for the following well(s): %s. ',
                paste(k_singular_vec, collapse=', ')
            )
        }
    }

    return(list('k'=k, 'k_inv_array'=k_inv_array, 'k_singular'=k_singular))
    }

# multi-channel deconvolution
deconv <- function(
    array2dcv, # dim1 must be channel, dim3 must be well; dim2 is cycle for amplification and temperature point for melting curve
    db_conn,
    calib_info
    ) {

    a2d_dim1 <- dim(array2dcv)[1]
    a2d_dim2 <- dim(array2dcv)[2]
    a2d_dim3 <- dim(array2dcv)[3]
    a2d_dimnames <- dimnames(array2dcv)

    # if data only has 1 cycle (amplification) or 1 temperature point (melt curve)
    if (is.na(a2d_dim3)) array2dcv <- array(c(array2dcv),
                                            dim=c(a2d_dim1, 1, a2d_dim2),
                                            dimnames=list(a2d_dimnames[[1]], '1', a2d_dimnames[[2]]))

    if (class(calib_info) == "numeric" ||
        sum(duplicated(sapply(calib_info, function(calib_ele) calib_ele[['step_id']]))) > 0
    ) {
        k_list_temp <- k_list
    } else {
        k_list_temp <- get_k(db_conn, calib_info, 'dim3')
    }

    k_inv_array = k_list_temp[['k_inv_array']]

    dcvd_by_dim2_well <- lapply(1:a2d_dim2,
        function(dim2_i) do.call(cbind, lapply(1:a2d_dim3,
            function(well_i) k_inv_array[,,well_i] %*% array2dcv[,dim2_i,well_i]))) # dim2 is cycle_num for amp and temperature for melt curve

    dcvd_array <- array(NA, dim(array2dcv))
    for (dim2_i in 1:dim(array2dcv)[2]) dcvd_array[,dim2_i,] <- dcvd_by_dim2_well[[dim2_i]]
    dimnames(dcvd_array) <- dimnames(array2dcv)

    # scale by channel to adjust for different fluorescence excitation strengths among dyes
    for (channel in dimnames(dcvd_array)[1]) {
        dcvd_array[channel,,] <- dcvd_array[channel,,] * scaling_factors_deconv[channel] }

    return(list('dcvd_array'=dcvd_array, 'k_list_temp'=k_list_temp))
    }


#' Calculate Progeny Scores with Permutations
#'
#'This function generate a series of scatter plot with marginal distribution
#'(in the form of an arrangeGrob object), for each progeny pathway and
#'sample/contrast. Each scatter plot has progeny weights as x-axis and the gene
#'level stat used to compute progeny score as the y-axis. The marginal
#'distribution of the gene level stats is displayed on the right of the plot
#'to give visual support of the significance of each gene contributing to
#'the progeny pathway score. The green and red colors represent the positive
#'and negative contribution of genes to the progeny pathway, respectively.
#'For each gene contribution, 4 cases are possible, as the combinations of
#'the sign of the gene level stat and the sign of the gene level weight.
#'Positive weight will lead to a positive(green)/negative(red) gene contribution
#'if the gene level stat is positive/negative. Negative weight will lead to
#'a negative(red)/positive(green) gene contribution if the gene level stat
#'is positive/negative.
#'
#'@param df an n*m data frame, where n is the number of omic features (genes).
#'m isn't really important, as long as at least one column corresponds to a
#'sample or contrast statistic. One of the columns should correspond to the gene
#'symbols.
#'@param weight_matrix A progeny coefficient matrix. the first column should be
#'the identifiers of the omic features, and should be coherent with
#'the identifiers provided in df.
#'@param dfID an integer corresponding to the column number of
#'the gene identifiers of df.
#'@param weightID an integer corresponding to the column number of the gene
#'identifiers of the weight matrix.
#'@param statName The name of the stat used, to be displayed on the plot
#'@param verbose  Logical indicating whether we want to have the messages
#'indicating the different computed weights.
#'@importFrom stats ecdf
#'@import ggplot2
#'@import ggrepel
#'@import gridExtra
#'@return The function returns a list of list of arrangeGrob objects.
#'The first level list elements correspond to samples/contrasts.
#'The second level correspond to pathways.
#'The plots can be saved in a pdf format using the saveProgenyPlots function.
#'@examples
#' # use example gene expression matrix
#'
#' gene_expression <- read.csv(system.file("extdata",
#' "human_input.csv", package = "progeny"))
#'
#' # getting a model matrix with 100 top significant genes and converting to df
#' weight_matrix <- getModel("Human", top=100)
#' weight_matrix <- data.frame(names = row.names(weight_matrix),
#'   row.names = NULL, weight_matrix)
#'
#' #use progenyScatter function
#' plots <- progenyScatter(gene_expression, weight_matrix)
#'@export
progenyScatter <- function(df,weight_matrix,dfID = 1, weightID = 1,
    statName = "gene stats", verbose = FALSE) {

    weight <- color <- ID <- NULL
    plot_list_contrasts <- list(0)
    for (i in 2:length(df[1,])) {
        plot_list_pathways <- list(0)
        for (j in 2:length(weight_matrix[1,])) {
            sub_df <- df[,c(dfID,i)]
            pathway_weights <- weight_matrix[,c(weightID,j)]
            names(sub_df) <- c("ID","stat")
            minstat <- min(sub_df$stat)
            maxstat <- max(sub_df$stat)

            histo <- ggplot(sub_df, aes(x = stat, fill = "blue")) +
                geom_density() + coord_flip() +
                scale_fill_manual(values = c("#00c5ff")) +
                xlim(minstat, maxstat) + theme_minimal() +
                theme(legend.position = "none", axis.text.x = element_blank(),
                axis.ticks.x = element_blank(), axis.title.y = element_blank(),
                axis.text.y = element_blank(), axis.ticks.y = element_blank(),
                panel.grid.major = element_blank(),
                panel.grid.minor = element_blank())

            names(pathway_weights) <- c("ID","weight")
            pathway_weights <- pathway_weights[pathway_weights$weight != 0,]
            percentile <- ecdf(sub_df$stat)
            sub_df <- merge(sub_df,pathway_weights,by = "ID")
            sub_df$color <- "3"
            sub_df[(sub_df$weight > 0 & sub_df$stat > 0),"color"] <- "1"
            sub_df[(sub_df$weight > 0 & sub_df$stat < 0),"color"] <- "2"
            sub_df[(sub_df$weight < 0 & sub_df$stat > 0),"color"] <- "2"
            sub_df[(sub_df$weight < 0 & sub_df$stat < 0),"color"] <- "1"
            sub_df[(percentile(sub_df$stat) < .95 &
                percentile(sub_df$stat) > .05),1] <- NA

            if (verbose){
                message(paste("weights of ",names(weight_matrix)[j], sep = ""))
            }

            title <- paste("weights of ",names(weight_matrix)[j], sep = "")

            scatterplot <- ggplot(sub_df, aes(x = weight, y = stat,
                color = color)) + geom_point() +
            scale_colour_manual(values = c("red","royalblue3","grey")) +
            geom_label_repel(aes(label = ID)) +
            ylim(minstat, maxstat) + theme_minimal() +
            theme(legend.position = "none") +
            geom_vline(xintercept = 0, linetype = 'dotted') +
            geom_hline(yintercept = 0, linetype = 'dotted') +
            labs(x = title, y = statName)

            lay <- t(as.matrix(c(1,1,1,1,2)))
            gg <- arrangeGrob(scatterplot, histo, nrow = 1, ncol = 2,
                layout_matrix = lay)
            plot_list_pathways[[j-1]] <- gg
        }
        names(plot_list_pathways) <- names(weight_matrix[,-weightID])
        plot_list_contrasts[[i-1]] <- plot_list_pathways
    }
    return(plot_list_contrasts)
}

#'Function to save Progeny plots
#'
#'This function is designed to save the plots (in pdf format) of a nested
#'(2 level) list of arrangeGrob objects, such as the one returned by
#'the progenyScatter function.
#'
#'@param plots a list of list of arrangeGrob object (such as the one returned
#'by the progenyScatter function.).The first level list elements correspond
#'to samples/contrasts. The second level corresponds to pathways.
#'The plots can be saved in a pdf format using the saveProgenyPlots function.
#'@param contrast_names a vector of the same length as the first level of
#'the plot list corresponding to the names of each sample/contrast
#'@param dirpath the path to the directory where the plots should be saved
#'@import ggplot2
#'@examples
#' #create plots using progneyScatter function
#' gene_expression <- read.csv(system.file("extdata",
#' "human_input.csv", package = "progeny"))
#'
#' # getting a weight_matrix
#' weight_matrix <- getModel("Human", top=100)
#' weight_matrix <- data.frame(names = row.names(weight_matrix),
#'   row.names = NULL, weight_matrix)
#' plots <- progenyScatter(gene_expression, weight_matrix)
#'
#' #create a list with contrast names
#' contrast_names <- names(gene_expression[2:ncol(gene_expression)])
#'
#' #assign a path to store your plots
#' dirpath <- "./progeny_plots/"
#'
#' # save it
#' # saveProgenyPlots(plots, contrast_names, dirpath)
#' @return This function produces the pdf files of plots taken from the
#' progenyScatter function
#'@export
saveProgenyPlots <- function(plots, contrast_names, dirpath) {

    i <- 1
    for (condition in plots) {
        dirname <- paste(dirpath,contrast_names[i], sep = "")
        dir.create(dirname, recursive = TRUE, showWarnings = FALSE)
        j <- 1
        for (pathway in condition) {
            filename <- paste(dirname,names(condition)[j],sep = "/")
            filename <- paste(filename,".pdf",sep = "")
            ggsave(filename, pathway,device = "pdf", dpi = 300)
            j <- j+1
        }
    i <- i+1
    }
}

#'Returns the Progeny Model
#'
#'This function is designed for getting a model matrix with top significant
#'genes for each pathway
#'
#'@param organism "Human" or "Mouse" taken from the main function's argument.
#'Default to "Human"
#'@param top Desired top number of genes for each pathway according to their
#'significance(p.value). Default to 100
#'@examples #getting a model matrix according to the desired top n significant
#'model <- getModel("Human", top=100)
#'@return This function returns model matrix according to the top n significant
#'@importFrom dplyr group_by top_n ungroup select
#'@importFrom tidyr spread %>%
#'@export
getModel <- function(organism = "Human", top= 100) {

    pathway <- p.value <- weight <- NULL

    if (organism == "Human") {
        full_model <- progeny::model_human_full
    } else if (organism == "Mouse") {
        full_model <- progeny::model_mouse_full
    } else {
        stop("Wrong organism name. Please specify 'Human' or 'Mouse'.")
    }

    if (!(is.numeric(top)) || top < 1){
        stop("perm should be an integer value")
    }

    model <- full_model %>%
        dplyr::group_by(pathway) %>%
        dplyr::top_n(top, wt = -p.value) %>%
        dplyr::ungroup(pathway) %>%
        dplyr::select(-p.value) %>%
        tidyr::spread(pathway, weight, fill=0) %>%
        data.frame(row.names = 1, check.names = FALSE, stringsAsFactors = FALSE)

  return(model)
}


#' Evaluate the bandwidth selection criterion for a given bandwidth
#'
#' @param formula symbolic representation of the model
#' @param data data frame containing observations of all the terms represented in the formula
#' @param weights vector of prior observation weights (due to, e.g., overdispersion). Not related to the kernel weights.
#' @param family exponential family distribution of the response
#' @param bw bandwidth for the kernel
#' @param kernel kernel function for generating the local observation weights
#' @param coords matrix of locations, with each row giving the location at which the corresponding row of data was observed
#' @param longlat \code{TRUE} indicates that the coordinates are specified in longitude/latitude, \code{FALSE} indicates Cartesian coordinates. Default is \code{FALSE}.
#' @param varselect.method criterion to minimize in the regularization step of fitting local models - options are \code{AIC}, \code{AICc}, \code{BIC}, \code{GCV}
#' @param tol.loc tolerance for the tuning of an adaptive bandwidth (e.g. \code{knn} or \code{nen})
#' @param bw.type type of bandwidth - options are \code{dist} for distance (the default), \code{knn} for nearest neighbors (bandwidth a proportion of \code{n}), and \code{nen} for nearest effective neighbors (bandwidth a proportion of the sum of squared residuals from a global model)
#' @param bwselect.method criterion to minimize when tuning bandwidth - options are \code{AICc}, \code{BICg}, and \code{GCV}
#' @param verbose print detailed information about our progress?
#'
#' @return value of the \code{bwselect.method} criterion for the given bandwidth
#'
lagr.tune.bw = function(x, y, weights, coords, dist, family, bw, kernel, env, oracle, varselect.method, tol.loc, bw.type, bwselect.method, min.dist, max.dist, lambda.min.ratio, n.lambda, lagr.convergence.tol, lagr.max.iter, verbose) {
    #Fit the model with the given bandwidth:
    cat(paste('Bandwidth: ', round(bw, 3), '; ', sep=""))

    # Tell lagr.dispatch whether to select bandwidth via the jacknife
    if (bwselect.method=='jacknife') {
        jacknife = TRUE
    } else {
        jacknife = FALSE
    }

    vcr.model = lagr.dispatch(
        x=x,
        y=y,
        coords=coords,
        fit.loc=NULL,
        D=dist,
        family=family,
        prior.weights=weights,
        tuning=TRUE,
        predict=FALSE,
        simulation=FALSE,
        oracle=oracle,
        varselect.method=varselect.method,
        verbose=verbose,
        bw=bw,
        bw.type=bw.type,
        kernel=kernel,
        min.dist=min.dist,
        max.dist=max.dist,
        tol.loc=tol.loc,,
        lambda.min.ratio=lambda.min.ratio,
        n.lambda=n.lambda,
        lagr.convergence.tol=lagr.convergence.tol,
        lagr.max.iter=lagr.max.iter
    )

    res = mget('trace', env=env, ifnotfound=list(matrix(NA, nrow=0, ncol=3)))
    res$trace = as.data.frame(rbind(res$trace, c(bw, vcr.model[[bwselect.method]], vcr.model$df)))
    colnames(res$trace) = c("bw", "loss", "df")
    res$trace = res$trace[order(res$trace$bw),]
    assign('trace', res$trace, env=env)

    cat(paste('df: ', round(vcr.model$df,4), '; Loss: ', signif(vcr.model[[bwselect.method]], 5), '\n', sep=''))
    return(vcr.model[[bwselect.method]])
}


library(flume)
library(Matrix)
library(units)

data("flume_networks")
net = flume_networks$kamp

set.seed(1703)

options(mc.cores = 4)

# generate x species with same niche breadth, niche height but random location
nsp = 50

# use niches_uniform to calculate niche location for all species at once
nopts = list(location = runif(nsp, 0.1, 0.9),
	breadth = 0.1, scale_e = 1.25e-7, scale_c = 6e-6, r_use = 0.05)

# number of different dispersal abilities
n_disp = 6
alpha = seq(0.05, 1, length.out = n_disp)

# passive dispersal is kept constant at the moment
beta = 0.1

# starting prevalence for species in the network
prev = 0.2

# starting/boundary state of the network
start_r = matrix(0.5, nrow = length(net), ncol = 1)
## headwaters are most extreme
start_r[c(10:12, 16, 20:24), ] = 0.9
start_r[c(42:43, 46, 47:52), ] = 0.1

start_r[c(9, 13:15, 17:19), ] = 0.7
start_r[c(38:41, 44:45), ] = 0.3

## gamma diversity scenarios
## how many species are possible in each scenario
n_gamma = 6
g_div = c(2, 10, 20, 30, 40, 50)

## how many times to repeat each particular species richness (with new random species)
## and dispersal combo
n_reps = 40

# generate random species lists for each gamma
sps = lapply(g_div[-n_gamma], \(gam) t(sapply(1:n_reps, \(n) sample(nsp, gam, replace = FALSE))))
names(sps) = paste("g", g_div[-n_gamma], sep="")
sps$g50 = matrix(1:nsp, nrow = 1)
saveRDS(sps, "splists.rds")

## how many times to repeat each particular combination
## multithreaded, so up to mc.cores is free
n_iter = 2 * getOption("mc.cores")

nt = 60 # number of time steps of one simulation

# total number of simulations, and time
# n_sims = n_reps * n_gamma * n_disp * ceiling((n_iter / getOption("mc.cores")))
# set_units(n_sims * set_units(19.223, "seconds"), "hours")

# loop across all the scenarios
for(d_alpha in alpha) {
	cat("alpha = ", d_alpha, " (", which(alpha == d_alpha), " of ", length(alpha), ")\n", sep="")
	dopts = list(alpha = d_alpha, beta = beta)
	mcom = metacommunity(nsp = nsp, nr = 1, niches = niches_custom, niche_args = nopts,
			dispersal = dispersal_custom, dispersal_args = dopts)

	for(j in 1:n_gamma) {
		gam = g_div[j]
		splist = sps[[j]]
		cat("     gamma diversity = ", gam, " (", j, " of ", n_gamma, ")\n", sep="")
		for(i in 1:nrow(splist)) {
			species_ids = splist[i,]
			cat("          species ", paste(species_ids, collapse = " "), " (", i, " of ",
				nrow(splist), ")\n", sep="")
			fbase = paste0("fit_alpha-", round(d_alpha, 2), "_sp-",
				paste(species_ids, collapse='.'), ".rds")
			fname = file.path("ex3", "res", fbase)
			start_sp = matrix(0, nrow = length(net), ncol = nsp)
			for(k in species_ids)
				start_sp[,k] = rbinom(length(net), 1, prev)
			mod = flume(mcom, net, start_sp, start_r)
			suppressMessages(mod <- run_simulation(mod, nt, reps = n_iter))
			saveRDS(mod, fname)
		}
	}
}


# Best fixed AR(1) model for drift detection
# Rest is taken over from analysis v23 and v26

source('./../../gwloggeR/R/fourier.R')

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name) {
  compare(read.baro(logger.name), read.baro('KNMI_20200312_hourly'))
}

coef.pvals <- function(M) {
  (1-pnorm(abs(M$coef[colnames(M$var.coef)])/sqrt(diag(M$var.coef))))*2
}

plt.comp <- function(TIMESTAMP_UTC, Y, M = NULL, significant = NULL, front_layer = NULL,
                     xlim = range(TIMESTAMP_UTC), ylim = quantile(Y, c(0.005, 0.995))) {

  force(TIMESTAMP_UTC); force(Y); force(M)
  force(ylim); force(xlim)

  p <- ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = 'red', alpha = 0.9)

  if (!is.null(M))
    p <- p + ggplot2::geom_line(mapping = ggplot2::aes(y = fitted(M)), col = 'black', size = 1.5)

  if (!is.null(significant)) {
    p <- p + ggplot2::annotate(
      "label", x = as.POSIXct(-Inf, origin = '1970-01-01'), y = Inf,
      size = 4, col = if (significant) 'green' else 'red',
      hjust = 0, vjust = 1, fill = 'grey', label.size = NA,
      label = if (significant) 'SIGNIFINCANT' else 'NOT SIGNIFICANT'
    )
  }

  if (!is.null(M[['btrend']]) && coef.pvals(M)['btrend'] < 0.0001)
    p <- p + ggplot2::geom_vline(xintercept = TIMESTAMP_UTC[which.max(M$btrend > 0)],
                                 col = 'blue', linetype = 'dotted', size = 1.2)

  p <- p +
    ggplot2::coord_cartesian(ylim = ylim, xlim = xlim) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                   axis.title.y = ggplot2::element_blank(),
                   axis.title.x = ggplot2::element_blank())

  p
}

report <- function(logger.name) {
  require(forecast)

  environment(plt.comp) <- environment() # fitted(Arima) then can find the source data.

  print(logger.name)

  df.diff <- ref.compare(logger.name)

  if (nrow(df.diff) < 10L) return(invisible(FALSE))

  M <- arima(x = df.diff$PRESSURE_DIFF, order = c(0, 0, 0))
  df.diff[, M_pred := fitted(M)]

  M.AR90 <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), transform.pars = FALSE, fixed = c(0.90, NA))
  df.diff[, M.AR90.pred := fitted(M.AR90)]

  M.AR60 <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), transform.pars = FALSE, fixed = c(0.60, NA))
  df.diff[, M.AR60.pred := fitted(M.AR60)]

  trend <- c(0, cumsum(diff(as.numeric(df.diff$TIMESTAMP_UTC))/3600/24))
  breakpoints <- seq(from = 1, to = nrow(df.diff) - 1, by = 10)

  M.ARD90 <- M.AR90
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = btrend, transform.pars = FALSE, fixed = c(0.90, NA, NA))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARD90)) M.ARD90 <- .M
  }
  df.diff[, M.ARD90.pred := fitted(M.ARD90)]

  M.ARD60 <- M.AR60
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = btrend, transform.pars = FALSE, fixed = c(0.60, NA, NA))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARD60)) M.ARD60 <- .M
  }
  df.diff[, M.ARD60.pred := fitted(M.ARD60)]

  sbasis <- fbasis(timestamps = df.diff$TIMESTAMP_UTC, frequencies = 1/(365.25*3600*24))

  M.ARS90 <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = sbasis, transform.pars = FALSE, fixed = c(0.90, NA, NA, NA))

  M.ARDS90 <- M.ARS90
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = cbind(sbasis, btrend), transform.pars = FALSE, fixed = c(0.90, NA, NA, NA, NA))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARDS90)) M.ARDS90 <- .M
  }

  M.ARS60 <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = sbasis, transform.pars = FALSE, fixed = c(0.60, NA, NA, NA))

  M.ARDS60 <- M.ARS60
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = cbind(sbasis, btrend), transform.pars = FALSE, fixed = c(0.60, NA, NA, NA, NA))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARDS60)) M.ARDS60 <- .M
  }

  M.AUTO <- forecast::auto.arima(df.diff$PRESSURE_DIFF, trace = TRUE,
                                 stationary = TRUE, ic = 'aicc',
                                 xreg = data.matrix(cbind(sbasis, 'btrend' = M.ARDS90[['btrend']])))
  M.AUTO[['btrend']] <- M.ARDS90[['btrend']]

  df.diff[, TIMESTAMP_UTC_DIFF_HOURS := c(NA, round(diff(as.numeric(TIMESTAMP_UTC))/3600))]

  p.comp <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF)

  p.M <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M)

  p.M.AR60 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AR60)
  p.M.AR90 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AR90)

  p.M.ARS60 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARS60)
  p.M.ARS90 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARS90)

  p.M.ARD60 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARD60)
  p.M.ARD90 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARD90)

  p.M.ARDS60 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARDS60)
  p.M.ARDS90 <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARDS90)

  p.M.AUTO <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AUTO)

  p.ts.diff <- ggplot2::ggplot(data = df.diff[-1, ], mapping = ggplot2::aes(
    x = TIMESTAMP_UTC,
    y = TIMESTAMP_UTC_DIFF_HOURS)) +
    ggplot2::scale_y_continuous(
      trans = scales::trans_new(name = 'log12',
                                transform = function(x) logb(x = x, base = 12),
                                inverse = function(x) 12^x)) +
    ggplot2::geom_point(pch = '-', size = 8) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5),
                   axis.title.y = ggplot2::element_blank(),
                   axis.title.x = ggplot2::element_blank())

  # File export ----------------------------------------------------------------

  filename <- sprintf('./drifts/analysis_28/%s.png', tools::file_path_sans_ext(basename(logger.name)))
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)

  layout_matrix <- rbind(c(1, 2),
                         c(3, 4),
                         c(5, 6))

  grob.title <- grid::textGrob(sprintf('%s (#%s differences with KNMI data from %s to %s) -> %s | Fixed AR(1) = 0.9 and 0.6',
                                       basename(logger.name), nrow(df.diff),
                                       min(df.diff$TIMESTAMP_UTC), max(df.diff$TIMESTAMP_UTC),
                                       forecast:::arima.string(M.AUTO)),
                               x = 0.05, hjust = 0)

  p.empty <- ggplot2::ggplot() + ggplot2::theme_void()

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    gridExtra::grid.arrange(p.M.AUTO, p.ts.diff,
                            p.M.ARD90, p.M.ARDS90,
                            p.M.ARD60, p.M.ARDS60,
                            layout_matrix = layout_matrix,
                            top = grob.title)
  })

  invisible(TRUE)

}

# report('BAOL009X_78680') # drifter
# report('BAOL008X_72528') # x-y model AR component significantly down to 0.46
# report('BAOL538X_B_002A2') # strong undetected (?) drift
# report('BAOL031X_B5554') # shift at the end
invisible(lapply(logger.names, report))


library("testthat");
#install.packages("testthat")

source("../testCatSingle.r");

# reordering values of a categorical variable
x1 = reorderOrderedCategory(c(7,3,5,1,8,10,1,5,3,7), "7|3|5|1");
expect_equal(x1, c(1,2,3,4,NA,NA,4,3,2,1));


technical_ui <- tabItem(tabName = "Technical",
	h2("Technical"),
	tabsetPanel(id="tabSelected",
		tabPanel("MARS"), #multiple adaptive regression splines?
		tabPanel("LM"), #linear model
		tabPanel("MACD") #provides thresholds for buying and selling based on stretched points?
	)
)


#------------------------------
# library
#------------------------------

library(magrittr)
library(dplyr)

#------------------------------
# main
#------------------------------

# setting
dir_path <- file.path("..", "submission")
prj_name <- "submission_pre"

# stack filenames
print("==> Stack filenames")
filename_regex <- ".+_train(.+)_valid(.+)_seed(.+).csv"

result <- list.files(file.path("..", "submission", prj_name)) %>%
	data.frame(
		filenames=.,
		train=gsub(filename_regex, "\\1", .) %>% as.numeric,
		valid=gsub(filename_regex, "\\2", .) %>% as.numeric,
		seed=gsub(filename_regex, "\\3", .) %>% as.integer
		) %>%
	arrange(desc(valid)) %T>%
	print

# number of input
num_model <- nrow(result)

# averaging
print("==> Load data")
data_all <- NULL
for(i in 1:num_model){
	target_file <- as.character(result$filename[i])
	cat("filename: ", target_file, "\n")

	datai <- read.csv(file.path(dir_path, prj_name, target_file))
	print(table(datai$Response))

	colnames(datai) <- c("Id", result$seed[i])

	if(i==1){
		data_all <- datai
	}else{
		data_all <- merge(data_all, datai, by="Id")
	}
}

# ensemble
print("==> Averaging")
threshold <- ceiling(num_model / 2)
ensemble <- as.integer(rowSums(data_all[,-1]) >= threshold)
cat("ensemble result\n")
print(table(ensemble))

submission <- data.frame(Id=data_all$Id, Response=ensemble)

# display scores
train_scores <- result$train[1:num_model]
valid_scores <- result$valid[1:num_model]
cat("train: ", sprintf("%.4f +- %.4f", mean(train_scores), sd(train_scores)), "\n")
cat("valid: ", sprintf("%.4f +- %.4f", mean(valid_scores), sd(valid_scores)), "\n")

# save output
meantrain <- mean(train_scores)
meanvalid <- mean(valid_scores)
st <- function(score) return(sprintf("%.3f", score))
filename <- paste0("submission_ensemble", num_model, "_mtrain", st(meantrain), "_mvalid", st(meanvalid), ".csv")
write.table(submission, file.path(dir_path, filename), row.names = FALSE, sep=",", quote = FALSE)


# Model prediction Accuracy calculating function.
#The accuracy calculation function work based on +- one log bacterial count of predicted values from the actual values.

# x = is predicted values using the trained model
# y = is the actual test data
Percentage<-function(x, y){
  SVMLM_TVC<-c()
  for ( i in 1:length(x)){
    if((x[i])<=((y[i])+1) & x[i]>=((y[i])-1)){
      G<-i
      SVMLM_TVC<-c(SVMLM_TVC, G)

    }
    else{

    }

  }
  percentage_SVMLM_TVC<- length(SVMLM_TVC)/length(y)*100
}


# Extract values from reference products
library(terra)
source("pixel-based/utils/load-sampling-data.r")

InDir = "../data/pixel-based/reference-products"
OutDir = "../data/pixel-based/reference-products"

if (!dir.exists(OutDir))
    dir.create(OutDir)

# Points to extract
#TrainingPoints = LoadGlobalTrainingData()
ValidationPoints = LoadGlobalValidationData()
#PredictionPoints = LoadGlobalRasterPoints()
AllPoints = ValidationPoints[,c("x", "y")]#rbind(TrainingPoints[,c("x", "y")], ValidationPoints[,c("x", "y")], PredictionPoints[,c("x", "y")])

# Put all data sources into a list
MetricNames = c("treecover", "gsw", "ghsl", "impervious")
MetricFiles = c(
    file.path(InDir, "MeasuresTreecover.vrt"),
    file.path(InDir, "GSW2015.vrt"),
    file.path(InDir, "GHSLBuiltup2014.vrt"),
    file.path(InDir, "QinghuaImpervious2015.vrt"))
names(MetricFiles) = MetricNames

for (f in 1:length(MetricFiles))
{
    MetricRast = rast(MetricFiles[f])

    ChunkSize = 5000
    Iterator = seq(1, nrow(AllPoints), ChunkSize)
    pb = txtProgressBar(min = 1, max = nrow(AllPoints), style = 3)
    for (i in Iterator)
    {
        ChunkEnd = min(i+ChunkSize-1, nrow(AllPoints))
        DataChunk = AllPoints[i:ChunkEnd,]

        DSValues = cbind(extract(MetricRast, vect(DataChunk)), DataChunk)
        names(DSValues)[1] = MetricNames[f]
        st_write(DSValues, file.path(OutDir, paste0(MetricNames[f], ".gpkg")), append=TRUE)
        rm(DSValues)
        rm(DataChunk)
        gc()

        setTxtProgressBar(pb, ChunkEnd)
    }

    close(pb)
}


nextState <- function(x, y, dir, inp) {
    cmd <- substring(inp, 1, 1)
    val <- strtoi(substring(inp, 2, nchar(inp)))

    result <- switch(cmd,
        "N" = move(x, y, "N", val, dir),
        "S" = move(x, y, "S", val, dir),
        "E" = move(x, y, "E", val, dir),
        "W" = move(x, y, "W", val, dir),
        "F" = move(x, y, dir, val, dir),
        "R" = c(x, y, rotate(val, dir)),
        "L" = c(x, y, rotate(-val, dir)))

    result
}

move <- function(x, y, moveDir, val, dir) {
    switch(moveDir,
        "N" = c(x, y + val, dir),
        "S" = c(x, y - val, dir),
        "E" = c(x + val, y, dir),
        "W" = c(x - val, y, dir))
}

fromDirection <- function(dir) {
    switch(dir,
        "N" = 0,
        "E" = 90,
        "S" = 180,
        "W" = 270)
}

toDirection <- function(deg) {
    switch((deg %/% 90) + 1,
        "N",
        "E",
        "S",
        "W")
}

rotate <- function(rotation, dir) {
    toDirection((360 + fromDirection(dir) + rotation) %% 360)
}

fileName <- "input.txt"
x <- 0
y <- 0
dir <- "E"

inp <- file(fileName, "r")

for (line in readLines(inp)) {
    s <- nextState(x, y, dir, line)
    x <- strtoi(s[1])
    y <- strtoi(s[2])
    dir <- s[3]
}

close(inp)

print(abs(x) + abs(y))


########################################################################################
## This file is a part of YAP package of scripts. https://github.com/shpakoo/YAP
## Distributed under the MIT license: http://www.opensource.org/licenses/mit-license.php
## Copyright (c) 2011-2013 Sebastian Szpakowski
########################################################################################

library(ggplot2)
library(grid)
library(scales)

multiplot <- function(..., plotlist=NULL, cols=1, layout=NULL)
{
	require(grid)

	# Make a list from the ... arguments and plotlist
	plots = c(list(...), plotlist)

	numPlots = length(plots)
	print (numPlots)

	# If layout is NULL, then use 'cols' to determine layout
	if (is.null(layout))
	{
		layout = grid.layout(ceiling(numPlots/cols), cols)
	}

	# create a panel that will be used to map ids later

	panel = matrix(1:(layout$nrow * layout$ncol), nrow = layout$nrow, ncol = layout$ncol, byrow=TRUE )

	if (numPlots==1)
	{
		print(plots[[1]])
	}
	else
	{
		# Set up the page
		grid.newpage()
		pushViewport(viewport(layout = layout))

		for (i in 1:numPlots)
		{
			matching <- as.data.frame(which(panel == i, arr.ind = TRUE))

			print ( plots[[i]], vp = viewport(	layout.pos.row = matching$row,
							layout.pos.col = matching$col)
			)
		}
	}
}

makePlot = function(filename = "read.groups.tab.txt", minreads = 0, mingroups = 0, nlevels = 500, mode="OTU", xlim=c(0,0), ylim=c(0,0))
{
	if (mode=="OTU")
	{
		x = read.table(filename, as.is=T, header=F, sep="\t")
		x=x[-1,]
		names(x) = c("reads", "groups")

		ylab = "number of samples showing an OTU"
		xlab = "OTU size (i.e. number of reads in OTU, log10 scale)"

		histlab="OTU size"

		groups = unique(x$groups)
		labs = groups

		alldata = x
		subsetdata =  x[x$reads>minreads & x$groups>mingroups,]

		v = NA
		h = NA

		forhist = subsetdata$reads
		forhist[forhist>100]=100

	}
	else if ( mode=="coverage")
	{
		x = read.table(filename, as.is=T, header=F, sep="", skip=34)
		#print (dim(x))
		#x=x[-1,]

		###  Contig     Sites     Reads   Coverage
		names(x) = c("x1", "reads", "x2", "groups")

		ylab = "coverage"
		xlab = "Contig Size (log10 scale)"

		histlab="Contig Coverage"

		x$groups = log10(x$groups)

		#groups = round(seq(0,ceiling(max(x$groups)), length.out=20),2)
		groups = log10(c(1,10,100,1000,10000))
		labs = round(10^groups,0)

		alldata = x
		subsetdata =  x[x$reads>minreads & x$groups>mingroups,]

		forhist = 10^subsetdata$groups

		h = mean(subsetdata$reads)
		v = sum(subsetdata$x2) / sum(subsetdata$reads) * 100

		xlim = log10(c(100,100000))
		ylim = log10 (c(0.1,10000))

		forhist[forhist>100]=100
		print (v)

	}
	else
	{
		print ("unknown plotting mode.")
		return (0)
	}

	if (nrow(subsetdata)>2 && nrow(alldata)>2)
	{
		alldata = alldata[is.finite(alldata$groups),]
		subsetdata = subsetdata[is.finite(subsetdata$groups),]

		### setup  canvas using all data

		nf <- layout(matrix(c(1,2,3,0), 2, 2, byrow=TRUE), respect=FALSE, width=c(0.8,0.2))

		if (xlim[1]==xlim[2])
		{
			ylim = c(min(alldata$groups)-0.5,max(alldata$groups)+0.5)
			plot (log10(alldata$reads), alldata$groups, type= "n", ylab = ylab, xlab = xlab, ylim=ylim, axes=FALSE, main=filename)

		}
		else
		{
			plot (log10(alldata$reads), alldata$groups, type= "n", ylab = ylab, xlab = xlab, ylim=ylim, xlim=xlim,  axes=FALSE, main=filename)
		}

		axis(2, at=groups, lab=labs, las=2)
		A = c(1:9)
		B =seq(0, log10(max(alldata$reads)), by=1)
		C =expand.grid(A, B)
		C$at = C[,1] * 10^(C[,2])
		C$lab = ifelse (C[,1]%%10==1, 10^C[,2], "")

		axis(1, at=log10(C$at), lab=rep("", nrow(C)) , col.ticks="gray", lwd.ticks=2 )
		C2 = C[C$lab!="", ]
		axis(1, at=log10(C2$at), lab=C2$lab , col.ticks="black", lwd.ticks= 4 )

		### use only subset data from now on:
		subsetdata$reads = log10(subsetdata$reads)

		# contour
		require(MASS)
        try( {
		xykde = MASS::kde2d(subsetdata$reads, subsetdata$groups, lims = c( min(subsetdata$reads)-5, max(subsetdata$reads)+5, min(subsetdata$groups)-5, max(subsetdata$groups)+5) )

		if (sum(is.nan(xykde$z))>0)
		{
			cat("have to nudge groups...\n")
			b = subsetdata$groups + sample(c(-0.1, 0.1), length(subsetdata$groups), replace=T)
			xykde = MASS::kde2d(subsetdata$reads, b, lims = c( min(subsetdata$reads)-5, max(subsetdata$reads)+5, min(subsetdata$groups)-5, max(subsetdata$groups)+5) )
		}

		zlim = range(xykde$z, finite = TRUE)
		lev = seq(zlim[1], zlim[2], le = nlevels)
		col = rev(heat.colors(length(lev)))
		contour(xykde, add = TRUE, levels = lev,
			drawlabels = FALSE, col=col  )

		# trendline
		trendline = lowess((subsetdata$reads), subsetdata$groups, f=0.1)
		points(trendline , type="l", lwd=5, col="gray30")

		# points
		points(subsetdata$reads, subsetdata$group, pch=19, col="gray60", cex=0.4)

		# cutoff lines	if (mingroups>0)
		{
			abline(h=mingroups, col="red", lty=2, lwd=0.5)
		}
		if (minreads>0)
		{
			abline(v=log10(minreads), col="red", lty=2, lwd=0.5)
		}
		box(lwd=5)

		# legend
		plot (0,100, xlim=c(0,1), ylim = c(min(lev), max(lev)), xlab="", ylab="", axes=F, main="")
		rect(0, lev[-length(lev)], 1, lev[-1L], col = col, border=NA)

		#print (lev)

		at = unique(round(seq(0, max(lev), length.out=10),2))
		lab = paste(round((1-(at/ceiling(max(at)))) * 100,0) , "%", sep="")
		axis(4, las=1, cex.axis=0.5)
		axis(2, las=1, at = at, lab=lab)
		box()

		# histogram
		hist ((forhist), col="gray", br=seq(0.5,100.5, by=1), axes =FALSE, xlab = histlab, main="")
		axis(2)
		at = c(1:10, seq(20,100, by=10) )
		labs = paste(at)
		labs [2:9]=""

		labs[length(labs)] = paste(labs[length(labs)], "+", sep="")
		axis(1, at = at, lab=labs, las=3)

		if (! is.na(v))
		{
			#abline(v= v, lwd=5, col="green")
			#abline(h= h, lwd=5, col="blue")
			legend("top", c(
								paste( "Average coverage: ", round(v,2), sep=" "),
								paste( "Average length: ", round(h,2), sep=" ")
								),

			fill=c("green", "blue"))
		}

		#print ( nrow(x[x$groups<=1 & x$reads<=0.1,]) )
		#print ( nrow(x))
        } )
	}

}

getData = function(files, mode="clccoverage")
{
	global = data.frame()
	for (f in files)
	{

		print (f)
		if (mode =="clccoverage")
		{
			tmp = read.table(f, as.is=T, header=F, sep="", skip=34)
			names(tmp) <- c("Contig", "Sites", "Reads", "Coverage")

		}
		else if (mode == "otu")
		{
			tmp = read.table(f, as.is=T, header=F, sep="\t")
			names(tmp) <- c("Reads", "Groups")

		}
		else
		{
			return (global)
		}

		a = strsplit( f, "\\.")[[1]][2]
		b = strsplit( a,"-")[[1]][1]
		cat(f, "->", a, "->", b, "\n")
		tmp$File = rep(b, nrow(tmp))

		if (nrow(global)==0)
		{
			global=tmp
		}
		else
		{
			global=rbind(tmp,global)
		}

	}
	return (global)
}

makeGGplotOTU = function(global)
{
	print ("not there yet")
}

makeGGplotCOVERAGE = function(global)
{

	### how do files compare w/r to contig sizes
	plots = list()

	for (S in c("Reads", "Sites", "Coverage"))
	{
		x1 = (ggplot(global,  aes_string(y=S, x="File", color="File"))
					+ geom_boxplot()
					+ scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
							labels = trans_format("log10", math_format(10^.x)))
					+ coord_flip()
					+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())

					)

		x2 = (ggplot(global,  aes_string(x=S, y="..count..",  fill="File", group="File" ))
					+ stat_bin(aes(y=..count..), geom="area", position="stack", weight=2)
					+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
							labels = trans_format("log10", math_format(10^.x)))
					)

		x3 = (ggplot(global,  aes_string(x=S, y="..count..",  fill="File", group="File" ))
					+ stat_bin(aes(y=..count..), geom="area", position="dodge", alpha=0.5, weight=2)
					+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
							labels = trans_format("log10", math_format(10^.x)))
					)

		x4 = (ggplot(global,  aes_string(x=S, y="..count..", fill="File", group="File" ))
					+ geom_bar(position="fill")
					+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
							labels = trans_format("log10", math_format(10^.x)))
					)

	 	plots = append(list(x1, x2, x3, x4), plots)

	}
	y1 = (ggplot(global,  aes(y=Reads / Sites, x=File, color=File))
				+ geom_boxplot()
				+ scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
						labels = trans_format("log10", math_format(10^.x)))
				+ coord_flip()
				+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())

				)
	y2 = (ggplot(global,  aes(x= Reads/Sites , y=..count..,  fill=File, group=File ))
				+ stat_bin(aes(y=..count..), geom="area", position="stack", weight=2)
				+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
						labels = trans_format("log10", math_format(10^.x)))
				)

	y3 = (ggplot(global,  aes(x= Reads/Sites , y=..count..,  fill=File, group=File ))
				+ stat_bin(aes(y=..count..), geom="area", position="dodge", alpha=0.5, weight=2)
				+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
						labels = trans_format("log10", math_format(10^.x)))
				)

	y4 = (ggplot(global,  aes(x= Reads/Sites , y=..count..,  fill=File, group=File ))
				+ geom_bar(position="fill")
				+ scale_x_log10(breaks = trans_breaks("log10", function(x) 10^x),
						labels = trans_format("log10", math_format(10^.x)))
				)

	plots = append(plots, list(y1, y2, y3, y4), )

	#return (plots)

#	B = (ggplot(global,  aes(File, Sites, color=File))
#				+ geom_boxplot()
#				+ scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
#						labels = trans_format("log10", math_format(10^.x)))
#				+ coord_flip()
#				+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())
#
#				)
#	C = (ggplot(global,  aes(File, Coverage, color=File))
#				+ geom_boxplot()
#				+ scale_y_log10(breaks = trans_breaks("log10", function(x) 10^x),
#						labels = trans_format("log10", math_format(10^.x)))
#				+ coord_flip()
#				+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())
#
#				)

	png("AllAssemblyStats_GG.png", width=20, height = 20, units="in", res=250)
	multiplot(plotlist=plots, cols=4)
	dev.off()
	invisible(plots)

}

makeBatchOTU = function(filename)
{
	pdf(paste(filename,"otusizes.pdf", sep="."), paper="special", width=11, height=10)
	makePlot(filename = filename, minreads=0, mingroups=0)
	makePlot(filename = filename, minreads=1, mingroups=0)
	makePlot(filename = filename, minreads=1, mingroups=1)
	makePlot(filename = filename, minreads=5, mingroups=1)
	dev.off()
}

makeBatchCoverage = function(filename)
{
	pdf(paste(filename,"coveragestats.pdf", sep="."), paper="special", width=11, height=10)
	makePlot(filename = filename, minreads=0, mingroups=0, mode="coverage", nlevels=50)
	makePlot(filename = filename, minreads=0, mingroups=log10(10), mode="coverage", nlevels=50)
	makePlot(filename = filename, minreads=1000, mingroups=log10(10), mode="coverage", nlevels=50)
	dev.off()
}

###################################################################
##### OTU stats
files = dir( pattern=glob2rx("*.otustats"))
for (f in files)
{
	print (f)
	makeBatchOTU (f)
}

if (length(files)>0)
{
	inputdata = getData(files, mode="otu")
	makeGGplotOTU (inputdata)
}

##### COVERAGE stats
files = dir( pattern=glob2rx("*.clcassemblystats"))
for (f in files)
{
	print (f)
	makeBatchCoverage (f)
}

if (length(files)>0)
{
	inputdata = getData(files, mode="clccoverage")
	makeGGplotCOVERAGE (inputdata)
}


base_datos <- read.csv("../base_data/dataTableAnaliticEmotionText.csv")
base_datos[1,]

# fecha <- '2018-06-27T19:40:00.000Z'

# formatoFecha = function(fecha){
#     substr(fecha,12,13)
# }

# cleanBase_datos = replace(base_datos$fecha,,substr(base_datos$fecha,12,13))

# cleanBase_datos[1:2,]
# cleanBase_datos = base_datos[base_datos$fecha <- substr(base_datos$fecha,12,13),]
#  eliminar nulos
base_datos <- base_datos[!is.na(base_datos$puntajeEmocion),]
#unir valores por hora
emotionHourMean = aggregate(base_datos$puntajeEmocion, by=list(fecha=base_datos$fecha), FUN=mean)

titulo = 'grafica_emotion_hour'
png(file = paste("../public/",titulo, ".png"))
plot(puntajeEmocion ~ fecha,data =base_datos)
abline(lm(base_datos$fecha ~ base_datos$puntajeEmocion ))
correlacion <- cor(base_datos$puntajeEmocion,base_datos$fecha)
legend("bottomleft",col=c(correlacion),legend =c(correlacion), lwd=3, bty = "n")

dev.off()

titulo = 'grafica_emotion_hour_mean'
png(file = paste("../public/",titulo, ".png"))
plot(emotionHourMean )
dev.off()

titulo = 'bandera_emotion_hour'
png(file = paste("../public/",titulo, ".png"))
boxplot(puntajeEmocion ~ fecha,data =base_datos)
dev.off()

titulo = 'histograma_emotion_hour_mean'
png(file = paste("../public/",titulo, ".png"))
hist(emotionHourMean$x )
dev.off()


# ruth's unifrac method

library(phangorn)
library(ape)
library(zCompositions)

gm_mean = function(x, na.rm=TRUE){
  exp(mean(log(x), na.rm=na.rm) )
}

# gm_vector = function(node_count, other_counts, geometric_mean) {
#   gm_vec <- array(0,length(node_count))
#   # a count of -1 means that the OTU has been amalgamated to other OTUs in the node_count
#   zero_means <- list()
#   counter = 1
#   for (i in 1:length(node_count)) {
#   # CHECK IF THIS IS CORRECT - indexing for other_counts
#     gm_vec[i] <- gm_mean(c(node_count[i],other_counts[i,][which(other_counts[i,]!=-1)]))
#     if (gm_vec[i] == 0) {
#       gm_vec[i] = geometric_mean[i]
#     }
#   }
#   return(gm_vec)
# }

gm_from_props = function(rownum, colnums) {
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  return(log2(otuPropsPerNode.adjustedZeros[rownum,colnums[1]]) - mean(log2(otuPropsPerNode.adjustedZeros[rownum,colnums])))
}

make_otu_props_positive = function() {
  otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  otuPropsPerNode <- abs(otuPropsPerNode)
  otuPropsPerNode.adjustedZeros <- abs(otuPropsPerNode.adjustedZeros)
  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
}

get_children = function(root) {
  unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
  children <- unifrac.tree$edge[which(unifrac.tree$edge[,1]==root),2]
  return(children)
}

get_subtree = function() {
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  return(colnames(otuPropsPerNode.adjustedZeros)[which(otuPropsPerNode.adjustedZeros[1,] < 0)])
}

build_weights = function(root) {
  # make all weight values positive
  make_otu_props_positive()
  # if root is leaf, then weight has already been calculated and we can skip this
  if (root > length(unifrac.tree$tip.label)) {

    children <- get_children(root)

    # construct values for left child
    build_weights(children[1])
    leftChildSubtree <- get_subtree()

    # construct values for right child
    build_weights(children[2])
    rightChildSubtree <- get_subtree()

    otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
    otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
    weightsPerNode <- get("weightsPerNode",envir = .GlobalEnv)
    unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
    unifrac.treeLeaves <- get("unifrac.treeLeaves",envir=.GlobalEnv)

    # the negative values in leftChildProportions are for all the nodes in the subtree of the left child
    # the negative values in rightChildProportions are for all the nodes in the subtree of the right child

    leafColumns <- colnames(otuPropsPerNode)[which(colnames(otuPropsPerNode) %in% unifrac.treeLeaves)]

    # make both left and right child subtrees negative
    otuPropsPerNode[,leftChildSubtree] <- (-1)*abs(otuPropsPerNode[,leftChildSubtree])
    otuPropsPerNode.adjustedZeros[,leftChildSubtree] <- (-1)*abs(otuPropsPerNode.adjustedZeros[,leftChildSubtree])

    # get columns for use in weight calculation (leaves not in right or left subtree plus root)
    columnsForWeightCalculation <- leafColumns
    columnsForWeightCalculation <- columnsForWeightCalculation[which(!(columnsForWeightCalculation %in% leftChildSubtree))]
    columnsForWeightCalculation <- columnsForWeightCalculation[which(!(columnsForWeightCalculation %in% rightChildSubtree))]
    columnsForWeightCalculation <- c(root, columnsForWeightCalculation)

    # calculate proportion of current node
    otuPropsPerNode[,root] <- abs(otuPropsPerNode[,children[1]]) + abs(otuPropsPerNode[,children[2]])
    otuPropsPerNode.adjustedZeros[,root] <- abs(otuPropsPerNode.adjustedZeros[,children[1]]) + abs(otuPropsPerNode.adjustedZeros[,children[2]])
    assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
    assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)

    # calculate weight of current node
    weightsPerNode[,root] <- sapply(c(1:nrow(otuPropsPerNode.adjustedZeros)),function(x) { gm_from_props(x, columnsForWeightCalculation)})
  }
  # make root node values negative
  otuPropsPerNode[,root] <- (-1)*abs(otuPropsPerNode[,root])
  otuPropsPerNode.adjustedZeros[,root] <- (-1)*abs(otuPropsPerNode.adjustedZeros[,root])

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)
}

calculateDistanceMatrix <- function(weights, method, otuTable, verbose, pruneTree, normalize) {
  unifrac.tree <- get("unifrac.tree",envir=.GlobalEnv)
  otuPropsPerNode <- get("otuPropsPerNode",envir=.GlobalEnv)

  nSamples <- nrow(otuTable)
  distanceMatrix <- matrix(NA,nrow=nSamples,ncol=nSamples)
  rownames(distanceMatrix) <- rownames(otuTable)
  colnames(distanceMatrix) <- rownames(otuTable)

  branchLengths <- unifrac.tree$edge.length

  weightColnames <- as.numeric(colnames(weights))

  weights <- weights[,match(unifrac.tree$edge[,2], weightColnames)]

	for (i in 1:nSamples) {
		for (j in i:nSamples) {

				if (method == "weighted" || method == "information" || method == "ratio" || method == "ratio_no_log") {
					# the formula is sum of (proportional branch lengths * | proportional abundance for sample A - proportional abundance for sample B| )
					if (pruneTree==TRUE){
						includeBranchLengths <- which( (otuPropsPerNode[i,] > 0) | (otuPropsPerNode[j,] > 0) )
						if (normalize==TRUE && (method != "ratio" || method != "ratio_no_log")) {
							distance <- sum( branchLengths[includeBranchLengths] * abs(weights[i,includeBranchLengths] - weights[j,includeBranchLengths]) )/sum( branchLengths[includeBranchLengths]* (weights[i,includeBranchLengths] + weights[j,includeBranchLengths]) )
						}
						else {
							distance <- sum( branchLengths[includeBranchLengths] * abs(weights[i,includeBranchLengths] - weights[j,includeBranchLengths]) )/sum( branchLengths[includeBranchLengths])
						}
					}
					else {
						distance <- sum( branchLengths * abs(weights[i,] - weights[j,]) )/sum(branchLengths)
						if (normalize==TRUE) {
							distance <- sum( branchLengths * abs(weights[i,] - weights[j,]) )/sum(branchLengths * (weights[i,] + weights[j,]))
						}
					}

				}
			else {
				if (method!="unweighted") {
					warning(paste("Invalid method",method,", using unweighted Unifrac instead"))
				}
				# the formula is sum of (branch lengths * (1 if one sample has counts and not the other, 0 otherwise) )
				#	i call the (1 if one sample has counts and not the other, 0 otherwise) xorBranchLength
				xorBranchLength <- as.numeric(xor( weights[i,] > 0, weights[j,] > 0))
				if (pruneTree==TRUE) {
					includeBranchLengths <- which( (weights[i,] > 0) | (weights[j,] > 0) )
					distance <- sum( branchLengths[includeBranchLengths] *  xorBranchLength[includeBranchLengths])/sum(branchLengths[includeBranchLengths])
				}
				else {
					distance <- sum( branchLengths *  xorBranchLength)/sum(branchLengths)
				}

			}
			distanceMatrix[i,j] <- distance
			distanceMatrix[j,i] <- distance

		}
	}

	if(verbose) {	print("done")	}

	return(distanceMatrix)

}

#valid methods are unweighted, weighted, information, and ratio. Any other method will result in a warning and the unweighted analysis
#pruneTree option prunes the tree for each comparison to exclude branch lenxgths not present in both samples
#normalize divides the value at each node by sum of weights to guarantee output between 0 and 1 (breaks the triangle inequality)

#otuTable must have samples as rows, OTUs as columns
#tree must be phylo tree object from ape package (can use read.tree method to read in a newick tree to this format)

getDistanceMatrix <- function(otuTable,tree,method="weighted",verbose=FALSE,pruneTree=FALSE,normalize=TRUE)  {

	if (length(which(is.na(otuTable))) > 0) {
		stop("OTU count table has NA")
	}

	if (!is.rooted(tree)) {
		tree <- midpoint(tree)
		if(verbose) { print("Rooting tree by midpoint") }
	}

	if (attributes(tree)$order!="postorder") {
		tree <- reorder(tree,order="postorder")
		if (verbose) { print("Reordering tree as postorder for distance calculation algorithm") }
	}

  #make globally available copy of tree
  assign("unifrac.tree", tree, envir = .GlobalEnv)
  unifrac.tree <- get("unifrac.tree", envir = .GlobalEnv)

  #make globally available copy of leaves
  assign("unifrac.treeLeaves", c(1:length(tree$tip.label)), envir = .GlobalEnv)
  unifrac.treeLeaves <- get("unifrac.treeLeaves", envir = .GlobalEnv)

	# get proportions
	readsPerSample <- apply(otuTable,1,sum)
	otu.prop <- otuTable/readsPerSample
	otu.prop <- as.matrix(otu.prop)
	rownames(otu.prop) <- rownames(otuTable)
	colnames(otu.prop) <- colnames(otuTable)
	if(verbose) {	print("calculated proportional abundance")	}

	# add priors to zeros based on bayesian approach
	otuTable.adjustedZeros <- cmultRepl(otuTable, method="CZM", output="counts")
  # make any negative numbers as close to zero as possible - this is probably due to a precision error.
  otuTable.adjustedZeros <- apply(otuTable.adjustedZeros,2,function(x) { x[which(x < 0)] <- .Machine$double.eps; return(x) })
  readsPerSample <- apply(otuTable.adjustedZeros,1,sum)
  otu.prop.adjustedZeros <- otuTable.adjustedZeros/readsPerSample
  otu.prop.adjustedZeros <- as.matrix(otu.prop.adjustedZeros)
	rownames(otu.prop.adjustedZeros) <- rownames(otuTable)
	colnames(otu.prop.adjustedZeros) <- colnames(otuTable)

	##get cumulative proportional abundance for the nodes (nodes are ordered same as in the phylo tree representation)

  otuPropsPerNode <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))
  otuPropsPerNode.adjustedZeros <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))
  weightsPerNode <- matrix(NA, ncol=length(tree$edge.length)+1, nrow=length(rownames(otuTable)))

	#each row is a sample
  rownames(otuPropsPerNode) <- rownames(otuTable)
  rownames(otuPropsPerNode.adjustedZeros) <- rownames(otuTable)
  rownames(weightsPerNode) <- rownames(otuTable)
  #each column is a node in the tree
  colnames(otuPropsPerNode) <- c(1:(length(tree$edge.length)+1))
  colnames(otuPropsPerNode.adjustedZeros) <- c(1:(length(tree$edge.length)+1))
  colnames(weightsPerNode) <- c(1:(length(tree$edge.length)+1))

  leafNodes <- c(1:length(tree$tip.label))
  leafOrder <- match(tree$tip.label,colnames(otu.prop))

  otuPropsPerNode[,leafNodes] <- otu.prop[,leafOrder]
  otuPropsPerNode.adjustedZeros[,leafNodes] <- otu.prop.adjustedZeros[,leafOrder]
  weightsPerNode[,leafNodes] <- log2(otu.prop.adjustedZeros[,leafOrder])
  weightsPerNode[,leafNodes] <- t(apply(weightsPerNode[,leafNodes],1,function(x) { return(x - mean(x))}))

  # the tree is in postorder, so the last edges belong to the root
  root <- tree$edge[nrow(tree$edge),1]

  if(verbose) {	print("calculating weights...")	}

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)

  build_weights(root)

  otuPropsPerNode <- get("otuPropsPerNode",envir = .GlobalEnv)
  otuPropsPerNode.adjustedZeros <- get("otuPropsPerNode.adjustedZeros",envir = .GlobalEnv)
  weightsPerNode <- get("weightsPerNode",envir = .GlobalEnv)

  # build_weights makes everything negative, make everything positive again
  otuPropsPerNode[,c(1:ncol(otuPropsPerNode))] <- abs(otuPropsPerNode[,c(1:ncol(otuPropsPerNode))])
  otuPropsPerNode.adjustedZeros[,c(1:ncol(otuPropsPerNode.adjustedZeros))] <- abs(otuPropsPerNode.adjustedZeros[,c(1:ncol(otuPropsPerNode.adjustedZeros))])

  assign("otuPropsPerNode", otuPropsPerNode, envir = .GlobalEnv)
  assign("otuPropsPerNode.adjustedZeros", otuPropsPerNode.adjustedZeros, envir = .GlobalEnv)
  assign("weightsPerNode", weightsPerNode, envir = .GlobalEnv)

  if(verbose) {	print("calculating pairwise distances...")	}

  #convert table according to weight
  if (method == "all") {
    returnList <- list()
    # unweighted
    print("calculating unweighted distance matrix")
    weights <- otuPropsPerNode
    returnList[["unweighted"]] <- calculateDistanceMatrix(weights, "unweighted", otuTable, verbose, pruneTree, normalize)
    # weighted
    print("calculating weighted distance matrix")
    weights <- otuPropsPerNode
    returnList[["weighted"]] <- calculateDistanceMatrix(weights, "weighted", otuTable, verbose, pruneTree, normalize)
    # information
    print("calculating information distance matrix")
    weights <- otuPropsPerNode.adjustedZeros*log2(otuPropsPerNode.adjustedZeros)
    returnList[["information"]] <- calculateDistanceMatrix(weights, "information", otuTable, verbose, pruneTree, normalize)
    # ratio
    print("calculating ratio distance matrix")
    weights <- weightsPerNode
    returnList[["ratio"]] <- calculateDistanceMatrix(weights, "ratio", otuTable, verbose, pruneTree, normalize)
    # ratio no log
    print("calculating no log ratio distance matrix")
    weights <- weightsPerNode
    weights <- 2^weights
    returnList[["ratio_no_log"]] <- calculateDistanceMatrix(weights, "ratio_no_log", otuTable, verbose, pruneTree, normalize)
    return(returnList)
  } else if (method=="information") {
    weights <- otuPropsPerNode.adjustedZeros*log2(otuPropsPerNode.adjustedZeros)
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  } else if (method == "ratio_no_log") {
    weights <- weightsPerNode
    weights <- 2^weights
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  } else if (method == "ratio") {
    weights <- weightsPerNode
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  }
  else {
    weights <- otuPropsPerNode
    return(calculateDistanceMatrix(weights, method, otuTable, verbose, pruneTree, normalize))
  }
}


library(ggplot2)
theme_set(theme_bw(18))
setwd("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/11_sinking-marbles-normal/results/")
source("rscripts/helpers.r")

load("data/r.RData")
r1 = read.table("data/sinking_marbles.tsv", sep="\t", header=T, quote="")
r2 = read.csv("data/sinking_marbles.csv", header=T)
r2$workerid = as.numeric(as.character(r2$workerid))+60

r = rbind(r1,r2)
r$trial = r$slide_number_in_experiment - 2
r = r[,c("workerid", "rt", "effect", "cause","language","gender.1","age","gender","other_gender","quantifier", "object_level", "response", "object","num_objects","trial","enjoyment","asses","comments")]
r$Item = as.factor(paste(r$effect,r$object))

## add priors to data.frame
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/24_sinking-marbles-prior-fourstep/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
# prior expectation for each item
gathered_probs <- priorprobs %>%
  gather(State,Probability,X0:X15)
gathered_probs$State = as.numeric(as.character(gsub("X","",gathered_probs$State)))
prior_exps <- gathered_probs %>%
  group_by(Item) %>%
  summarise(exp.val=sum(State*Probability))
prior_exps = as.data.frame(prior_exps)
row.names(prior_exps) = prior_exps$Item

r$PriorExpectation = prior_exps[as.character(r$Item),]$exp.val
summary(r)

save(r, file="data/r.RData")

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

ggplot(aes(x=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=rt), data=r) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,20000))

ggplot(aes(x=age), data=r) +
  geom_histogram()

ggplot(aes(x=enjoyment), data=r) +
  geom_histogram()

ggplot(aes(x=asses), data=r) +
  geom_histogram()

ggplot(aes(x=quantifier), data=r) +
  geom_histogram()

head(r$comments)
unique(r$comments)

ggplot(r, aes(x=PriorExpectation, fill=response)) +
  geom_histogram() +
  facet_grid(workerid~quantifier)
ggsave("graphs/subject_variability.pdf")