\name{getSignalsFromList}
\alias{getSignalsFromList}
\title{
Get Signals from a List
}
\description{
Get Signals from a List
}
\usage{
getSignalsFromList(lt, fun = function(x) mean(x, na.rm = TRUE))
}
\arguments{

  \item{lt}{A list of normalized matrices which are returned by \code{\link{normalizeToMatrix}}. Matrices in the list should be generated with same settings (e.g. they should use same target regions, same extension to targets and same number of windows).}
  \item{fun}{A user-defined function to summarize signals.}

}
\details{
Let's assume you have a list of histone modification signals for different samples and you want
to visualize the mean pattern across samples. You can first normalize histone mark signals for each sample and then
calculate means values across all samples. In following example code, \code{hm_gr_list} is a list of \code{GRanges} objects
which contain positions of histone modifications, \code{tss} is a \code{GRanges} object containing positions of gene TSS.

  \preformatted{
    mat_list = NULL
    for(i in seq_along(hm_gr_list)) \{
        mat_list[[i]] = normalizeToMatrix(hm_gr_list[[i]], tss, value_column = "density")
    \}  }

If we compress the list of matrices as a three-dimension array where the first dimension corresponds to genes,
the second dimension corresponds to windows and the third dimension corresponds to samples, the mean signal
across all sample can be calculated on the third dimension. Here \code{\link{getSignalsFromList}} simplifies this job.

Applying \code{getSignalsFromList()} to \code{mat_list}, it gives a new normalized matrix which contains mean signals across all samples and can
be directly used in \code{EnrichedHeatmap()}.

  \preformatted{
    mat_mean = getSignalsFromList(mat_list)
    EnrichedHeatmap(mat_mean)  }

The correlation between histone modification and gene expression can
also be calculated on the third dimension of the array. In the user-defined function \code{fun}, \code{x} is the vector for gene i
and window j in the array, and \code{i} is the index of current gene.

  \preformatted{
    mat_corr = getSignalsFromList(mat_list,
        fun = function(x, i) cor(x, expr[i, ], method = "spearman"))  }

Then \code{mat_corr} here can be used to visualize how gene expression is correlated to histone modification around TSS.

  \preformatted{
    EnrichedHeatmap(mat_corr)  }
}
\value{
A \code{\link{normalizeToMatrix}} object which can be directly used for \code{\link{EnrichedHeatmap}}.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
NULL
}


# defining an operator
`%*%` <- function (v, p) {
    r <- 1
    if (p == 1) {
        r <- v
    } else {
        for (i in 1:p) {
            r <- r * v
        }
    }
    r
}

print (c(2 %*% 10, 2%*%2, 2%*%3)[1:2])

# j introduced as a global var.
for (j in 1:3) {
    print (j)
}
print (j)


library(ggplot2)
library(reshape2)

#topic_names <- read.csv("../topic_names/final_lda20_fulltext.txt",header=FALSE,as.is=TRUE)
#topic_names <- read.csv("..//topic_names/abs_lda20_all4.txt",header=FALSE,as.is=TRUE)
#topic_names <- read.csv("~/work/tmpl/analysis/topic_names/abs_ICFP_lda20_topics.txt",header=FALSE,as.is=TRUE)

#src <- "2015-01-06_11:06/lda20.csv"
src <- "2016-01-27_16:44/lda10.csv"

setwd("~/tmpl/out/")
lda <- data.frame(read.csv(src, header=TRUE,sep=",",quote="\""))
#names(lda)[4:23] <- topic_names[1:20,]

# for OOP and OOSD
#s <- data.frame(c(lda[1:3],lda[16],lda[23]))
#names(s)[4:5] <- c(names(lda)[16],names(lda)[23])

# for languages and control
#s <- data.frame(c(lda[1:3],lda[10]))
#names(s)[4] <- names(lda)[10]

# PLDI data history stuff
#s <- data.frame(c(lda[1:3],lda[4],lda[8]))
#names(s)[4:5] <- c(names(lda)[4],names(lda)[8])

# POPL topics
#s <- data.frame(c(lda[1:3],lda[13],lda[22]))
#names(s)[4:5] <- c(names(lda)[13],names(lda)[22])

s <- data.frame(lda)

d <- melt(s,seq(1,3))
names(d)[4:5] <- c("Topic","Weight")

p <- ggplot(d, aes(x=Year,y=Weight,colour=Conference))
p + stat_smooth(method='loess')  + facet_wrap(~Topic) + theme(strip.text=element_text(size=10))
#coord_cartesian(ylim=c(-50,1100))
#+ coord_cartesian(ylim=c(-5,30))

# OOPSLA
# p + stat_smooth(method='loess') + coord_cartesian(ylim=c(-50,1100)) + facet_wrap(~Topic) + theme(strip.text=element_text(size=20))  + coord_cartesian(ylim=c(-5,30)) + geom_vline(xintercept=2006, colour = "green", linetype = "longdash") + geom_vline(xintercept=2010, colour = "red", linetype="longdash")


#### GO Analysis
library(goseq)
library(dplyr)
library(tidyr)
library(ggplot2)
library(GO.db)

do_goseq_DE <- function(data, perturbation, control,
                        direction = NA, test = "GO") {
    foo <- data %>%
        filter(Perturbation == perturbation) %>%
        filter(Control == control)
    if (is.na(direction)) {
        genes <- as.integer(p.adjust(foo$PValue[foo$logFC != 0],
            method = "BH"
        ) < .05)
        names(genes) <- foo[foo$logFC != 0, ]$Geneid
    } else if (direction == "up") {
        genes <- as.integer(p.adjust(foo$PValue[foo$logFC > 0],
            method = "BH"
        ) < .05)
        names(genes) <- foo[foo$logFC > 0, ]$Geneid
    } else if (direction == "down") {
        genes <- as.integer(p.adjust(foo$PValue[foo$logFC < 0],
            method = "BH"
        ) < .05)
        names(genes) <- foo[foo$logFC < 0, ]$Geneid
    }
    ## Fit the Probability Weighting Function (PWF)
    pwf <- nullp(genes, "hg19", "geneSymbol")
    print(head(pwf))
    ## Fetch relationship between gene symbols and GO categories
    ## Then use Wallenius approximation
    if (test == "GO") {
        go_wall <- goseq(pwf, "hg19", "geneSymbol")
        return(go_wall)
    } else if (test == "MF") {
        go_mf <- goseq(pwf, "hg19", "geneSymbol", test.cats = c("GO:MF"))
        return(go_mf)
    } else if (test == "BP") {
        go_bp <- goseq(pwf, "hg19", "geneSymbol", test.cats = c("GO:BP"))
        return(go_bp)
    } else if (test == "hallmarks") {
        hallmarks <- read.table(
            paste0(
                "/fh/fast/berger_a/grp/bergerlab_shared/Projects/RNA_eVIP/",
                "mSigDB/h.all.v6.2.symbols.gmt"
            ),
            sep = "\t", fill = TRUE
        )
        names(hallmarks) <- c("Category", "Gene", seq(200))
        hallmarks <- data.frame(hallmarks) %>%
            gather("foo", "Gene", 3:202) %>%
            dplyr::select("Category", "Gene") %>%
            filter(Gene != "")
        go_hallmarks <- goseq(pwf, gene2cat = hallmarks)
        go_hallmarks$ontology <- "mSigH"
        return(go_hallmarks)
    }
}


options(stringsAsFactors = F)
library(reshape2)
library(ggplot2)
library(plyr)
library(stringr)
library(MASS)
source("../Data/tidy-data/data/xtable.r")

if (!file.exists("../Data/tidy-data/case-study/deaths.rds")) {
  src <- "https://github.com/hadley/mexico-mortality/raw/master/deaths/deaths08.csv.bz2"
  file.download(src, "../Data/tidy-data/case-study/deaths.csv.bz2", quiet = TRUE)

  deaths <- read.csv("../Data/tidy-data/case-study/eaths08.csv.bz2")
  unlink("deaths08.csv.bz2")
  deaths$hod[deaths$hod == 99] <- NA
  deaths$hod[deaths$hod == 24] <- 0
  deaths$hod[deaths$hod == 0] <- NA
  deaths$hod <- as.integer(deaths$hod)
  deaths <- arrange(deaths, yod, mod, dod, hod, cod)
  deaths <- deaths[c("yod", "mod", "dod", "hod", "cod")]

  saveRDS(deaths, "deaths.rds")
}

deaths <- readRDS("deaths.rds")

ok <- subset(deaths, yod == 2008 & mod != 0 & dod != 0)
xtable(ok[c(1, 1:14 * 2000), c("yod", "mod", "dod", "hod", "cod")],
  "raw.tex")

codes <- read.csv("icd-main.csv")
codes$disease <- sapply(codes$disease, function(x)
  str_c(strwrap(x, width = 30), collapse = "\n"))
names(codes)[1] <- "cod"
codes <- codes[!duplicated(codes$cod), ]

# Display overall hourly deaths
hod_all <- subset(count(deaths, "hod"), !is.na(hod))
qplot(hod, freq, data = hod_all, geom = "line") +
  scale_y_continuous("Number of deaths", labels = function(x) format(x, big.mark = ",")) +
  xlab("Hour of day")
ggsave("overall.pdf", width = 10, height = 6)

# Count deaths per hour, per disease
hod2 <- count(deaths, c("cod", "hod"))
hod2 <- subset(hod2, !is.na(hod))
hod2 <- join(hod2, codes)
hod2 <- ddply(hod2, "cod", transform, prop = freq / sum(freq))

# Compare to overall abundance
overall <- ddply(hod2, "hod", summarise, freq_all = sum(freq))
overall <- mutate(overall, prop_all = freq_all / sum(freq_all))

hod2 <- join(overall, hod2, by = "hod")

# Pick better subset of rows to show
cods <- join(arrange(count(deaths, "cod"), desc(freq)), codes)
mutate(tail(subset(cods, freq > 100), 30), disease = str_sub(disease, 1, 30))

hod3 <- subset(hod2, cod %in% c("I21", "N18", "E84", "B16") & hod >= 8 & hod <= 12)[1:15, c("hod", "cod", "disease", "freq", "prop", "freq_all", "prop_all")]

xtable(hod3[c("hod", "cod", "freq")], "counts.tex")
xtable(hod3[c("disease")], "counts-disease.tex")
xtable(hod3[5], "counts-prop.tex")
xtable(hod3[6:7], "counts-all.tex")

devi <- ddply(hod2, "cod", summarise, n = sum(freq),
  dist = mean((prop - prop_all)^2))
devi <- subset(devi, n > 50)

# Find outliers
xlog10 <- scale_x_log10(
  breaks = c(100, 1000, 10000),
  labels = c(100, 1000, 10000),
  minor_breaks = log10(outer(1:9, 10^(1:5), "*")))
ylog10 <- scale_y_log10(
  breaks = 10 ^ -c(3, 4, 5),
  labels = c("0.001", "0.0001", "0.00001"),
  minor_breaks = log10(outer(1:9, 10^-(3:6), "*")))

qplot(n, dist, data = devi)
ggsave("n-dist-raw.pdf", width = 6, height = 6)
qplot(n, dist, data = devi) +
  geom_smooth(method = "rlm", se = F) +
  xlog10 +
  ylog10
ggsave("n-dist-log.pdf", width = 6, height = 6)

devi$resid <- resid(rlm(log(dist) ~ log(n), data = devi))
coef(rlm(log(dist) ~ log(n), data = devi))
ggplot(devi, aes(n, resid)) +
  geom_hline(yintercept = 1.5, colour = "grey50") +
  geom_point() +
  xlog10
ggsave("n-dist-resid.pdf", width = 6, height = 6)

unusual <- subset(devi, resid > 1.5)
hod_unusual_big <- match_df(hod2, subset(unusual, n > 350))
hod_unusual_sml <- match_df(hod2, subset(unusual, n <= 350))

