#
# call: Rscript ../plots.r 2018-02-03_053826
# (curr. workdir is where the run-???.csv is)
#
# packages to install: dplyr, ggplot2, svglite, gplots, anytime, gridExtra
# (e.g. install.packages('svglite'))
#

# if run in RStudio one can select the csv ("run-2018???.csv") in a file dialogue
INTERACTIVE <- FALSE

library(dplyr)
library(ggplot2)
library(gplots)
library(anytime)
library(grid)
library(gridExtra)

if (INTERACTIVE) {
  #library('ggedit')    # only if interactive editing
  #pdf(NULL)   # prevent PDF output
  fnames <- file.choose()
  fname <- fnames[1]
  RUN <- sub('.*run-([-_0-9]+).csv', '\\1', fname)
  bp <- dirname(fname)
} else {
  args = commandArgs(trailingOnly=TRUE)
  RUN <- args[1]
  bp <- "."
  fname <- paste('run-', RUN, '.csv', sep='')
  pdf(paste("BM-",RUN,".pdf",sep=''), onefile=TRUE, compress=TRUE, paper="a4")   # PDF output to file
}
fname2 <- paste(bp, '/report_', RUN, '.txt', sep='')
fname3 <- paste(bp, '/bench-settings', sep='')
fname4 <- paste(bp, '/times.csv', sep='')

DESC=''                    # Add custom text to titles
k <- 6 #12 #24             # Protocol parameters determining
SLOTLENGTH <- 20           # the length of an epoch
EPOCHLENGTH <- 10*k*SLOTLENGTH

# general constants which should correspond to the recording script
# these are defaults to which we fall back if they cannot be extracted from the log
#recDelay0 <- 5   # seconds
recCpuTicks0 <- 100  # `getconf CLK_TCK`
recPageSize0 <- 4096 # memory is indicated in pages

# have trx times?
hasTrxTimes <- FALSE
if (file.exists(fname4)) {
  hasTrxTimes <- TRUE
}

# names of relay nodes
relays <- c('r-a-1', 'r-a-2', 'r-a-3'
          , 'r-b-1', 'r-b-2'
          , 'r-c-1', 'r-c-2'
          , 'u-a-1', 'u-b-1', 'u-c-1'
            )

# names of unprivileged relay nodes
uRelays <- c('u-a-1', 'u-b-1', 'u-c-1')

coreNodes <- c('c-a-1', 'c-a-2', 'c-a-3', 'c-b-1', 'c-b-2', 'c-c-1', 'c-c-2')

# read in transaction times
if (hasTrxTimes) {
  times <- read.csv(fname4, header=FALSE, col.names=c("time", "cumm"))
}

# prep and read in benchmark parameters
system(paste("sed -e 's/, /\\\n/g' ", fname3, " > ", fname3, "2", sep=''))
params <- read.csv(paste(fname3, "2", sep=''), header=FALSE,
                   col.names = c("parameter","value"), sep="=",
                   stringsAsFactor=FALSE)

maxparam <- length(params[,2])
if (params[maxparam,1]=="systemstart") {
  params[maxparam+1,1] <- "time UTC"
  params[maxparam+1,2] <- paste("", anytime(as.numeric(params[maxparam,2]), tz="UTC"), sep='')
}

# read the report of the benchmark run
readReport <- function(filename, run=RUN) {
  print(paste('reading data from', filename, sep=' '))
  report <- read.table(filename, sep=':', nrows=3, skip=1, col.names = c("desc", "count"))
  return (report);
}

# read and pre-process data from a benchmark run
readData <- function(filename, run=RUN) {
    #filename <- paste('run-', run, '.csv', sep='')
    print(paste('reading data from', filename, sep=' '))
    data <- read.csv(filename)
    t0 <- min(data$time)

    # find first block created
    txWritten <- data %>% filter(txType %in% c("written")) %>% filter(txCount > 0)
    tFirstBlock <- min(txWritten$time)
    tFirstBlock <- trunc((tFirstBlock - t0) / 1000 / EPOCHLENGTH) * EPOCHLENGTH * 1000 + t0
    data <- filter(data, time >= tFirstBlock)

    # time after start of experiment, in seconds
    data$t <- (data$time - t0) %/% 1e6
    data$clustersize <- as.factor(data$clustersize)
    data$concF <- as.factor(data$conc)
    data$delayF <- as.factor(data$delay)
    data <- data[!(data$txType %in% c('failed')),]
    data$endT <- ave(data$t, data$run, FUN=max)
    data$isRelay <- data$node %in% relays
    data$isRelay <- as.factor(data$isRelay)
    levels(data$isRelay) <- c('Core Nodes', 'Relay Nodes')

    # make the labels shorter
    levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_Modify"] <- "hold tx"
    levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_Wait"] <- "wait tx"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_Modify"] <- "hold block"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_Wait"] <- "wait block"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_Modify"] <- "hold rollback"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_Wait"] <- "wait rollback"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_SizeAfter"] <- "size after block"
    levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_SizeAfter"] <- "size after rollback"
    levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_SizeAfter"] <- "size after tx"

    return(data)
}

# reads os metrics from a file per node and returns dataframe with (io, statm, stat)
readOSmetrics <- function(nodename) {
  fn <- paste(bp, '/', nodename, '-ts.log', sep='')
  metrics <- {}
  if (file.exists(fn)) {
    isNewFile <- TRUE
    # add to read.csv?   stringsAsFactors=FALSE
    if (isNewFile) {
      metrics_csv <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=7, sep=" ")
    } else {
      metrics_csv <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=5, sep=" ")
    }
    mlen <- dim(metrics_csv)[1]
    colnames(metrics_csv)[1:2] <- c("time", "stats")
    metrics_csv <- cbind(nodename, metrics_csv[1:(mlen-2),])  # skip last 2 lines
    metrics_csv$stats <- as.factor(metrics_csv$stats)
    metrics_csv$time <- as.numeric(metrics_csv$time)

    metrics$io <- select(metrics_csv %>% filter(stats %in% c("io")), nodename : V9)
    colnames(metrics$io) <- c("nodename", "time", "stats", "rchar", "wchar", "syscr", "syscw", "readbytes", "writebytes", "cxwbytes")
    # convert columns from char to numeric
    metrics$io$rchar <- as.numeric(metrics$io$rchar)
    metrics$io$wchar <- as.numeric(metrics$io$wchar)
    metrics$io$syscr <- as.numeric(metrics$io$syscr)

    metrics$mstat <- select(metrics_csv %>% filter(stats %in% c("statm")), nodename : V9)
    colnames(metrics$mstat) <- c("nodename", "time", "stats", "size", "resident", "shared", "text", "lib", "data", "dt")
    # convert columns from char to numeric
    metrics$mstat$size <- as.numeric(metrics$mstat$size)
    metrics$mstat$resident <- as.numeric(metrics$mstat$resident)
    metrics$mstat$shared <- as.numeric(metrics$mstat$shared)
    #plot(metrics$statm$size)

    metrics$stat <- metrics_csv %>% filter(stats %in% c("stat"))
    colnames(metrics$stat) <- c("nodename", "time", "stats", "pid", "comm", "state", "ppid", "pgrp", "session", "tty", "tpgid", "flags", "minflt","cminflt","majflt","cmajflt", "utime", "stime", "cutime", "cstime", "priority", "nice", "nthr", "itrv", "starttime", "vsize", "rss", "rsslim", "startcode", "endcode", "startstack", "kstkesp", "kstkeip", "signal",
                                "blocked", "sigignore", "sigcatch", "wchan", "nswap", "cnswap", "exitsig", "processor", "rtprio", "policy", "delayio", "guesttime", "cguesttime", "startdata", "enddata", "startbrk", "argstart", "argend", "envstart", "envend", "exitcode")
    metrics$stat$pid <- as.factor(metrics$stat$pid)
    metrics$stat$comm <- as.factor(metrics$stat$comm)
    metrics$stat$state <- as.factor(metrics$stat$state)
    metrics$stat$ppid <- as.factor(metrics$stat$ppid)
    metrics$stat$pgrp <- as.factor(metrics$stat$pgrp)
    metrics$stat$session <- as.factor(metrics$stat$session)
    metrics$stat$tty <- as.factor(metrics$stat$tty)
    metrics$stat$tpgid <- as.factor(metrics$stat$tpgid)
    metrics$stat$priority <- as.factor(metrics$stat$priority)
    metrics$stat$starttime <- as.factor(metrics$stat$starttime)
    metrics$stat$policy <- as.factor(metrics$stat$policy)

    # kernel constants per node; read from log file once they are there
    if (isNewFile) {
      metrics_params <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=5, nrows=1, sep=" ")
      metrics_params <- strsplit(t(metrics_params), "=")
      for (q in metrics_params) {
        if (q[1] == "PAGESIZE") { metrics$pagesize[nodename] <- as.numeric(q[2]); }
        if (q[1] == "CLKTCK") { metrics$clktck[nodename] <- as.numeric(q[2]); }
      }
      if (is.na(metrics$pagesize[nodename])) {
        metrics$pagesize[nodename] <- recPageSize0;
      }
      if (is.na(metrics$clktck[nodename])) { metrics$clktck[nodename] <- recCpuTicks0; }
    } else {
      metrics$pagesize[nodename] <- recPageSize0
      #metrics$delay[nodename] <- recDelay0
      metrics$clktck[nodename] <- recCpuTicks0
    }

    # adjust
    recPageSize <- recPageSize0
    if (! is.null(metrics$pagesize[nodename])) { recPageSize <- metrics$pagesize[nodename] }
    recCpuTicks <- recCpuTicks0
    if (! is.null(metrics$clktck[nodename])) { recCpuTicks <- metrics$clktck[nodename] }
    metrics$stat$rss <- metrics$stat$rss * recPageSize
    metrics$stat$utime <- metrics$stat$utime / recCpuTicks * 100
    metrics$stat$stime <- metrics$stat$stime / recCpuTicks * 100
    #plot(metrics$stat$nthr)
    #plot(metrics$stat$vsize)
  }
  return(metrics)
}

# dashed vertical lines at the epoch boundaries
epochs <- function(d) {
    tmin <- min(d$t)
    tmin <- trunc(tmin / EPOCHLENGTH) * EPOCHLENGTH
    epochs <- data.frame(start=seq(from=tmin, to=max(d$t), by=EPOCHLENGTH))
    geom_vline(data=epochs,
               aes(xintercept = start, alpha=0.60)
             , colour='red'
             , linetype='dashed'
               )
    }

# dotted vertical lines every k slots
kslots <- function(d) {
  tmin <- min(d$t)
  tmin <- trunc(tmin / EPOCHLENGTH) * EPOCHLENGTH
  kslots <- data.frame(start=seq(from=tmin, to=max(d$t), by=k*SLOTLENGTH))
    geom_vline(data=kslots,
               aes(xintercept = start, alpha=0.60)
             , colour='red'
             , linetype='dotted'
               )
    }

# histograms the rate of sent and written transactions
histTxs <- function(d, run=RUN, desc=DESC) {
  dd <- d %>%
    filter(txType %in% c("submitted", "written"))
  maxtx <- max(dd$txCount)
  crit <- "submitted"
  dd <- d %>%
    filter(txType %in% c(crit)) %>%
    filter(txCount > 0)   ### only blocks with transactions

  hist(dd$txCount, main=paste('generated (>0)', desc, sep = ' ')
       , breaks=seq(0,maxtx, by=1)
       , col=gray.colors(maxtx/2)
       , xlab = "transactions/slot" )

  crit <- "written"
  dd <- d %>%
    filter(txType %in% c(crit)) %>%
    filter(txCount > 0)   ### only blocks with transactions

  hist(dd$txCount, main=paste('integrated in blocks (>0)', desc, sep = ' ')
       , breaks=seq(0,maxtx, by=1)
       , col=gray.colors(maxtx/2)
       , xlab = "transactions/slot" )
}

# plot the rate of sent and written transactions
plotTxs <- function(d, run=RUN, desc=DESC) {
    dd <- d %>%
        filter(txType %in% c("submitted", "written")) %>%
            filter(txCount > 0)   ### only blocks with transactions
    ggplot(dd, aes(t, txCount/slotDuration)) +
        epochs(d) + kslots(d) +
        geom_point(aes(colour=node)) +
        geom_smooth() +
        ggtitle(paste(
            'Transaction frequency for core and relay nodes, run at '
          , run, desc, sep = ' ')) +
        xlab("t [s] after start of experiment") +
        ylab("transaction rate [Hz]") +
        facet_grid(txType ~ run) +
        guides(size = "none", colour = "legend", alpha = "none")
    }

# plot the mempool residency for core and relay nodes
plotMempools <- function(d, str='core and relay', run=RUN, desc=DESC) {
    dd <- d %>%
        filter(txType %in% c("size after block"
                           , "size after rollback"
                           , "size after tx"))
    ggplot(dd, aes(t, txCount)) +
      epochs(d) +
      geom_point(aes(colour=node)) +
        ggtitle(paste(
            'Mempool sizes for', str, 'nodes, run at '
          , run, desc, sep = ' ')) +
        xlab("t [s] after start of experiment") +
        ylab("Mempool size [# of transactions]") +
        facet_grid(txType ~ isRelay, scales= "free", space = "free") +
        guides(size = "none", colour = "legend", alpha = "none")
}

# plot the wait and hold times for the local state lock
plotTimes <- function(d, str='core and relay', run=RUN, desc=DESC, lin=TRUE, minfilter = 0) {
    if (lin) {
      desc <- paste("\n(", desc, "linear scale,", "min =", minfilter, ")", sep=" ")
    } else {
      desc <- paste("\n(", desc, "log scale,", "min =", minfilter, ")", sep=" ")
    }
    dd <- d %>%
            filter(txType %in% c("hold tx"
                               , "wait tx"
                               , "hold block"
                               , "wait block"
                               , "hold rollback"
                               , "wait rollback"
                                 ))      %>% filter(txCount > minfilter)    ###  <<<<<<
    ggplot(dd, aes(t, txCount/1000)) +
      epochs(d) +
      geom_point(aes(colour=node)) +
#      geom_smooth() +
      ggtitle(paste(
            'Wait and work times for', str, 'nodes, run at '
          , run, desc, sep = ' ')) +
      xlab("t [s] after start of experiment") +
      ylab("Times waiting for/holding the lock [milliseconds]") +
      (if (lin) { scale_y_continuous(); } else { scale_y_log10(); }) +     ###  <<<<<<
      facet_grid(txType ~ isRelay) +
      guides(size = "none", colour = "legend", alpha = "none")
}

plotOverview <- function(d, report, run=RUN, desc=DESC) {
  def.par <- par(no.readonly = TRUE)
  layout(mat = matrix(c(1,1,1,1,2,3,4,4,5,5,6,6), 3, 4, byrow = TRUE), heights=c(2,3,4))

  textplot(paste("\nBenchmark of ", run), cex = 2, valign = "top")
  bp <- barplot(as.matrix(report[,2]), col=c("green", "blue", "red"))
  textplot(report, show.rownames = FALSE)
  textplot(params, show.rownames = FALSE)

  histTxs(data)

  par(def.par)
  #layout(matrix(c(1,1), 1, 1, byrow = TRUE))
}

plotDuration <- function(run=RUN, desc=DESC) {

  formatylabels <- function(x) { lab <- sprintf("%1.2f", x) }

  # 1
  t1 <- grid.text(paste("\nTransaction times ", run), draw = FALSE)
  # 2
  bxstats <- boxplot.stats(times$time)
  t2 <- grid.text(paste("median time", sprintf("%1.1f", bxstats$stats[3]), "seconds", sep=" "), draw = FALSE)
  # 3
  g1 <- ggplot(times, aes(x=time, y=cumm)) +
          geom_point(col="blue") +
          geom_vline(xintercept = bxstats$stats, col=c("grey","grey60","darkgreen","grey60","grey")) +
          xlab("time (s)") + ylab("") +
          scale_y_continuous(label=formatylabels)
  # 4
  g2 <- ggplot(times, aes(y=time, x=1)) +
          geom_boxplot(fill = "lightblue", outlier.color = "darkred", outlier.size = 3, outlier.shape = 6) +
          coord_flip() +
          xlab("") + ylab("") +
          scale_x_continuous(label=formatylabels) +
          theme(axis.text.y = element_text(color="white"), axis.ticks.y = element_blank())

  grid.arrange(t1, t2, g1, g2, ncol = 1, heights = c(1,0.5,4,1))
}

plotMessages <- function(d, run=RUN, desc=DESC) {
  messages_by_type <- aggregate(txCount ~ txType, data, sum)
  submitted_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("submitted")), sum)
  colnames(submitted_by_node) <- c("node", "submitted")
  written_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("written")), sum)  %>% filter(txCount > 0)
  core_nodes <- select(written_by_node %>% filter(txCount > 0), node)
  colnames(written_by_node) <- c("node", "written")
  colnames(core_nodes) <- c("core")
  rollbackwait_by_node <- {}
  try({
      rollbackwait_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("wait rollback")), sum)
      colnames(rollbackwait_by_node) <- c("node", "wait rollback") },
    TRUE
  )
  rollbacksize_by_node <- {}
  try({
      rollbacksize_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("size after rollback")), sum)
      colnames(rollbacksize_by_node) <- c("node", "size rollback") },
    TRUE
  )
  maxparam <- length(submitted_by_node[,2])
  summsg <- sum(submitted_by_node[,2])
  #submitted_by_node[maxparam+1,1] <- "sum"
  submitted_by_node[maxparam+1,2] <- summsg
  maxparam <- length(written_by_node[,2])
  summsg <- sum(written_by_node[,2])
  #written_by_node[maxparam+1,1] <- "sum"
  written_by_node[maxparam+1,2] <- summsg

  def.par <- par(no.readonly = TRUE)
  layout(mat = matrix(c(1,1,1,1,2,2,3,4,5,6,7,0), 3, 4, byrow = TRUE), heights=c(2,4,3))

  layout(matrix(c(1,1,1,2,3,4,5,6,7), 3, 3, byrow = TRUE))
  textplot(paste("\nMessage counts of ", run), cex = 2, valign = "top")

  defborder <- c(1,0,1,1)
  textplot(messages_by_type, show.rownames = FALSE, mar=defborder, cex=1, valign="top")
  textplot(submitted_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top")
  textplot(written_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top")

  if (! is.null(rollbackwait_by_node)) {
    textplot(rollbackwait_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top")
  }
  if (! is.null(rollbacksize_by_node)) {
    textplot(rollbacksize_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top")
  }
  #textplot(core_nodes, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top")

  par(def.par)
}

report <- readReport(fname2)
data <- readData(fname)

if (! INTERACTIVE) {
  png(filename=paste('overview-', RUN, '.png', sep=''))
  plotOverview(data, report)
  dev.off()
  p1 <- plotOverview(data, report)

  png(filename=paste('msgcount-', RUN, '.png', sep=''))
  plotMessages(data)
  dev.off()
  p2 <- plotMessages(data)

  p3 <- if (hasTrxTimes) {
    png(filename=paste('duration-', RUN, '.png', sep=''))
    plotDuration()
    dev.off()
    plotDuration()
  }

  p4 <- plotTxs(data)
  #ggsave(paste('txs-', RUN, '.svg', sep=''))
  ggsave(paste('txs-', RUN, '.png', sep=''))

  p5 <- plotMempools(data)
  #ggsave(paste('mempools-', RUN, '.svg', sep=''))
  ggsave(paste('mempools-', RUN, '.png', sep=''))

  p6 <- plotTimes(data, lin=FALSE)
  #ggsave(paste('times-', RUN, '.svg', sep=''))
  ggsave(paste('times-', RUN, '.png', sep=''))

  p7 <- plotTimes(data, lin=TRUE, minfilter=1e+03)
  #ggsave(paste('times-', RUN, '.svg', sep=''))
  ggsave(paste('times-', RUN, '-linear_scale.png', sep=''))

  #observe only core nodes:
  #plotMempools(data %>% filter(!(node %in% relays)), 'core')

  #observe only unprivileged relays:
  #plotMempools(data %>% filter(node %in% uRelays), 'unprivileged relay')

  #observe only privileged relays:
  #plotMempools(data %>% filter((node %in% relays) & (!(node %in% uRelays))), 'privileged relay')

  #plotTimes(data %>% filter(!(node %in% relays)), 'core')
  list(p1,p2,p3,p4,p5,p6,p7)
}

# plot the rate of sent and written transactions
plotOSMetrics <- function(d, run=RUN, labx="", laby="", desc=DESC) {
     ggplot(d, aes(x=(time), y=metrics)) +
        epochs(data) + kslots(data) +
        geom_point(colour = "blue", size=0.1) +
        ggtitle(paste(
            desc
          , run, sep = ' ')) +
        xlab(if (labx == "") {"t [s] since start of experiment"} else labx) +
        ylab(if (laby == "") {"[??]"} else laby) +
        facet_grid(node ~ category, scales = "fixed") +
        guides(size = "none", colour = "legend", alpha = "none") +
        scale_y_continuous(labels = scales::comma)
    }

# first block was written
#t1stBlock <- min(trunc(data$time/1000/1000))
#tlastBlock <- max(trunc(data$time/1000/1000))

prepareOSMetrics4nodes <- function (nodes, target, title) {
  # read in OS metrics from all core nodes
  osmetrics = {}
  for (n in nodes) {
      m <- readOSmetrics(n)
      osmetrics$io <- rbind(osmetrics$io, m$io)
      osmetrics$mstat <- rbind(osmetrics$mstat, m$mstat)
      osmetrics$stat <- rbind(osmetrics$stat, m$stat)
  }

  # we only run this if there are some ts data
  # older runs that lack them can still be analyzed
  if (! is.null(osmetrics$io)) {
    # skip first 20 datapoins (start up of process)
    tmin <- min(osmetrics$io$time)
    tmax <- max(osmetrics$io$time)
    tstartup <- 20
    osmetrics$io <- osmetrics$io %>% filter(time >= tmin + tstartup)
    osmetrics$mstat <- osmetrics$mstat %>% filter(time >= tmin + tstartup)
    osmetrics$stat <- osmetrics$stat %>% filter(time >= tmin + tstartup)

    # epoch start time, aligned to times in `data`
    t0 <- round(data$time[1] / 1e6) - data$t[1]

    osmetrics$io$time0 <- osmetrics$io$time
    osmetrics$mstat$time0 <- osmetrics$mstat$time
    osmetrics$stat$time0 <- osmetrics$stat$time
    osmetrics$io$time <- osmetrics$io$time - t0
    osmetrics$mstat$time <- osmetrics$mstat$time - t0
    osmetrics$stat$time <- osmetrics$stat$time - t0

    osmetrics$io <- osmetrics$io %>% filter(time >= 0)
    osmetrics$mstat <- osmetrics$mstat %>% filter(time >= 0)
    osmetrics$stat <- osmetrics$stat %>% filter(time >= 0)

  # prepare plot data (I/O)
    plotdata <- {}
    for (n in nodes) {
      # extract node's data and sort it by the 'time' column:
      d <- osmetrics$io %>% filter(nodename == n) %>% arrange_all(c(time))
      if (dim(d)[1] > 50) {
        print(c(dim(d), n))
        td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1]
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$rchar) / td), category='read'))
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$wchar) / td), category='written'))
      }
    }

    p1 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="bytes per s", desc=paste("I/O metrics", title, sep=" "))
    ggsave(paste('os-io-', target, "-", RUN, '.png', sep=''))

  # prepare plot data (CPU)
    plotdata <- {}
    for (n in nodes) {
      #recDelay <- recDelay0
      #if (! is.null(osmetrics$delay[n])) { recDelay <- osmetrics$delay[n] }
      # extract node's data and sort it by the 'time' column:
      d <- osmetrics$stat %>% filter(nodename == n) %>% arrange_all(c(time))
      if (dim(d)[1] > 50) {
        print(c(dim(d), n))
        td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1]
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$utime) / td), category='CPU (user time)'))
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$stime) / td), category='CPU (kernel time)'))
      }
    }

    p2 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="single CPU %", desc=paste("CPU metrics", title, sep=" "))
    ggsave(paste('os-cpu-', target, "-", RUN, '.png', sep=''))

  # prepare plot data (memory)
    plotdata <- {}
    for (n in nodes) {
      # extract node's data and sort it by the 'time' column:
      d <- osmetrics$stat %>% filter(nodename == n) %>% arrange_all(c(time))
      if (dim(d)[1] > 50) {
        print(c(dim(d), n))
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=(d$rss / 1024 / 1024), category='memory (RSS)'))
      }
    }

    p3 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="megabytes", desc=paste("Memory usage", title, sep=" "))
    ggsave(paste('os-mem-', target, "-", RUN, '.png', sep=''))

  # prepare plot data (read bytes / sys. calls, wbytes / sys. calls)
    plotdata <- {}
    for (n in nodes) {
      d <- osmetrics$io %>% filter(nodename == n) %>% arrange_all(c(time))
      if (dim(d)[1] > 50) {
        print(c(dim(d), n))
        td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1]
        tr <- append(0,diff(d$syscr) / td) #d$rchar / d$syscr
        tw <- append(0,diff(d$syscw) / td) #d$wchar / d$syscw
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=tr, category='read syscalls'))
        plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=tw, category='write syscalls'))
      }
    }

    p4 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="syscalls per second", desc=paste("I/O work", title, sep=" "))
    ggsave(paste('os-io-work-', target, "-", RUN, '.png', sep=''))

    list(p1,p2,p3,p4);
  }
}