# Visualise unusual causes of death
ggplot(hod_unusual_big, aes(hod, prop)) +
  geom_line(aes(y = prop_all), data = overall, colour = "grey50") +
  geom_line() +
  facet_wrap(~ disease, ncol = 3)
ggsave("unusual-big.pdf", width = 8, height = 6)
last_plot() %+% hod_unusual_sml
ggsave("unusual-sml.pdf", width = 8, height = 4)


# Generates a png image of the median RTD of each pair of ranks

require('ggplot2')
require('reshape')

analyze_all_pairs <- function(raw_data, kernel, kind, outputdir){
  time_cols        = c(3:length(raw_data))
  cores_per_host   = 8 # Adjust to your needs
  cores_per_socket = 4 # Adjust to your needs
  upper_bound      = 600
  top_limit        = 12
  title            = paste("all pairs RTD in microsec (", kernel , ")", sep="")
  kernel_fname     = gsub(" ", "_", fixed = TRUE, kernel) # replace spaces
	plotfile				 = paste(kernel_fname, kind, "png", sep=".")
  plotfile         = paste(outputdir, plotfile, sep="/")

  measure_data <- raw_data

  # combine all aggregated data
  clear_data <- melt(measure_data)
  # name columns for plotting
  names(clear_data) <- c("sender", "reciever", "data")

  # set outliers to top_limit
  clear_data$data[clear_data$data > top_limit] <- top_limit

  # set correct name
#  colnames(clear_data)[3] <- kind
  maj_grid_lines = seq(0, dim(raw_data)[1], cores_per_host)
  min_grid_lines = seq(cores_per_socket, dim(raw_data)[1], cores_per_host)
  pal <- colorRampPalette(c("blue", "cyan", "yellow", "red", "deeppink"))
  #plot
  p <- ggplot(clear_data, aes(x=sender-0.5, y=reciever-0.5))
  p <- p + ggtitle(title) + ylab("sender rank") + xlab("reciever rank")
  p <- p + geom_tile(aes(fill=data))
	p <- p + scale_fill_gradientn( colours = pal(100), limits = c(0,top_limit), guide = guide_legend(title = kind))
  p <- p + scale_x_continuous(minor_breaks = maj_grid_lines)
  p <- p + scale_y_continuous(minor_breaks = maj_grid_lines)

# mark host and socket boundaries
#  p <- p + geom_vline(xintercept=maj_grid_lines, alpha=1/8, size=.5) # major v lines
#  p <- p + geom_hline(yintercept=maj_grid_lines, alpha=1/8, size=.5) # major h lines

  p <- p + theme_bw()
  p <- p + coord_fixed(ratio = 1)
  p <- p + theme(plot.title=element_text(face="bold", size=20))
  ggsave(filename = plotfile, plot=p, units = "mm", width = 200, dpi = 400)

  return (clear_data)
}


# Shows the different conversations (neighbourhoods) in which a user participated
#
# author: Alberto Lumbreras
library(RSQLite)

plot.user.participations <- function(thread, user, con, database='reddit'){

  g <- database.to.graph(thread, con, database)
  gp <- g$gp
  mask <- V(gp)$user==user
  posts <- V(gp)[mask]

  for(i in 1:length(posts)){
    eg <- neighborhood.temporal.order(gp, posts[i], 2, 4)
    g <- graph.union(gp,eg)

    # Color nodes
    root.post <- V(gp)[which(degree(gp, mode='out')==0)]$name
    user.name <- V(gp)[posts[i]]$user
    post.id <- V(gp)[posts[i]]$name

    # See if it matches any seen motif
    u <- V(gp)[V(gp)$name==post.id] # identify the ego vertex
    uu <- V(gp)[V(gp)$user==user.name] # posts writen by ego author

    # note the <= in case two siblings have the same date
    V(gp)$color[V(gp)$date<=V(gp)[u]$date] <- 1
    V(gp)$color[V(gp)$date>V(gp)[u]$date] <- 2
    if(degree(gp, v=u, mode='out')==1){
      p.user.name <- neighbors(gp, u, mode='out')$user
      V(gp)[V(gp)$user==p.user.name]$color <- 3 # posts writen by parent of ego
    }
    V(gp)[uu]$color <- 4
    V(gp)[u]$color <- 5
    V(gp)[V(eg)$name==root.post]$color <- 6
    V(gp)[! V(gp)$name %in% V(eg)$name]$color <- 7

    mypalette <- c("grey", "black", "yellow", "orange", "red", "white", 'green')

    # Plot
    gmotif <- as.undirected(gp)
    la = layout_as_tree(gmotif, mode='out', root=which.min(V(gmotif)$date))
    plot(gmotif,
         layout = la,
         vertex.color=mypalette[V(gmotif)$color],
         vertex.label = order(V(gp)$date),
         vertex.label.cex = 1,
         vertex.size= ifelse(V(gp)$color==7, 1, 3),
         edge.arrow.size=0.6)
    title(paste(user))
  }
}

con <- dbConnect(dbDriver("SQLite"), dbname = paste0("./data/", database, ".db"))
database <- 'reddit'

for (u in 1:length(cluster1)){
  user <- as.character(cluster1[u])
  query <- paste0("SELECT DISTINCT(t.threadid)  FROM  posts p, threads t WHERE t.forum LIKE 'podemos' AND p.thread = t.threadid AND p.user = '", user, "'")
  threads <- dbGetQuery(con, query)$threadid

  for(i in 1:length(threads)){
    plot.user.participations(threads[i], user, con)

    answer <- readline("Continue with user? ([y]/n/exit) ")
    if (answer=='yes' || answer == '')
    {
      next
    }
    else if (answer == 'n'){
     break
    }
    else if (answer == 'exit'){
      stop("Bye!")
    }
  }
}


# Seasonality analysis

source('./../../gwloggeR/R/graphics.R')
source('./../../gwloggeR/R/fourier.R')
sys.source('./utils/utils.r', envir = (utils <- new.env()))

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), ]

  diff.df
}

#cl <- parallel::makeCluster(5L)
#doParallel::registerDoParallel(cl)
#parallel::stopCluster(cl)

coefs <- function(fit, lambda) {
  coef <- glmnet::coef.glmnet(fit$glmnet.fit, s = lambda)
  coef[coef[, '1'] != 0,,drop = FALSE]
}

coef.periods <- function(coefs) {
  coefs <- coefs[grepl('(sin\\(|cos\\(.*)', rownames(coefs)), , drop = FALSE]
  periods.sec <- sub(pattern = '(sin|cos)\\(([0-9.]+)\\)', replacement = '\\2', rownames(coefs))
  periods.sec <- as.numeric(periods.sec)
  periods.day <- periods.sec/3600/24
  if (length(periods.day) < 2L) return(round(periods.day))
  idx <- cutree(hclust(dist(periods.day)), h = 10)
  round(aggregate(periods.day, by = list(idx), FUN = mean)$x)
}

# # DTFT analysis
#
# dtft(frequency = 1/(365.25*24*3600), x = df.diff$PRESSURE_DIFF, timestamps = df.diff$TIMESTAMP_UTC)
# dtft(frequency = 4/diff(as.numeric(range(df.diff$TIMESTAMP_UTC))), x = df.diff$PRESSURE_DIFF, timestamps = df.diff$TIMESTAMP_UTC)
#
# period <- seq(from = 12*3600*4, to = diff(as.numeric(range(df.diff$TIMESTAMP_UTC))), length.out = 10000)
# fd <- sapply(1/period, FUN = dtft,
#              x = df.diff$PRESSURE_DIFF, timestamps = df.diff$TIMESTAMP_UTC)
# plot(Mod(fd), type = 'l', x = period/3600/24)
# period[which.max(Mod(fd))]/3600/24
# table(diff(df.diff$TIMESTAMP_UTC))

# # FFT analysis
#
# z <- fft(df.diff$PRESSURE_DIFF)
# P <- diff(as.numeric(range(df.diff$TIMESTAMP_UTC)))
# P1 <- P/(length(z) - 1)
# fft.periods <- 1/((0:(length(z) - 1))*P1/P)
# plot(Mod(z), type = 'l',
#      x = fft.periods,
#      xlab = 'days')
# fft.periods[order(Mod(z), decreasing = TRUE)][1:5]
# spectrum(df.diff$PRESSURE_DIFF)
# dft(1L, df.diff$PRESSURE_DIFF)

fit.glmnet <- function(y, x, parallel = FALSE) {

  # alist stores symbols (i.e. doesn't evaluate the arguments.)
  glmnet.args <- alist(
    y = y, x = x,
    alpha = 1,
    parallel = parallel,
    nlambda = 500L,
    foldid = rep(1:10, each = nrow(x)/10, length.out = nrow(x))
  )

  cv.glmnet <- glmnet::cv.glmnet

  fit <- utils$cache$as.file(
    fun = 'cv.glmnet', # this way glmnet stores only "glmnet()" call in fit
    args = glmnet.args,
    prefix = 'glmnet',
    cache.dir = './drifts/analysis_20'
  )

  fit$lambda.2se <- fit$lambda.min + 2*(fit$lambda.1se - fit$lambda.min)

  fit
}

plt.fspec <- function(periods.sec, intensity) {
  force(periods.sec); force(intensity)
  ggplot2::ggplot(mapping = ggplot2::aes(x = periods.sec/3600/24, y = intensity)) +
    ggplot2::geom_line(col = 'black') +
    ggplot2::geom_vline(xintercept = 365.25, col = 'red') +
    #ggplot2::ylab('Intensity') +
    ggplot2::xlab('Period (days)') +
    #ggplot2::ggtitle('Discrete-Time Fourier Transform') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.title.y = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))
}

plt.yearly <- function(TIMESTAMP_UTC, y, ylim = quantile(y, probs = c(0.001, 0.999))) {
  force(TIMESTAMP_UTC); force(y)
  ggplot2::ggplot() +
    ggplot2::geom_point(mapping = ggplot2::aes(x = data.table::yday(TIMESTAMP_UTC), y = y)) +
    ggplot2::xlab('Day') +
    ggplot2::coord_cartesian(ylim = ylim,
                             xlim = c(1, 366)) +
    ggplot2::theme_light() +
    ggplot2::theme(axis.title.y = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))
}

plt.hist <- function(x, xlim = quantile(x, probs = c(0.001, 0.999))) {
  force(x)
  binwidth <- 1.5 * IQR(x) / length(x) ^ (1/3)
  ggplot2::ggplot(mapping = ggplot2::aes(x = x)) +
    ggplot2::geom_histogram(binwidth = binwidth, fill = 'black') +
    ggplot2::xlab('PRESSURE_DIFF') +
    ggplot2::coord_cartesian(xlim = xlim) +
    ggplot2::theme_light() +
    ggplot2::theme(#axis.title.x = ggplot2::element_blank(),
                   axis.title.y = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_blank())
}

plt.comp <- function(TIMESTAMP_UTC, Y, Y_FIT_OPT, Y_FIT_1SE, Y_FIT_1SE_LABEL,
                     front_layer = NULL, ylim, xlim, Y.col = 'red', Y.lab = 'PRESSURE_DIFF') {
  force(TIMESTAMP_UTC); force(Y)
  force(Y_FIT_OPT); force(Y_FIT_1SE); force(Y_FIT_1SE_LABEL)
  force(ylim); force(xlim)
  ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = Y.col, alpha = 0.9) +
    ggplot2::geom_line(mapping = ggplot2::aes(y = Y_FIT_OPT), col = 'blue', size = 1.3) +
    ggplot2::geom_line(mapping = ggplot2::aes(y = Y_FIT_1SE), col = 'green', size = 1.3) +
    ggplot2::coord_cartesian(ylim = ylim,
                             xlim = xlim) +
    ggplot2::annotate(
      "label", x = as.POSIXct(-Inf, origin = '1970-01-01'), y = Inf,
      size = 4, col = 'green', hjust = 0, vjust = 1, fill = 'grey', label.size = NA,
      label = Y_FIT_1SE_LABEL
    ) +
    ggplot2::ylab(Y.lab) +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))
}