prepareOSMetrics4nodes(coreNodes, "core", "for core nodes")

prepareOSMetrics4nodes(relays, "relays", "for relay nodes")

print("all done.")
dev.off()


#creates a facet plot of model error (vs observation) for 'Arable', 'Pasture', 'Nature' across years

rm(list=ls())

#required packages
library(tidyverse)
library(caret)   #for confusionMatrix
library(diffeR)  #for map comparison
library(gridExtra)  #for printing tables to pdf
library(grid)
library(sf)
library(RColorBrewer)  #for plotting
library(raster)
library(rasterVis)
library(animation)
library(viridisLite)
library(tidyselect)
library(viridis)

scenario <- "testing_demand_smoother3_2020-02-10c"
runID <- "0-0"
class4 <- F

cl <- "PastureB"  #classification for observed LU map
data_dir <- "C:/Users/k1076631/craftyworkspace/CRAFTY_TemplateCoBRA/output/Brazil/Unknown/"
#data_dir <- "C:/Users/k1076631/Google Drive/Shared/Crafty Telecoupling/CRAFTY_testing/CRAFTYOutput/Data/"
states <- c()  #all states
#states <- c(51) #MT

if(length(states) > 0){
  state_label = paste(c("_States", states), collapse = "-")
} else{ state_label = "_States-All" }

fig_yrs <- c(2005, 2010, 2015) #figures output for only these years

if(class4){
  SC_name <- paste0(data_dir,scenario,"/",runID,"/",scenario,state_label,"_CRAFTYmunisServCap_4class.csv")  #output file name for services and capitals
  LC_name <- paste0(data_dir,scenario,"/",runID,"/",scenario,state_label,"_CRAFTYmunisLC_4class.csv")  #output file name for land cover data
} else {
  SC_name <- paste0(data_dir,scenario,"/",runID,"/",scenario,state_label,"_CRAFTYmunisServCap.csv")  #output file name for services and capitals
  LC_name <- paste0(data_dir,scenario,"/",runID,"/",scenario,state_label,"_CRAFTYmunisLC.csv")  #output file name for land cover data
}

#Next, vector maps
#different approach - create figures first, then videos (as cannot save sf plot objects to a list)
cDat <- readr::read_csv(LC_name,
  col_types = cols(Year = col_integer(), diffcProp3 = col_double()))  #needed to ensure correct import (many zeros in diffcProp3 at top of file)
scDat <- readr::read_csv(SC_name,
  col_types = cols(meanMoisC = col_double(), meanNatureC = col_double(), meanInfraC = col_double(),meanLandPriceC = col_double(),meanSoyProteC = col_double(),meanGSeasonC = col_double()))  #needed to ensure correct import )

#note following shp was created using simplyfying_shapefiles.r
BRmunis <- st_read(paste0(data_dir,"Vector/BRmunis_sim10_simple2.shp"))

#join simulation data to shapefile
cDat_map <- left_join(BRmunis,cDat, by = c("CD_GEOCMUn" ="muniID"))

#filter to specified states (if needed)
if(!is.null(states)){
  cDat_map <- filter(cDat_map, State %in% states)
}

#create viridis (divergent) palette: ://stackoverflow.com/questions/37482977/what-is-a-good-palette-for-divergent-colors-in-r-or-can-viridis-and-magma-b
viridis <- viridis::viridis(11)
viridis_hcl <- colorspace::sequential_hcl(11,
  h = c(300, 75), c = c(35, 95), l = c(15, 90), power = c(0.8, 1.2))

yr_cDat <- cDat_map %>%
  filter(Year %in% fig_yrs) %>%
  dplyr::select(.,one_of(c("Year","diffcProp3","diffcProp5","diffcProp1"))) %>%
  rename("Arable" = "diffcProp3", "Pasture" = "diffcProp5", "Nature" = "diffcProp1") %>%
  gather(key = "LC", value = "prop", -geometry, -Year) %>%
  mutate(LC = factor(LC, levels=c("Arable", "Pasture", "Nature")))

muni_prop <- yr_cDat %>%
  ggplot(aes(fill = prop, color = prop)) +
  geom_sf() +
  theme(axis.text.x = element_text(size = 6),
    axis.text.y = element_text(size = 6)) +
  scale_fill_viridis() +
  scale_color_viridis() +
  labs(fill="Proportion", color="Proportion") +
  facet_grid(LC ~ Year)

if(class4){
  ggsave(paste0(data_dir,scenario,"/",runID,"/CalibrationMaps_miniprop_4class.png"), muni_prop, dpi="print")
} else {
  ggsave(paste0(data_dir,scenario,"/",runID,"/CalibrationMaps_miniprop.png"), muni_prop, dpi="print")
}


model_updatecalendar <- function (cumulTT = 741.510096671757,
         calendarMoments = c('Sowing'),
         calendarDates = c('2007/3/21'),
         calendarCumuls = c(0.0),
         currentdate = '2007/3/27',
         phase = 1.0){
    #'- Name: UpdateCalendar -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Calendar Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Lists containing for each stage the date it occurs as well as a copy of all types of cumulated thermal times
    #'- inputs:
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 741.510096671757
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: calendarMoments
    #'                          ** description : List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** default : ['Sowing']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarDates
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** default : ['2007/3/21']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarCumuls
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: currentdate
    #'                          ** description : current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DATE
    #'                          ** default : 2007/3/27
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: phase
    #'                          ** description :  the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: calendarMoments
    #'                          ** description :  List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** unit :
    #'            * name: calendarDates
    #'                          ** description :  List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** unit :
    #'            * name: calendarCumuls
    #'                          ** description :  list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit : °C d
    if (phase >= 1.0 && phase < 2.0 && !('Emergence' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Emergence')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 2.0 && phase < 3.0 && !('FloralInitiation' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'FloralInitiation')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 3.0 && phase < 4.0 && !('Heading' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Heading')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase == 4.0 && !('Anthesis' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Anthesis')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase == 4.5 && !('EndCellDivision' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'EndCellDivision')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 5.0 && phase < 6.0 && !('EndGrainFilling' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'EndGrainFilling')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 6.0 && phase < 7.0 && !('Maturity' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Maturity')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    return (list ("calendarMoments" = calendarMoments,"calendarDates" = calendarDates,"calendarCumuls" = calendarCumuls))
}


# S T A N D A R D   S H O C K   F O R M A T T I N G

# This code is very specific to drawing shock pictures.
# I apologize for the spaghettiness and redundancy of this code;
#  it evolved over a looong period of time and optimizing it
#  did not seem a good use of my time.  Works; don't fix it.
#
# Requires that the following constants be defined by the caller:
#
# nServerDefaultLife  server default half-life in years.  (Recall that this
#                      must be nonzero for all shock scenarios.)
# nShockspan          span of shocks when they occur: 0,1,2,3,4.
# nShockImpactMin     minimum percent value of shock impact for this picture;
#                      the interval is closed (inclusive) at both ends.
# nShockImpactMax     maximum percent value of shock impact.
#                      (To consider only fatal shocks, e.g., set both min
#                      and max to 100.)
# nSegments           number of audit segments per year: 1,2,4,10,50.
#                      (Audit cycles are always annual.)
#

sPlotFile <- (  sprintf("shockspan%d",nShockspan)
            %+% sprintf("server%d",nServerDefaultLife)
            %+% sprintf("seg%d",nSegments)
            %+% ".png"
            )
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , serverdefaultlife
                                    , shockfreq, shockspan, shockimpact
                                    , auditfrequency, auditsegments
                                    , simlength
                                    )}
fnSubset <- function(dfIn)  {subset(dfIn,
                                      serverdefaultlife==nServerDefaultLife * 10000
                                    & shockspan==nShockspan
                                    & shockimpact>=nShockImpactMin
                                    & shockimpact<=nShockImpactMax
                                    & copies>=5
                                    & auditfrequency==10000
                                    & auditsegments==nSegments
                                    )}
want.varnames <- c("copies","lifem","lost","docstotal","serverdefaultlife"
                ,"shockfreq","shockimpact","shockspan","shockmaxlife"
                ,"auditfrequency","audittype","auditsegments"
                ,"deadserversactive","deadserversall","simlength")
fnNarrow <- function(dfIn)  {dfIn[want.varnames]}

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
allnewdat <- alldat.df %>% fnNarrow() %>% fnGroupBy() %>%
summarize(losspct=round(mean(lost/docstotal)*100.0, 2), n=n())
newdat <- fnSubset(allnewdat)
trows <- newdat
# ************ Also may need to change summarize function and ggplot(color=...).
# E N D   O F   S T A N D A R D   S H O C K   F O R M A T T I N G


library(vegan)
library(MASS)
library(ggplot2)
library(plyr)
library(dplyr)
library(magrittr)
library(scales)
library(grid)
library(reshape2)
library(phyloseq)
library(randomForest)
library(knitr)
library(ape)
library(ggpubr)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom <-import_biom ( "C:\\Users\\Joe Receveur\\Documents\\Virtual Box\\BeninMozzie2018\\BMoz2018.biom", parseFunction = parse_taxonomy_greengenes)
biom
meta=sample_data(read.table("C:\\Users\\Joe Receveur\\Documents\\Virtual Box\\BeninMozzie2018\\Bmozmetadata1.27.18.txt",header=TRUE))
sample_names(meta)=meta$SampleID

physeq=merge_phyloseq(meta,biom)
physeq

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPrPhylum=tax_glom(GPr, "Phylum")
PhylumLevel = filter_taxa(GPrPhylum, function(x) mean(x) > 1e-3, TRUE) #filter out any taxa lower tha 0.1%
GPrFamily=tax_glom(GPr,"Family")
FamilyLevel = filter_taxa(GPrFamily, function(x) mean(x) > 1e-2, TRUE) #filter out any taxa lower tha 1%
GPrGenus=tax_glom(GPr,"Genus")
GenusLevel = filter_taxa(GPrGenus, function(x) mean(x) > 1e-2, TRUE) #filter out any taxa lower tha 1%

df <- psmelt(PhylumLevel)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Phylum", "Strain"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)

p <- ggbarplot(df, x = "Strain", y = "Abundance",add = c("mean_se"),#"mean_se"
               color = "black", palette = "cbPalette", facet.by="Phylum",
               line.color = "gray", line.size = 0.4, short.panel.labs = TRUE, p.adjust.method = "fdr", fill= "Strain") + stat_compare_means(aes(group = Strain), label = "..p.signif..",label.y = 7)

p+ theme(axis.text.x = element_text(angle = 45, hjust = 1))+ylab("Relative abundance (> 0.1%)")+ theme(legend.position="none")

Means=compare_means(Abundance ~ Strain, data = df,
                    group.by = "Phylum", p.adjust.method = "fdr")
#head(Means)
keeps <- c("Phylum","group1","group2","p.format","p.adj","method","p.signif")
keeps=Means[keeps]
#keeps

test3 <- list('Phylum'= keeps$Phylum,'group1'=keeps$group1,'group2'= keeps$group2 ,'p'=keeps$p.format,'p.adj'=keeps$p.adj,p.signif=keeps$p.signif,'Method'=keeps$method)
test3= as.data.frame(test3)
#test3
FilteredResults<-test3[!(test3$p.adj>0.1),]
FilteredResults

df <- psmelt(FamilyLevel)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Family", "Strain"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)