periods.label <- function(coefs) {
  p <- coef.periods(coefs)
  has.trend <- any(grepl(pattern = 'trend', x = rownames(coefs), ignore.case = TRUE))
  str <- if (length(p) == 0L) 'Periods: /' else sprintf('Periods: %s days', paste0(p, collapse = ', '))
  if (has.trend) str <- paste0(str, ' + LinTrend')
  str
}

report <- function(logger.name, ref.logger.names, parallel = FALSE) {

  print(logger.name)

  on.exit(gc(TRUE))

  df.logger <- read.baro(logger.name = logger.name)
  data.table::setkey(df.logger, TIMESTAMP_UTC)

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

  periods <- seq(from = 2*24*3600,
                 # take minimum a year for the periods
                 to = max(diff(as.numeric(range(df.logger$TIMESTAMP_UTC))), 1.1*365.25*24*3600),
                 length.out = 10000)

  fbase <- data.matrix(fbasis(df.logger$TIMESTAMP_UTC, trend = TRUE, frequencies = 1/periods))

  # Logger analysis ------------------------------------------------------------

  fd.single <- sapply(1/periods, FUN = dtft,
                      x = df.logger$PRESSURE_VALUE - median(df.logger$PRESSURE_VALUE), timestamps = df.logger$TIMESTAMP_UTC)
  #plot(Mod(fd.single), type = 'l', x = periods/3600/24, xlab = 'days')

  p.single.fspec <- plt.fspec(periods.sec = periods, intensity = Mod(fd.single)/nrow(df.logger))

  fit.single <- fit.glmnet(y = df.logger$PRESSURE_VALUE, x = fbase, parallel = parallel)
  #plot(fit.single)
  #coef.periods(coefs(fit.single, lambda = fit.single$lambda.min))

  df.logger[, PRESSURE_VALUE_GLMNET_MIN := glmnet::predict.glmnet(fit.single$glmnet.fit, newx = fbase, s = fit.single$lambda.min)]
  df.logger[, PRESSURE_VALUE_GLMNET_1SE := glmnet::predict.glmnet(fit.single$glmnet.fit, newx = fbase, s = fit.single$lambda.1se)]

  # Multi comparison -----------------------------------------------------------

  df.diff <- lapply(setdiff(basename(ref.logger.names), basename(logger.name)), function(other.name) {
    df.other <- read.baro(other.name)
    compare(df.logger, df.other)
  })
  df.diff <- data.table::rbindlist(df.diff, use.names = TRUE, fill = TRUE)

  df.multi <- df.diff[
    , .(Q.025 = quantile(PRESSURE_DIFF, 0.025),
        Q.5 = quantile(PRESSURE_DIFF, 0.5),
        Q.975 = quantile(PRESSURE_DIFF, 0.975)),
    keyby = TIMESTAMP_UTC]

  # fbase is made on logger timestamps. we need to filter that one to get only the multi timestamps
  ridx.multi <- df.logger[, .(TIMESTAMP_UTC, I = 1:.N)][J(df.multi$TIMESTAMP_UTC), I]
  fbase.multi <- fbase[ridx.multi,,drop=FALSE]

  fit.multi <- fit.glmnet(y = df.multi$Q.5, x = fbase.multi, parallel = parallel)
  #plot(fit.multi)
  #coefs(fit.multi, lambda = fit.multi$lambda.1se)
  #coef.periods(coefs(fit.multi, lambda = fit.multi$lambda.1se))

  df.multi[, Q.5_GLMNET_MIN := glmnet::predict.glmnet(fit.multi$glmnet.fit, newx = fbase.multi, s = fit.multi$lambda.min)]
  df.multi[, Q.5_GLMNET_1SE := glmnet::predict.glmnet(fit.multi$glmnet.fit, newx = fbase.multi, s = fit.multi$lambda.1se)]

  fd.multi <- sapply(1/periods, FUN = dtft,
                     x = df.multi$Q.5 - median(df.multi$Q.5), timestamps = df.multi$TIMESTAMP_UTC)
  #plot(Mod(fd.multi), type = 'l', x = periods/3600/24, xlab = 'days')

  p.multi.fspec <- plt.fspec(periods.sec = periods, intensity = Mod(fd.multi)/nrow(df.multi))

  # Reference comparison -------------------------------------------------------

  df.ref <- compare(df.logger, read.baro('KNMI_20200312_hourly'))
  data.table::setkey(df.ref, TIMESTAMP_UTC)
  #plot(df.ref$PRESSURE_DIFF, type = 'l', x = df.ref$TIMESTAMP_UTC)

  # fbase is made on logger timestamps. we need to filter that one to get only the ref timestamps
  ridx.ref <- df.logger[, .(TIMESTAMP_UTC, I = 1:.N)][J(df.ref$TIMESTAMP_UTC), I]
  fbase.ref <- fbase[ridx.ref,,drop=FALSE]

  fit.ref <- fit.glmnet(y = df.ref$PRESSURE_DIFF, x = fbase.ref, parallel = parallel)
  #plot(fit.ref)
  #coef.periods(coefs(fit.ref, lambda = fit.ref$lambda.1se))

  df.ref[, PRESSURE_DIFF_GLMNET_MIN := glmnet::predict.glmnet(fit.ref$glmnet.fit, newx = fbase.ref, s = fit.ref$lambda.min)]
  df.ref[, PRESSURE_DIFF_GLMNET_1SE := glmnet::predict.glmnet(fit.ref$glmnet.fit, newx = fbase.ref, s = fit.ref$lambda.1se)]

  fd.ref <- sapply(1/periods, FUN = dtft,
                   x = df.ref$PRESSURE_DIFF - median(df.ref$PRESSURE_DIFF), timestamps = df.ref$TIMESTAMP_UTC)
  #plot(Mod(fd.ref), type = 'l', x = periods/3600/24, xlab = 'days')

  p.ref.fspec <- plt.fspec(periods.sec = periods, intensity = Mod(fd.ref)/nrow(df.ref))

  # Comparison plots -----------------------------------------------------------

  p.single <- plt.comp(
    TIMESTAMP_UTC = df.logger$TIMESTAMP_UTC, Y = df.logger$PRESSURE_VALUE,
    Y_FIT_OPT = df.logger$PRESSURE_VALUE_GLMNET_MIN, Y_FIT_1SE = df.logger$PRESSURE_VALUE_GLMNET_1SE,
    Y_FIT_1SE_LABEL = periods.label(coefs(fit.single, lambda = fit.single$lambda.1se)),
    ylim = quantile(df.logger$PRESSURE_VALUE, probs = c(0.001, 0.999)),
    xlim = range(df.logger$TIMESTAMP_UTC), Y.col = 'black', Y.lab = 'PRESSURE_VALUE'
  )

  ylim.multi <- quantile(df.multi$Q.5, probs = c(0.005, 0.995))
  ylim.ref <- quantile(df.ref$PRESSURE_DIFF, probs = c(0.005, 0.995))
  ylim.comp.range <- max(diff(ylim.multi), diff(ylim.ref))

  p.multi <- plt.comp(
    TIMESTAMP_UTC = df.multi$TIMESTAMP_UTC, Y = df.multi$Q.5,
    Y_FIT_OPT = df.multi$Q.5_GLMNET_MIN, Y_FIT_1SE = df.multi$Q.5_GLMNET_1SE,
    Y_FIT_1SE_LABEL = periods.label(coefs(fit.multi, lambda = fit.multi$lambda.1se)),
    front_layer = ggplot2::geom_point(data = df.diff, mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_DIFF), pch = '.'),
    ylim = mean(ylim.multi) + c(-1, +1)*ylim.comp.range/2, xlim = range(df.logger$TIMESTAMP_UTC)
  )

  p.ref <- plt.comp(
    TIMESTAMP_UTC = df.ref$TIMESTAMP_UTC, Y = df.ref$PRESSURE_DIFF,
    Y_FIT_OPT = df.ref$PRESSURE_DIFF_GLMNET_MIN, Y_FIT_1SE = df.ref$PRESSURE_DIFF_GLMNET_1SE,
    Y_FIT_1SE_LABEL = periods.label(coefs(fit.ref, lambda = fit.ref$lambda.1se)),
    ylim = mean(ylim.ref) + c(-1, +1)*ylim.comp.range/2, xlim = range(df.logger$TIMESTAMP_UTC))

  # Yearly plots ---------------------------------------------------------------

  p.single.yearly <- plt.yearly(TIMESTAMP_UTC = df.logger$TIMESTAMP_UTC, y = df.logger$PRESSURE_VALUE)

  p.multi.yearly <- plt.yearly(TIMESTAMP_UTC = df.multi$TIMESTAMP_UTC, y = df.multi$Q.5,
                               ylim = mean(ylim.multi) + c(-1, +1)*ylim.comp.range/2)

  p.ref.yearly <- plt.yearly(TIMESTAMP_UTC = df.ref$TIMESTAMP_UTC, y = df.ref$PRESSURE_DIFF,
                             ylim = mean(ylim.ref) + c(-1, +1)*ylim.comp.range/2)

  # Density plots --------------------------------------------------------------

  xlim.hist.multi <- quantile(df.multi$Q.5, probs = c(0.001, 0.999))
  xlim.hist.ref <- quantile(df.ref$PRESSURE_DIFF, probs = c(0.001, 0.999))
  xlim.hist.range <- max(diff(xlim.hist.multi), diff(xlim.hist.ref))

  p.multi.hist <- plt.hist(df.multi$Q.5, mean(xlim.hist.multi) + c(-1, +1)*xlim.hist.range/2)
  p.ref.hist <- plt.hist(df.ref$PRESSURE_DIFF, mean(xlim.hist.ref) + c(-1, +1)*xlim.hist.range/2)

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

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

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

  layout_matrix <- rbind(c(1, 1, 1,  4,  5,  6),
                         c(2, 2, 2,  7,  8,  9),
                         c(3, 3, 3, 10, 11, 12))

  grob.title <- grid::textGrob(sprintf('%s (#%s observations from %s to %s)',
                                       basename(logger.name), nrow(df.logger),
                                       min(df.logger$TIMESTAMP_UTC), max(df.logger$TIMESTAMP_UTC)),
                               x = 0.05, hjust = 0)

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    print(gridExtra::grid.arrange(p.single, p.multi, p.ref,
                                  p.single.fspec, p.single.yearly, p.empty,
                                  p.multi.fspec, p.multi.yearly, p.multi.hist,
                                  p.ref.fspec, p.ref.yearly, p.ref.hist,
                                  layout_matrix = layout_matrix,
                                  top = grob.title))
  })

  invisible(TRUE)
}

# report('BAOL828X_P2_15705.csv', ref.logger.names = logger.names, parallel = TRUE)
# report('BAOL528X_B_B2152.csv', ref.logger.names = logger.names, parallel = TRUE)
# invisible(lapply(logger.names, report, ref.logger.names = logger.names))

parallel::setDefaultCluster(parallel::makeCluster(spec = 4L, outfile=''))
parallel::clusterExport(varlist = ls())
results <- parallel::parSapplyLB(X = logger.names, FUN = report, chunk.size = 1,
                                 ref.logger.names = logger.names)
parallel::stopCluster(cl = parallel::getDefaultCluster())


context("annotate")

test_that("dates in segment annotation work", {
  dt <- structure(list(month = structure(c(1364774400, 1377993600),
      class = c("POSIXct", "POSIXt"), tzone = "UTC"), total = c(-10.3,
      11.7)), .Names = c("month", "total"), row.names = c(NA, -2L), class =
      "data.frame")

  p <- ggplot(dt, aes(month, total)) +
    geom_point() +
    annotate("segment",
      x = as.POSIXct("2013-04-01"),
      xend = as.POSIXct("2013-07-01"),
      y = -10,
      yend = 10
    )

  expect_true(all(c("xend", "yend") %in% names(layer_data(p, 2))))
})

test_that("segment annotations transform with scales", {
  # This should be a visual test, but contriubtion documentation does not
  # explain how to make one
  ggplot(mtcars, aes(wt, mpg)) +
    geom_point() +
    annotate("segment", x = 2, y = 10, xend = 5, yend = 30, colour = "red") +
    scale_y_reverse()
})

test_that("annotation_* has dummy data assigned and don't inherit aes", {
  custom <- annotation_custom(zeroGrob())
  logtick <- annotation_logticks()
  library(maps)
  usamap <- map_data("state")
  map <- annotation_map(usamap)
  rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50)
  raster <- annotation_raster(rainbow, 15, 20, 3, 4)
  dummy <- dummy_data()
  expect_equal(custom$data, dummy)
  expect_equal(logtick$data, dummy)
  expect_equal(map$data, dummy)
  expect_equal(raster$data, dummy)

  expect_false(custom$inherit.aes)
  expect_false(logtick$inherit.aes)
  expect_false(map$inherit.aes)
  expect_false(raster$inherit.aes)
})


#
# Combine the results of the two classification runs with gradient boosted models
#
# The population and sampled classifications are in a data frame called "results"
# The tasampled classifications are in a data frame called "subsets" since they're subsets of the single large database
# The combined (non-subsetted) tasampled classification is in a data frame called "combined_results"
#
library(mmadsenr)

results_files <- c(
"classification-combined-tassize-result-gbm-dfonly.RData",
"classification-population-results-gbm-dfOnly.RData",
"classification-ta-sampled-results-gbm-dfonly.RData",
"per-locus-analysis-gbm-dfonly.RData",
"perlocus-tassize-results-gbm-dfonly.RData"
)

for(file in results_files) {
  load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = file))
}

# Step #1:  Add sample size and ta duration columns to the results data frame
results$sample_size <- 0
results$ta_duration <- 0  # this broadcasts 0 to the entire column

# Add an "experiment group" to each df before merging, to be used in visually distinguishing the classes

results$exp_group <- 'Population Census'
perlocus_results$exp_group <- 'Population Per-Locus Only'
combined_tassize_results$exp_group <- 'Time Averaged and Sampled Combined Intervals'
tassize_perlocus_results$exp_group <- 'Time Averaged and Sampled Per-Locus Only'
tassize_subsets_results$exp_group <- 'Time Averaged and Sampled'

# now merge the two into a single dataframe
classifier_results <- rbind(results,
                            perlocus_results,
                            combined_tassize_results,
                            tassize_perlocus_results,
                            tassize_subsets_results)

###### Add two useful statistics #######

classifier_results$fdr <- 1.0 - classifier_results$ppv
classifier_results$youdensj <- classifier_results$sensitivity + classifier_results$specificity - 1.0

############## Complete Processing and Save Results ##########3

# save objects from the environment
image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "classification-gbm-merged-dfonly.RData")
save(classifier_results, file=image_file)


#!/usr/bin/env Rscript

t <- read.table("./invest_return.tsv", sep="\t", header=FALSE)

x <- as.Date(t$V1, "%m/%d/%Y")
y1 <- as.numeric(gsub(",","", t$V2))/1000000
y2 <- as.numeric(gsub(",","", t$V3))/1000000
png("../images/investment_return/investment_return.png")
y_range <- range(y1, y2)

par(family = "HiraKakuProN-W3")
# mar – A numeric vector of length 4, which sets the margin sizes in the following order: bottom, left, top, and right. The default is c(5.1, 4.1, 4.1, 2.1).

par(mar = c(3, 7, 2, 2))

# mgp – A numeric vector of length 3, which sets the axis label locations relative to the edge of the inner plot window. The first value represents the location the labels (i.e. xlab and ylab in plot), the second the tick-mark labels, and third the tick marks. The default is c(3, 1, 0).

par(mgp = c(3.5, 1, 0))

plot(x, y1, xlab="", ylab="金額[百万円]", type="o",
     cex.lab=2, cex.axis=1.5, cex.main=1.5, cex=2, ylim=y_range,
     xaxt="n",
     yaxp = c(10, 50, 4),
     pch=1
     )
lines(x, y2, xlab="", type="o", pch=16,
     ylab="金額[百万円]",
     cex.lab=2, cex.axis=1.5, cex.main=1.5, cex=2, ylim=y_range,
     xaxt="n",
# 1,000万円から4,000万円までを4分割で
     yaxp = c(10, 50, 4)
     )
x_years = as.Date(c("2015/1/1", "2016/1/1", "2017/1/1", "2018/1/1", "2019/1/1", "2020/1/1", "2021/1/1"), "%Y/%m/%d")
axis(1, x_years, format(x_years, "%Y/%m"), cex=2, cex.axis=1.5, cex.main=1.5, cex.lab=2)

legend(x_years[1], y_range[2], c("評価額", "投資額"), cex=1.5, pch=c(16, 1))


# Rectangling data

# A. Intro to non-rectangular data
# 1. Rectangling Star Wars movies
# Data is taken from Star Wars API and is in JSON format

# Create a movie column from the movie_list
tibble(movie = movie_list) %>%
  # Unnest the movie column
  unnest_wider(movie)

# Create a tibble with a movie column
tibble(movie = movie_planets_list) %>%
  # Unnest the movie column
  unnest_wider(movie) %>%
  # Unnest the planets column
  unnest_wider(planets)

# B. From nested values to observations
# 1. Rectangling Star Wars planets
# unnest_wider(): common length of lists
# unnest_longer(): varying length of lists

# Create a tibble from movie_planets_list
tibble(movie = movie_planets_list) %>%
  # Unnest the movie column in the correct direction
  unnest_wider(movie) %>%
  # Unnest the planets column in the correct direction
  unnest_longer(planets)

# 2. The Solar System's biggest moons
planet_df %>%
  # Unnest the moons list column over observations
  unnest_longer(moons) %>%
  # Further unnest the moons column
  unnest_wider(moons) %>%
  # Unnest the moon_data column
  unnest_wider(moon_data) %>%
  # Get the top five largest moons by radius
  slice_max(radius, n = 5)

# C. Selecting nested variables
# 1. Hoisting Star Wars films
# hoist(): can be used to select a specify element of the JSON dictionary
character_df %>%
  # Unnest the metadata column
  unnest_wider(metadata) %>%
  # Unnest the films column
  unnest_longer(films)

# Hoisting to find the same information. Selecting the first film for each film list by row of metadata layer
character_df %>%
  hoist(metadata, first_film = list("films", 1))

# 2. Hoisting movie ratings
movie_df %>%
  # Unnest the movie column
  unnest_wider(movie) %>%
  select(Title, Year, Ratings) %>%
  # Unnest the Ratings column
  unnest_wider(Ratings)

# Hoisting method to extract the Rotten Tomatoes rating for each movie
movie_df %>%
  hoist(
    movie,
    title = "Title",
    year = "Year",
    rating = list("Ratings", "Rotten Tomatoes")
  )

# D. Nesting data for modelling
# 1. Tidy model outputs with broom
# Linear model
model <- lm(weight_kg ~ waist_circum_m + stature_m, data = ansur_df)
# Review the model Statistics using broom
broom::glance(model)
# Review the variable fit statistics with broom
broom::tidy(model)

# 2. Nesting tibbles
# Tibble data is added to the DataFrame
ansur_df %>%
  # Group the data by branch, then nest
  group_by(branch) %>%
  nest()

ansur_df %>%
  # Group the data by branch and sex, then nest
  group_by(branch, sex) %>%
  nest()

# 3. Modelling on nested dataframes
# The dplyr, broom, and purrr packages have been pre-loaded for you
# In the provided code, the purrr package's map() function applies functions on each nested data frame
ansur_df %>%
  # Group the data by sex
  group_by(sex) %>%
  # Nest the data
  nest() %>%
  mutate(
    fit = map(data, function(df) lm(weight_kg ~ waist_circum_m + stature_m, data = df)),
    glanced = map(fit, glance)
  ) %>%
  # Unnest the glanced column
  unnest(glanced)


#' @title Prepare bootstrapped results for `ggplot` friendly data format.
#'
#' @description Helper function to convert the bootstrapped dissimilarities from
#'   matrix format to `ggplot2` friendly data format.
#'
#' @param x A matrix of bootstrapped dissimilarities from
#'   \code{\link[bootdissim]{boot_dissim}}
#'
#' @param probs A numeric vector of two probabilities in the interval `[0, 1]`.
#'   Used for building the lower and upper bounds of the confidence intervals.
#'   Defaults to `c(0.025, 0.975)`, which corresponds to a 95\\% confidence
#'   interval.
#'
#' @return A list of two data frames to be used with
#'   \code{\link[ggplot2]{ggplot}}. First one, `stats_df` is a 4 columns data
#'   frame, containing the sample size/number of sampled interactions
#'   (`spl_size`) at each step and the corresponding mean dissimilarity (`mean`)
#'   together with its bootstrap confidence interval limits (`ci_low`, `ci_up`).
#'   The second one, `lines_df`, contains all the bootstrapped dissimilarities
#'   (`value`) at each bootstrap iteration (`simulation_id`) and its
#'   corresponding sample size/sampled interactions (`spl_size`). Can be used
#'   for enhancing visual effect when plotting the mean bootstrap values.
#'
#' @importFrom magrittr %>%
#' @importFrom data.table melt setDT
#' @importFrom dplyr mutate
#' @importFrom tibble rownames_to_column
#' @importFrom matrixStats rowMeans2 rowQuantiles
#'
#' @export
#'
#' @md
get_stats_gg <- function(x, probs = c(0.025, 0.975)){
  if (! is.matrix(x) ) stop("Expecting a matrix")

  stats_df <- data.frame(spl_size = as.integer(rownames(x))) %>%
    dplyr::mutate(mean   = matrixStats::rowMeans2(x, na.rm = TRUE),
                  ci_low = matrixStats::rowQuantiles(x, probs = probs[1], na.rm = TRUE) %>% unname,
                  ci_up  = matrixStats::rowQuantiles(x, probs = probs[2], na.rm = TRUE) %>% unname)

  lines_df <- x %>%
    as.data.frame %>%
    tibble::rownames_to_column(var = "spl_size") %>%
    setDT() %>%
    data.table::melt(id.vars = "spl_size",
                     variable.name = "simulation_id") %>%
    dplyr::mutate(spl_size = as.integer(spl_size),
                  simulation_id = as.integer(simulation_id))

  return(list(stats_df = stats_df,
              lines_df = lines_df))
}