p <- ggbarplot(df, x = "Strain", y = "Abundance",add = c("mean_se"),#"mean_se"
               color = "black", palette = "cbPalette", facet.by="Family",
               line.color = "gray", line.size = 0.4, short.panel.labs = TRUE, p.adjust.method = "bonferroni", fill= "Strain") + stat_compare_means(aes(group = Strain), label = "..p.signif..",label.y = 7)

p+ theme(axis.text.x = element_text(angle = 45, hjust = 1))+ylab("Relative abundance (> 1%)")+ theme(legend.position="none")

Means=compare_means(Abundance ~ Strain, data = df,
                    group.by = "Family", p.adjust.method = "fdr")
#head(Means)
keeps <- c("Family","group1","group2","p.format","p.adj","method","p.signif")
keeps=Means[keeps]
#keeps

test3 <- list('Family'= keeps$Family,'group1'=keeps$group1,'group2'= keeps$group2 ,'p'=keeps$p.format,'p.adj'=keeps$p.adj,p.signif=keeps$p.signif,'Method'=keeps$method)
test3= as.data.frame(test3)
#test3
FilteredResults<-test3[!(test3$p.adj>0.1),]
FilteredResults

ord=ordinate(physeq,"PCoA", "jaccard")
ordplot=plot_ordination(physeq, ord,"samples", color="Strain")#+geom_point(size=4)+scale_colour_manual(values=cbPalette)+scale_fill_manual(values=cbPalette)
ordplot+ stat_ellipse(type= "norm",geom = "polygon", alpha = 1/4, aes(fill = Strain))+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())#+ theme(legend.justification=c(1,0), legend.position=c(1,0))

GPdist=phyloseq::distance(physeq, "jaccard")
MONMDS= ordinate(physeq, "NMDS",GPdist)

adonis(GPdist ~ Strain, as(sample_data(physeq), "data.frame"))

ForestData=physeq#Change this one so you dont have to rewrite all variables
predictors=t(otu_table(ForestData))
dim(predictors)
response <- as.factor(sample_data(ForestData)$Strain)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
imp <- data.frame(predictors = rownames(imp), imp)
imp.sort <- arrange(imp, desc(MeanDecreaseGini))
imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.20 <- imp.sort[1:20, ]
ggplot(imp.20, aes(x = predictors, y = MeanDecreaseGini)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +
  ggtitle("Most important OTUs for classifying  samples\n by Strain")#\n in a string tells it to start a new line
imp.20$MeanDecreaseGini
otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification


# remember first to remove data.path and rm statement from init.R

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

# log-normal size, log-normal noise
data.path<-file.path(root,"NS_4_7_MAC_logn_logn")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# log-normal size, log-normal noise, nBar
data.path<-file.path(root,"NS_4_7_MAC_logn_logn_nBar")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# log-normal size, Dirichlet noise
data.path<-file.path(root,"NS_4_7_MAC_logn_diri")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

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

# no size, log-normal noise
data.path<-file.path(root,"NS_4_7_MAC_noSize_logn")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# no size, log-normal noise, nBar
data.path<-file.path(root,"NS_4_7_MAC_noSize_logn_nbar")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# no size, Dirichlet noise
data.path<-file.path(root,"NS_4_7_MAC_noSize_diri")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

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

# beta5 (unconstraint parameters) size, log-normal noise
data.path<-file.path(root,"NS_4_7_MAC_beta5_logn")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# beta6 (unimodal) size, log-normal noise
data.path<-file.path(root,"NS_4_7_MAC_beta6_logn")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# beta5 (unconstraint parameters) size, Dirichlet noise
data.path<-file.path(root,"NS_4_7_MAC_beta5_diri")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

# beta6 (unimodal) size, Dirichlet noise
data.path<-file.path(root,"NS_4_7_MAC_beta6_diri")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

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

# gamma size, log-normal noise
data.path<-file.path(root,"NS_4_7_MAC_gamma_logn")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

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

data.path<-file.path(root,"Baltic_logn_Diri_77-86")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

data.path<-file.path(root,"Baltic_logn_Diri_87-94")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

data.path<-file.path(root,"Baltic_logn_Diri_81-83")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

data.path<-file.path(root,"Baltic_logn_Diri_91-93")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

data.path<-file.path(root,"Baltic_logn_logn_77-86")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))

data.path<-file.path(root,"Baltic_logn_logn_87-94")
source(file.path(prog.path,"Init.R"))
source(file.path(prog.path,"do_a_full_sms_run.R"))


# Multiple run script

################################
######## multiple run ##########
################################

require( raster )
require( dplyr )
require( tidyr )

# Local location of indus ix model - MAKE SURE TO ADD TO SYSTEM ENVIRONMENT VARIABLES
indus_ix_path = Sys.getenv("INDUS_IX_PATH")

## data source ##
# I is possible to run the Github version of NEST without access to IIASA databases
# the data for the Indus Basin model SSP2 and RCP6.0 default assumptions
# is available in .RData format in 'Data_NESTv2.1_Indus_SSP2_RCP6.RData'
# to use this data set default_data=T ,
# to load data from IIASA internal database set default_data=F
default_data = T

# Scenario names
scens = c( 	'baseline0',
			'baseline',
			'no_planned_hydro',
			'baseline_coop',
			'no_hydro_EMI_res',
			'SDG6') # no flood in HIST_AGRICULTURE

# Data frame containing the various settings for each scenario
policy_settings.df = data.frame( scen_name = scens , stringsAsFactors = F ) %>%
    mutate( SSP = rep('SSP2', length(scens) ),
			climate_model = rep('ensemble', length(scens) ),
			climate_scenario = rep('rcp60', length(scens) ),
			REDUCE_RUNOFF = rep( F, length(scens) ),
			IND_TREAT =         c( T, T, T, F, T ,T ),
			ENV_FLOWS =        	c( F, F, F, F, F ,F ),
			SDG6 =             	c( F, F, F, F, F ,T ),            # SDG6
			EMISS =            	c( F, F, F, F, T ,F ),          # GhG Emission
			SDG7 =             	c( F, F, F, F, F ,F ),        # SDG7: solar/wind targets + phase out of oc
			GROUNDWAT =        	c( F, T, T, T, T ,T ),       # groundwater extraction bounds
			CONSTRAINT_LAND =  	c( F, F, F, F, F ,F ),      # constraint available land, anyhow
			CHANGE_FOOD_DEMAND =c( F, F, F, F, F ,F ),     # change food demaind, customize the multiplication factor in policy script
			FIX_ELEC_IMPORT =  	c( F, T, T, T, T ,T ),
		  SMART_IRR_WATER =  	c( F, F, F, F, F ,F ),
		  RAINFED_LAND   =   	c( T, T, T, T, T ,T ),
		  NOT_PLANNED_HYDRO =	c( F, F, T, F, T ,F ),
		  FULL_COOPERATION = 	c( F, F, F, T, F ,F ),
			HIST_AGRICULTURE =  c( T, T, T, T, T ,T )
  ) %>%
  gather(key,value,2:length(.))

## Run single scenario: two ways ##
# uncomment and write the name of the specific scenario
# policy_settings.df = policy_settings.df %>% filter(scen_name %in% c('baseline') )

# uncomment and write the number of the specific scenario in scens
# sc = (unique(policy_settings.df$scen_name ))[1]

## Run multiple scenarios in a row ##
for( sc in (unique(policy_settings.df$scen_name )) ){

	rm(list=setdiff(ls(), c("policy_settings.df",'sc','indus_ix_path','default_data') ) )

	# assign
	for( nnn in ( policy_settings.df$key ) ){

		if ( !is.na( as.logical( policy_settings.df %>% filter(scen_name == sc, key == nnn) %>% dplyr::select( value ) ) ) ){

			assign( nnn, as.logical((policy_settings.df %>% filter(scen_name == sc, key == nnn))$value ) )

			}else{

			assign( nnn, as.character((policy_settings.df %>% filter(scen_name == sc, key == nnn))$value ) )

			}

		}

	# to be saved in the data gdx name
	policy_option = paste0(	'_EF.',substr(ENV_FLOWS, 1,1),'_IT.',substr(IND_TREAT, 1,1),'_EM.',substr(EMISS, 1,1),
							'_S6.',substr(SDG6, 1,1),'_S7.',substr(SDG7, 1,1))
	baseline = 'baseline'
	baseline0 = 'baseline0'
	data_gdx = paste0(sc,policy_option)
	shiny_mode = F
	Beta_water = 1
	source( paste( indus_ix_path, 'basin_msggdx.r', sep = '/' ) )

	}

#### Another set of scenario, same procedure as before
# multiple sustainable objective
scens = c( 'multiple_objective',
           'multiple_obj_coop',
           'baseline_glacier',
           'multi_obj_glacier',
           'baseline_extreme',
           'multi_obj_extreme_new',
           'baseline_coop_extreme',
           'multi_obj_coop_extreme')

# Data frame containing the various settings for each scenario
policy_settings.df = data.frame( scen_name = scens , stringsAsFactors = F ) %>%
  mutate( SSP = rep('SSP2', length(scens) ),
          climate_model = rep('ensemble', length(scens) ),
          climate_scenario = rep('rcp60', length(scens) ),
          REDUCE_RUNOFF =     c( F, F , T, T, F, F, F, F),
          IND_TREAT =         c( T, F , T, T, T, T, F, F),
          ENV_FLOWS =        	c( T, T , F, T, F, T, F, T),
          SDG6 =             	c( T, T , F, T, F, T, F, T),            # SDG6
          EMISS =            	c( T, T , F, T, F, T, F, T),          # GhG Emission
          SDG7 =             	c( T, T , F, T, F, T, F, T),        # SDG7: solar/wind targets + phase out of oc
          GROUNDWAT =        	c( T, T , T, T, T, T, T, T),       # groundwater extraction bounds
          CONSTRAINT_LAND = 	c( F, F , F, F, F, F, F, F),       # constraint available land, anyhow
          CHANGE_FOOD_DEMAND =c( F, F , F, F, F ,F, F, F ),  # change food demaind, customize the multiplication factor in policy script
          FIX_ELEC_IMPORT =  	c( T, T , T, T, T, T, T, T),
          SMART_IRR_WATER =  	c( T, T , F, T, F, T, F, T),
          RAINFED_LAND   =   	c( T, T , T, T, T, T, T, T),
          NOT_PLANNED_HYDRO =	c( F, F , F, F, F, F, F, F),
          FULL_COOPERATION = 	c( F, T , F, F, F, F, T, T),
          HIST_AGRICULTURE =  c( F, F , T, F, T, F, T, F)
  ) %>%
  gather(key,value,2:length(.))

## Run multiple scenarios in a row ##
for( sc in (unique(policy_settings.df$scen_name )) ){

  rm(list=setdiff(ls(), c("policy_settings.df",'sc','indus_ix_path','default_data') ) )

  # assign
  for( nnn in ( policy_settings.df$key ) ){

    if ( !is.na( as.logical( policy_settings.df %>% filter(scen_name == sc, key == nnn) %>% dplyr::select( value ) ) ) ){

      assign( nnn, as.logical((policy_settings.df %>% filter(scen_name == sc, key == nnn))$value ) )

    }else{

      assign( nnn, as.character((policy_settings.df %>% filter(scen_name == sc, key == nnn))$value ) )

    }

  }

  # to be saved in the data gdx name
  policy_option = paste0(	'_EF.',substr(ENV_FLOWS, 1,1),'_IT.',substr(IND_TREAT, 1,1),'_EM.',substr(EMISS, 1,1),
                          '_S6.',substr(SDG6, 1,1),'_S7.',substr(SDG7, 1,1))
  baseline = 'multiple_objective'
  baseline0 = 'baseline0'
  data_gdx = paste0(sc,policy_option)
  shiny_mode = F
  Beta_water = 1
  source( paste( indus_ix_path, 'basin_msggdx.r', sep = '/' ) )

}


library(shiny)
library(magrittr)
library(dplyr)
library(tidyr)
library(ggplot2)
library(RColorBrewer)
library(cowplot)
library(igraph)
library(pals)
library(UpSetR)
library(tidyselect)

options(stringsAsFactors = FALSE)

# RELEVANT DATA ====
test<-read.csv("data/for_NB.csv")
sample_list<-readRDS(file="data/final_sample_summary.rds")
clone_mutations<-readRDS(file="data/clone_mutations.rds")
sample_mutations <-readRDS(file="data/sample_mutations_with_pheno.rds")