#' @title Plot bootstrapped dissimilarities
#'
#' @description Custom plotting function to display the bootstrapped
#'   dissimilarities, the mean line and its confidence intervals.
#'
#' @param metrics_stats The output of \code{\link[bootdissim]{get_stats_gg}}.
#'
#' @param size_boot_lines Size of the line connecting the bootstrapped values.
#'   Default is 0.2. Passed to \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @param alpha_boot_lines Alpha parameter of the line connecting the
#'   bootstrapped values. Default is 0.2. Passed to
#'   \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @param size_ci Size of the line used for the confidence intervals. Default is
#'   1. Passed to \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @param linetype_ci Type of the line used for the confidence intervals.
#'   Default is 2. Passed to \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @param size_mean Size of the line connecting the bootstrapped mean values of
#'   the metric. Default is 1. Passed to
#'   \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @param linetype_mean Type of the line connecting the bootstrapped mean values
#'   of the metric. Default is 1. Passed to
#'   \code{\link[ggplot2:geom_path]{geom_line}}.
#'
#' @return A ggplot object.
#'
#' @import ggplot2
#'
#' @export
#'
#' @md
plot_dissim <- function(metrics_stats,
                        size_boot_lines = 0.2,
                        alpha_boot_lines = 0.2,
                        size_ci = 1,
                        linetype_ci = 2,
                        size_mean = 1,
                        linetype_mean = 1){

  stats_df <- metrics_stats[["stats_df"]]
  lines_df <- metrics_stats[["lines_df"]]

  plots_gg <- ggplot() +
    # Bootstrap lines
    geom_line(data = lines_df,
              aes(x = spl_size,
                  y = value,
                  group = simulation_id),
              size = size_boot_lines,
              alpha = alpha_boot_lines) +
    # Lower confidence interval bound
    geom_line(data = stats_df,
              aes(x = spl_size,
                  y = ci_low),
              size = size_ci,
              linetype = linetype_ci) +
    # Upper confidence interval bound
    geom_line(data = stats_df,
              aes(x = spl_size,
                  y = ci_up),
              size = size_ci,
              linetype = linetype_ci) +
    # Average line
    geom_line(data = stats_df,
              aes(x = spl_size,
                  y = mean),
              size = size_mean,
              linetype = linetype_mean)

  return(plots_gg)
}


2: 1 -> 2
4: 2 -> 4
3: 3 -> 4


library(gapminder)
library(tidyverse)
library(gganimate)
options(gganimate.nframes=20)

gapminder %>%
    select(country, pop, year, continent) %>%
    group_by(year) %>%
    arrange(year, -pop) %>%
    mutate(rank=1:n()) %>%
    filter(rank <= 10) ->
ranked_by_year

my_theme <- theme_classic(base_family = "Times") +
  theme(axis.text.y = element_blank()) +
  theme(axis.ticks.y = element_blank()) +
  theme(axis.line.y = element_blank()) +
  theme(legend.background = element_rect(fill = "linen")) +
  theme(plot.background = element_rect(fill = "linen")) +
  theme(panel.background = element_rect(fill = "linen"))

ggplot(data = ranked_by_year) +
  aes(group = country, fill = continent) +
  aes(xmin = 0 ,
      xmax = pop / 1000000) +
  aes(ymin = rank - .45,
      ymax = rank + .45) +
  scale_y_reverse() +
  scale_x_continuous(
    limits = c(-300, 1400),
    breaks = c(0, 400, 800, 1200),
    labels = c(0, 400, 800, 1200)) +
  labs(fill = "") +
  geom_rect(alpha = .7) +
  labs(x = 'Population (millions)') +
  aes(label = country, y = rank) +
  geom_text(col = "gray13",
            hjust = "right",
            x = -50) +
  labs(y = "") +
  scale_fill_viridis_d(option = "magma",
                       direction = -1) +
  geom_text(x = 1000 , y = -10,
            family = "Times",
            aes(label = as.character(year)),
            size = 30, col = "grey18") +
    my_theme -> g
g + gganimate::transition_time(year)


##This script was written to clean the data retrieved manually from https://www.dol.gov/whd/state/stateMinWageHis.htm
##On 1/14/2019 and combine it with the January 2019 week three makeover monday data set to use for a visualization
##The goal of the visualization is to contextualize Bureau of Labor Statistics and Department of Labor data to answer:
##Do state minimum wages affect the percentage of workers paid at or below the federal minimum wage?

##Author: Pauly Russ
##Date: 1/14/2019

##load required libraries
library(dplyr)
library(stringr)
library(tidyr)

##set working directory and load data files
setwd("C:\\Users\\pruss\\Documents\\My Tableau Repository\\WIP")
StateMinWages <- read.csv("State Minimum Wage.csv", stringsAsFactors = FALSE)
FedMinWages <- read.csv("Minimum Wage.csv", stringsAsFactors = FALSE)

##clean up state minimum wage data

  ##first pull the header names and clean those
stateminwagenames <- colnames(StateMinWages)

  ##I saw three patterns: first year colnames started with X, state colname had junk char + .., one state had junk char + .
stateminwagenames <- str_replace_all(stateminwagenames, "(ï\\.\\.)|(X)|(Â\\.)", "")

  ##second clean data. four strings need to be removed
    ##1. [\c] - some values have a note indicated by an alpha character wrapped in square brackets
    ##2. (\c) - some values have a note indicated by an alpha character wrapped in parenthesis
    ##3. Â - a few instances of this junk character appear in the data set
    ##4. Some entries have two values listed separated by a hyphen. I read through the notes and decided to drop the second (higher) value
      ## the lower value is indicative of the state's true 'MINIMUM' that can be paid
StateMinWages <- lapply(StateMinWages, str_replace_all, pattern = "(\\[[A-z]\\])|(\\([A-z]\\))|(Â)|( *\\- *\\d*\\.\\d*)", replacement = "")

StateMinWages[2:20] <- lapply(StateMinWages[2:20], str_replace_all, pattern = "\\h", replacement = "")

  ##states with no state minimum were indicated by three dots, replace with 0 so we can use math
StateMinWages <- lapply(StateMinWages, str_replace_all, pattern = "\\.\\.\\.", replacement = "0")

  ##lapply breaks data frame, put back into 51 row data frame
StateMinWages <- data.frame(matrix(unlist(StateMinWages), nrow=51, byrow=F),stringsAsFactors=FALSE)

  ##reapply column names
colnames(StateMinWages) <- stateminwagenames

## now we prep and combine for final set and calculate some columns

## first, pivot the state minimum wages into a long format
pivotStateMinWages <- reshape(StateMinWages, direction = "long", varying = list(colnames(StateMinWages[2:20])))

## I think the pivot treated years as factors, but they were sequential, so math to fix year values
pivotStateMinWages$time = pivotStateMinWages$time + 1999

## rename some columns
colnames(pivotStateMinWages)[colnames(pivotStateMinWages)=="time"] <- "year"
colnames(pivotStateMinWages)[colnames(pivotStateMinWages)=="State.or.other"] <- "state"
colnames(pivotStateMinWages)[colnames(pivotStateMinWages)=="2000"] <- "minwage"

## convert the minimum wage to number and make year/state into factors
pivotStateMinWages$minwage <- as.numeric(pivotStateMinWages$minwage)
pivotStateMinWages$year <- as.factor(as.character(pivotStateMinWages$year))
pivotStateMinWages$state <- as.factor(as.character(pivotStateMinWages$state))

## rename some columns
colnames(FedMinWages)[1] <- "year"
colnames(FedMinWages)[2] <- "state"
colnames(FedMinWages) <- tolower(colnames(FedMinWages))

## the federal minimum wage data set had a 'total' set of rows, drop them and convert to factor
FedMinWages <- FedMinWages[-grep('Total', FedMinWages$state),]

## make state and year into factors
FedMinWages$year <- as.factor(as.character(FedMinWages$year))
FedMinWages$state <- as.factor(as.character(FedMinWages$state))

## combine minimum wage table with pivoted state minimums
finalset <- merge(FedMinWages, pivotStateMinWages)

##rename some columns
colnames(finalset)[6] <- "state.minimum.wage"
colnames(finalset)[5] <- "pcnt.below.fed.min"
colnames(finalset)[4] <- "pcnt.at.fed.min"

## forgot fed minimum wage changed over observed time, below adds that based on the chart at https://www.dol.gov/whd/minwage/chart.htm
fedminovertime <- data.frame(year = unique(finalset$year))
fedminovertime$fed.minimum.wage <- 5.15

fedminovertime$year <- as.numeric(as.character(fedminovertime$year))
fedminovertime$fed.minimum.wage <- if_else(fedminovertime$year == 2007, fedminovertime$fed.minimum.wage + 0.7, if_else(fedminovertime$year == 2008, fedminovertime$fed.minimum.wage + 1.4, if_else(fedminovertime$year >= 2009, fedminovertime$fed.minimum.wage + 2.1, fedminovertime$fed.minimum.wage)))

## merge the federal minimum wage over time on to the final set as a column
finalset <- merge(finalset, fedminovertime)

## create a column that quickly indicates whether a state minimum is higher, equal or lower than federal min
finalset <- finalset%>%
  mutate(state.min.vs.fed.min = case_when(
  state.minimum.wage < fed.minimum.wage & state.minimum.wage != 0 ~ "lt",
  state.minimum.wage == fed.minimum.wage | state.minimum.wage == 0 ~ "eq",
  state.minimum.wage > fed.minimum.wage ~ "gt"))

write.csv(finalset, "enhancedWageData.csv", sep = ",", row.names = FALSE, fileEncoding = "UTF-8")


library(tidyverse)

#########
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder = file.path(folder, '..', 'data', 'intermediate', 'model_inputs')

filename = 'rp_by_distance.csv'
data <- read.csv(file.path(folder, filename))

data$frequency_category = factor(data$frequency_category,
                                 levels=c("6-8 GHz",
                                          "11-15 GHz",
                                          "15-18 GHz"),
                                 labels=c("6-8",
                                          "11-15",
                                          "15-18"))

data$distance_category = factor(data$distance_category,
                                levels=c("<10 km",
                                         "10-25 km",
                                         "25-40 km"))

plot1 =
  ggplot(data, aes(received_power_db, frequency_category)) + coord_flip() +
  geom_boxplot() + geom_jitter(width = 0.5, size=.05, alpha=.2) +
  labs(title="(A) Simulation Results for the Received Signal based on the FSPL",
       colour=NULL,
       subtitle = "Reported for all frequency and distance categories",
       x = 'Received Signal (dB)', y = "Frequency (GHz)") +
  scale_x_continuous(expand = c(0, 0), limits = c(-40,0)) +
  facet_wrap(~distance_category)

############
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder = file.path(folder, '..', 'data', 'intermediate', 'model_inputs')

filename = 'fresnel_clearances.csv'
data <- read.csv(file.path(folder, filename))

data = data[data$clearance > 1,]

data$frequency_category = factor(data$frequency_category,
                                 levels=c("6-8 GHz",
                                          "11-15 GHz",
                                          "15-18 GHz"),
                                 labels=c("6-8",
                                          "11-15",
                                          "15-18"))

plot2 =
  ggplot(data, aes(clearance, frequency_category)) + coord_flip() +
  geom_boxplot() + geom_jitter(width = 0.5, size=.05, alpha=.2) +
  labs(title="(B) Simulation Results for Required Fresnel Clearance Values",
       colour=NULL,
       subtitle = "Reported for all frequency and distance categories",
       x = 'Clearance (M)', y = "Frequency (GHz)") +
  scale_x_continuous(expand = c(0, 0), limits = c(0,22.5)) +
  facet_wrap(~distance_category)

combined <- ggarrange(plot1, plot2,
                      ncol = 1, nrow = 2)

folder <- dirname(rstudioapi::getSourceEditorContext()$path)
path = file.path(folder, 'figures', 'panel_plot.png')
ggsave(path, units="in", width=7, height=5, dpi=300)
print(combined)
dev.off()

# folder <- dirname(rstudioapi::getSourceEditorContext()$path)
# path = file.path(folder, 'figures', 'fresnel_clearances.png')
# ggsave(path, units="in", width=7, height=4, dpi=300)
# print(plot)
# dev.off()


library(ggplot2)
library(ggthemes)

pdf('streak_year.pdf',width=12.5417,height=4.9722)

data = read.csv(file='year_avg_streak.csv', sep=',', header = TRUE)

reset <- par(mar=rep(0,4))

plot <- ggplot(new_data, aes(x = year, y = avg_streak)) +
        geom_line(size = 1, color='#251AED') +
        scale_x_continuous(breaks = seq(1967, 2017, by = 5)) +
        scale_y_continuous(breaks = seq(0, 20, by = 1)) +
        theme_wsj(color='white') +
        guides(alpha = FALSE) +
        theme(plot.margin=grid::unit(c(0,0,0,0), 'mm'))

par(reset)
print(plot)
par(reset)
dev.off()


library(caret)
library(tidyverse)
library(dplyr)
library(randomForest)
library(fpc) # pamk
library(cluster) # pam
library(ggplot2,quietly=TRUE)
suppressMessages(library(ellipse))
suppressMessages(library(RColorBrewer))
library(reshape2,quietly=TRUE) # Load the reshape2 package (for the melt() function)

source('robust.clustering.metagenomics.functions.r')

#####################################
### Function process.one.fluxes.file
#####################################
# a) To generate subjectID (suffix from file, between 'biomass_' and '.tsv')
# b) To generate sample ID: subjectID_[0*]seqNum
process.one.fluxes.file <- function(file){
  suffix = gsub('.tsv$','',gsub('^fluxes_','',file))
  table=read.table(file,sep="\t",header=TRUE)
  table[,grep('time',colnames(table))] <- NULL # Remove repeated time columns (from different strains)
  id.subject=rep(suffix,nrow(table))
  id.num=seq(1,nrow(table),1)
  id.num=str_pad(id.num,5, pad = '0') # Add leading zeros, to easy sort
  id.vector=paste(id.subject, id.num,sep = '_')
  rownames(table)=id.vector
  return(table)
} # end-function process.one.fluxes.file

#####################################
### Function rbind.with.rownames
#####################################
rbind.with.rownames <- function(datalist) {
  require(plyr)
  temp <- rbind.fill(datalist)
  rownames(temp) <- unlist(lapply(datalist, row.names))
  return(temp)
} # end-function rbind.with.rownames

#####################################
### Function cluster names
#####################################
cluster_names <- function(df) {
  require(dplyr)
  means <- df %>%
    select(starts_with("Biomass"), cluster) %>%
    group_by(cluster) %>%
    summarize_all(mean)
  signed <- c(as.character(means[which.max(rowSums(means[,2:ncol(means)])),]$cluster),
              as.character(means[which.min(rowSums(means[,2:ncol(means)])),]$cluster))
  df$cluster <- mapvalues(df$cluster, from = signed, to = c("growth", "stationary"))
  return(df)
} # end-function cluster names

#####################################
### Function rf.10CV
#####################################
# Build and evaluate (with 10 Cross-Validation) a model with Random Forest, using caret.
# Args:
#   df: data frame with all data (including predictors and class variable)
#   formula: object of class formula (i.e. class~ predictors (separated by '+'))
#   classVar: string/number of class variable in 'df'. Default: the last one.
#   ntree: number of trees in the forest
# Output:
#   finalModel: object with the model in randomForest format, for further evaluations or plots.
rf.10CV <- function(df,formula,classVar=length(df),ntree=1000){
  require(doMC) # parallel processing; in Windows, maybe doParallel would work
  registerDoMC(cores = 5)
  set.seed(123)
  train_control <- trainControl(method="cv", number=10, savePredictions = TRUE)
  model <- train(form=formula,data=df, trControl=train_control, method="rf", metric='Accuracy',
                 ntree=ntree, importance=TRUE, localImp=TRUE, na.action=na.omit,
                 allowParallel = T, ncores = 5, nodesize = 42)
  # Define output
  output <- list("model"=model$finalModel, "pred"=model$pred)
  # summarize results
  print(model)
  # plot model error
  print(plot(model))
  # Variable Importance
  pdf('varImportance_rf10CV.pdf')
  print(varImpPlot(model$finalModel))
  dev.off()
  print(plot(margin(model$finalModel,df[,classNum])))

  return(output)
}

####################################################
### plot.rf.var.importance.by.class.andMean.dotplot
####################################################
# Plot dotplot with variable importance mean over all classes
# Args:
#   model: random forest model already build
#   predVar: string of column ID with predictor/variables names values
#   classVar: string of class variable in 'df'
#   title: header of the plot
#   colorVector: vector of colors
#   nBestFeatures: number of top relevant features to show in the plot.
plot.rf.var.importance.by.class.andMean.dotplot <- function(model,predVar,classVar,title='',colorVector=NULL,nBestFeatures=NULL){
  library(reshape2)
  imp.df <- melt(importance(model)[,1:(length(model$classes)+1)])
  colnames(imp.df)=c(predVar,classVar,'value')
  # a.-Order features
  pred.order=names(sort(importance(model)[,'MeanDecreaseAccuracy'])) # My order according to global MeandDecreaseAccuracy
  imp.df[,predVar] <- factor(imp.df[,predVar], levels = pred.order)
  class.names=levels(imp.df[,classVar])
  levels(imp.df[,classVar]) <- c(class.names[1:(length(class.names)-1)],"MEAN")
  imp.df[,classVar] <- factor(imp.df[,classVar])
  # b.- Subset features to show
  if(!is.null(nBestFeatures)){
    imp.df=subset(imp.df,subset=(imp.df[,predVar] %in% tail(pred.order,n=nBestFeatures)))
  }
  p <- ggplot(imp.df, aes_string(x = 'value', y = predVar, group = predVar, colour = classVar)) +
    geom_segment(aes_string(yend=predVar), xend=0, colour="grey50") +
    geom_point( size = 1) +
    theme_bw() +
    facet_grid(reformulate(classVar)) +
    theme(panel.grid.major.y = element_blank()) +
    #theme(text = element_text(size=16)) +
    xlab(paste(predVar," importance",sep='')) +
    theme(axis.text.x = element_text(angle = 270, hjust = 1)) +
    theme(legend.position="none") +
    ggtitle(title)
  if(!is.null(colorVector)){
    p +  scale_color_manual(values=colorVector)
  }else{
    p
  }
  return(p)
}

##########################################################################
# END FUNCTIONS
##########################################################################

# 1. READ DATA
# Read fluxes tables from MMODES
file <- list.files(pattern="^fluxes\\_.*\\.tsv$")
# Add subject and sample ID per table
tables.list=lapply(file, process.one.fluxes.file)
# Concatenate all fluxes data.frames (one per subject time series) in a unique one
table.all <- rbind.with.rownames(tables.list)
# Save
fluxes_raw  <- table.all
saveRDS(fluxes, "fluxes.rds")
write.table(fluxes,file='allTimeSeries_fluxes.tsv',sep='\t',quote=FALSE)
fluxes_raw <- readRDS("fluxes.rds")

# 1.2. FEATURE SELECTION
# Check columns with NA values
# fluxes.isna=colnames(fluxes)[colSums(is.na(fluxes)) > 0]
# NA values are generated if some Perturbations are missing in some simulation.
# We can afford to remove the rows of these simulations (generally 1 or 0 in the dataset).
fluxes <- fluxes_raw[complete.cases(fluxes_raw),]
# Check fluxes with constant values (sd=0)
output_sd=apply(fluxes, MARGIN=2, sd)
fluxes.sd0=colnames(fluxes)[output_sd==0]
# Remove those fluxes
if(length(fluxes.sd0)>0){
  fluxes = fluxes[, -which(names(fluxes) %in% fluxes.sd0)]
}
# Remove first all of the transporters and exchanges
# It does not remove knowledge, but interpretations of the inner metabolism is possible
fluxes <- fluxes %>%
  select(-starts_with("EX"), -starts_with("Ex"), -contains("tex_"), -contains("tpp_"), -contains("abcpp"))
# Some columns shares identical values across rows. That is because reactions are coupled,
# belonging to the same pathway
fluxes <- fluxes[,-which(duplicated(t(fluxes)) == TRUE)]
cat("Predictos variables reduced sized from", ncol(fluxes_raw), "to", ncol(fluxes),
    "by feature selection.")

# normalization
library(scales)
fluxes.rescale <- apply(fluxes[,1:ncol(fluxes)-1], MARGIN = 2, rescale, to=c(-1,1))

# 2. RANDOM SUFFLE
iniSeed <- 1234
set.seed(iniSeed)
selected <- sample(nrow(fluxes.rescale))
fluxes.rescale.random <- fluxes.rescale[selected,] # for clustering
fluxes.random <- fluxes[selected,] # for random forest, without normalization

# 3. CLUSTERING
maxClus=10
eval.array2d <- array(0,dim=c(maxClus-1,3),dimnames=list(as.character(seq(2,maxClus,1)), list('SI','PS','Jaccard')))
# Silhouette
fitPamBest <- pamk(fluxes.rescale.random,krange=2:maxClus)
save(fitPamBest,file='fitPamBest.Rdata')
eval.array2d[,'SI']=fitPamBest$crit[2:maxClus]
# Prediction Strength
out.pred.str <- prediction.strength(fluxes.rescale.random, Gmin=2, Gmax=maxClus, M=50, clustermethod=claraCBI, classification="centroid")
eval.array2d[,'PS']=out.pred.str$mean.pred[2:maxClus]
# Jaccard
for(k in 2:maxClus){
  cf <- clusterboot(fluxes.rescale.random,B=100,bootmethod="boot",clustermethod=claraCBI,k=k,seed=iniSeed,count=FALSE)
  #print(mean(cf$bootmean))
  eval.array2d[as.character(k),'Jaccard'] <- mean(cf$bootmean)
}
save(eval.array2d,file='eval.arrays.RData')
plot.robust.clustering.PAM(eval.array2d)

# Select the best k (with the higher SI and (PS or Jac) > their thresholds)
kBest <- robust.clustering.decision(eval.array2d)
fit <- pam(fluxes.rescale.random,kBest)
print.clustering.results(eval.array2d,fit,kBest)

# Getting a list <sampleID,clusterID>
labels <-  as.data.frame(as.factor(fit$cluster))
colnames(labels) <- c('cluster')
df.fluxes <- as.data.frame(fluxes.random)
df <- merge(df.fluxes,labels,by='row.names')
row.names(df) <- df$Row.names
df$Row.names <- NULL
df.out <- subset(df,select=cluster)
write.table(df.out,'sampleId-cluster_pairs_fluxes.txt',quote=FALSE,sep=',',row.names=TRUE)
rm(df.fluxes,df.out)

# 4. RANDOM FOREST
# Print medoids with their values in the most relevant features
# Very important to intepretate the clusters!!
as_tibble(df[rownames(fit$medoids),])

# Supervised learning after feature selection
# Random forest with the clusters defined by PAM
formula <- formula("cluster~.")
model <- rf.10CV(df,formula)
saveRDS(model, "final_RF_bf_model.rsd")
sink('model_RF_bf.txt')
cat('Growth in medoids')
as_tibble(df[rownames(fit$medoids),]) %>% select(starts_with("Biomass"))
print(model)
sink()
mod <- model$model
pred <- model$pred
# fluxes importance independent by predicted class
plot.rf.var.importance.by.class.andMean.dotplot(mod,'flux','cluster',title='Most relevant fluxes',nBestFeatures=25)
# see predictions (and in which CV fold it was tested)


## 2. Reading a CSV Files into a Dataframe ##

df <- read.csv("recent-grads.csv")
print(df)

## 3. Previewing the First Few Rows ##

head(df)
tail(df)

## 4. Examining the Internal Structure ##

str(df)

## 5. Numeric vs. Integer Data Types ##

petro_eng_med_salary <- 110000
finance_med_salary <- 47000

pet_integer <- is.integer(petro_eng_med_salary)
fin_integer <- is.integer(finance_med_salary)

## 6. Representing Categorical Values Using Factors ##

majors <- c('Arts','Biology & Life Science','Business','Computers & Mathematics', 'Engineering',
            'Health','Humanities & Liberal Arts','Psychology & Social Work','Social Science')

factor_majors <- factor(majors)
print(levels(factor_majors))
major_levels <- levels(factor_majors)

## 7. Selecting Data by Rows ##