#Sample Clonality Customization
test$Final_group<- factor(test$Final_group,levels=c("CH","MPN","Signaling","DTAI","DTAI-RAS","DTAI-FLT3","DTAI-FLT3-RAS"))

##plotting functions

# Number of clones
gg_number_of_mutations<- function(selected_group) {ggplot(test%>%group_by(.data[[all_of(selected_group)]])%>%
                                                            summarise(mean=mean(Number_of_mutations),
                                                                      sd = sd(Number_of_mutations),
                                                                      sem = sd(Number_of_mutations)/
                                                                        sqrt(length(Number_of_mutations))),
                                                          aes(x=get(all_of(selected_group)),y=mean,fill=get(all_of(selected_group))))+
    geom_bar(stat="identity",color="black")+
    geom_errorbar(aes(ymin = mean-sem, ymax = mean+sem),width=0.5,lwd=0.5)+
    theme_classic(base_size = 16)+
    ylab("Number of mutations")+xlab("")+ggtitle("")+
    scale_y_continuous(limits = c(0,9), expand = c(0, 0)) +
    theme(axis.text.x = element_text(angle=30,hjust=1)) +
    scale_fill_brewer(type="seq",palette = "Reds",aesthetics = "fill",guide=FALSE)
}

# Number of clones
gg_number_of_clones<- function(selected_group) {ggplot(test,aes(y=Number_of_clones,x=get(selected_group),fill=get(selected_group)))+
    geom_boxplot(outlier.shape = NA)+
    geom_jitter(width = 0.1,size=0.5)+
    theme_classic(base_size = 16)+
    ylab("Number of clones")+
    xlab("")+
    theme(axis.text.x = element_text(angle=30,hjust=1)) +
    scale_fill_brewer(type="seq",palette = "Reds",aesthetics = "fill",guide=FALSE)
}

# Shannon diversity index
gg_shannon<- function(selected_group) {ggplot(test,aes(y=Shannon,x=get(selected_group),fill=get(selected_group)))+
    geom_boxplot(outlier.shape = NA)+
    geom_jitter(width = 0.1,size=0.5)+
    theme_classic(base_size = 16)+
    ylab("Shannon diveristy index")+
    xlab("")+
    theme(axis.text.x = element_text(angle=30,hjust=1)) +
    scale_fill_brewer(type="seq",palette = "Reds",aesthetics = "fill",guide=FALSE)
}

# Number of mutations in each cohort
gg_Number_of_mutations_in_Dclone<- function(selected_group) {ggplot(test%>%group_by(.data[[selected_group]])%>%
                                                                      summarise(mean=mean(Number_of_mutations_in_dominant_clone),
                                                                                sd = sd(Number_of_mutations_in_dominant_clone),
                                                                                sem = sd(Number_of_mutations_in_dominant_clone)/
                                                                                sqrt(length(Number_of_mutations_in_dominant_clone))),
                                                                    aes(x=get(selected_group),y=mean,fill=get(selected_group)))+
    geom_bar(stat="identity",color="black")+
    geom_errorbar(aes(ymin = mean-sem, ymax = mean+sem),width=0.5,lwd=0.5)+
    theme_classic(base_size = 16)+
    ylab("Number of mutations \n in dominant clone")+xlab("")+ggtitle("")+
    scale_y_continuous(limits = c(0,4.5), expand = c(0, 0)) +
    theme(axis.text.x = element_text(angle=30,hjust=1)) +
    scale_fill_brewer(type="seq",palette = "Reds",
                      aesthetics = "fill",guide=FALSE)
}

# Dominant clone size
gg_dominant_clone_size_function <- function(selected_group){
  gg_dominant_clone_size<-ggplot(test,
                                 aes(y=Dominant_clone_size,x=get(selected_group),fill=get(selected_group)))+
    geom_boxplot(outlier.shape = NA)+
    geom_jitter(width = 0.1,size=0.5)+
    theme_classic(base_size = 16)+
    ylab("Fraction of sample \n in dominant clone")+
    xlab("")+
    theme(axis.text.x = element_text(angle=30,hjust=1)) +
    scale_fill_brewer(type="seq",palette = "Reds",aesthetics = "fill",guide=FALSE)
  return(gg_dominant_clone_size)
}

# Generate clonal abundance barplot
gg_clonograph <- function(sample) {
  # Extract out the sample of interest
  clonal_abundance <-sample_list[[sample]]$Clones
  clonal_architecture <-sample_list[[sample]]$Architecture

  # Ensure the order of the clone abundance and clone architecture are the same.
  clonal_architecture$Clone <- factor(clonal_architecture$Clone, levels=rev(clonal_abundance$Clone))
  clonal_abundance$Clone <- factor(clonal_abundance$Clone, levels=levels(clonal_architecture$Clone))

  gg_clonal_barplot<-ggplot(data=clonal_abundance, aes(x=Clone, y=Count,fill=Count)) +
    geom_col()+
    ggtitle(sample)+
    theme_classic(base_size=12)+
    scale_y_continuous(expand=c(0.01,0))+
    #ylim() +
    ylab("Cell Count")+
    geom_errorbar(aes(ymin = LCI, ymax = UCI), width = 0.2)+
    scale_fill_distiller(name = "Value", palette = "Reds", direction = 1) +
    theme(axis.title.x = element_blank(),
          axis.text.x = element_blank(),
          axis.ticks.x = element_blank(),
          axis.line.x =element_blank(),
          legend.position = "none",
          plot.title = element_text(hjust=0.5,size=16),
          plot.margin=unit(c(0,0,0,0),"cm"))

  gg_heatmap<-ggplot(data=clonal_architecture,
                     aes(x=Clone, y=Mutant, fill=Genotype))+
    geom_tile() +
    scale_fill_manual(values=c("WT"=brewer.pal(7,"Reds")[1],
                               "Heterozygous"=brewer.pal(7,"Reds")[3],
                               "Homozygous"=brewer.pal(7,"Reds")[6],
                               "Unknown"="grey50"),name="Genotype")+
    theme_classic(base_size=12) +
    ylab("Mutation")+
    scale_y_discrete(limits = rev(levels(clonal_architecture$Mutant)))+
    theme(legend.position = "right", legend.direction = "vertical",
          axis.text.x = element_blank(),
          axis.line=element_blank(),
          axis.title.x=element_blank(),
          axis.ticks.x = element_blank(),
          plot.margin=unit(c(0,0,0,0),"cm"))

  return(plot_grid(gg_clonal_barplot,gg_heatmap,ncol=1,align="v",axis="lr",rel_heights=c(1,0.75)))
}

# select which samples are mutated for all of the listed genes
gene_sample_selection <- function(genes){
  sample_set<- sample_mutations%>%
    select(Sample,all_of(unlist(genes)))%>%
    filter_at(vars(!Sample),all_vars(.==1)) %>%
    pull(Sample)
}

# Generate clonograph multiplot
gg_clonograph_multiplot<-function(sample){

  if(all(unlist(sample)%in%colnames(sample_mutations)[c(2:27,30)])){
    sample_set<- gene_sample_selection(gene=sample)
    graphs <- lapply(sample_set,gg_clonograph)
    grobs  <- lapply(graphs,as_grob)
    return(plot_grid(plotlist = grobs,ncol=2,align="v",axis="lr"))
  } else {
    graphs <- lapply(sample,gg_clonograph)
    grobs <- lapply(graphs,as_grob)
    return(plot_grid(plotlist = grobs,ncol=2,align="v",axis="lr"))
  }
}

# NETWORK GRAPH ====
network_graph<-function(genes_of_interest,disease,multi_mutant_only){
  # Subset data.frame above to only the dominant clones
  dominant_clone_mutations <- clone_mutations%>%filter(Clonality=="Dominant")

  # For each sample, determine if the dominant clone
  sample_mutations$Match<-ifelse(sapply(sample_mutations$Sample,function(sample) {
    all(sample_mutations%>%
          filter(Sample==sample)%>%
          select(all_of(genes_of_interest))==
          dominant_clone_mutations%>%
          filter(Sample==sample)%>%
          select(all_of(genes_of_interest)))
  }) ,"Match","Absent")

  # identify sample with at least 2 DTAI mutationss
  multi_mutant<-sample_mutations%>%
    filter(grepl(`disease`,Dx))%>%
    mutate(mutations = rowSums(select(., all_of(genes_of_interest))))%>%
    filter(mutations>=2)%>%
    distinct(Sample)%>%pull(Sample)

  if(length(multi_mutant)<2){
    return(print("No patients Identified"))
  }
  # Identify dominant clones
  dominant_clones_of_interest<-clone_mutations%>%filter(Sample%in%multi_mutant)%>%
    filter(Clonality=="Dominant")%>%
    select(Clone,Clone_size,Sample,all_of(genes_of_interest))%>%
    pivot_longer(cols=all_of(genes_of_interest),
                 names_to="Gene",values_to="Mutated")%>%
    filter(Mutated==1)

  # Now we want to know which variants are in the dominant clone, and the size of that clone.
  # I'm sure there is a nice way to do this in dplyr, grouping on sample, but I couldn't figure it out
  # so we will use lapply.
  genes_in_each_dominant_clone<- do.call(rbind,setNames(lapply(multi_mutant,function(x){
    # Extract the genes
    dominant_variants<- dominant_clones_of_interest%>%filter(Sample==x)%>%pull(Gene)

    # Extract the clone size
    dominant_clone_size<- dominant_clones_of_interest%>%filter(Sample==x)%>%pull(Clone_size)

    # if there are more than two DTAI variants in the dominant clone make a combinatorial edgelist
    if(length(dominant_variants)>=2){
      return(setNames(data.frame(t(combn(dominant_variants,2)),dominant_clone_size[1],"Dominant"),c("to","from","size","Clonality")))}
    # if there is only 1 mutant in the dominant clone, list it for now so we can count the mutation,
    # but we will eventually filter it out
    else if(length(dominant_variants)==1){
      return(setNames(data.frame(t(c(dominant_variants,dominant_variants)),dominant_clone_size,"Subclone"),c("to","from","size","Clonality")))}
    # if no DTAI mutants in the dominant clone, ignore.
    else if(length(dominant_variants)==0){
      NULL
    }
  }),multi_mutant))%>%distinct()

  # Now we will go for a similar process with subclones.
  sub_clones_of_interest<-clone_mutations%>%filter(Sample%in%multi_mutant)%>%
    filter(Clonality!="Dominant")%>%
    select(Clone,Clone_size,Sample,all_of(genes_of_interest))%>%
    pivot_longer(cols=all_of(genes_of_interest),
                 names_to="Gene",values_to="Mutated")%>%
    filter(Mutated==1)%>%
    # This is how we specifically select multi mutant subclone
    group_by(Clone,Sample)%>%
    add_tally()%>%filter(n>1)%>%
    ungroup()

  # Same process as above, but note that we decided to only plot the largest multi mutant clone.
  # Try getting rid of this and seeing how it looks.
  genes_in_each_subclone <- do.call(rbind,setNames(lapply(multi_mutant,function(x){
    subclone_variants <- sub_clones_of_interest%>%filter(Sample==x)%>%
      filter(Clone_size==max(Clone_size))%>%
      pull(Gene)
    subclone_size <- sub_clones_of_interest%>%filter(Sample==x)%>%
      filter(Clone_size==max(Clone_size))%>%
      pull(Clone_size)

    if(length(subclone_variants)>=2){
      return(setNames(data.frame(t(combn(rev(subclone_variants),2)),subclone_size[1],"Subclone"),c("to","from","size","Clonality")))}
    else if(length(subclone_variants)==1){
      return(setNames(data.frame(t(c(subclone_variants,subclone_variants)),subclone_size[1],"Subclone"),c("to","from","size","Clonality")))}
    else if(length(subclone_variants)==0){
      NULL
    }
  }),multi_mutant))%>%distinct()

  # Now bind these two dataframe together
  final_set<- rbind(genes_in_each_dominant_clone,genes_in_each_subclone)

  # And remove the edges that are self referencing. We preserve the input variable so we can represent
  # the vertex size in relation to total mutation burden in this subset of patients.
  final_set_filtered <-final_set%>%filter(to!=from)

  graph<-graph_from_data_frame(final_set_filtered,directed=F)%>%
    set_edge_attr("weight", value = as.numeric(final_set_filtered%>%pull(size))*3) %>%
    set_edge_attr("color", value = ifelse(final_set_filtered%>%
                                            pull(Clonality)=="Dominant",
                                          alpha(brewer.pal(5,"Reds")[5],0.5),
                                          alpha("grey20",0.5)))

  mutant_counts<-table(c(as.character(final_set$to),as.character(final_set$from)))[names(V(graph))]
  scaled_mutant_counts <-mutant_counts/sum(mutant_counts)*50

  radian.rescale <- function(x, start=0, direction=1) {
    c.rotate <- function(x) (x + start) %% (2 * pi) * direction
    c.rotate(scales::rescale(x, c(0, 2 * pi), range(x)))
  }

  lab.locs <- radian.rescale(x=1:length(genes_of_interest), direction=-1, start=length(genes_of_interest))
  #lab.locs[1]<- 0

  plot.igraph(graph,
              edge.width = E(graph)$weight*2,
              vertex.color=kelly(n=2+length(genes_of_interest))[-c(1:2)],#brewer.pal(5,"Reds")[5],
              vertex.frame.color="black",
              vertex.size=scaled_mutant_counts[names(V(graph))]*1.5,
              vertex.label.family="Arial",
              vertex.label.font=2,
              vertex.label.cex=2,
              vertex.label.color="black",
              vertex.label.dist=rep(3,length(genes_of_interest)),
              layout=layout_with_graphopt)
  legend(x=-2,y=1.5,legend=names(V(graph)),
         col=kelly(n=2+length(names(V(graph))))[-c(1:2)],
         bty = "n", pch=20 ,
         pt.cex = 5,
         cex =1.4,
         text.font=12,
         text.col=kelly(n=2+length(names(V(graph))))[-c(1:2)],
         horiz = FALSE,
         ncol=1)
}