rank_1_100 <- df[1:100,]
architectural_engineering <- df[19,]
computer_science <- df[21,]

## 8. Selecting Data by Columns ##

select_df <- df[,c("Major","Unemployment_rate","Median","Men","Women")]

## 9. Selecting Specific Values ##

mech_eng_salary <- df["MECHANICAL ENGINEERING","Median"]
comp_sci_salary <- df["COMPUTER SCIENCE","Median"]
finance_salary <- df["FINANCE","Median"]

## 10. Using Comparison Operators to Filter Values ##

above_50 <- df[df$Median > 50000,]
engineering <- df[df$Major_category == "Engineering",]
great_40 <- df[df$ShareWomen > 0.4,]

## 11. Combining Conditions using Logical Operators ##

majors <- df[df$Median >50000 & df$ShareWomen >0.4, ]

## 12. Sorting A DataFrame ##

majors <- df[df$Median >50000 & df$ShareWomen >0.4, ]

major_choice <- majors[order(majors$Unemployment_rate),]

R Fundamentals/Introduction to DataFrames-313.r


library(ggplot2)
theme_set(theme_bw(18))
setwd("~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/sinking-marbles-nullutterance-simple/results/")
source("rscripts/helpers.r")
load("data/priors.RData")
#r = read.table("data/sinking_marbles_nullutterance-simple.tsv", sep="\t", header=T)
r = read.table("data/test.csv", sep=",", header=T)
nrow(r)
summary(r)
#as.data.frame(table(r$assignmentid))[as.data.frame(table(r$assignmentid))$Freq < 120,]
r$trial = r$slide_number_in_experiment - 2
r = r[,c("assignmentid","workerid", "rt", "effect", "cause","language","gender.1","age","gender","other_gender","quantifier", "object_level", "response", "object","slider_id","num_objects","trial","enjoyment","asses","comments","Answer.time_in_minutes")]
row.names(priors) = paste(priors$effect, priors$object)
r$Prior = priors[paste(r$effect, r$object),]$response
r$object_level = factor(r$object_level, levels=c("object_high", "object_mid", "object_low"))
r$Proportion = factor(ifelse(r$slider_id == "all","100",ifelse(r$slider_id == "lower_half","1-50",ifelse(r$slider_id == "upper_half","51-99","0"))),levels=c("0","1-50","51-99","100"))
r$Half = as.factor(ifelse(r$trial < 16, 1, 2))
r$Quarter = as.factor(ifelse(r$trial < 8, 1, ifelse(r$trial < 16, 2, ifelse(r$trial < 24, 3, 4))))
summary(r)
r$Combination = as.factor(paste(r$cause,r$object,r$effect))
table(r$Combination)

# compute normalized probabilities
nr = ddply(r, .(assignmentid,trial), summarize, normresponse=response/(sum(response)),assignmentid=assignmentid,Proportion=Proportion)
row.names(nr) = paste(nr$assignmentid,nr$trial,nr$Proportion)
r$normresponse = nr[paste(r$assignmentid,r$trial,r$Proportion),]$normresponse
# test: sums should add to 1
sums = ddply(r, .(assignmentid,trial), summarize, sum(normresponse))
colnames(sums) = c("assignmentid","trial","sum")
summary(sums)
sums[is.na(sums$sum),]

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,50000))

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

ggplot(aes(x=age,fill=gender.1), 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()

ggplot(aes(x=Answer.time_in_minutes), data=r) +
  geom_histogram()

ggplot(aes(x=age,y=Answer.time_in_minutes,color=gender.1), data=unique(r[,c("assignmentid","age","Answer.time_in_minutes","gender.1")])) +
  geom_point() +
  geom_smooth(method="lm")

unique(r$comments)


bottom.contact.incremental = function( sm, bcp=bcp )  {
  ## Algorithm: this is essentially a faster discrete version of the "smooth method"
  ## .. using an equally spaced x-interval, determine locations where change in slope is maximal
 stop( "Not working well enough for full time use")

  if(0) {
    load("~/aegis/data/nets/Scanmar/bottom.contact/results/bc.NED2014102.8.rdata")
    sm =data.frame( Z=bc$Z)
    sm$timestamp=bc$timestamp
    sm$ts=bc$ts
    good = bc$good
    sm$Z[ !good] = NA
  }

  res = c(NA, NA)

  # use only the subset with data for this step
  names( sm) = c("Z", "timestamp", "ts" ) # Z is used to abstract the variable name such that any variable can be passed
  N = nrow(sm)
  if ( N < 50 ) return(res)  # insufficient data

  # interpolate missing data
  sm$Z.cleaned = interpolate.xy.robust( sm[, c("ts", "Z")], method="sequential.linear" , probs=bcp$incremental.quants )

  sm$slope = NA
  sm$rsq = NA
  # n.target = n.target   # nrequired to enter into a linear regression model
  dta = -bcp$incremental.windowsize:bcp$incremental.windowsize
  for ( i in (bcp$incremental.windowsize+1):(N-bcp$incremental.windowsize) ) {
    j = i+dta
    lmres = lm( Z.cleaned ~ ts, data=sm[j,], na.action="na.omit" )
    # sm$rsq[i] = Rsquared(lmres)
    sm$slope[i] =  coefficients(lmres)["ts"]
  }

  sm$slope.cleaned = interpolate.xy.robust( sm[, c("ts", "slope")], method="sequential.linear" , probs=bcp$incremental.quants )

  slope.imax = which.max( sm$slope )  # descent has a positive slope start search from maximal slope
  slope.imin = which.min( sm$slope )  # ascending limb has a negative slope .. start search from min slope
  slope.mid = trunc( (slope.imin + slope.imax) /2 )
  slope.modes = modes( sm$slope )
  # sm$slope.smoothed = interpolate.xy.robust( sm[, c("ts", "slope")], method="inla" )

  if ( !is.finite(slope.modes$sd ) || slope.modes$sd < 1e-3) {
    return(res)
  }

  i0 = slope.imax
  for (i0 in slope.imax:slope.mid) {
    if (sm$slope[i0] < slope.modes$ub2 ) break()
  }

  i1 = slope.imin
  for (i1 in slope.imin:slope.mid) {
    if (sm$slope[i1] > slope.modes$lb2 ) break()
  }

  res =  c( sm$timestamp[i0], sm$timestamp[i1] )

  if (0) {
    plot(Z~ts,sm, pch=".")
    points(Z.cleaned~ts,sm, col="red", pch=20)
    abline( v=sm$ts[ c(i0, i1) ], col="blue" )

    plot.new()
    plot(slope~ts, sm, pch=20, col="green" )
    abline( h=slope.modes, col="red" )
    abline( v=sm$ts[ c(i0, i1) ], col="blue" )
  }

  sm$slope.smoothed = interpolate.xy.robust( sm[, c("ts", "slope.cleaned")], method="inla" , probs=bcp$incremental.quants, target.r2=0.9 )

  return(res)
}


library(s2dverification)
library(ncdf4)
library(multiApply) #nolint
library(yaml)
library(abind)
library(ClimProjDiags) #nolint
library(RColorBrewer) #nolint

args <- commandArgs(trailingOnly = TRUE)
params <- read_yaml(args[1])
plot_dir <- params$plot_dir
run_dir <- params$run_dir
work_dir <- params$work_dir

dir.create(plot_dir, recursive = TRUE)
dir.create(run_dir, recursive = TRUE)
dir.create(work_dir, recursive = TRUE)

# setup provenance file and list
provenance_file <- paste0(run_dir, "/", "diagnostic_provenance.yml")
provenance <- list()

input_files_per_var <- yaml::read_yaml(params$input_files)

model_names <- lapply(input_files_per_var, function(x) x$model)
model_names <- unname(model_names)
var0 <- lapply(input_files_per_var, function(x) x$short_name)
fullpath_filenames <- names(var0)
var0 <- unname(var0)[1]
a <- 1
b <- params$beta
g <- 0.1
nm <- params$number_of_members
nstartd <- 1
nleadt <- params$no_of_lead_times

var0 <- unlist(var0)
data_nc <- nc_open(fullpath_filenames)
data <- ncvar_get(data_nc, var0)
data <- InsertDim(InsertDim(data, 1, 1), 1, 1) #nolint
names(dim(data)) <- c("model", "var", "lon", "lat", "time")
lat <- ncvar_get(data_nc, "lat")
lon <- ncvar_get(data_nc, "lon")
lon <- unlist(lon)
lat <- unlist(lat)
attributes(lon) <- NULL
attributes(lat) <- NULL
units <- ncatt_get(data_nc, var0, "units")$value
calendar <- ncatt_get(data_nc, "time", "calendar")$value
long_names <-  ncatt_get(data_nc, var0, "long_name")$value
time <-  ncvar_get(data_nc, "time")
start_date <- as.POSIXct(substr(ncatt_get(data_nc, "time", "units")$value,
                                          11, 29))
nc_close(data_nc)
time <- as.Date(time, origin = start_date, calendar = calendar)

dim_names <- names(dim(data))
lon_dim <- which(names(dim(data)) == "lon")
lat_dim <- which(names(dim(data)) == "lat")
data <- WeightedMean(data, lat = lat, lon = lon, #nolint
                     londim = lon_dim, latdim = lat_dim)
names(dim(data)) <- dim_names[-c(lon_dim, lat_dim)]
time_dim <- which(names(dim(data)) == "time")

ToyModel <- function (alpha = 0.1, beta = 0.4, gamma = 1, sig = 1, #nolint
                      trend = 0, nstartd = 30, nleadt = 4, nmemb = 10,
                      obsini = NULL, fxerr = NULL) {
  if (any(!is.numeric(c(alpha, beta, gamma, sig, trend, nstartd,
                        nleadt, nmemb)))) {
      stop(paste("Parameters alpha, beta, gamma, sig, trend, nstartd,",
                 "nleadt and nmemb must be numeric."))
  }
  nstartd <- round(nstartd)
  nleadt <- round(nleadt)
  nmemb <- round(nmemb)
  if (!is.null(obsini)) {
    if (!is.numeric(obsini) || !is.array(obsini)) {
      stop("Parameter obsini must be a numeric array.")
    }
    if (length(dim(obsini)) != 4) {
      stop(paste("Parameter obsini must be an array with dimensions",
                 "c(1, 1, nleadt, nstartd)."))
    }
    if (dim(obsini)[3] != nstartd || dim(obsini)[4] != nleadt) {
      stop(paste0("The dimensions of parameter obsini and the parameters ",
                  "nleadt and nstartd must match:\n  dim(obsini) = c(",
                  dim(obsini)[3], ", ", dim(obsini)[4], ")\n  nstartd = ",
                  nstartd, "  nleadt = ", nleadt))
    }
  }
  if (!is.null(fxerr)) {
    if (!is.numeric(fxerr)) {
        stop("Parameter fxerr must be numeric.")
    }
  }
  if (nstartd < 0) {
      stop("Number of start dates must be positive")
  }
  if (nleadt < 0) {
      stop("Number of lead-times must be positive")
  }
  if (nmemb < 0) {
      stop("Number of members must be positive")
  }

  obs_ano <- obsini

  forecast <- array(dim = c(length(gamma), nmemb, nstartd, nleadt))
  for (j in 1 : nstartd) {
    for (f in 1 : nleadt) {
      for (g in 1 : length(gamma)) {
        auto_term <-  obs_ano[1, 1, j, f]
        if (is.numeric(fxerr)) {
          conf_term <- fxerr
        }
        else {
          conf_term <- rnorm(nmemb, mean = 0, sd = beta)
        }
        trend_term <- gamma[g] * trend * j
        var_corr <- rnorm(nmemb, mean = 0,
                          sd = sqrt(sig - alpha ^ 2 - beta ^ 2))
        forecast[g, , j, f] <- matrix(auto_term, c(nmemb,1)) + #nolint
            matrix(conf_term, c(nmemb, 1)) + matrix(trend_term, c(nmemb, 1))
      }
    }
  }
  list(mod = forecast, obs = obs_ano)
}

forecast <- ToyModel(alpha = a, beta = b, gamma = g, nmemb = nm, #nolint
                     obsini = InsertDim(data, 1, 1), # nolint
                     nstartd = 1, nleadt = dim(data)[time_dim])

ymin <- min(forecast$mod, na.rm = TRUE)
ymax <- max(forecast$mod, na.rm = TRUE)

filepng <- paste0(plot_dir, "/", "synthetic_", gsub(".nc", "",
                  basename(fullpath_filenames)), ".jpg")
jpeg(filepng, height = 15, width = 20, res = 300, units = "cm")
title <- paste(nm, "synthetic members generated")
plot(time, forecast$obs, type = "l", ylab = paste(var0, "(", units, ")"),
     main = title, bty = "n", ylim = c(ymin, ymax))
matlines(time, t(forecast$mod[1, , 1, ]), #nolint
         col = brewer.pal(n = nm, name = "Blues"))
lines(time, forecast$obs, lwd = 2)
dev.off()

obs_data <- forecast$obs
data <- forecast$mod[1, , 1, ] #nolint
names(dim(data))[c(1, 2)] <- c("number", "time")

attributes(time) <- NULL
dim(time) <- c(time = length(time))
metadata <- list(time = list(standard_name = "time", long_name = "time",
                 units = "days since 1970-01-01 00:00:00", prec = "double",
                 dim = list(list(name = "time", unlim = FALSE))))
attr(time, "variables") <- metadata
metadata <- list(index = list(dim = list(list(name = "time", unlim = FALSE,
                                              prec = "double"))))
names(metadata)[1] <- var0
attr(data, "variables") <- metadata
variable_list <- list(variable = data, time = time)
names(variable_list)[1] <- var0
filencdf <- paste0(work_dir, "/", "synthetic_", basename(fullpath_filenames))
ArrayToNetCDF(variable_list, filencdf) #nolint

    # Set provenance for output files
    xprov <- list(ancestors = list(fullpath_filenames),
                  authors = list("bellprat_omar"),
                  projects = list("c3s-magic"),
                  caption = title,
                  statistics = list("other"),
                  realms = list("atmos"),
                  themes = list("phys"),
                  plot_file = filepng)

      provenance[[filencdf]] <- xprov

# Write provenance to file
write_yaml(provenance, provenance_file)


#!/usr/bin/env Rscript
#
# Use generalized linear mixed models to test for differences in allele
# frequency.
#
# Each read is treated as an observation, and pools are treated as random
# effects. A likelihood ratio test is used to produce a p-value.
#
# Usage:
#
#   snp_by_snp_glmm_test.r <sync file> <file with pool names>
#       <group 1 pools> <group 2 pools>
#
#   The names of the pools in each group should be separated by commas.
#
#==============================================================================#

library(data.table)
library(lme4)

options(warn=1)

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

## From a sync file row, get read counts.
get_counts = function(sync_row, pools, pool_names) {
    contig = sync_row[[1]]
    pos = sync_row[[2]]
    ref_allele = toupper(sync_row[[3]])
    counts = structure(vector('list', length=length(pools)),
                       names=pools)
    for(pn in pools) {
        x = sync_row[[which(pool_names == pn) + 3]]
        cnts = as.numeric(unlist(strsplit(x, ':')))
        names(cnts) = c('A', 'T', 'C', 'G', 'N', 'D')
        ref_cnt = cnts[ref_allele]
        alt_cnt = (sum(cnts) - cnts['N']) - ref_cnt
        counts[[pn]] = c('ref'=ref_cnt, 'alt'=alt_cnt)
    }
    counts
}

## Test if this set of counts is variable
is_variable = function(counts) {
    ref = sum(sapply(counts, function(x) x[1]))
    alt = sum(sapply(counts, function(x) x[2]))
    return((ref != 0) && (alt != 0))
}

null_result = list('p'=NaN, 'effect'=NaN, term=NA, converged=NA,
                   'wald_p'=NaN, 'freqs0'=NA, 'freqs1'=NA)

## Run a GLMM with pool as a random effect. Use the default
## Wald Z-test and likelihood ratio test to get p-values
test = function(counts, groups) {
    resp = unlist(sapply(counts, function(x) c(rep(0, x[1]), rep(1, x[2]))))
    n_reads = sapply(counts, sum)
    freqs = structure(round(sapply(counts, function(x) x[1] / sum(x)), 4),
                      names=names(counts))
    pools = factor(rep(names(counts), n_reads))
    trt = rep(names(groups),
              sapply(groups, function(x) sum(n_reads[x])))
    freqs0 = paste(freqs[names(freqs) %in% groups[[1]]], collapse=',')
    freqs1 = paste(freqs[names(freqs) %in% groups[[2]]], collapse=',')
    ret = null_result
    if(length(unique(trt)) > 1) {
        ## Random intercept for each pool
        m = glmer(resp ~ trt + (1|pools), family=binomial('logit'))
        mnull = glmer(resp ~ (1|pools), family=binomial('logit'))
        lrt_p = anova(m, mnull)[['Pr(>Chisq)']][2]
        s = summary(m)
        conv = (length(s$optinfo$conv$lme4) == 0) &&
               (length(mnull@optinfo$conv$lme4) == 0)
        p = s$coefficients[2, 4]
        fe = fixef(m)[2]
        ret = list('p'=lrt_p, 'wald_p'=p, 'effect'=fe, 'term'=names(fe),
                   'converged'=as.numeric(conv),
                   'freqs0'=freqs0, 'freqs1'=freqs1)
    }
    ret
}

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

## Get arguments to the script
cargs = commandArgs(trailingOnly=TRUE)
sync_file_name = cargs[1]
pool_file_name = cargs[2]
group_1 = Filter(function(x) x != '', unlist(strsplit(cargs[3], ',')))
group_2 = Filter(function(x) x != '', unlist(strsplit(cargs[4], ',')))

## Read in data
read_counts = fread(sync_file_name, sep='\t', stringsAsFactors=FALSE)
pool_names = scan(pool_file_name, what='character')

trts = list('group1'=group_1, 'group2'=group_2)

## Test every SNP and print results
cat('contig\tpos\tref\tp\twald_p\teffect\tterm\tconverged\tfreqs0\tfreqs1\n', file=stdout())
for(i in 1:nrow(read_counts)) {
    row_data = read_counts[i]
    contig = row_data[[1]]
    pos = row_data[[2]]
    ref = row_data[[3]]
    counts = get_counts(row_data, unlist(trts), pool_names)
    if(is_variable(counts)) {
        test_results = tryCatch(test(counts, trts),
                                error=function(e) null_result)
    } else {
        test_results = null_result
    }

    cat(paste(contig, pos, ref, test_results$p, test_results$wald_p,
              test_results$effect, test_results$term, test_results$converged,
              test_results$freqs0, test_results$freqs1,
              sep='\t'),
        '\n', sep='', file=stdout())
}


#!/usr/bin/env Rscript

library(SparseM)
library(peakRAM)
library(FateID)
library(RaceID)

print(packageVersion("FateID"))
print(packageVersion("RaceID"))

args = commandArgs(trailingOnly=TRUE)
stopifnot(length(args) == 2)

size <- as.numeric(args[1])
split <- as.numeric(args[2])
profiler_root <- "../../../data/benchmarking/memory_analysis/fateid/"
fname = paste(profiler_root, paste("fateid", size, split, sep="_"), ".txt", sep="")
drivers <- paste("../../../data/morris_data/", "lin_drivers/", sep="")

select_driver_genes <- function(valid_genes, ld) {
    selected_genes = {}

    ld <- ld[ld[[1]] %in% valid_genes,]
    selected_genes <- list()

    for (i in c(2, 3, 4)) {
        c <- colnames(ld)[i]
        genes <- unlist(selected_genes)
        y <- ld[!(ld[[1]] %in% genes), ]
        y <- y[order(y[, c], decreasing=TRUE),]
        selected_genes[[c]] <- as.vector(y$X[seq(1, 3)])
    }

    selected_genes
}

print("Reading data")
X <- as(readRDS("adata_t.rds"), "dgCMatrix")
rownames(X) <- readRDS("var_names.rds")
colnames(X) <- readRDS("obs_names.rds")

stopifnot(dim(X)[2] == size)
mintotal = size %/% 1000

print("Preprocessing")

sc <- SCseq(X)
sc <- filterdata(sc, mintotal=mintotal)
x <- getfdata(sc)[sc@cluster$features,]

print("Getting marker genes")

valid_genes <- rownames(x)
ld <- read.csv(paste(drivers, size, "_", split, ".csv", sep=""))
markers <- select_driver_genes(valid_genes, ld)

minnr = minnrh = size %/% 100
n = size %/% 500

pa <- getPart(x, markers, n=n)
clustering <- pa$part
endpoints <- pa$tar
z <- sc@distances

print("Profiling fateBias")
x <- as.matrix(x)

mem <- peakRAM({
    fb <- fateBias(x, clustering,
                   endpoints, z=z,
                   minnr=minnr, minnrh=minnrh,
                   seed=123, use.dist=FALSE)
})
sink(fname)
print(mem)
sink()


#!/usr/bin/env Rscript

require(ggplot2)
require(data.table)
library(reshape2)
require(plyr)
library(grid)
# require(Hmisc)
library(plyr)

source("summarySE.r")

file <- "update_time.log"

args <- commandArgs(trailingOnly = TRUE)
if(length(args) > 0)
{
	file <- args[1]
}

alldata <- as.data.frame(read.table(file, header=TRUE, sep="\t"))

asfactors <- c("arg_method","arg_topology")
for (i in asfactors) {
    alldata[[i]] <- as.factor(alldata[[i]])
}
alldata$arg_method <- revalue(alldata$arg_method, c("cen"="Cent.", "ez"="ez-Seg."))
alldata$arg_topology <- revalue(alldata$arg_topology, c("b4"="B4", "i2"="I2"))

data <- alldata

Xquantified50 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(update_only, probs = 0.50),type="Coordination", perc=50)

Xquantified90 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(update_only, probs = 0.90),type="Coordination", perc=90)

Xquantified99 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(update_only, probs = 0.99),type="Coordination", perc=99)

CTRquantified50 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(ctr_time, probs = 0.5),type="Computation", perc=50)

CTRquantified90 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(ctr_time, probs = 0.90),type="Computation", perc=90)

CTRquantified99 <- ddply(alldata,c("arg_method","arg_topology"),summarise,time = quantile(ctr_time, probs = 0.99),type="Computation", perc=99)

quantified <- rbind(CTRquantified50, CTRquantified90, CTRquantified99,Xquantified50, Xquantified90, Xquantified99)

quantified <- ddply(quantified,c("arg_method"),transform,group=paste(arg_topology," ",perc,"th-ile",sep=""))

p1 <- ggplot() +
  geom_bar(data=quantified, aes(y = time, x = arg_method, fill = type), stat="identity",
           position='stack',colour="black",
             size=.3) +
  facet_grid( ~ group) +
  labs(y="Time [ms]",fill = "Update time") +
    theme_bw() +
  guides(fill = guide_legend(override.aes = list(colour = NULL))) +
  theme(plot.margin=unit(x=c(1,1,1,1),units="mm"),
        axis.title.x=element_blank(),
        axis.text.x = element_text(size=8),
        legend.title = element_blank(), legend.key = element_rect(colour = "black"), legend.position="top", legend.margin=unit(-0.225, 'cm')) +
  scale_y_continuous(breaks = c(0,200,400,600,800,1000,1200,1400,1600,1800,2000,2200,2400))

ggsave("plot-percentile.pdf", width=6.5, height=2.5)