library(ggplot2)
theme_set(theme_bw(18))
setwd("~/Dropbox/sinking_marbles/sinking-marbles/models/varied_alternatives/results/")
source("rscripts/helpers.r")

load("data/mp.RData")

mp = read.table("data/parsed_results.tsv", quote="", sep="\t", header=T)
nrow(mp)

summary(mp)
mp$Proportion = mp$NumState / mp$TotalMarbles
summary(mp)
mp$OptTotal = as.factor(paste(mp$SpeakerOptimality,mp$TotalMarbles))
mp$QUDTotal = as.factor(paste(mp$QUD,mp$TotalMarbles))
save(mp, file="data/mp.RData")

isall = subset(mp, QUD=="is-all")
ggplot(isall, aes(x=Proportion,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_grid(Alternatives~PriorAllProbability)
  ggsave("graphs/byproportion-qud-all.pdf",width=25,height=25)

howmany = subset(mp, QUD=="how-many")
ggplot(howmany, aes(x=Proportion,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_grid(Alternatives~PriorAllProbability)
ggsave("graphs/byproportion-qud-howmany.pdf",width=25,height=25)

ggplot(isall, aes(x=PriorAllProbability,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_grid(Alternatives~Proportion)
ggsave("graphs/byprior-qud-isall.pdf",width=40,height=15)

ggplot(howmany, aes(x=PriorAllProbability,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_grid(Alternatives~Proportion)
ggsave("graphs/byprior-qud-howmany.pdf",width=40,height=15)

allisall = subset(mp, Proportion == 1 & QUD == "is-all")
ggplot(allisall, aes(x=PriorAllProbability,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Alternatives)
ggsave("graphs/allprobability-qud-isall.pdf",width=12)

allhowmany = subset(mp, Proportion == 1 & QUD == "how-many")
ggplot(allhowmany, aes(x=PriorAllProbability,y=PosteriorProbability,shape=as.factor(SpeakerOptimality),color=as.factor(TotalMarbles),group=OptTotal)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Alternatives)
ggsave("graphs/allprobability-qud-howmany.pdf",width=12)

all = subset(mp, Proportion == 1 & SpeakerOptimality == 1)
ggplot(all, aes(x=PriorAllProbability,y=PosteriorProbability,shape=QUD,color=as.factor(TotalMarbles),group=QUDTotal)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Alternatives)
ggsave("graphs/allprobability-quds.pdf",width=12)

head(mp)
nrow(mp)
hmbasic2 = subset(mp, QUD=="how-many" & Alternatives == "basic" & SpeakerOptimality == 2 & Proportion == 1 & TotalMarbles == 4)
nrow(hmbasic2)
summary(hmbasic2)
hmbasic2 = unique(hmbasic2)
hmbasic2 = droplevels(hmbasic2)

row.names(hmbasic2) = as.character(hmbasic2$PriorAllProbability)
head(hmbasic2)
hmbasic2.gprior = hmbasic2
save(hmbasic2.gprior, file="data/hmbasic2.gprior.RData")


#!/usr/bin/env Rscript
options(stringAsfactors = FALSE, useFancyQuotes = FALSE)
# This script is used to correct the RT drift using xcms. It can also do IPO for RT correction parameter estimatation
# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for performing RT correction!\n")
require(xcms)
previousEnv<-NA
output<-NA
method="obiwarp"
ncores<-1
profStep<-1
center<-NULL
response_l<-1
response_h<-1
factorDiag_l<-2
factorDiag_h<-2
factorGap_l<-1
factorGap_h<-1
response<-1
distFunc<-"cor_opt"
gapInit<-NULL
gapExtend<-NULL
factorDiag<-2
factorGap<-1
localAlignment<-0
ipo_in<-NA
ipo_inv<-FALSE
ipo_gapInit_l<-0.0
ipo_gapInit_h<-0.4
ipo_gapExtend_l<-2.1
ipo_gapExtend_h<-2.7
ipo_profStep_l<-0.7
ipo_profStep_h<-1.0

bw_l<-22
bw_h<-38
minfrac_l<-0.3
minfrac_h<-0.7
mzwid_l<-0.015
mzwid_h<-0.035
minsamp<-1
max<-50
minsamp_l<-1
minsamp_h<-1
max_l<-50
max_h<-50
inputraw<-NA
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="inputraw")
  {
    input=as.character(value)
    if(file.info(input)$isdir & !is.na(file.info(input)$isdir))
    {
      inputraw<-list.files(input,full.names = T)

    }else
    {

      inputraw<-sapply(strsplit(x = input,split = "\\;|,| |\\||\\t"),function(x){x})

    }
  }
  if(argCase=="method")
  {
    method=as.character(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }
  if(argCase=="ipo_in")
  {
    ipo_in=as.character(value)
  }

  if(argCase=="profStep")
  {
    profStep=as.numeric(value)
  }
  if(argCase=="center")
  {
    if(as.character(value)!="NULL")
    {
      center=as.numeric(value)
    }
  }
  if(argCase=="response")
  {
    response=as.numeric(value)
  }
  if(argCase=="distFunc")
  {
    distFunc=as.character(value)
  }
  if(argCase=="gapInit")
  {
    if(as.character(value)!="NULL")
    {
      gapInit=as.numeric(value)
    }
  }
  if(argCase=="gapExtend")
  {
    if(as.character(value)!="NULL")
    {
      gapExtend=as.numeric(value)
    }
  }
  if(argCase=="factorDiag")
  {
    factorDiag=as.numeric(value)
  }
  if(argCase=="factorGap")
  {
    factorGap=as.numeric(value)
  }
  if(argCase=="localAlignment")
  {
    localAlignment=as.numeric(value)
  }

  if(argCase=="ipo_inv")
  {
    ipo_inv=as.logical(value)
  }

  if(argCase=="ipo_gapInit_l")
  {
    ipo_gapInit_l=as.numeric(value)
  }

  if(argCase=="ipo_gapInit_h")
  {
    ipo_gapInit_h=as.numeric(value)
  }
  if(argCase=="ipo_gapExtend_l")
  {
    ipo_gapExtend_l=as.numeric(value)
  }
  if(argCase=="ipo_gapExtend_h")
  {
    ipo_gapExtend_h=as.numeric(value)
  }
  if(argCase=="ipo_profStep_l")
  {
    ipo_profStep_l=as.numeric(value)
  }
  if(argCase=="ipo_profStep_h")
  {
    ipo_profStep_h=as.numeric(value)
  }

  if(argCase=="bw_l")
  {
    bw_l=as.numeric(value)
  }

  if(argCase=="bw_h")
  {
    bw_h=as.numeric(value)
  }

  if(argCase=="minfrac_l")
  {
    minfrac_l=as.numeric(value)
  }

  if(argCase=="minfrac_h")
  {
    minfrac_h=as.numeric(value)
  }

  if(argCase=="mzwid_l")
  {
    mzwid_l=as.numeric(value)
  }

  if(argCase=="mzwid_h")
  {
    mzwid_h=as.numeric(value)
  }
  if(argCase=="minsamp_l")
  {
    minsamp_l=as.numeric(value)
  }
  if(argCase=="minsamp_h")
  {
    minsamp_h=as.numeric(value)
  }
  if(argCase=="max_l")
  {
    max_l=as.numeric(value)
  }
  if(argCase=="max_h")
  {
    max_h=as.numeric(value)
  }
  if(argCase=="minsamp")
  {
    minsamp=as.numeric(value)
  }

  if(argCase=="max")
  {
    max=as.numeric(value)
  }
  if(argCase=="response_l")
  {
    response_l=as.numeric(value)
  }
  if(argCase=="response_h")
  {
    response_h=as.numeric(value)
  }
  if(argCase=="factorDiag_l")
  {
    factorDiag_l=as.numeric(value)
  }
  if(argCase=="factorDiag_h")
  {
    factorDiag_l=as.numeric(value)
  }
  if(argCase=="factorGap_l")
  {
    factorGap_l=as.numeric(value)
  }
  if(argCase=="factorGap_h")
  {
    factorGap_h=as.numeric(value)
  }
  if(argCase=="ncores")
  {
    ncores=as.numeric(value)
  }
}
if(is.na(previousEnv) | is.na(output)) stop("Input/inputraw and output need to be specified!\n")
load(file = previousEnv)

toBeRTCorrected<-get(varNameForNextStep)
ipo_params_set<-NA
if(!is.na(ipo_in) & !ipo_inv)
{
  ## Read IPO params
  ## This will overwrite the parameters that have been supplies by the user
  library(jsonlite)
  ipo_json<-read_json(ipo_in,simplifyVector = T)
  ipo_params<-fromJSON(ipo_json)
  profStep<-ipo_params$profStep
  ## Fix center
  #center<-ipo_params$center

  center<-which(tools::file_path_sans_ext(rownames(toBeRTCorrected@phenoData))==tools::file_path_sans_ext(ipo_params$centerName))
  ##
  response<-ipo_params$response
  distFunc<-ipo_params$distFunc
  gapInit<-ipo_params$gapInit
  gapExtend<-ipo_params$gapExtend
  factorDiag<-ipo_params$factorDiag
  factorGap<-ipo_params$factorGap
  localAlignment<-ipo_params$localAlignment
  ipo_params_set<-ipo_params
}

if(ipo_inv==TRUE)
{
  library(IPO)
  ipo_params<-getDefaultRetGroupStartingParams(method)
  ipo_params$factorDiag<-unique(c(factorDiag_l,factorDiag_h))
  ipo_params$factorGap<-unique(c(factorGap_l,factorGap_h))
  ipo_params$distFunc<-distFunc
  ipo_params$gapInit<-unique(c(ipo_gapInit_l,ipo_gapInit_h))
  ipo_params$gapExtend<-unique(c(ipo_gapExtend_l,ipo_gapExtend_h))
  ipo_params$profStep<-unique(c(ipo_profStep_l,ipo_profStep_h))
  ipo_params$localAlignment<-localAlignment
  ipo_params$response<-unique(c(response_l,response_h))
  ipo_params$retcorMethod<-method
  ipo_params$bw<-unique(c(bw_l,bw_h))
  ipo_params$minfrac<-unique(c(minfrac_l,minfrac_h))
  ipo_params$mzwid<-unique(c(mzwid_l,mzwid_h))
  ipo_params$minsamp<-unique(c(minsamp_l,minsamp_h))
  ipo_params$max<-unique(c(max_l,max_h))
  result_ipo <- optimizeRetGroup(toBeRTCorrected, ipo_params,nSlaves = ncores)
  ipo_params_set<-result_ipo$best_settings
  ipo_params<- result_ipo$best_settings
  profStep<-ipo_params$profStep
  center<-ipo_params$center
  response<-ipo_params$response
  distFunc<-ipo_params$distFunc
  gapInit<-ipo_params$gapInit
  gapExtend<-ipo_params$gapExtend
  factorDiag<-ipo_params$factorDiag
  factorGap<-ipo_params$factorGap
  localAlignment<-ipo_params$localAlignment
}
if(ipo_inv | !is.na(ipo_in))
{
  ipo_inv<-TRUE
}
if(!any(is.na(inputraw)))
{
  toBeRTCorrected@filepaths<-inputraw[match(basename(toBeRTCorrected@filepaths),basename(inputraw))]
}

params_list<-list(object=toBeRTCorrected,method=method,
                  profStep=profStep,center=center,response=response,distFunc=distFunc,
                  gapInit=gapInit,gapExtend=gapExtend,
                  factorDiag=as.numeric(factorDiag),factorGap=as.numeric(factorGap),localAlignment=localAlignment)

xcmsSetRTcorrected<-do.call(retcor,params_list[!sapply(params_list,is.null)],quote = T )

preprocessingSteps<-c(preprocessingSteps,"RTCorrection")

varNameForNextStep<-as.character("xcmsSetRTcorrected")

save(list = c("xcmsSetRTcorrected","preprocessingSteps","varNameForNextStep","ipo_inv","ipo_params_set"),file = output)


#' blake2b
#'
#' A 512-bit blake2b hash implementation.
#'
#' @param x
#' Input to be hashed. Can be a single string or a raw vector.
#' @param key
#' An optional key. Should be \code{NULL} (for no key), a single string, or a
#' raw vector.
#'
#' @return
#' The hash of the string as a raw vector.
#'
#' @references
#' Aumasson, J.P., Neves, S., Wilcox-O'Hearn, Z. and Winnerlein, C., 2013, June.
#' BLAKE2: simpler, smaller, fast as MD5. In International Conference on Applied
#' Cryptography and Network Security (pp. 119-135). Springer Berlin Heidelberg.
#'
#' @examples
#' \dontrun{
#' library(argon2)
#' blake2b("some string")
#' blake2b("another")
#' }
#'
#' @export
blake2b <- function(x, key=NULL)
{
  if (!is.string(x) && !is.raw(x))
    stop("argument 'x' must be a single string or a raw vector", call.=FALSE)
  if (!is.null(key) && !is.string(x) && !is.raw(x))
    stop("argument 'key' must be NULL, a single string, or a raw vector", call.=FALSE)

  .Call(R_blake2b, x, key)
}


REBOL [
	Title: "Basic DRAW test"
	Date: 24-Sep-2010
	Author: "Cyphre"
	Purpose: "Tests many of the basic DRAW dialect commands, eg. lines, boxes, curves, fills etc."
]
load-gui
; do %gfx-pre.r3

black: 0.0.0
white: 255.255.255
red: 255.0.0
green: 0.255.0
blue: 0.0.255
yellow: 255.255.0

img1: load %dev-small.jpg

img1-alpha: copy img1
oft: 0x0
siz: img1-alpha/size - 1
repeat y siz/y [
	repeat x siz/x [
		pos: as-pair x + oft/x y + oft/y
		pix: pick img1-alpha pos
		pix/4: to-integer (x * (255 / siz/x))
		poke img1-alpha pos pix
	]
]

img2: make image! [44x44]
change/dup img2 255.0.0 22x22
change/dup at img2 22x0 0.255.0 22x22
change/dup at img2 0x22 0.0.255 22x22
change/dup at img2 22x22 255.255.0 22x22

;;; WINDOW
win: make gob! [text: "Basic DRAW test" offset: 200x20 size: 800x800]

;;; background GOB
gobb: make gob! []
gobb/size: win/size
gobb/color: white
append win gobb

gobd: make gob! []
gobd/size: gobb/size

gobe: make gob! []
gobe/size: gobd/size
;gobe/effect: [blur]

gobd/draw: to-draw [

		pen 0.127.127
		fill-pen 218.188.189
		anti-alias on
		line-width 1
		line-cap square
		line-join bevel

		;ANTI-ALIAS
		translate 25x25
		arc 0x0 25x25 0 90
		translate 50x0
		arc 0x0 25x25 0 180
		translate 0x50
		arc 0x0 25x25 0 270
		translate -50x0
		arc 0x0 25x25 0 360

		translate 105x-50
		arc 0x0 25x25 0 90 closed
		translate 50x0
		arc 0x0 25x25 0 180 closed
		translate 0x50
		arc 0x0 25x25 0 270 closed
		translate -50x0
		arc 0x0 25x25 0 360 closed

		;ARROW
		reset-matrix
		translate 200x0

		translate 10x0
		line 0x90 0x10
		arrow 1x0
		translate 10x0
		line 0x90 0x10
		arrow 2x0
		translate 10x0
		line 0x90 0x10
		arrow 0x1
		translate 10x0
		line 0x90 0x10
		arrow 0x2
		translate 10x0
		line 0x90 0x10
		arrow 1x2
		translate 10x0
		line 0x90 0x10
		arrow 2x1
		translate 10x0
		line 0x90 0x10
		arrow 1x1
		translate 10x0
		line 0x90 0x10
		arrow 2x2
		translate 10x0
		line 0x90 0x10
		arrow 0x0

		reset-matrix
		translate 300x0

		translate 0x10
		line 10x0 90x0
		arrow 1x0
		translate 0x10
		line 10x0 90x0
		arrow 2x0
		translate 0x10
		line 10x0 90x0
		arrow 0x1
		translate 0x10
		line 10x0 90x0
		arrow 0x2
		translate 0x10
		line 10x0 90x0
		arrow 1x2
		translate 0x10
		line 10x0 90x0
		arrow 2x1
		translate 0x10
		line 10x0 90x0
		arrow 1x1
		translate 0x10
		line 10x0 90x0
		arrow 2x2
		translate 0x10
		line 10x0 90x0
		arrow 0x0

		;BOX
		reset-matrix
		translate 400x0
		box 5x5 95x95
		translate 100x0
		box 5x5 95x45
		box 5x50 95x95 10
		translate 100x0
		box 5x5 45x95
		box 50x5 95x95 10
		translate 100x0
		box 5x5 95x95 10

		;CIRCLE
		reset-matrix
		translate 0x100
		circle 50x50 45
		translate 100x0
		circle 50x50 45 22.5
		translate 100x0
		circle 50x50 22.5 45

		;CURVE
		reset-matrix
		translate 300x100
		curve 0x0 100x0 100x100
		translate 100x0
		curve 0x0 100x0 0x100 100x100

		;ELLIPSE
		reset-matrix
		translate 500x100
		ellipse 5x5 95x95
		translate 100x0
		ellipse 5x25 95x50
		translate 100x0
		ellipse 25x5 50x95

		;IMAGE
		reset-matrix
		translate 0x200
		image-filter bilinear
		image img1
		image-options border
		image 50x50 img1

		image-options no-border
		translate 100x0
		image img1 5x5 95x95
		translate 100x0
		image img1 30x5 70x95

		translate 100x0
		image 5x30 95x30 95x70 img1
		reset-matrix
		translate 450x250
		rotate 45
		image-options border
		image img1 -35x-35 35x35
		rotate -45
		translate 50x-50
		image-options no-border
		image img1 35x35 70x15 90x95 10x95
		translate 100x0
		image-options border
		image img1 15x5 95x20 55x75 20x93
		translate 100x0
		image-options border 255.0.0
		image img2 5x5
		image-options border 0.255.0
		image img2 49x5
		image-options border 0.0.255
		image img2 5x49
		image-options border 255.0.0
		image img2 49x49

		reset-matrix
		translate 0x300
		image-options no-border
		image-pattern repeat
		image img1 5x5 95x95
		translate 100x0
		image-pattern repeat 0x0 100x100
		image img1 5x5 95x95
		translate 100x0
		image-pattern repeat 25x25 100x100
		image img1 5x5 95x95
		translate 100x0
		image-pattern repeat 0x0 200x200
		image img1 5x5 95x95
		translate 100x0
		image-pattern reflect
		image img1 5x5 95x95
		translate 100x0
		image-pattern reflect 0x0 100x100
		image img1 5x5 95x95
		translate 100x0
		image-pattern reflect 25x25 100x100
		image img1 5x5 95x95
		translate 100x0
		image-pattern reflect 0x0 200x200
		image img1 5x5 95x95

		reset-matrix
		translate 0x400
		image-pattern repeat
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern repeat 0x0 100x100
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern repeat 25x25 100x100
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern repeat 0x0 200x200
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern reflect
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern reflect 0x0 100x100
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern reflect 25x25 100x100
		image img1 35x5 65x5 95x95 5x95
		translate 100x0
		image-pattern reflect 0x0 200x200
		image img1 35x5 65x5 95x95 5x95

		;LINE
		reset-matrix
		translate 0x500

		line 5x5  95x5
		line 5x15 95x15
		line 5x25 95x25
		line 5x35 95x35
		line 5x45 95x45
		line 5x55 95x55
		line 5x65 95x65
		line 5x75 95x75
		line 5x85 95x85
		line 5x95 95x95

		translate 100x0
		line 5x5  5x95
		line 15x5 15x95
		line 25x5 25x95
		line 35x5 35x95
		line 45x5 45x95
		line 55x5 55x95
		line 65x5 65x95
		line 75x5 75x95
		line 85x5 85x95
		line 95x5 95x95

		translate 100x0
		line 5x5  95x5
		5x15 95x15
		5x25 95x25
		5x35 95x35
		5x45 95x45
		5x55 95x55
		5x65 95x65
		5x75 95x75
		5x85 95x85
		5x95 95x95

		translate 100x0
		line 5x5  5x95
		15x5 15x95
		25x5 25x95
		35x5 35x95
		45x5 45x95
		55x5 55x95
		65x5 65x95
		75x5 75x95
		85x5 85x95
		95x5 95x95

		translate 100x0
		line 5x85 15x95
		line 5x75 25x95
		line 5x65 35x95
		line 5x55 45x95
		line 5x45 55x95
		line 5x35 65x95
		line 5x25 75x95
		line 5x15 85x95
		line  5x5 95x95
		line 15x5 95x85
		line 25x5 95x75
		line 35x5 95x65
		line 45x5 95x55
		line 55x5 95x45
		line 65x5 95x35
		line 75x5 95x25
		line 85x5 95x15

		translate 100x0
		line 5x15 15x5
		line 5x25 25x5
		line 5x35 35x5
		line 5x45 45x5
		line 5x55 55x5
		line 5x65 65x5
		line 5x75 75x5
		line 5x85 85x5
		line 5x95 95x5
		line 15x95 95x15
		line 25x95 95x25
		line 35x95 95x35
		line 45x95 95x45
		line 55x95 95x55
		line 65x95 95x65
		line 75x95 95x75
		line 85x95 95x85

		translate 100x0
		line 5x85 15x95
		5x75 25x95
		5x65 35x95
		5x55 45x95
		5x45 55x95
		5x35 65x95
		5x25 75x95
		5x15 85x95
		 5x5 95x95
		15x5 95x85
		25x5 95x75
		35x5 95x65
		45x5 95x55
		55x5 95x45
		65x5 95x35
		75x5 95x25
		85x5 95x15

		translate 100x0
		line 5x15 15x5
		5x25 25x5
		5x35 35x5
		5x45 45x5
		5x55 55x5
		5x65 65x5
		5x75 75x5
		5x85 85x5
		5x95 95x5
		15x95 95x15
		25x95 95x25
		35x95 95x35
		45x95 95x45
		55x95 95x55
		65x95 95x65
		75x95 95x75
		85x95 95x85

		;POLYGON
		reset-matrix
		translate 0x600
		polygon
		50x5
		62x40
		95x40
		68x60
		80x95
		50x74
		20x95
		32x60
		5x40
		38x40

		translate 100x0
		polygon
		50x5
		95x28
		95x72
		50x95
		5x72
		5x28

		translate 100x0
		polygon 14x59 17x85 92x57 94x32 52x38 59x15

		translate 100x0
		polygon
		5x15 15x5
		5x35 35x5
		5x55 55x5
		5x75 75x5
		5x95 95x5
		15x95 95x15
		35x95 95x35
		55x95 95x55
		75x95 95x75
		85x95 95x85

		;SPLINE
		translate 100x0
		spline 87x71 86x28 50x9 15x30 17x69 50x86 80x67 79x33 50x17 23x34
		24x64 50x78 73x63 71x37 50x26 30x38 31x60 50x69 65x59 64x41 49x34 37x42 38x56 50x61 58x54 57x45
 		50x42 44x47 46x52 50x53 51x50 50x49

		translate 100x0
		spline 2 87x71 86x28 50x9 15x30 17x69 50x86 80x67 79x33 50x17 23x34
		24x64 50x78 73x63 71x37 50x26 30x38 31x60 50x69 65x59 64x41 49x34 37x42 38x56 50x61 58x54 57x45
 		50x42 44x47 46x52 50x53 51x50 50x49

		translate 100x0
		spline 3 87x71 86x28 50x9 15x30 17x69 50x86 80x67 79x33 50x17 23x34
		24x64 50x78 73x63 71x37 50x26 30x38 31x60 50x69 65x59 64x41 49x34 37x42 38x56 50x61 58x54 57x45
 		50x42 44x47 46x52 50x53 51x50 50x49

		translate 100x0
		spline 5 87x71 86x28 50x9 15x30 17x69 50x86 80x67 79x33 50x17 23x34
		24x64 50x78 73x63 71x37 50x26 30x38 31x60 50x69 65x59 64x41 49x34 37x42 38x56 50x61 58x54 57x45
 		50x42 44x47 46x52 50x53 51x50 50x49 closed

		;TRIANGLE
		reset-matrix
		translate 0x700
		triangle 50x5 95x95

		translate 100x0
		triangle 50x5 95x95 5x95

		translate 100x0
		triangle 50x5 95x95 5x95 red

		translate 100x0
		triangle 50x5 95x95 5x95 green 2

		translate 100x0
		triangle 50x5 95x95 5x95 blue -2

		translate 100x0
		triangle 50x5 95x95 5x95 red green

		translate 100x0
		triangle 50x5 95x95 5x95 red green blue

		translate 100x0
		triangle 50x5 95x95 5x95 255.0.0.200 0.255.0.200 0.0.255.200

		;SHAPE
		;TEXT
] copy []
append gobb gobd
append gobd gobe
init-view-system ;why?

view win

comment [
view/options win [
	offset: 200x20
	handler: [
		name: 'draw-test-handler
		priority: 100
		handler: func [event] [
			if event/type = 'close [
				unhandle-events self ; Remove this handler from the global list.
				unview event/window
				quit
			]
			none
		]
	]
]
]


n=sum(1:1000000000);
print(n);


rebol []
	do-crops: func[
		/local
		 bmp bmp-file minx miny maxx maxy imgsz
		 a b c d tx ty tmp ai bi ci di txi tyi xA yA xB yB xC yC xD yD
		 nminx nminy nmaxx nmaxy x y w h
	][
		;probe bmpFills
		;probe Media
		;ask ""
		crops: copy []
		xxx: copy []
		foreach [id minx miny maxx maxy sx sy rx ry tx ty] bmpFills [
			print ["???" id minx miny maxx maxy sx sy rx ry tx ty]
			unless find noCrops id [
				minx: minx / 20
				miny: miny / 20
				maxx: maxx / 20
				maxy: maxy / 20
				a: sx / 20
				c: ry / 20
				b: rx / 20
				d: sy / 20
				tx: tx
				ty: ty

				tmp: (a * d) - (b * c)
				ai:   d / tmp
				bi: - b / tmp
				ci: - c / tmp
				di:   a / tmp
				txi: ((c * ty) - (d * tx)) / tmp
				tyi: -((a * ty) - (b * tx)) / tmp

				xA: (minx * ai) + (miny * ci) + txi
				yA: (minx * bi) + (miny * di) + tyi

				xB: (maxx * ai) + (miny * ci) + txi
				yB: (maxx * bi) + (miny * di) + tyi

				xC: (maxx * ai) + (maxy * ci) + txi
				yC: (maxx * bi) + (maxy * di) + tyi

				xD: (minx * ai) + (maxy * ci) + txi
				yD: (minx * bi) + (maxy * di) + tyi

			;	print "============="
			;	print [xA yA]
			;	print [xB yB]
			;	print [xC yC]
			;	print [xD yD]

				nminx: to-integer min xD min xC min xA xB
				nmaxx: to-integer max xD max xC max xA xB
				nminy: to-integer min yD min yC min yA yB
				nmaxy: to-integer max yD max yC max yA yB

				;print [nminx nminy nmaxx nmaxy]
				x: xc: round/floor nminx
				y: yc: round/floor nminy
				w: round/ceiling(nmaxx - x)
				h: round/ceiling(nmaxy - y)

				if bmp: select media id [
					bmp-file: bmp/("sourceExternalFilepath")
					unless exists? xfl-folder-new/(bmp-file) [
						export-media-item bmp
					]
					imgsz: get-image-size xfl-folder-new/(bmp-file)
					if xc < 0 [xc: imgsz/1 + (xc // imgsz/1)]
					if yc < 0 [yc: imgsz/2 + (yc // imgsz/2)]
					if xc > imgsz/1 [xc: xc // imgsz/1]
					if yc > imgsz/2 [yc: yc // imgsz/2]
					if xc > 1 [x: x - 2 xc: xc - 2 w: w + 2]
					if yc > 1 [y: y - 2 yc: yc - 2 h: h + 2]
					if (xc + w) < imgsz/1 [w: w + 2]
					if (yc + h) < imgsz/2 [h: h + 2]
					;print [xc yc w h]
				]

				print ["crop:" x y w h tab "===" tab nminx nminy nmaxx nmaxy]
;ask ""
			;	print ["===" x y w h sx sy rx ry tx ty]

				either tmp: select xxx id [
					repend tmp [xc yc (xc + w) (yc + h) x y]
				][
					append xxx id
					repend/only xxx [xc yc xc + w yc + h x y]
				]

				either none? tmp: select crops id [
					append crops id
					repend/only crops [xc yc xc + w yc + h x y]
				][
					change tmp reduce [
						min tmp/1 xc
						min tmp/2 yc
						max tmp/3 (xc + w)
						max tmp/4 (yc + h)
						min tmp/5 x
						min tmp/6 y
					]
				]
				;if error? try [md5: last select swfBitmaps id][md5: none]
				;print ["BMP" id md5 w h as-pair x y as-pair x + w y + h]
			]
		]
		print "============CROP=============="
		;probe xxx
		;save %crops.rb xxx
		clear Media-to-remove
		;probe media
		;ask ""
		foreach [id sizes] crops [
			if bmp: select media id [
				print ["crop bitmap type:" mold bmp]
				probe sizes
				either probe tmp: crop-images
					xfl-folder-new/(bmp/("sourceExternalFilepath"))
					sizes/1
					sizes/2
					sizes/3 - sizes/1
					sizes/4 - sizes/2
				[
					import-media-img/dom/smoothing tmp select bmp "allowSmoothing"
					append sizes second split-path to-rebol-file tmp
					append Media-to-remove id
				][
					print ["!!!" id]
					append noCrops id
				]
			]
		]
		print "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
		probe noCrops: unique noCrops
		probe crops
		foreach id sort/reverse noCrops [
			print ["noCrop:" id]
			;probe select swfBitmaps id
			if tmp: find crops id [
				print ["noCrop:" mold tmp/2]
				remove/part tmp 2
			]
		]
		probe crops
		;ask ""
	]


#' Increase the size of input intervals.
#'
#' @inheritParams bed_flank
#'
#' @return [tbl_interval()]
#'
#' @family single set operations
#'
#' @seealso
#'   \url{http://bedtools.readthedocs.org/en/latest/content/tools/slop.html}
#'
#' @examples
#' x <- trbl_interval(
#'   ~chrom, ~start, ~end,
#'   'chr1', 110,    120,
#'   'chr1', 225,    235
#' )
#'
#' genome <- trbl_genome(
#'   ~chrom, ~size,
#'   'chr1', 400
#' )
#'
#' bed_glyph(bed_slop(x, genome, both = 20, trim = TRUE))
#'
#' genome <- trbl_genome(
#'  ~chrom, ~size,
#'  "chr1", 5000
#' )
#'
#' x <- trbl_interval(
#'  ~chrom, ~start, ~end, ~name, ~score, ~strand,
#'  "chr1", 500,    1000, '.',   '.',     '+',
#'  "chr1", 1000,   1500, '.',   '.',     '-'
#' )
#'
#' bed_slop(x, genome, left = 100)
#'
#' bed_slop(x, genome, right = 100)
#'
#' bed_slop(x, genome, both = 100)
#'
#' bed_slop(x, genome, both = 0.5, fraction = TRUE)
#'
#' @export
bed_slop <- function(x, genome, both = 0, left = 0,
                     right = 0, fraction = FALSE,
                     strand = FALSE, trim = FALSE, ...) {
  if (!is.tbl_interval(x)) x <- as.tbl_interval(x)
  if (!is.tbl_genome(genome)) genome <- as.tbl_genome(genome)

  if (strand && !"strand" %in% colnames(x)) {
    stop("expected `strand` in `x`", call. = FALSE)
  }

  if (both != 0 && (left != 0 || right != 0)) {
    stop("ambiguous side spec for bed_slop", call. = FALSE)
  }

  if (fraction) x <- mutate(x, .size = end - start)

  if (both != 0) {
    if (fraction) {
      res <- mutate(
        x,
        start = start - round(both * .size),
        end = end + round(both * .size)
      )
    } else {
      res <- mutate(
        x,
        start = start - both,
        end = end + both
      )
    }
  } else {
    # calc left and right based on strand
    if (strand) {
      if (fraction) {
        res <- mutate(
          x,
          start = ifelse(strand == "+",
            start - round(left * .size),
            start - round(right * .size)
          ),
          end = ifelse(strand == "+",
            end + round(right * .size),
            end + round(left * .size)
          )
        )
      } else {
        res <- mutate(
          x,
          start = ifelse(strand == "+",
            start - left,
            start - right
          ),
          end = ifelse(strand == "+",
            end + right,
            end + left
          )
        )
      }
    } else {
      if (fraction) {
        res <- mutate(
          x,
          start = start - round(left * .size),
          end = end + round(right * .size)
        )
      } else {
        res <- mutate(
          x,
          start = start - left,
          end = end + right
        )
      }
    }
  }

  if (fraction) res <- select(res, -.size)

  res <- bound_intervals(res, genome, trim)
  res <- bed_sort(res)

  res <- mutate(res,
    temp_start = start,
    temp_end = end
  )

  res <- mutate(res,
    start = ifelse(temp_start - temp_end < 0,
      temp_start, temp_end
    ),
    end = ifelse(temp_start - temp_end < 0,
      temp_end, temp_start
    )
  )

  res <- select(res, -temp_start, -temp_end)

  res
}


  k-ingleside
           value  ------------- Distribution ------------- count
               0                                         | 0
               1 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@| -123
               2                                         | 0

  j-church
           value  ------------- Distribution ------------- count
             < 0 |                                         0
               0 |                                         0
               1 |                                         0

  l-taraval
           value  ------------- Distribution ------------- count
             < 0                @@@@@|                     -123
               0                @@@@@|                     -123
               1                     |@@@@@@@@@@           246
               2                     |                     0

  n-judah
           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |@@@@@@@@@@@@@                            123
               2 |@@@@@@@@@@@@@@@@@@@@@@@@@@@              247
               3 |                                         0

  m-oceanview
           value  ------------- Distribution ------------- count
               0                     |                     0
               1           @@@@@@@@@@|                     -9223372036854775808
               2                     |@@@@@@@@@@           9223372036854775807
               3                     |                     0
               4                     |                     0
               5                     |                     0
               6                     |                     0
               7                     |                     0
               8                     |                     400000
               9                     |                     0

  s-castro
           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |@@@@@@@@@@@@@@@                          9223372036854775801
               2 |@@@@@@@@                                 4611686018427387903
               3 |@@@@@                                    3074457345618258602
               4 |@@@@                                     2305843009213693951
               5 |@@@                                      1844674407370955161
               6 |@@@                                      1537228672809129301
               7 |@@                                       1317624576693539401
               8 |                                         0

  f-market
           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |@@@@@@@@@@@@@@@                          9223372036854775807
               2 |@@@@@@@@                                 4611686018427387903
               3 |@@@@@                                    3074457345618258602
               4 |@@@@                                     2305843009213693951
               5 |@@@                                      1844674407370955161
               6 |@@@                                      1537228672809129301
               7 |@@                                       1317624576693539401
               8 |                                         0