library(leaflet)
library(rgdal)
library(sf)
library(htmltools)
library(htmlwidgets)

USA_data <- st_read("map2/USA_data.shp")

pal <- colorFactor(
  palette = c('#fff5f0', '#b4b4b4', '#fb6a4a', '#fcbba1'),
  domain = US$category
)

USA_data$label <- paste("
", USA_data$NAME, "
",
                  "Category: ", USA_data$category, "
",
                  "Percent Change From 2016-2017: ", USA_data$change, "
",
                  "Statistically ignificant: ",USA_data$significan, "
",
                  "2016 Number: ", USA_data$X2016number, "
",
                  "2016 Rate: ", USA_data$X2016rate, "
",
                  "2017 Number: ", USA_data$X2017number, "
",
                  "2017 Rate: ", USA_data$X2017rate)

my_map <- leaflet(USA_data) %>%
  addPolygons(color = "#444444", weight = 1, smoothFactor = 0.5,
              opacity = 1.0, fillOpacity = 0.5,
              fillColor = ~pal(category),
              highlightOptions = highlightOptions(color = "white", weight = 2,
                                                  bringToFront = TRUE),
              label=lapply(USA_data$label, HTML),
              labelOptions = labelOptions(textsize = "15px")) %>%
  addLegend(position="bottomright", pal=pal, values=~category, title="Category", opacity=1) %>%
  setView(lng=-98.134, lat=38.053, zoom=4)
saveWidget(widget=my_map, file="my_map.html")

library(shiny)
library(ggplot2)

ui <- shinyUI(fluidPage(
  headerPanel(title = 'Test Kmeans'),
  sidebarPanel(
    selectInput(inputId = 'Col',label = 'The Variables',
                choices = c('Sepal.Length','Sepal.Width','Petal.Length','Petal.Width'),
                selected = c('Sepal.Length','Sepal.Width'),
                multiple = T),
    numericInput(inputId = 'center',label = 'Centroids',value = 3,min = 1,max = 10,step = 1),
    submitButton(text='submit')
  ),
  mainPanel(
    h1('The result of Kmeans'),
    plotOutput(outputId = 'plot')
  )
))

server <- shinyServer(function(input,output){
  output$plot <- renderPlot({
    da <- iris[,input$Col]
    fit <- kmeans(da,centers = input$center)
    da$cluster <- fit$cluster
    da2 <- as.data.frame(fit$centers)
    ggplot()+
      geom_point(data = da,aes(x=da[,input$Col[1]],y=da[,input$Col[2]],color=factor(cluster)))+
      geom_point(data = da2,aes(x=da2[,names(da2)[1]],y=da2[,names(da2)[2]],color=factor(1:nrow(da2))),size=5,shape=3)+
      xlab(input$Col[1])+ylab(input$Col[2])
    })
})

outline <- quakes[chull(quakes$long, quakes$lat),]

map <- leaflet(quakes) %>%
  # Base groups
  addTiles(group = "OSM (default)") %>%
  addProviderTiles(providers$Stamen.Toner, group = "Toner") %>%
  addProviderTiles(providers$Stamen.TonerLite, group = "Toner Lite") %>%
  # Overlay groups
  addCircles(~long, ~lat, ~10^mag/5, stroke = F, group = "Quakes") %>%
  addPolygons(data = outline, lng = ~long, lat = ~lat,
    fill = F, weight = 2, color = "#FFFFCC", group = "Outline") %>%
  # Layers control
  addLayersControl(
    baseGroups = c("OSM (default)", "Toner", "Toner Lite"),
    overlayGroups = c("Quakes", "Outline"),
    options = layersControlOptions(collapsed = FALSE)
  )

/////////////////
ui <- shinyUI(fluidPage(

   absolutePanel(width = 430,top=200,left = 'auto',draggable = T,
                 textInput(inputId = 'Loc',label = 'THE PLACE'),
                 textInput(inputId = 'Start',label = 'FROM',width = "50%"),
                 textInput(inputId = 'End',label = 'TO',width = "50%"),
                 selectInput(inputId = 'selected',label = 'Route or Loc',
                             choices = c('Loc','Route'),selected = 'Loc',
                             multiple = F),
                 textOutput(outputId = 'Request'),
                 submitButton(text = "Submit")
                 )
))

server <- shinyServer(function(input, output) {

    ## acquire the coordinate from rjson file
    getcoord <- function(x){## x is a name of some place
      x <- fromJSON(getCoordinate(x))
      return(x)
    }

    ## output leaflet map to the id:map
    output$map <- renderLeaflet({
      m <- leaflet()
      m <- m%>%addTiles()

      if(input$selected == 'Loc'){
        temp <- getcoord(input$Loc)
        if(temp$status!=0){
          output$Request <- renderText({
            c('The location failed to be found')
          })
          m
        }else{
          output$Request <- renderText({
            c('The location is found successfully')
          })
          m %>% addMarkers(lng=temp$result$location$lng,
                          lat=temp$result$location$lat,
                          popup = paste0(input$Loc,'--',temp$result$level))
        }
      }else{
        temp1 <- getcoord(input$Start)
        temp2 <- getcoord(input$End)
        if(temp1$status==0&temp2$status==0){
          output$Request <- renderText({
            c('Both start point and end point are valid')
          })
          route <- getRoute(input$Start,input$End)
          m%>%addPolylines(route$lon,route$lat)%>%
            addMarkers(lng=route$lon[c(1,nrow(route))],
                      lat=route$lat[c(1,nrow(route))],
                            popup = c(paste0(input$Start,'--',temp1$result$level),
                                      paste0(input$End,'--',temp2$result$level)))
        }else{
            output$Request <- renderText({
              c('One or both of origin and destination is invalid')
            })
          }
        }
    })
})

server <- function(input, output, session) {
  filteredData <- reactive({
    df_history[df_history$years >= input$range[1] & df_history$years <= input$range[2],]
  })

  output$map <- renderLeaflet({
    leaflet(df_history) %>% addTiles() %>%
      fitBounds(~min(lng), ~min(lat), ~max(lng), ~max(lat))
  })

  observe({
    proxy <- leafletProxy("map", data = df_history)
    proxy %>% clearControls()

    if (input$legend) {
      catego <- unique(df_history$owner)
      proxy %>% addLegend(position = "bottomright", colors = RdYlBu(catego),
                          labels = catego
      )

      leafletProxy("map", data = filteredData()) %>%
        clearShapes() %>% clearMarkerClusters() %>%
        addCircles(weight = ~size_check,
                   color = ~RdYlBu(owner),
                   opacity = 1,
                   fillOpacity = 1)

    }
    else{
      leafletProxy("map", data = filteredData()) %>%
        clearShapes() %>% clearMarkerClusters() %>%
        addMarkers(popup = ~paste("
",name_tw,"
",
                                  years,"year
",
                                  address,"
"),
                   clusterOptions = markerClusterOptions()) # %>%

    }
  })
}

library(shiny)
library(leaflet)
library(RColorBrewer)
library(shinythemes)

ui <- bootstrapPage(
  theme = shinytheme("cosmo"),
  title = "Taiwan Historical Map",
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
  leafletOutput("map", width = "100%", height = "100%"),
  absolutePanel(top = 100, right = 30,
                draggable = FALSE,
                sliderInput("range", "Years", 1800, 2000,
                            value = c(1800,2000), step = 10
                ),
                checkboxInput("legend", "Show Scatter Diagram", FALSE)
  ),
  absolutePanel(top = 20, right = 42,
                titlePanel(h2("Taiwan Historical Map"))
  )
)

## Setup work directory;
setwd("/srv/shiny-system/Data")
I <- 0
for (i in 1:60) {
  system("top -n 1 -b -u shiny > top.log")
  dat <- readLines("top.log")
  id <- grep("R *$", dat)
  Names <- strsplit(gsub("^ +|%|\\+", "", dat[7]), " +")[[1]]
  if (length(id) > 0) {
    # 'top' data frame;
    L <- strsplit(gsub("^ *", "", dat[id]), " +")
    dat <- data.frame(matrix(unlist(L), ncol = 12, byrow = T))
    names(dat) <- Names
    dat <- data.frame(Time = Sys.time(), dat[, -ncol(dat)], usr = NA, app = NA)
    dat$CPU <-as.numeric(as.character(dat$CPU))
    dat$MEM <-as.numeric(as.character(dat$MEM))
    # Check if connection number changed;
    for (i in 1:length(dat$PID)) {
      PID <- dat$PID[i]
      system(paste("sudo netstat -p | grep", PID, "> netstat.log"))
      system(paste("sudo netstat -p | grep", PID, ">> netstat.log2"))
      system(paste("sudo lsof -p", PID, "| grep /srv > lsof.log"))
      netstat <- readLines("netstat.log")
      lsof <- readLines("lsof.log")
      dat$usr[i] <- length(grep("ESTABLISHED", netstat) & grep("tcp", netstat))
      dat$app[i] <- regmatches(lsof, regexec("srv/(.*)", lsof))[[1]][2]
    }
    dat <- dat[, c("app", "usr")]
  } else {
    dat <- data.frame(app = "app", usr = 0)
  }
  write.table(dat, file = "CPU.txt")
}

ui <- bootstrapPage(

  tags$head(
    tags$link(href = "https://fonts.googleapis.com/css?family=Oswald", rel = "stylesheet"),
    tags$style(type = "text/css", "html, body {width:100%;height:100%; font-family: Oswald, sans-serif;}"),
    includeHTML("meta.html"),
    tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.5.16/iframeResizer.contentWindow.min.js",
                type="text/javascript"),
    tags$script('
                $(document).ready(function () {
                  navigator.geolocation.getCurrentPosition(onSuccess, onError);

                  function onError (err) {
                    Shiny.onInputChange("geolocation", false);
                  }

                  function onSuccess (position) {
                    setTimeout(function () {
                      var coords = position.coords;
                      console.log(coords.latitude + ", " + coords.longitude);
                      Shiny.onInputChange("geolocation", true);
                      Shiny.onInputChange("lat", coords.latitude);
                      Shiny.onInputChange("long", coords.longitude);
                    }, 1100)
                  }
                });
                ')
  ),

  leafletOutput("map", width = "100%", height = "100%"),


#!/usr/bin/env Rscript
####################################################################################
### Copyright (C) 2015-2019 by ABLIFE
####################################################################################

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

####################################################################################
# Date           Version       Author            ChangeLog

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

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

#####################################################################################
#
suppressPackageStartupMessages(library("optparse"))
suppressPackageStartupMessages(library("stats"))

option_list <- list(
  make_option(c("-f", "--file"),action = "store",type = "character",
              help = "The Input file"),
  make_option(c("-s","--sample"),action = "store",type = "character",
              help = "The sample file"),
  make_option(c("-b","--start"),action = "store",type = "integer",default = 1,
              help = "appoint the column of start ; default = 1"),
  make_option(c("-e","--end"),action = "store",type = "integer",default = -1,
              help = "appoint the column of end; default = -1"),
  make_option(c("-n","--filename"),action = "store",type = "character",default="Sample_correlation",
              help = "The filename of the picture ; default = test.pdf"),
  make_option(c("-o", "--outdir"),action = "store",type = "character",default = "./",
              help = "The outdir;default = ./")
)
opt <- parse_args(OptionParser(option_list = option_list))
start <- as.numeric(opt$start)
end <- as.numeric(opt$end)

# library(cluster)
# library(Biobase)
# library(qvalue)
library("corrplot")
NO_REUSE = F

# opt$file = "Sex_specific_lncRNA_value.txt"
# opt$file = "exp.txt"

# # get the filename to use later
filename <- strsplit(opt$file,"/")[[1]]
filename <- filename[length(filename)]
filename <- sub('.txt','',filename)

# # try to reuse earlier-loaded data if possible

# print('Reading matrix file.')
primary_data = read.table(opt$file, header=T, com='', sep="\t", row.names=1, check.names=F)
# primary_data = read.table("Sample_correlation.dat", header=T, com='', sep="\t", row.names=1, check.names=F)

if(end> 0){
  primary_data <- primary_data[,start:end]
}
primary_data = as.matrix(primary_data)
primary_data = log2(primary_data+1)
data = primary_data

sample_cor = cor(data, method='pearson', use='pairwise.complete.obs')
# sample_cor = cor(data, method='pearson')
# round(sample_cor,2)
cat(c('Gene\t'),file=paste(opt$filename,".xls",sep=''))

write.table(sample_cor, file=paste(opt$filename,".xls",sep=''), quote=F, append=T, sep='\t')
data <- sample_cor
# # sample_dist = dist(t(data), method='euclidean')
# # hc_samples = hclust(sample_dist, method='complete')
# col <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D",
#                           "#F4A582", "#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
#                           "#4393C3", "#2166AC", "#053061","#67001F", "#B2182B", "#D6604D",
#                           "#F4A582", "#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
#                           "#4393C3", "#2166AC", "#053061","#67001F", "#B2182B", "#D6604D",
#                           "#F4A582", "#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
#                           "#4393C3", "#2166AC", "#053061","#67001F", "#B2182B", "#D6604D",
#                           "#F4A582", "#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
#                           "#4393C3", "#2166AC", "#053061"))(200)
# min <- min(sample_cor)
# corrplot(sample_cor, type="upper", order="hclust", hclust.method="complete",col=col,tl.srt=45,cl.lim=c(min,1))

# data("ALL")
# library(limma)
# eset<-ALL[,ALL$mol.biol %in% c("BCR/ABL","ALL1/AF4")]
# f<-factor(as.character(eset$mol.biol))
# design<-model.matrix(~f)

# selected  <- p.adjust(fit$p.value[, 2]) <0.001

# data<-exprs(esetSel)

library(pheatmap)
library("RColorBrewer")
library(grid)

# data[lower.tri(data)]=NA

# triangle heatmap
o = rownames(data)
sample_dist = dist(t(primary_data), method='euclidean')
hc = hclust(sample_dist, method='complete')
# hc = hclust(as.dist(1 - data))
data = data[hc$order, hc$order]
# data[lower.tri(data)] = NA
data = data[o, o]
data

## Edit body of pheatmap:::draw_colnames, customizing it to your liking
# draw_colnames_45 <- function (coln, ...) {
#     m = length(coln)
#     x = (1:m)/m - 1/2/m
#     grid.text(coln, x = x, y = unit(0.96, "npc"), vjust = .5,
#         hjust = 1, rot = 45, gp = gpar(...)) ## Was 'hjust=0' and 'rot=270'
# }

# ## 'Overwrite' default draw_colnames with your own version
# assignInNamespace(x="draw_colnames", value="draw_colnames_45",
# ns=asNamespace("pheatmap"))

# scaleyellowred <- colorRampPalette(c("#08519c","#3182bd","#ffffff","#e6550d","#e6550d","#a63603","#a63603"),space = "rgb")(500)
# scaleyellowred <- colorRampPalette(c("#08519c","#3182bd","#ffffff","#e6550d","#e6550d","#e6550d","#a63603","#a63603","#a63603"),space = "rgb")(500)

rowcount <- nrow(data)

if (rowcount>7){
  pheatmap(data, cluster_col = hc, cluster_row = hc,border_color="white",show_colnames=T,cellwidth = 30, cellheight = 30, fontsize=27,filename = paste(opt$filename,".pdf",sep=''),display_numbers = FALSE)

  pheatmap(data, cluster_col = hc, cluster_row = hc,border_color="white",show_colnames=T,cellwidth = 30, cellheight = 30, fontsize=27,filename = paste(opt$filename,".png",sep=''),display_numbers = FALSE)
}

if (rowcount<=7){
  pheatmap(data, cluster_col = hc, cluster_row = hc,border_color="white",show_colnames=T,fontsize=20,filename = paste(opt$filename,".pdf",sep=''),display_numbers = FALSE,width = 8, height = 7)

  pheatmap(data, cluster_col = hc, cluster_row = hc,border_color="white",show_colnames=T,fontsize=20,filename = paste(opt$filename,".png",sep=''),display_numbers = FALSE,width = 8, height = 7)
}

# correlation

# gene heatmap

# # data = log2(data+1)
# data[,c(1,2,3,4,5)] <- data[,c(1,2,3,4,5)]/data[,1]
# #deg
# col.pal <- brewer.pal(9,"Blues")
# # colorRampPalette is in the RColorBrewer package.  This creates a colour palette that shades from light yellow to red in RGB space with 100 unique colours
# scaleyellowred <- colorRampPalette(c("lightyellow","pink", "red"),space = "rgb")(500)

# color.map <- function(mol.biol) { if (mol.biol=="ALL1/AF4") 1 else 2 }
# patientcolors <- unlist(lapply(esetSel$mol.bio, color.map))
# hc<-hclust(dist(t(data)))
# dd.col<-as.dendrogram(hc)
# groups <- cutree(hc,k=7)
# annotation<-data.frame(Var1=factor(patientcolors,labels=c("class1","class2")),Var2=groups)

# Var1 = c("navy", "skyblue")
# Var2 = c("snow", "steelblue")
# names(Var1) = c("class1", "class2")
# ann_colors = list(Var1 = Var1, Var2 = Var2)


#' @title apply_lag
#'
#' @description lag some of the columns in a \code{\link[base]{data.frame}}
#'
#' @importFrom magrittr "%>%"
#' @export
#'
#' @param data a \code{\link[base]{data.frame}} to operate over
#' @param hold a vector of column names to hold steady
#' @param move a vector of column names to lag
#' @param lag the number of rows to lag by
#' @return
#'
#' @author Mark Newman, \email{mark@trinetteandmark.com}
#' @keywords macros
#' @family data_dredging
#'
#' @examples
#'   \dontshow{
#'     library(mndredge)}
#'   data.frame(
#'     a = c(1,2,3,4),
#'     b = c(2,3,4,5),
#'     c = c(4,5,6,7)) %>%
#'     apply_lag(hold = "a", move = "b", lag = 1)
#'
apply_lag <- function(data, hold, move, lag = 0) {

  stopifnot(is.data.frame(data))
  stopifnot(is.character(hold))
  stopifnot(is.character(move))

  cn <- colnames(data)
  stopifnot(hold %in% cn %>% all())
  stopifnot(move %in% cn %>% all())

  stopifnot(is.numeric(lag))
  stopifnot(lag >= 0)

  n <- nrow(data)
  stopifnot(n > lag)

  df1 <- data[, hold] %>% as.data.frame()
  df2 <- data[, move] %>% as.data.frame()

  res <- cbind(
    df1[1:(n-lag),],
    df2[(1+lag):n,]) %>%
    as.data.frame()
  colnames(res) <- c(hold, move)
  rownames(res) <- 1:(n-lag)

  res
}


#### volcano plot source. also trendplots.

## trendplot code:
trendplot = function(x,ylab=NULL,xlabels=NULL,patient,groups,pointcols,show.ids=FALSE)
{
  pts = unique(patient)
  group = groups
  jgroup = jitter(as.numeric(groups),factor=0.5)
  xlim=NULL
  if (length(xlabels) == 0) {xlabels = levels(groups)}
  if(show.ids){xlim=range(as.numeric(as.factor(groups)))+c(-.08,.08)*diff(range(as.numeric(as.factor(groups))))}
  plot(jgroup,x,xaxt="n",xlim=xlim,ylab=ylab,xlab="",pch=16,col=pointcols,cex.lab=1.5)
  axis(1,at = as.numeric(1:length(levels(groups))),labels = xlabels,cex.axis = 1.3,las=2)
  for(pt in pts)
  {
    use = which(patient==pt)
    if(length(use)>0)
    {
      o = order(groups[use])
      lines(x=jgroup[use][o],y=x[use][o],col=pointcols[use[1]])
    }
    if(show.ids)
    {
      text(min(as.numeric(groups[use]))-0.5,x[use][o[1]],pt,cex=0.5,col="grey30")
      text(max(as.numeric(groups[use]))+0.5,x[use][o[length(o)]],pt,cex=0.5,col="grey30")
    }
  }

}

## volc plot code: estmat,pvalmat,fdrmat: matrices of log2fcs, pvals, etc. each row in a gene, each column is a contrast. (so a simple t-test model will have 1-column matrices)
# genesets is a 1-0 matrix of gene set membership. It might be required to align with the gene names.
# is.score is a logical vector saying which genes to highlight as a "score"
drawvolc = function(estmat,pvalmat,fdrmat,genesets,is.score=rep(FALSE,nrow(estmat)))
{
  if(length(colnames(estmat))==0){colnames(estmat)=colnames(pvalmat)=colnames(fdrmat)=""}
  ylim = range(-log10(pvalmat))
  xlim = range(estmat)
  par(mfrow = c(ncol(estmat),2))
  par(mar = c(12,4,2,1))
  for(j in 1:ncol(estmat))
  {
    level = colnames(estmat)[j]
    main=level
    #if(length(grouping.name.for.response)==0){main = ""}
    #if(length(grouping.name.for.response)>0){main = paste0(grouping.name.for.response," = ",level)}
    # id the top 50:
    top = unique(c(order(pvalmat[,j])[1:50],which(is.score)))
    # volc plot:
    plot(estmat[,j],-log10(pvalmat[,j]),pch=1,col=c("grey50","white")[1+is.element(1:nrow(pvalmat),top)],xlim=xlim,ylim=ylim,
         xlab=paste0("log2 fold-change"),
         main=main,ylab="-log10(p-value)",cex.lab=1.5)
    # text for top 50:
    text(estmat[top,j],-log10(pvalmat[top,j]),rownames(pvalmat)[top],cex=.7,col=c("aquamarine4","darkorange2")[1+is.element(top,which(is.score))])
    # draw lines for FDR cutoffs:
    fdr.cutoffs = c(0.5,0.1,0.05)
    for(i in 1:length(fdr.cutoffs))
    {
      suppressWarnings(abline(h=-log10(suppressWarnings((max(pvalmat[fdrmat[,j]<fdr.cutoffs[i],j])))),lty=i))
    }
    legend("bottomleft",lty=1:length(fdr.cutoffs),legend = paste0("FDR = ",fdr.cutoffs))

    ## now run gene set analysis:
    # summary stat for each gene set: mean -log10(pval)
    genesetscore = c()
    for(geneset in colnames(genesets))
    {
      tempgenes = intersect(rownames(genesets)[genesets[,geneset]==1],rownames(pvalmat))
      genesetscore[geneset] = mean(-log10(pvalmat[tempgenes,j]))
    }
    # identify the top 5 gene sets:
    top5 = names(genesetscore)[order(genesetscore,decreasing = T)[1:10]]

    # now plot the gene sets' -log10 pvals:
    plot(c(0,0),col=0,xlim=c(1,length(top5)),ylim=ylim,xaxt="n",xlab="",ylab="-log10(p-value)")
    bp = 1:length(top5)
    #bp = barplot(genesetscore[top5],col=rgb(0,0,0,.1),ylim=ylim,xaxt="n",xlab="",ylab="-log10(p-value)",border = F,main="Gene set results")
    axis(1,at = bp,labels = top5,las=2)
    #abline(v = 1:length(top5),col="grey80")
    abline(v = bp,col="grey80")
    for(i in 1:length(top5))
    {
      geneset = top5[i]
      rect(bp[i]-.4,ylim[1],bp[i]+.4,genesetscore[geneset],col=rgb(0,0,0,.5),border = F)
      tempgenes = intersect(rownames(genesets)[genesets[,geneset]==1],rownames(pvalmat))
      text(rep(bp[i],length(tempgenes)),-log10(pvalmat[tempgenes,j]),tempgenes,cex=0.5,
           col = c(rgb(0,0,1,0.7),rgb(1,0,0,0.7))[1+(estmat[tempgenes,j]>0)])
    }
  }
}


suppressMessages(library(dplyr))
suppressMessages(library(here))
suppressMessages(library(lubridate))
suppressMessages(library(readr))
suppressMessages(library(scoringutils))
suppressMessages(library(covidHubUtils))
suppressMessages(library(EuroForecastHub))

load_and_score_models <- function(subdir = "") {

  data_types <- get_hub_config("target_variables")

  ## load forecasts --------------------------------------------------------------
  forecasts <- load_forecasts(
    source = "local_hub_repo",
    hub_repo_path = here(subdir),
    hub = "ECDC"
  ) %>%
    ## set forecast date to corresponding submission date
    mutate(forecast_date = ceiling_date(forecast_date, "week", week_start = 2) - 1) %>%
    filter(forecast_date >= as.Date(get_hub_config("launch_date"))) %>%
    rename(prediction = value)

  ## load truth data -------------------------------------------------------------
  raw_truth <- load_truth(truth_source = "JHU",
                          temporal_resolution = "weekly",
                          hub = "ECDC")
  ## get anomalies
  anomalies <- read_csv(here("data-truth", "anomalies", "anomalies.csv"))
  truth <- anti_join(raw_truth, anomalies) %>%
    mutate(model = NULL) %>%
    rename(true_value = value)

  ## remove forecasts made directly after a data anomaly
  forecasts <- forecasts %>%
    mutate(previous_end_date = forecast_date - 2) %>%
    left_join(anomalies %>%
              rename(previous_end_date = target_end_date),
              by = c("target_variable",
                     "location", "location_name",
                     "previous_end_date")) %>%
    filter(is.na(anomaly)) %>%
    select(-anomaly, -previous_end_date)

  data <- scoringutils::merge_pred_and_obs(forecasts, truth,
                                           join = "full")

  message("Scoring all forecasts.")

  scores <- score_forecasts(
    forecasts = data,
    quantiles = get_hub_config("forecast_type")$quantiles
  )

  return(scores)
}


library(data.table)
N = 2e9/8
K = 100

DT <- data.table(
  id4 = sample(K, N, TRUE),                     # small groups (int)
  v1 =  sample(5, N, TRUE)                          # int in range [1,5
)

system.time(DT[, sum(v1),keyby = id4])
system.time(DT[, sum(v1),keyby = id4])

system.time(setkey(DT, id4))

system.time(DT[, sum(v1),id4])
system.time(DT[, sum(v1),id4])


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Martins T.
#' @author: Mendes R.
#' @author: Santos R.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels',"DMwR","recipes","epiR","pubh","leaps",
                "MASS","autoimage","randomForest","settings","factoextra","dummies"))

# Load data ---------------------------------------------------------------
#Load normalized data xlsx
source("src/wrangling.r")
normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

#backup set
temp<-normalizedDataset

#Logistic

###' Debug
normalizedDataset <- temp

include <- c("DistanceHomeOffice","isAfterHours",
             "RoleSatisfaction","isSingle",
             "isMarried","Age",
             "FacilitiesSatisfaction","avgSatisfaction",
             "TenureWorking","NumCompaniesWorked",
             "LastPromotion","MonthlyIncome","isDepartIT",
             "isChurn")

normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% include)]

correlation <- round(cor(normalizedDataset, method = "kendall"), 1)
png(filename="presentations/correlation.png",width=760, height=565)
p<-corr_plot(correlation)
p
dev.off()
p

# Data Partition
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
normalizedDataset$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

png(filename="presentations/stratification.png",width=760, height=565)
p<-stratification(normalizedDataset,trainData,testData)
p
dev.off()
p

# #
trainData$isChurn <- ifelse(trainData$isChurn==1,"Yes","No")
testData$isChurn <- ifelse(testData$isChurn==1,"Yes","No")

#
# #Save test_labels
test_labels <- as.factor(testData$isChurn)
#trainData$isChurn<-as.factor(trainData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

#Setting up CV
ControlParamteres <- trainControl(method="cv",
                                  number=10,
                                  #repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

#regLogistic
log_CV <- train(isChurn~.,
                data=trainData,
                method = "glm",
                #preProc=c("center", "scale"),
                #metric="Accuracy",
                family = binomial(),
                trControl = ControlParamteres)

summary(log_CV)

#The same propotion of target variable is maintained
summary(log_CV$finalModel$data$.outcome)

testData$pred <- predict(log_CV,testData,type = "raw")
testData$prob <-predict(log_CV, testData,type = "prob")[2]
testData$isChurn <- test_labels

g <- roc(isChurn ~ prob$Yes, data =testData )
reset.par()

p<-recordPlot()
plot(g, col = 4, lty = 1,
     main = "ROC", asp = NA,
     xlab = "Specificity (%)",
     ylab = "Sensitivity (%)",
     print.auc=TRUE, type  = 'l', ps=1000)
legend(.40,.75,
       legend=c("13 Predictors CV"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)

png(filename="presentations/roc50PredictorsCV.png",width=760, height=565)
p
dev.off()

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(testData$pred, testData$isChurn, positive = '1',
                             dnn=c("Pred","Actual"))

png(filename="presentations/cm13PredictorsCV.png",width=760, height=565)
draw_confusion_matrix_cv(cm)
dev.off()
draw_confusion_matrix_cv(cm)


install.packages("dplyr")

library(dplyr)

datafile = "VANSASHData.csv"

df = read.csv(datafile,encoding = "Windows-1252",stringsAsFactors = F, header =T)

summary(df)

colnames(df)

head(df)

attach(df)

VWF <- subset(df,Team.in.possession == "Vancouver Whitecaps FC")

VWF <- VWF %>%
filter(!(Action %in% c('direct free kick','penalty')))

GoalIndex <- which(VWF == 'Goal', arr.ind = TRUE)
Goalx <- GoalIndex[,1]

Goalx

Contribute <- c()

for (i in Goalx){
    t <- i
    while (VWF[i,17] !=  VWF[t,9]){
        i <- i-1
    }
    Ass <- VWF[i,17]
    Contribute <- c(Contribute,Ass)
    while (VWF[i,17] !=  VWF[t,9]){
        i <- i-1
    }
    Contribute <- Contribute <- c(Contribute,VWF[i,17])
}

Contribute

Hist <- Rle(sort(Contribute))
Count <- runLength(Hist)

T <- table(Contribute)
plot(T)


library(rstan)
library(tidyverse)
library(lubridate)

load('cleanedData.RData')

dat <- dat%>%filter(!is.na(anxlevel)|!is.na(anyHard)|!is.na(alcCat)|!is.na(Dep_total_G),
  !is.na(Date))%>%
  group_by(StudyId)%>%mutate(ntimes=n())%>%filter(ntimes>1)%>%
  arrange(Date)%>%mutate(time=as.numeric(Date-min(Date))/100)%>%
  ungroup()%>%
  mutate(id=as.numeric(as.factor(StudyId)),
    dep=ifelse(Dep_total_G<3,Dep_total_G,3))

datAnx <- filter(dat,!is.na(anxlevel))
datSub <- filter(dat,!is.na(anyHard))
datAlc <- filter(dat,!is.na(alcCat))
datDep <- filter(dat,!is.na(dep))

stanDat <- list(
  Nanx=nrow(datAnx),
  Nsubj=max(dat$id),
  subjAnx=datAnx$id,
  timeAnx=datAnx$time,
  anx=datAnx$anxlevel,
  Nsub=nrow(datSub),
  subjSub=datSub$id,
  timeSub=datSub$time,
  sub=datSub$anyHard,
  alc=datAlc$alcCat,
  Nalc=nrow(datAlc),
  subjAlc=datAlc$id,
  timeAlc=datAlc$time,
  dep=datDep$dep,
  Ndep=nrow(datDep),
  subjDep=datDep$id,
  timeDep=datDep$time

)

## subject-level covariates

dat$race <- as.factor(dat$Race_R)

covDat <- dat%>%
  dplyr::select(id,age,gender,race,Hispanic_R,Site,ntimes)%>%
  group_by(id)%>%
  summarize_all(function(x) if(any(!is.na(x))) x[!is.na(x)][1] else NA)

## fill in missing values by assumption
covDat$race[is.na(covDat$race)] <- 1

covDat$Hispanic_R[is.na(covDat$Hispanic_R)] <- 2
covDat$hisp <- ifelse(covDat$Hispanic_R==1,1,0)

covDat$gender[is.na(covDat$gender)] <- 1

X <- model.matrix(~age+gender+race+hisp+Site+ntimes,covDat)

stanDat$X <- scale(X[,-1])

stanDat$p <- ncol(X)-1

mod2 <- stan('anxDepSubAlc.stan',data=stanDat,chains=5,iter=5000,cores=5,pars='rand',include=FALSE); save(mod2,file='anxDepSubAlc.RData')

### correlations
omega <- rstan::extract(mod2,'Omega')[[1]]

omegaM <- apply(omega,c(2,3),mean)
omegaP <- apply(omega,c(2,3),function(x) min(mean(x<0),mean(x>0))*2)

omegaM <- omegaM[c(1,2,7,8,5,6,3,4),c(1,2,7,8,5,6,3,4)]
omegaP <- omegaP[c(1,2,7,8,5,6,3,4),c(1,2,7,8,5,6,3,4)]

colnames(omegaM) <- rownames(omegaM) <- colnames(omegaP) <- rownames(omegaP) <-
  paste(rep(c('anx','dep','alc','sub'),each=2),rep(c('int','slope'),4))

slopeR <- omegaM[c(2,4,6,8),c(2,4,6,8)]
intR <- omegaM[c(1,3,5,7),c(1,3,5,7)]
colnames(slopeR) <- rownames(slopeR) <- colnames(intR) <- rownames(intR) <- c('anx','dep','alc','sub')

intSlopeR <- omegaM[c(1,3,5,7),c(2,4,6,8)]
rownames(intSlopeR) <- paste(c('anx','dep','alc','sub'),'int')
colnames(intSlopeR) <- paste(c('anx','dep','alc','sub'),'slope')


cat(Filter(function(x) !is.na(x), sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  if (nchar(s) == 0) {
    return(NA)
  }
  m <- gregexpr("\"id\": \\d+,", s)[[1]]
  if (attr(m, "match.length") == -1) {
    return("0")
  }
  r <- 0
  for (i in m) {
    r <- r + as.integer(gsub("\\D+", "", substr(s, i+5, i+11)))
  }
  r
})), sep="\n")


setwd("~/dev/cuAI/CUTG_ML_paper_datasets/") #yours will be different

myInput <- read.csv("wolfgang_original_CUTG_datafiles/processed_1e3.csv", stringsAsFactors = FALSE) #yours will be different
myInput <- myInput[-3] #remove SpeciesID from ML models #yours will be different

#inspect
table(myInput$Kingdom)
table(myInput$DNAtype)

#recode as factors
myInput$Kingdom <- factor(myInput$Kingdom, levels = c("archaea", "bacteria", "invertebrate", "mammal", "phage", "plasmid", "plant", "primate", "rodent", "virus", "vertebrate"))
myInput$DNAtype <- factor(myInput$DNAtype, levels = c("nuclear", "mitochondrion", "chloroplast"))

#see percentages
round(prop.table(table(myInput$Kingdom)) * 100, digits = 1)
round(prop.table(table(myInput$DNAtype)) * 100, digits = 1)

#chk it
str(myInput)

#---------------------random sampling for training/test data---------------------
set.seed(123)
train_sample <- sample(12980, 10384) #80% training split

myInput_train <- myInput[train_sample, ]
myInput_train_labels <- myInput[train_sample, 2] #DNAtype labels only
myInput_train <- subset(myInput_train, select = -c(Kingdom, DNAtype, Ncodons, SpeciesName))

myInput_test  <- myInput[-train_sample, ]
myInput_test_labels <- myInput[-train_sample, 2] #DNAtype labels only
myInput_test <- subset(myInput_test, select = -c(Kingdom, DNAtype, Ncodons, SpeciesName))

#---------------------k-NN---------------------

#install.packages("class")

myInput_test_pred <- class::knn(train = myInput_train, test = myInput_test, cl = myInput_train_labels, k = 3)

# install.packages("gmodels")
gmodels::CrossTable(x = myInput_test_labels, y = myInput_test_pred, prop.chisq = FALSE)


test<-gam(log(WEIGHT)~as.factor(YEAR)+s(length),gamma=1.4,data=Age_w)
new_data<-subset(Age_w,Age_w$YEAR==1980)
new_data$YEAR=1983
Age_w$WEIGHT[Age_w$YEAR==1980]<-exp(predict(test,newdata=new_data))

Weight<-subset(Age_w,is.na(Age_w$WEIGHT)==F)
WEIGHT<-aggregate(list(WEIGHT=Weight$WEIGHT),by=list(AGE=Weight$AGE1,YEAR=Weight$YEAR),FUN=mean)
grid=expand.grid(YEAR=sort(unique(WEIGHT$YEAR)),AGE=c(min(Age_w$AGE1):15))
WEIGHT_A<-merge(grid,WEIGHT,all=T)
test<-gam(log(WEIGHT)~as.factor(YEAR)+s(AGE,by=as.factor(YEAR)),gamma=1.4,data=subset(WEIGHT_A,is.na(WEIGHT_A$AGE)==F))
WEIGHT_A$pred<-exp(predict(test,newdata=WEIGHT_A))
WEIGHT_A$WEIGHT2<-WEIGHT_A$WEIGHT
WEIGHT_A$WEIGHT2[is.na(WEIGHT_A$WEIGHT2)==T]<-WEIGHT_A$pred[is.na(WEIGHT_A$WEIGHT2)==T]

GRID<-expand.grid(YEARS=c(1978:2011),AGE=c(1:15))
WEIGHT_B<-merge(GRID,WEIGHT_A,all=T)

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1978]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1979]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980]

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1981]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1982]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1984]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1985]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1987]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1988]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1989]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1990]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1992]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1993]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1995]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1996]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1998]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1999]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2001]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2000|WEIGHT_B$YEAR==2002],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2000|WEIGHT_B$YEAR==2002]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2003]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2004|WEIGHT_B$YEAR==2002],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2002|WEIGHT_B$YEAR==2004]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2005]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006|WEIGHT_B$YEAR==2004],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2004|WEIGHT_B$YEAR==2006]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2007]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2008]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2009]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2010]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2011]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]

AGE_WEIGHT<-data.frame(matrix(ncol=15,nrow=length(unique(WEIGHT_B$YEAR))))
names(AGE_WEIGHT)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
AGE_WEIGHT$YEAR<-c(1978:2011)

Years1<-c(1978:2011)
for( i in 1:length(Years1)){
AGE_WEIGHT[i,2:15]<-WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==Years1[i]][2:15]
}


#  James Rekow

aggBaseCaseDOCCreatorSameCohort = function(M = 40, N = 20, iStrength = 1, univ = 1, intIx = NULL,
                                           sigmaMax = 0.1, thresholdMult = 10 ^ (-2), maxSteps = 10 ^ 4,
                                           tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01,
                                           lambda = NULL, numDOC = 10){

  #  ARGS: numDOC - number of DOCs from which the aggregate points should be assembled
  #
  #  RETURNS: aggDOCDF - an aggregate DOC comprised of points from numDOC number of cohorts
  #                      with streamlined interaction steps (e.g. there is a completely connected
  #                      subset of interacting samples and a constellation of non-interacting samples
  #                      that don't interact at all). Each point also has a replicate ID associated with
  #                      it that tracks which replicate it was from, and the number of interacting
  #                      samples (0, 1, or 2) corresponding to it (e.g. if two interacting samples
  #                      are compared to create a DOC point this number would be 2)

  source("DOCProcedure.r")
  source("cohortCreator.r")
  source("eulerIntegrate.r")
  source("intraCohortInteraction_optimizedBaseCase.r")

  #  set default value of lambda
  if(is.null(lambda)){

    lambda = -0.5 * M * log(0.5)

  } #  end if

  #  let half of the samples be interacting samples
  numI = floor(M / 2)

  #  if intIx is not specified, randomly select half of the samples to interact
  if(is.null(intIx)){

    numI = floor(M / 2)
    intIx = sample(1:M, numI)

  } #  end if

  #  create a numerical vector with 1's in positions with the indices of interacting elements
  #  and 0's elsewhere
  intSmpls = rep(0, M)
  intSmpls[intIx] = 1

  #  create a matrix whose columns are each unique pair of sample indices
  pairMat = combn(M, 2)

  #  function to count the number of interacting samples in a vector of sample indices
  intCounter = function(ixVec) sum(intSmpls[ixVec])

  #  numerical vector of the number of samples in each sample pair that were interacting samples
  intCount = apply(pairMat, 2, intCounter)

  #  used to determine if the system is near equilibrium
  threshold = {thresholdMult * tStep} ^ 2

  #  define integrator function to apply eulerIntegrate with desired parameter vals
  integrator = function(smpl){
    return(eulerIntegrate(smpl, threshold = threshold, maxSteps = maxSteps, tStep = tStep))
  } #  end integrator function

  #  create cohort
  chrt = cohortCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax)

  #  integrate samples in the cohort and store the abundance vectors in a list
  abdList = lapply(chrt, integrator)

  produceDOCDF = function(n){

    #  simulate intra-cohort interaction if lambda > 0
    if(lambda > 0){

      #  update the abundances of each sample in the cohort
      for(i in 1:M){
        chrt[[i]][[1]] = abdList[[i]]
      } #  end for

      #  simulate intra-cohort interactions
      intAbdList = intraCohortInteraction_optimizedBaseCase(intIx = intIx, chrt = chrt, M = M, N = N,
                                                            lambda = lambda, threshold = threshold,
                                                            maxSteps = maxSteps, tStep = tStep,
                                                            intTime = intTime,
                                                            interSmplMult = interSmplMult)

    } #  end if

    #  create DOC
    doc = DOCProcedure(intAbdList)

    #  store data in a data frame
    DOCDF = data.frame(replicateID = n, intCount = intCount, over = doc$x, diss = doc$y)

    return(DOCDF)

  } #  end produceDOC function

  #  create a list of replicate data frames
  DOCDFList = lapply(as.list(1:numDOC), produceDOCDF)

  #  aggregate data from the replicates
  aggDOCDF = Reduce(rbind, DOCDFList)

  #  make the intCount variable a factor (mostly for plotting purposes)
  aggDOCDF$intCount = as.factor(aggDOCDF$intCount)

  return(aggDOCDF)

} #  end aggBaseCaseDOCCreatorSameCohort function


##### Box Plots by land use: #############################################################################

xlimits <- c(0.5,4.5)
ylimits <-  c(min(ParamData$storm_loads)/2, max(ParamData$storm_loads)*2)
BoxData <- ParamData
lu      <- c("IND","COM","HDR","LDR")
BoxData$Type <- factor(BoxData$Type, levels = lu)

ndMin   <- c()
ndMax   <- c()
numRows <- c()
detCounts <- c()

j = 1

# Clean the data before plotting
for (use in lu) {
  data     <- BoxData[which(BoxData$Type == use),]
  detcount <- sum(data$nonDetect_Flag == FALSE)
  nd       <- data[which(data$nonDetect_Flag == TRUE),]

  ndMax[j]    <- ifelse(length(nd$sample_loads) > 0, max(nd$sample_loads), 0)
  ndMin[j]    <- ifelse(length(nd$sample_loads) > 0, min(nd$sample_loads), -1)
  numRows[j]  <- nrow(nd)
  detCounts[j]<- detcount

  # Remove land uses with few detections from plotting
  if (detcount < 5 && any(BoxData$Type == use)) {
    BoxData <- BoxData[-which(BoxData$Type == use),]
  }

  j <- j+1
}

nonDetects <- BoxData[which(BoxData$nonDetect_Flag == TRUE),]
colorList <- c("blue", "blue", "blue", "blue")

# Insufficient data plot
if (nrow(BoxData) == 0 ) {
  plot(x=c(1:10), y=c(1:10), type="n", xaxt="n", yaxt="n", xlab="", ylab="", bty="n")
  text(x=5,y=5,"Not Plotted\n(No land use has 5 or more detections)")

# Full boxplot
} else if (nrow(nonDetects) > 0 ) {
  boxplot( sample_loads ~ Type,
           data   = BoxData,
           xaxt   = "n",
           border = colorList,
           log    = "y",
           xlim   = xlimits,
           ylim   = ylimits,
           las    = 2,
           cex.axis=0.8,
           xaxs   = "i",
           yaxs   = "i",
           main   = ""
  )

  # Plot the maximum non-detect for each land use (gray rectangles)
  for (k in 1:length(ndMax)) {
    if (ndMax[k] >= 0) {
      rect(xleft   = -0.5+k,
           xright  = 0.5+k,
           ybottom = ylimits[1],
           ytop    = ndMax[k],
           col     = "gray93",
           border  = "white"
      )
    }
  }

  par(new=TRUE)

  # Now plot over the previous boxplot, so it shows in front of the grey rectangles.

  boxplot(sample_loads ~ Type,
           data  = BoxData,
           xaxt  = "n",
           border= colorList,
           col   = rgb(1,1,1, alpha = 0),
           lty   = "dashed",
           log   = "y",
           xlim  = xlimits,
           ylim  = ylimits,
           ylab  = "Kilograms",
           las   = 2,
           cex.axis=0.8,
           xaxs  = "i",
           yaxs  = "i",
           main  = "\nMass Loads\nby Land Use (kg)"
  )

  # Plot the non-detect limits
  for (k in 1:length(ndMin)) {
    if (ndMin[k] > 0) {

      # Minimum limit
      lines(x   = c(-0.5+k, 0.5+k),
            y   = c(ndMin[k], ndMin[k]),
            lwd = 1,
            col = "red",
            lty = "solid"
      )

      # Maximum limit
      lines(x   = c(-0.5+k, 0.5+k),
            y   = c(ndMax[k], ndMax[k]),
            lwd = 1,
            col = "red",
            lty = "dashed"
      )
    }
  }

} else {
  boxplot( sample_loads ~ Type,
           data = BoxData,
           xaxt = "n",
           border=colorList,
           log  = "y",
           xlim = xlimits,
           ylim = ylimits,
           ylab = "Kilograms",
           las  = 2,
           cex.axis=0.8,
           xaxs = "i",
           yaxs = "i",
           main = "\nBoxplot\nby Land Use",
           cex.axis=0.8)
}

### Axis labels and legend:
if (nrow(BoxData) > 0 ) {
  percentCensor <- numRows
  percentCensor <- percentCensor / ( numRows + detCounts )
  percentCensor <- round(100*percentCensor, 1)

  axislabels <- paste(c("Ind", "Com", "HRes", "LRes"),
                      rep("\nDet=",4), detCounts,
                      rep("\n ND=",4), numRows,
                      rep("\n",4),     percentCensor,
                      rep("%",4),
                      sep="")
  axis(side=1, at=c(1:4), labels=rep("",4))
  mtext(side=1, line=3.5, at=c(1:4), text=axislabels, adj=0.5, padj=0, cex=0.6)

}


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")
library(xlsx)

# 32G 0+2kv 18nl/min

x<-c(2,2.5,3,3.5,4)

y0<-c(33/60,33/60,33.4/60,34/60,34/60)

y1<-c(34/60,35/60,34.5/60,34.5/60,35/60) # 32G,0+2kv,18nl/min

y2<-c(39/80,40/80,42/80,41/80,41/80) # 32G,V1,18nl/min

y3<-c(41/78,40/80,41/80,43/79,38/79) # 32G,V2,18nl/min

y4<-c(39/79,39/79,40/79,40/81,40/81) # 32G,V3,18nl/min

y5<-c(40/79,38/79,43/82,44/80,40/81) # 32G,V1,180nl/min

y6<-c(35/80,34/80,35/80,35/80,36/80) # 32G,V2,180nl/min

y7<-c(36/81,36/81,36/81,36/81,37/81) # 32G,V3,180nl/min

yan<-c("red","blue","black","green3")
pcc<-c(0,1,2,5)

par(mfrow = c(2,1), mar = c(2,2.4,0.8,1), oma = c(1,1,1,1))

plot(x,y1, col=0,xlab = expression(italic(f["v"]) (KHz)),
     ylab = expression(italic(h["m"]/D)), mgp=c(1.1, 0, 0),tck=0.02,
     main = "", xlim = c(2,4),ylim=c(0.2,0.8))

        mtext("18nl/min",3,line=-1,font=2,cex=1)

        lines(x,y0,col=yan[1],pch=pcc[1],type="b",lwd=2,lty=2)
        lines(x,y2,col=yan[2],pch=pcc[2],type="b",lwd=2,lty=2)
        lines(x,y3,col=yan[3],pch=pcc[3],type="b",lwd=2,lty=2)
        lines(x,y4,col=yan[4],pch=pcc[4],type="b",lwd=2,lty=2)

        leg<-c("0+2kv-18nl/min","1.7kv+2kv-18nl/min",
        "1.8kv-2kv-18nl/min","1.9kv-2kv-18nl/min")

        legend("bottomright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.01,cex=0.8,bty="n")

        plot(x,y1, col=0,xlab = expression(italic(f["v"]) (KHz)),
             ylab = expression(italic(h["m"]/D)), mgp=c(1.1, 0, 0),tck=0.02,
             main = "", xlim = c(2,4),ylim=c(0.2,0.8))

                mtext("180nl/min",3,line=-1,font=2,cex=1)

                lines(x,y1,col=yan[1],pch=pcc[1],type="b",lwd=2,lty=2)
                lines(x,y5,col=yan[2],pch=pcc[2],type="b",lwd=2,lty=2)
                lines(x,y6,col=yan[3],pch=pcc[3],type="b",lwd=2,lty=2)
                lines(x,y7,col=yan[4],pch=pcc[4],type="b",lwd=2,lty=2)

        leg2<-c("0-2kv-180nl/min","1.7kv-2kv-180nl/min",
        "1.8kv-2kv-180nl/min","1.9kv-2kv-180nl/min")
        legend("bottomright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.01,cex=0.8,bty="n")


## -----------
## Function file associated with LinkMODdat_Grid.r
## -----------

ExtrUIDs <- function(colstrings){
  liststr <- strsplit(colstrings, ",")
  charvec <- str_trim(gsub("[[:punct:]]|c", "", liststr[[1]]))
  return(charvec)
}

CalcVals <- function(Griddat, MODdat, scale) {
  require(modeest)
  UIDframe <- cbind.data.frame(ExtrUIDs(Griddat[,3]))
  colnames(UIDframe) <- "UID"
  #UIDframe <- as.data.frame(UIDframe[which(!(substr(UIDframe$UID, 7, 15) %in% rmlist)),])
  #colnames(UIDframe) <- "UID"
  Tog <- merge(UIDframe, MODdat, by="UID")
  Tog$CloudPhase <- ifelse(Tog$CloudPhase == 0, NA, Tog$CloudPhase)
  Tog$CloudEmiss <- ifelse(Tog$CloudEmiss==127, NA, Tog$CloudEmiss)*scale
  Tog$CloudFrac <- ifelse(Tog$CloudFrac == 127, NA, Tog$CloudFrac)*scale
  CP <- mfv(Tog$CloudPhase)
  CE <- mean(Tog$CloudEmiss, na.rm=T)
  CF <- mean(Tog$CloudFrac, na.rm=T)
  Outp <- cbind.data.frame(CP, CE, CF)
  return(Outp)
}

CalcValsTime <- function(Griddat, MODdat){
  UIDframe <- cbind.data.frame(ExtrUIDs(Griddat[,3]))
  colnames(UIDframe) <- "UID"
  Tog <- merge(UIDframe, MODdat, by="UID")
  Time <- median(Tog$timestamp)
  Outp <- cbind.data.frame(Time)
  return(Outp)
}


library(clinfun)
source(file.path(PROJECT_DIR, "R/functions/gg_color_hue.r"))

fn.si = file.path(PROJECT_DIR, "generated_data", "HIPC", "HIPC_cd38_ge_sig_score.txt")
info = fread(fn.si)%>%
  dplyr::filter(Response %in% c("low","middle","high")) %>%
  mutate(Response = factor(Response, levels=c("low","middle","high")))

sdy = data.frame(Study = c("SDY212", "SDY400", "SDY404"),
                 label = c("Stanford 2008", "Yale 2012", "Yale 2011"))

info = info %>%
  inner_join(sdy, by="Study")

df.text = data.frame()

for (study in unique(info$Study)) {
  tinfo = info %>% dplyr::filter(Study == study)

  j.pv = jonckheere.test(tinfo$CD38_score, as.numeric(tinfo$Response), alternative="inc")$p.value

  df.text = rbind(df.text,
                  data.frame(Study = study, #label.auc=sprintf("AUC = %.2f\np = %.2g", r$auc, r.p),
                             label.j.pv=sprintf("p = %.2g", j.pv)))
}

df.text$x = rep(0.25,3)
df.text$y = rep(0.1,3)
df.text = df.text %>%
  inner_join(sdy, by="Study")

# Generate boxplots

clr = gg_color_hue(4) %>% rev()

ggplot(info, aes(x=Response, y=CD38_score, group=Response)) +
  geom_boxplot(aes(fill=label), alpha=0.5, outlier.colour = NA) +
  geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
  facet_wrap(~label, nrow=1) +
  scale_fill_manual(values=c("black", "white", "grey35", clr[1:3]), name="Response",
                    breaks=c(0,1,2), labels=c("low","middle","high")) +
  geom_text(data = df.text, aes(label=label.j.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
  xlab("Response") + ylab("Baseline signature score") +
  coord_cartesian(xlim=c(0.8, 3.2)) +
  theme_bw() + theme(legend.position="none") +
  theme(panel.border = element_blank(), strip.background = element_blank(),
        strip.text.x = element_text(size=12),
        panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
        axis.ticks = element_blank())

fn.fig = file.path(PROJECT_DIR, "figure_generation", "HIPC_CD38.10gene.sig_with_mid_Jonckheere")
ggsave(paste0(fn.fig, ".png"), w=7,h=4)
ggsave(paste0(fn.fig, ".pdf"), w=7,h=4)


#!/usr/bin/env Rscript
# Model relative celltype abundance with a Dirichlet model
#  Combiz Khozoie <c.khozoie@imperial.ac.uk>

#   ____________________________________________________________________________
#   Initialization                                                          ####

options(mc.cores = future::availableCores())

##  ............................................................................
##  Load packages                                                           ####
library(argparse)
library(scFlow)
library(cli)

##  ............................................................................
##  Parse command-line arguments                                            ####

# create parser object
parser <- ArgumentParser()

# specify options
required <- parser$add_argument_group("Required", "required arguments")
optional <- parser$add_argument_group("Optional", "required arguments")

required$add_argument(
  "--sce_path",
  help = "path to SingleCellExperiment directory",
  metavar = "/dir/sce/",
  required = TRUE
)

required$add_argument(
  "--unique_id_var",
  help = "unique sample variable name",
  metavar = "manifest",
  required = TRUE
)

required$add_argument(
  "--celltype_var",
  help = "celltype variable name",
  metavar = "cluster_celltype",
  required = TRUE
)

required$add_argument(
  "--dependent_var",
  help = "name of the dependent variable",
  metavar = "group",
  required = TRUE
)

required$add_argument(
  "--ref_class",
  help = "class of the reference variable withing dependent_var",
  metavar = "control",
  required = TRUE
)

required$add_argument(
  "--var_order",
  help = "factor order for dependent variable",
  metavar = "c",
  required = TRUE
)

# get command line options, if help option encountered print help and exit,
# otherwise if options not found on command line then set defaults
args <- parser$parse_args()
args$var_order <- strsplit(args$var_order, ",")[[1]]
if (tolower(args$var_order) == "null") { args$var_order <- NULL }

#   ____________________________________________________________________________
#   Start                                                                   ####

sce <- read_sce(args$sce_path)

results <- model_celltype_freqs(
  sce,
  unique_id_var = args$unique_id_var,
  celltype_var = args$celltype_var,
  dependent_var = args$dependent_var,
  ref_class = args$ref_class,
  var_order = args$var_order
)

## ............................................................................
## Save Outputs ####

new_dirs <- c(
  "dirichlet_report"
)

#make dirs
purrr::walk(new_dirs, ~ dir.create(file.path(getwd(), .)))

report_celltype_model(
  results,
  report_folder_path = file.path(
    getwd(),
    "dirichlet_report"
  ),
  report_file = paste0(
    args$celltype_var,
    args$dependent_var,
    "dirichlet_report",
    sep = "_")
)


library(rrBLUP)
set.seed(42)
args = commandArgs(trailingOnly=TRUE)
X_file <- args[1]
Y_file <- args[2]
test_file <- args[3]

Y <- read.csv(Y_file, row.names=1)
X <- read.csv(X_file, row.names=1)
Test <- read.table(test_file, head=F,sep='\t',stringsAsFactors=F)

X_test <- X[Test[,1],]
Y_test <- Y[Test[,1],]
X <- X[!rownames(X) %in% Test[,1],]
Y <- Y[!rownames(Y) %in% Test[,1],]
write.csv(X,'geno_training.csv',row.names=T,quote=F)
write.csv(Y,'pheno_training.csv',row.names=T,quote=F)
write.csv(X_test,'geno_test.csv',row.names=T,quote=F)
write.csv(Y_test,'pheno_test.csv',row.names=T,quote=F)


require(lattice)

grid=list();
grid$arr_mod=vector();
grid$arr_tx=vector();
grid$thr=vector();

filename="trace-ma-eb"

data = read.table(filename);

len = length(data[[1]])

for( i in 1:len )
{

	grid$arr_mod=c(grid$arr_mod, data[[1]][[i]])
	grid$arr_tx=c(grid$arr_tx, data[[2]][[i]])
	grid$arr_thr=c(grid$arr_thr, data[[3]][[i]])

}

wireframe( arr_thr~arr_mod * arr_tx, grid, drape=TRUE, aspect = c(1, 0.4),  colorkey=TRUE, default.scales = list(distance = c(1, 1, 1), arrows=FALSE), screen = list(z = -40, x = -60) )


args <- commandArgs(trailingOnly = TRUE)
targetExpressionFile <- toString(args[1])
regulatorExpressionFile <- toString(args[2])
allowedMatrixFile <- toString(args[3])
perturbationMatrixFile <- toString(args[4])
differentialExpressionMatrixFile <- toString(args[5])
microarrayFlag <- as.integer(args[6])
nonGlobalShrinkageFlag <- as.integer(args[7])
lassoAdjMtrFileName <- toString(args[8])
combinedAdjMtrFileName <- toString(args[9])
outputDirectory <- toString(args[10])
combinedAdjLstFileName <- toString(args[11])
regulatorGeneNamesFileName <- toString(args[12])
targetGeneNamesFileName <- toString(args[13])

source("global.lars.regulators.r")

tdata <- as.matrix(read.table(targetExpressionFile))
rdata <- as.matrix(read.table(regulatorExpressionFile))
allowed <- as.matrix(read.table(allowedMatrixFile))
pert <- as.matrix(read.table(perturbationMatrixFile))
de_component <- as.matrix(read.table(differentialExpressionMatrixFile))
targets <- seq(dim(tdata)[1])

if(microarrayFlag == 0) {
	##RNA-Seq Data
	tdata <- log(tdata+1)/log(2)
	rdata <- log(rdata+1)/log(2)
}

## Skip regression on some genes
cat("Gene skipped count:")
skip_gen <- rep(0, dim(tdata)[1])
for (i in 1:dim(tdata)[1]) {
	if (sum(tdata[i,] != 0) < dim(tdata)[2]/10+1) {
		skip_gen[i] = 1
	}
}
cat(length(which(skip_gen == 1)), "\nRegulator skipped:")
skip_reg <- rep(0, dim(rdata)[1])
for (i in 1:dim(rdata)[1]) {
	if (sum(rdata[i,] != 0) < 1) {
		skip_reg[i] = 1
		cat(i, ",")
	}
}
cat("\n")

## Center data
tdata <- tdata - apply(tdata,1,mean)
rdata <- rdata - apply(rdata,1,mean)

## Scale data
t.sd <- apply(tdata,1,sd)
t.sdfloor <- mean(t.sd) + sd(t.sd)
t.norm <- apply(rbind(rep(t.sdfloor,times=length(t.sd)),t.sd),2,max) / sqrt(dim(tdata)[2])
tdata <- tdata / ( t.norm * sqrt(dim(tdata)[2]-1) )
# tdata <- tdata / t.sd
#
r.sd <- apply(rdata,1,sd)
r.sdfloor <- mean(r.sd) + sd(r.sd)
r.norm <- apply(rbind(rep(r.sdfloor,times=length(r.sd)),r.sd),2,max) / sqrt(dim(rdata)[2])
rdata <- rdata / ( r.norm * sqrt(dim(rdata)[2]-1) )
# rdata <- rdata / r.sd

## Compute unweighted solution
prior <- matrix(1,ncol=dim(tdata)[1] ,nrow=dim(rdata)[1] )

## TODO: Both seed and # of cv folds (in global.lars.regulators.r) are parameters that should be exposed to the user
seed <- 747
set.seed(seed)

if (nonGlobalShrinkageFlag == 1) {
	uniform.solution <- lars.local(tdata,rdata,pert,prior,allowed,skip_reg,skip_gen)
} else {
	uniform.solution <- lars.multi.optimize(tdata,rdata,pert,prior,allowed)
}

lasso_component <- uniform.solution[[1]]
write.table(lasso_component,file.path(outputDirectory,lassoAdjMtrFileName),row.names=FALSE,col.names=FALSE,quote=FALSE)

## Perform model averaging to get final NetProphet Predictions
source("combine_models.r")

# if(length(args) == 13 & file.exists(regulatorGeneNamesFileName) & file.exists(targetGeneNamesFileName)){
# 	source("make_adjacency_list.r")
# }


# fit prior models for bacterial taxa and functional groups
# from Delgado-Baquerizo et al. 2018 and Ramirez et al. 2018

rm(list = ls())
cat(paste0("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
           Running script at ", Sys.time(),
           "\n\n\n\n\n\n"))
library(data.table)
library(doParallel)
library(dplyr)
source('NEFI_functions/tic_toc.r')
source('NEFI_functions/crib_fun.r')
source('paths.r')
source('paths_fall2019.r')
source('NEFI_functions/ddirch_site.level_JAGS_study.effects.r')

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

# set output path and predictors of interest

  output.path <- prior_delgado_ddirch_16S.path
  preds <- c("NPP","map","mat","relEM","pH","study_id")

# read in data
y.all <- readRDS(delgado_ramirez_abun.path)
d <- readRDS(delgado_ramirez_bahram_mapping.path)

# format data
x <- d
rownames(x) <- x$sampleID
x <- x[,colnames(x) %in% preds]
#x <- x[1:400,] # testing

intercept <- rep(1, nrow(x))
x <- cbind(intercept, x)
d <- x

#fit model using function.
cat('Begin model fitting loop...\n')
tic()
output.list <-
  foreach(i = 1:length(y.all)) %dopar% {
    #foreach(i = 18:18) %dopar% {
      # i <- 18
    y <- y.all[[i]]
    # ensure "other" column is first
    y <- y %>% dplyr::select(other, everything())
    y <- as.data.frame(y)
    x <- d[complete.cases(d),]
    y <- y[complete.cases(y),]
    x <- x[rownames(x) %in% rownames(y),]
    y <- y[rownames(y) %in% rownames(x),]
    y <- y[match(rownames(x), rownames(y)),] #order abundance table to match the metadata file

    # study_id as integer
    study_id <- as.integer(as.factor(x$study_id))
    x$study_id <- NULL

    if(!sum(rownames(y) == rownames(x)) == nrow(y)){
      cat('Warning. x and y covariates not in the same order!')
    }

    fit <- site.level_dirlichet_jags(y=y,x_mu=x,
                                    #adapt = 20001, burnin = 10002, sample = 3003,
                                     #adapt = 501, burnin = 102, sample = 503,
                                     adapt = 60001, burnin = 15002, sample = 5003,
                                     parallel = T,
                                     parallel_method="parallel",
                                     #parallel_method='simple',
                                     study_id = study_id,
                                     jags.path = "/share/pkg.7/jags/4.3.0/install/bin/jags",
                                     thin = 10)

cat(paste("Model fit for", names(y.all)[i], "\n"))
return(fit)    #allows nested loop to work.
}
cat('Model fitting loop complete! ')
toc()

#output.list <- fit
names(output.list) <- names(y.all)

saveRDS(output.list, output.path)


#' Iterator that iterates through several iterables concurrently.
#'
#' The resulting iterator aggregates elements from each of the iterables into a
#' list from each iteration. Used for lock-step iteration over several iterables
#' at a time.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param ... multiple arguments to iterate through in sequence
#' @return iterator that iterates through each argument in sequence
#'
#' @examples
#' it <- izip(x=1:3, y=4:6, z=7:9)
#' iterators::nextElem(it) # list(x=1, y=4, z=7)
#' iterators::nextElem(it) # list(x=2, y=5, z=8)
#' iterators::nextElem(it) # list(x=3, y=6, z=9)
#'
#' # Sums the zip'd elements. 1 + 4 + 7, and so on.
#' it2 <- izip(1:3, 4:6, 7:9)
#' sum_zip <- sapply(it2, function(x) sum(unlist(x)))
#' sum_zip == c(12, 15, 18)
#'
#' it3 <- izip(a=1:3, b=4:42, class=levels(iris$Species))
#' iterators::nextElem(it3) # list(a=1, b=4, class="setosa")
#' iterators::nextElem(it3) # list(a=2, b=5, class="versicolor")
#' iterators::nextElem(it3) # list(a=3, b=6, class="virginica")
izip <- function(...) {
  iter_list <- lapply(list(...), iter)
  if (length(iter_list) == 0) {
    stop("At least one argument must be supplied.")
  }

  # TODO: Introduce iterators:::hasNext() to circumvent catching StopIteration?
  #       See the iterators vignette for details.
  nextElem <- function() {
    next_elem <- lapply(iter_list, function(x) {
      try(iterators::nextElem(x), silent=TRUE)
    })

    any_stopped <- any(sapply(next_elem, stop_iteration))
    if (any_stopped) {
      stop("StopIteration", call.=FALSE)
    }
    next_elem
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


require(graphics)
require(Matrix)

pdf(file="plots/Experiment2b.pdf",
  width=4.5, height=4.0, family="serif", pointsize=14)

data1 = read.table("results/Experiment2_Covtype.dat", sep=",")[,2:3]
data2 = read.table("results/Experiment2_USCensus.dat", sep=",")[,2:3]
data3 = read.table("results/Experiment2_KDD98.dat", sep=",")[,2:3]

data1 = t(rbind(as.matrix(data3),matrix(1,1,2),
      as.matrix(data2),matrix(1,1,2),as.matrix(data1)))

plot_colors <- c("cornflowerblue","black")

barplot( data1,
         space = c(0, 0.3),
         xlab = "",
         ylab = "",
         col=plot_colors,
         ylim = c(1,25000000),
         log = "y",
         axes = FALSE,
         names.arg = c("1","2","3","","1","2","3","4","","1","2","3"),
         cex.names=0.96,
         args.legend = list(x="topright", bty="n", bty="n", ncol=1),
         legend.text = c("Evaluated Slices", expression(paste("Valid Slices (",sigma,")"))),
         beside = TRUE,
         line = -0.9
)

axis(2, las=1, at=c(1,10,100,1000,1e4,1e5,1e6,1e7), labels=c("1","10","100","1000","1e4","1e5","1e6","1e7"))
mtext(2,text="# Enumerated Slices",line=2.7)
axis(1, las=1, at=c(3.0,14,24.8), labels=c("KDD98","USCensus","Covtype") )
#mtext(1,text="Datasets",line=2)

box()	              # box around plot
dev.off()


source("sample/R/heatmap_f.r") ##reading tiny R script
cols <- colorRampPalette(c("white","darkred")) ##setting colors from white to darkred

df <- read.delim ("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize300step10_all.txt") ##reading output file of ga_reads_summit_all
df.sort <- df[order(apply(df[,91:111], MARGIN=1, mean)),] ##sorting by means of win for -100 bp to +100 bp (win for center, 0 bp, is element of 101)
df.sort.norm.all <- return_mat_norm_all(df.sort, 0.99)

png("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize300step10_all.png",height=675)
image(seq(from=-1000, to=1000, by = 10),1:nrow(df.sort.norm.all),as.matrix(t(df.sort.norm.all)), col= cols(100), main="Enrichment of chip1 around peak1\nsorted by -100 to 100 bp enrichment", xlab="Distance from peak1 summits (bp)", ylab="peak1", xlim=c(-1000, 1300), bty="n") ; abline(v=0)
rect(1100, seq(from=10, to=109, by=1), 1200, seq(from=11, to=110,by=1),col=cols(100),border="transparent")
text(x=1250, y=10, "0")
text(x=1250, y=109, "1")
dev.off()


jackknifeCPUE<-function(data,err='se',grouping){
	#Smith 1980 CJFAS
	#grouping = c('month','year')
	#data must contain catch and effort columns
	if(!all(c('catch','effort') %in% names(data))) stop('Data frame must contain columns named catch and effort')
	a = Sys.time()
		data$grp = data[,grouping]
		if(length(grouping)>1) data$grp = apply( data[,grouping] , 1 , paste , collapse = "." )
		data$n = 1
		Cf<-aggregate(cbind(catch,effort,n)~grp,data=data,FUN=sum)
		Cf$Cf<-with(Cf,catch/effort)
		ng = length(grouping)
		ap = as.data.frame(matrix(NA,ncol=ng,nrow=nrow(Cf)))
		names(ap) = grouping
		out.dat<-cbind(data.frame(Cf,cpue=NA,cpue.var=NA),ap)
		nc = ncol(out.dat)
	for (i in 1:nrow(out.dat)){
		io = out.dat[i,]
		dp = data[which(data$grp==io$grp),]
		iu = unlist(strsplit(io$grp,"[.]"))
		iun = length(iu)
		out.dat[i,(nc-(iun-1)):nc] <- iu
	if(io$n>1){
			Rj<-c()
			for (j in 1:io$n){
				Rj[j]<-io$n * io$Cf - (io$n-1)*(sum(dp$catch[-j])/sum(dp$effort[-j]))
			}

			out.dat$cpue[i]<-mean(Rj)
		if(err=='sd')out.dat$cpue.var[i]<-var(Rj)
		if(err=='se')out.dat$cpue.var[i]<-1/(io$n*(io$n-1))*sum((Rj-mean(Rj))^2)
		}
	}
	out.dat$grp = NULL
	return(out.dat)
	}


#' Bounded coefficient differential expression
#'
#' @param x  a gene expression matrix (genes x samples)
#' @param design  the model to fit for each gene, e.g. '~ condition'
#' @param weights  weight vector for all coefficients
#' @param offset  vector of coefficient offsets of length 'n'
#' @param lower  named vector of coefficient lower bounds (-Inf otherwise)
#' @param upper  named vector of coefficient upper bounds (Inf otherwise)
#' @param control  named list of control variables for fit (e.g. maxiter)
#' @param reduced  the reduced model for a likelihood ratio test
#' @param verbose  print debug messages
#' @export
boundie = function(x, design, weights=rep(1, ncol(x)), offset=rep(0, ncol(x)),
                   lower=NULL, upper=NULL, control=list(), reduced=NULL,
                   verbose=FALSE) {
    fit_one = function(gene) {
        assign("y", x[gene,], envir=ee)

        mf = stats::model.frame(fml, w=w, o=o)
        terms = attr(mf, "terms")
        x = stats::model.matrix(terms, mf)
        y = stats::model.response(mf)
        w = stats::model.extract(mf, "w")
        o = stats::model.extract(mf, "o")

        valid = c(colnames(x), "theta")
        lower = lower[names(lower) %in% valid]
        upper = upper[names(upper) %in% valid]
        # log(.Machine$double.min/max.exp) == 0, hence 100
        dn = stats::setNames(c(rep(-Inf, ncol(x)), -100), valid)
        up = stats::setNames(c(rep(Inf, ncol(x)), 100), valid)
        dn[names(lower)] = unlist(lower)
        up[names(upper)] = unlist(upper)

        tfun(x, y, weights=w, offset=o, control=control,
             lower=dn, upper=up)
    }

    if (!class(design) == "formula" || length(design) != 2)
        stop("'design' needs to be a right-handed formula")

    ee = new.env(parent=environment(design))
    fml = stats::as.formula(paste("y ~", as.character(design)[2]), env=ee)
    assign("w", weights, envir=ee)
    assign("o", offset, envir=ee)

    if (is.null(reduced))
        tfun = wald
    else
        tfun = function(...) lrt(..., reduced=all.vars(reduced))

    res = lapply(rownames(x), function(x) try(fit_one(x)))

    success = sapply(res, function(x) class(x) != "try-error")
    if (any(!success))
        warning(sum(!success), " fits failed: ",
                paste(rownames(x)[!success], collapse=", "))

    res = res[success]
    coefs = do.call(rbind, res)
    data.frame(gene = rownames(x)[success], coefs, check.names=FALSE)
}


require(stringr)
require(gridExtra)

RotorsReflectors <- function(name,newL=NULL){
  #Rotor 1
  I     <- list("EKMFLGDQVZNTOWYHXUSPAIBRCJ","Q")
  names(I) <- c("Enc","Step")

  #Rotor 2
  II    <- list("AJDKSIRUXBLHWTMCQGZNPYFVOE","E")
  names(II) <- c("Enc","Step")

  #Rotor 3
  III   <- list("BDFHJLCPRTXVZNYEIWGAKMUSQO","V")
  names(III) <- c("Enc","Step")

  #Rotor 4
  IV    <- list("ESOVPZJAYQUIRHXLNFTGKDCMWB","J")
  names(IV) <- c("Enc","Step")

  #Rotor 5
  V     <- list("VZBRGITYUPSDNHLXAWMJQOFECK","Z")
  names(V) <- c("Enc","Step")

  #Rotor 6
  VI    <- list("JPGVOUMFYQBENHZRDKASXLICTW",c("Z","M"))
  names(V) <- c("Enc","Step")

  #Rotor 7
  VII   <- list("NZJHGRCXMYSWBOUFAIVLPEKQDT",c("Z","M"))
  names(VII) <- c("Enc","Step")

  #Rotor 8
  VIII  <- list("FKQHTLXOCBJSPDZRAMEWNIUYGV",c("Z","M"))
  names(VIII) <- c("Enc","Step")

  #Rotor Beta
  Beta  <- list("LEYJVCNIXWPBQMDRTAKZGFUHOS",NULL)
  names(Beta) <- c("Enc","Step")

  #Rotor Gamma
  Gamma <- list("FSOKANUERHMBTIYCWLQPZXVGJD",NULL)
  names(Gamma) <- c("Enc","Step")

  RefB  <- list("YRUHQSLDPXNGOKMIEBFZCWVJAT",NULL)
  names(RefB) <- "Enc"

  RefC  <- list("FVPJIAOYEDRZXWGCTKUQSBNMHL",NULL)
  names(RefC) <- "Enc"

  RefBt <- list("ENKQAUYWJICOPBLMDXZVFTHRGS",NULL)
  names(RefBt) <- "Enc"

  RefCt <- list("RDOBJNTKVEHMLFCWZAXGYIPSUQ",NULL)
  names(RefCt) <- "Enc"

  RotRef <- list(I,II,III,IV,V,VI,VII,VIII,Beta,Gamma,RefB,RefC,RefBt,RefCt)
  names(RotRef) <- c("I","II","III","IV","V","VI","VII","VIII","Beta","Gamma","RefB","RefC","RefBt","RefCt")

  if(!is.null(newL)){
    NewR <- list()
    for(i in 1:length(newL)){
      New <- list(newL[[i]][[1]],newL[[i]][[2]])
      names(New) <- c("Enc","Step")
      NewR[[i]] <- New
      names(NewR)[i] <- names(newL)[i]
    }
    RotRef <- c(RotRef,NewR)
  }
  return(RotRef[[name]])
}

C26 <- function(x){
  if(x < 1) x <- 26 + x
  if(x >26) x <- x - 26
  return(x)
}

EnigmaIntF <- function(InpL,
                       InpSf,OutSf,
                       InpR1f,IntR1f,DecR1f,OutR1f,
                       InpR2f=NULL,IntR2f,DecR2f,OutR2f,
                       InpR3f=NULL,IntR3f,DecR3f,OutR3f,
                       InpRe,OutRe,
                       InpR3f,IntR3f,DecR3f,OutR3f,
                       InpR2f=NULL,IntR2f,DecR2f,OutR2f,
                       InpR1f=NULL,IntR1f,DecR1f,OutR1f
                       InpSb,OutSb,
                       OutL,
                       RS1,RS2,RS3,RP1,RP2,RP3
                       ){
  FrameEnig <- data.frame(vInpL=LETTERS,vInpSf=LETTERS,vOutSf=LETTERS,
             #Rotor1
             vInpR1f=LETTERS,
             vIntR1f=c(LETTERS[(C26(RP1-RS1)+1):26],LETTERS[0:(C26(RP1-RS1))]),
             vDecR1f=c(LETTERS[(C26(RP1-RS1)+1):26],LETTERS[0:(C26(RP1-RS1))]),
             vRinR1f=c(LETTERS[(C26(RP1):26)],LETTERS[0:(C26(RP1)-1)]),
             vOutR1f=LETTERS,
             #Rotor2
             vIntR2f=c(LETTERS[(C26(RP2-RS2)+1):26],LETTERS[0:(C26(RP2-RS2))]),
             vDecR2f=c(LETTERS[(C26(RP2-RS2)+1):26],LETTERS[0:(C26(RP2-RS2))]),
             vRinR2f=c(LETTERS[(C26(RP2):26)],LETTERS[0:(C26(RP2)-1)]),
             vOutR2f=LETTERS,
             #Rotor3
             vIntR3f=c(LETTERS[(C26(RP3-RS3)+1):26],LETTERS[0:(C26(RP3-RS3))]),
             vDecR3f=c(LETTERS[(C26(RP3-RS3)+1):26],LETTERS[0:(C26(RP3-RS3))]),
             vRinR3f=c(LETTERS[(C26(RP3):26)],LETTERS[0:(C26(RP3)-1)]),
             vOutR3f=LETTERS,
             #Reflector
             vRef=LETTERS)
             #Rotor3

}

EnigmaExtF <- function(InpL=NULL,OutL=NULL,RotorPos){
  KeyBoard <-
    data.frame(Symb = c("Q","W","E","R","T","Z","U","I","O",
                        "A","S","D","F","G","H","J","K",
                        "P","Y","X","C","V","B","N","M","L"),
               X = c(seq(from = 1,by = 2, length.out = 9),
                     seq(from = 2,by = 2, length.out = 8),
                     seq(from = 1,by = 2, length.out = 9)
               ),
               Y = c(3,3,3,3,3,3,3,3,3,
                     2,2,2,2,2,2,2,2,
                     1,1,1,1,1,1,1,1,1),
               stringsAsFactors = FALSE
    )

  pushViewport(viewport(layout = grid.layout(nrow=7, ncol=17,
                                             widths  = unit(c(rep(1,17)), "null"),
                                             heights = unit(c(1, 1, 1, 1, 1, 1, 1), "null")
  )))

  grid.rect(gp=gpar(fill="grey"))
  grid.rect(gp=gpar(fill ="light grey"),vp = viewport(layout.pos.row = 1, layout.pos.col = 4))
  grid.rect(gp=gpar(fill ="light grey"),vp = viewport(layout.pos.row = 1, layout.pos.col = 6))
  grid.rect(gp=gpar(fill ="light grey"),vp = viewport(layout.pos.row = 1, layout.pos.col = 8))

  grid.text(RotorPos[1], vp = viewport(layout.pos.row = 1, layout.pos.col = 4), gp=gpar(col="black", fontsize=12))
  grid.text(RotorPos[2], vp = viewport(layout.pos.row = 1, layout.pos.col = 6), gp=gpar(col="black", fontsize=12))
  grid.text(RotorPos[3], vp = viewport(layout.pos.row = 1, layout.pos.col = 8), gp=gpar(col="black", fontsize=12))

  for(i in 1:nrow(KeyBoard)){
    grid.circle(r= .25, gp=gpar(col="white", fill="black"), vp = viewport(layout.pos.row = KeyBoard[i,"Y"] + 4, layout.pos.col = KeyBoard[i,"X"]))
    grid.circle(r= .25, gp=gpar(col="grey", fill="darkgray"), vp = viewport(layout.pos.row = KeyBoard[i,"Y"] + 1, layout.pos.col = KeyBoard[i,"X"]))
    grid.text(KeyBoard[i,"Symb"], vp = viewport(layout.pos.row = KeyBoard[i,"Y"] + 4, layout.pos.col = KeyBoard[i,"X"]), gp=gpar(col="white", fontsize=12))
    grid.text(KeyBoard[i,"Symb"], vp = viewport(layout.pos.row = KeyBoard[i,"Y"] + 1, layout.pos.col = KeyBoard[i,"X"]), gp=gpar(col="black", fontsize=12))
  }

  if(!is.null(InpL)){
  grid.circle(r= .25, gp=gpar(col="white", fill="pink"), vp = viewport(layout.pos.row = KeyBoard[KeyBoard$Symb == InpL,"Y"] + 4, layout.pos.col = KeyBoard[KeyBoard$Symb == InpL,"X"]))
  grid.text(KeyBoard[KeyBoard$Symb == InpL,"Symb"], vp = viewport(layout.pos.row = KeyBoard[KeyBoard$Symb == InpL,"Y"] + 4, layout.pos.col = KeyBoard[KeyBoard$Symb == InpL,"X"]), gp=gpar(col="black", fontsize=12))
  }

  if(!is.null(OutL)){
  grid.circle(r= .25, gp=gpar(col="grey", fill="yellow"), vp = viewport(layout.pos.row = KeyBoard[KeyBoard$Symb == OutL,"Y"] + 1, layout.pos.col = KeyBoard[KeyBoard$Symb == OutL,"X"]))
  grid.text(KeyBoard[KeyBoard$Symb == OutL,"Symb"], vp = viewport(layout.pos.row = KeyBoard[KeyBoard$Symb == OutL,"Y"] + 1, layout.pos.col = KeyBoard[KeyBoard$Symb == OutL,"X"]), gp=gpar(col="black", fontsize=12))
  }
}

Enigma <- function(Rotors = c("III","II","I"), RingSetting = c(1,1,1), RotorPos = c("A","A","A"), Reflector = "RefB", Plugboard = NULL, Text = "HENK", Figure = FALSE, Helper = NULL, NewRotRef = NULL){

  if(!any(Rotors[length(Rotors)] == c("I","II","III","IV","V","VI","VII","VIII","Beta","Gamma",names(NewRotRef)))) stop("Non existing name for Rotor 1")
  if(!any(Rotors[length(Rotors) - 1] == c("I","II","III","IV","V","VI","VII","VIII","Beta","Gamma",names(NewRotRef)))) stop("Non existing name for Rotor 2")
  if(!any(Rotors[length(Rotors) - 2] == c("I","II","III","IV","V","VI","VII","VIII","Beta","Gamma",names(NewRotRef)))) stop("Non existing name for Rotor 3")
  if(any(Rotors[length(Rotors)] == c("Beta","Gamma"))) warning("The Beta and/or Gamma rotor could only placed as fourth rotor")
  if(any(Rotors[length(Rotors) - 1] == c("Beta","Gamma"))) warning("The Beta and/or Gamma rotor could only placed as fourth rotor")
  if(any(Rotors[length(Rotors) - 2] == c("Beta","Gamma"))) warning("The Beta and/or Gamma rotor could only placed as fourth rotor")
  if(length(Rotors) == 4) if(!any(Rotors[length(Rotors) - 3] == c("I","II","III","IV","V","VI","VII","VIII","Beta","Gamma",names(NewRotRef)))) stop("Non existing name for Rotor 4")
  if(length(Rotors) == 4) if(any(Rotors[length(Rotors) - 3] == c("I","II","III","IV","V","VI","VII","VIII"))) warning("Only the Beta and Gamma rotor could be placed as fourth Rotor")
  if(!any(Reflector == c("RefB","RefC","RefBt","RefCt",names(NewRotRef)))) stop("Non existing name for the Reflector")
  if(length(Rotors) > 4 | length(Rotors) < 3) stop("Not enough/too many Rotors")
  if(length(RingSetting) > 4 | length(RingSetting) < 3) stop("Not enough/too many Ring Settings")
  if(length(RotorPos) > 4 | length(RotorPos) < 3) stop("Not enough/too many Rotor Positions")
  if(length(Reflector) > 1) stop("You can only have one rotor")
  if(length(Rotors) != length(RingSetting) | length(Rotors) != length(RotorPos) | length(RingSetting) != length(RotorPos)) stop("Length of Rotors/Ring Settings/Rotor Positions do not match")
  if(!is.null(Plugboard) & any(nchar(Plugboard) != 2)) stop("One (or more) of the Plugboard pairs consists of too many/not enough letters")
  if(any(duplicated(Rotors))) warning("You used the same rotor at least twice")

  countCharOccurrences <- function(char, s) {
    s2 <- gsub(char,"",s)
    return (nchar(s) - nchar(s2))
  }

  for(L in 1:26) if(sum(countCharOccurrences(LETTERS[L], Plugboard))>1) stop("A certain Letter occurs more than one time in the Plugboard settings")
  if(length(Plugboard) > 10) warning("You provide more than 10 Plugboard pairs (which is the number of cables provided for each Enigma machine)")

  Rotor1 <- strsplit(RotorsReflectors(Rotors[[length(Rotors)]], newL = NewRotRef)$Enc, "")[[1]]
  Rotor1 <- cbind(Rotor1,LETTERS)
  Rotor1T<- RotorsReflectors(Rotors[[length(Rotors)]])$Step

  Rotor2 <- strsplit(RotorsReflectors(Rotors[[length(Rotors) - 1]], newL = NewRotRef)$Enc, "")[[1]]
  Rotor2 <- cbind(Rotor2,LETTERS)
  Rotor2T<- RotorsReflectors(Rotors[[length(Rotors) - 1]], newL = NewRotRef)$Step

  Rotor3 <- strsplit(RotorsReflectors(Rotors[[length(Rotors) - 2]], newL = NewRotRef)$Enc, "")[[1]]
  Rotor3 <- cbind(Rotor3,LETTERS)
  Rotor3T<- RotorsReflectors(Rotors[[length(Rotors) - 2]], newL = NewRotRef)$Step

  if(length(Rotors) == 4){
    Rotor4 <- strsplit(RotorsReflectors(Rotors[[length(Rotors) - 3]], newL = NewRotRef)$Enc, "")[[1]]
    Rotor4 <- cbind(Rotor4,LETTERS)
  }

  if(is.numeric(RingSetting)){
    RingSetting1 <- RingSetting[length(RingSetting)]
    RingSetting2 <- RingSetting[length(RingSetting)-1]
    RingSetting3 <- RingSetting[length(RingSetting)-2]
    if(length(RingSetting) == 4) RingSetting4 <- RingSetting[length(RingSetting)-3]
  }

  if(is.character(RingSetting)){
    RingSetting1 <- which(LETTERS == RingSetting[length(RingSetting)])
    RingSetting2 <- which(LETTERS == RingSetting[length(RingSetting)-1])
    RingSetting3 <- which(LETTERS == RingSetting[length(RingSetting)-2])
    if(length(RingSetting) == 4) RingSetting4 <- which(LETTERS == RingSetting[length(RingSetting)-3])
  }

  Reflec <- strsplit(RotorsReflectors(Reflector, newL = NewRotRef)$Enc, "")[[1]]
  Reflec <- cbind(Reflec,LETTERS)

  Plugb <- cbind(LETTERS,LETTERS)
  if(!is.null(Plugboard)){
    for(s in 1:length(Plugboard)){
      SwapL <- strsplit(Plugboard[s],"")[[1]]
      Plugb[Plugb[,1]==SwapL[1],2] <- SwapL[2]
      Plugb[Plugb[,1]==SwapL[2],2] <- SwapL[1]
    }
  }

  if(is.character(RotorPos)){
    RotorPos1 <- which(LETTERS == RotorPos[length(RingSetting)])
    RotorPos2 <- which(LETTERS == RotorPos[length(RotorPos) - 1])
    RotorPos3 <- which(LETTERS == RotorPos[length(RotorPos) - 2])
    if(length(RotorPos) == 4)  RotorPos4 <- which(LETTERS == RotorPos[length(RotorPos) - 3])
  }
  if(is.numeric(RotorPos)){
    RotorPos1 <- RotorPos[length(RingSetting)]
    RotorPos2 <- RotorPos[length(RotorPos) - 1]
    RotorPos3 <- RotorPos[length(RotorPos) - 2]
    if(length(RotorPos) == 4)  RotorPos4 <- RotorPos[length(RotorPos) - 3]
  }

  StartSettings <- list(Rotors = Rotors,
                        RingSetting = list(Letters = c(LETTERS[RingSetting3],LETTERS[RingSetting2],LETTERS[RingSetting1]),
                                           Numeric = c(RingSetting3,RingSetting2,RingSetting1)),
                        RotorPos = list(Letters = c(LETTERS[RotorPos3],LETTERS[RotorPos2],LETTERS[RotorPos1]),
                                        Numeric = c(RotorPos3,RotorPos2,RotorPos1))
                        )

  TextOut <- vector()

  if(is.null(Text)){
    TextInp <- readline("")
    Entry <- 1
    TextIn <- vector()
    while(any(TextInp == LETTERS)){
      RotorPos1 <- C26(RotorPos1 + 1)

      if(any(LETTERS[C26(RotorPos1 - 1)] == Rotor1T)) RotorPos2 <- C26(RotorPos2 + 1)

      if(any(LETTERS[C26(RotorPos1 - 2)] == Rotor1T) &
           any(LETTERS[C26(RotorPos2)] == Rotor2T)){
        RotorPos3 <- C26(RotorPos3 + 1)
        RotorPos2 <- C26(RotorPos2 + 1)
      }

      if(length(RotorPos) == 4) c(RotorPos4,RotorPos3,RotorPos2,RotorPos1)
      if(length(RotorPos) == 3) c(RotorPos3,RotorPos2,RotorPos1)

      inpL <- TextInp
      inpL <- Plugb[Plugb[,1] == inpL,2]

      inp1 <- C26(which(LETTERS == inpL) + (RotorPos1 - 1) - (RingSetting1 - 1))
      out1 <- Rotor1[Rotor1[,2] == LETTERS[inp1], 1]
      out1 <- C26(which(LETTERS == out1) - (RotorPos1 - 1) + (RingSetting1 - 1))

      inp2 <- LETTERS[C26(out1 + (RotorPos2 - 1) - (RingSetting2 - 1))]
      out2 <- Rotor2[Rotor2[,2] == inp2, 1]
      out2 <- C26(which(LETTERS == out2) - (RotorPos2 - 1) + (RingSetting2 - 1))

      inp3 <- LETTERS[C26(out2 + (RotorPos3 - 1) - (RingSetting3 - 1))]
      out3 <- Rotor3[Rotor3[,2] == inp3, 1]
      out3 <- C26(which(LETTERS == out3) - (RotorPos3 - 1) + (RingSetting3 - 1))

      if(length(RotorPos) == 4){
        inp4 <- LETTERS[C26(out3 + (RotorPos4 - 1) - (RingSetting4 - 1))]
        out4 <- Rotor4[Rotor4[,2] == inp4, 1]
        out4 <- C26(which(LETTERS == out4) - (RotorPos4 - 1) + (RingSetting4 - 1))

        outR <- Reflec[Reflec[,2] == LETTERS[out4], 1]
        outR <- which(LETTERS == outR)

        inp4 <- LETTERS[C26(outR + (RotorPos4 - 1))]
        out4 <- Rotor4[Rotor4[,1] == inp4, 2]
        outR <- C26(which(LETTERS == out4) - (RotorPos4 - 1) + (RingSetting4 - 1))
      } else {
        outR <- Reflec[Reflec[,2] == LETTERS[out3], 1]
        outR <- which(LETTERS == outR)
      }

      inp3 <- LETTERS[C26(outR + (RotorPos3 - 1) - (RingSetting3 - 1))]
      out3 <- Rotor3[Rotor3[,1] == inp3, 2]
      out3 <- C26(which(LETTERS == out3) - (RotorPos3 - 1) + (RingSetting3 - 1))

      inp2 <- LETTERS[C26(out3 + (RotorPos2 - 1) - (RingSetting2 - 1))]
      out2 <- Rotor2[Rotor2[,1] == inp2, 2]
      out2 <- C26(which(LETTERS == out2) - (RotorPos2 - 1) + (RingSetting2 - 1))

      inp1 <- LETTERS[C26(out2 + (RotorPos1 - 1) - (RingSetting1 - 1))]
      out1 <- Rotor1[Rotor1[,1] == inp1, 2]
      out1 <- C26(which(LETTERS == out1) - (RotorPos1 - 1) + (RingSetting1 - 1))
      outL <- LETTERS[out1]
      outL <- Plugb[Plugb[,2] == outL,1]

      if(length(RotorPos) == 4) c(RotorPos4,RotorPos3,RotorPos2,RotorPos1)
      if(length(RotorPos) == 3) c(RotorPos3,RotorPos2,RotorPos1)

      #     print(outL)

      if(Figure){
        EnigmaExtF(InpL = TextIn[i], OutL = outL, RotorPos = c(RotorPos3,RotorPos2,RotorPos1))
        readline()
        if(i != length(TextIn)) dev.off()
      }

      TextIn[Entry]  <- TextInp
      TextOut[Entry] <- outL
      Entry <- Entry + 1
      cat(outL)
      cat("\n \n")
      TextInp <- readline("")
    }
  }

  if(!is.null(Text)){
    TextIn <- strsplit(gsub(" ","",Text), "")[[1]]

    if(Figure){
      EnigmaExtF(RotorPos = c(RotorPos3,RotorPos2,RotorPos1))
      readline()
    }

    for(i in 1:length(TextIn)){

      RotorPos1 <- C26(RotorPos1 + 1)

      if(any(LETTERS[C26(RotorPos1 - 1)] == Rotor1T)) RotorPos2 <- C26(RotorPos2 + 1)

      if(any(LETTERS[C26(RotorPos1 - 2)] == Rotor1T) &
           any(LETTERS[C26(RotorPos2)] == Rotor2T)){
        RotorPos3 <- C26(RotorPos3 + 1)
        RotorPos2 <- C26(RotorPos2 + 1)
      }

      inpL <- TextIn[i]
      inpL <- Plugb[Plugb[,1] == inpL,2]

      inp1 <- C26(which(LETTERS == inpL) + (RotorPos1 - 1) - (RingSetting1 - 1))
      out1 <- Rotor1[Rotor1[,2] == LETTERS[inp1], 1]
      out1 <- C26(which(LETTERS == out1) - (RotorPos1 - 1) + (RingSetting1 - 1))

      inp2 <- LETTERS[C26(out1 + (RotorPos2 - 1) - (RingSetting2 - 1))]
      out2 <- Rotor2[Rotor2[,2] == inp2, 1]
      out2 <- C26(which(LETTERS == out2) - (RotorPos2 - 1) + (RingSetting2 - 1))

      inp3 <- LETTERS[C26(out2 + (RotorPos3 - 1) - (RingSetting3 - 1))]
      out3 <- Rotor3[Rotor3[,2] == inp3, 1]
      out3 <- C26(which(LETTERS == out3) - (RotorPos3 - 1) + (RingSetting3 - 1))

      if(length(RotorPos) == 4){
        inp4 <- LETTERS[C26(out3 + (RotorPos4 - 1) - (RingSetting4 - 1))]
        out4 <- Rotor4[Rotor4[,2] == inp4, 1]
        out4 <- C26(which(LETTERS == out4) - (RotorPos4 - 1) + (RingSetting4 - 1))

        outR <- Reflec[Reflec[,2] == LETTERS[out4], 1]
        outR <- which(LETTERS == outR)

        inp4 <- LETTERS[C26(outR + (RotorPos4 - 1))]
        out4 <- Rotor4[Rotor4[,1] == inp4, 2]
        outR <- C26(which(LETTERS == out4) - (RotorPos4 - 1) + (RingSetting4 - 1))
      } else {
        outR <- Reflec[Reflec[,2] == LETTERS[out3], 1]
        outR <- which(LETTERS == outR)
      }

      inp3 <- LETTERS[C26(outR + (RotorPos3 - 1) - (RingSetting3 - 1))]
      out3 <- Rotor3[Rotor3[,1] == inp3, 2]
      out3 <- C26(which(LETTERS == out3) - (RotorPos3 - 1) + (RingSetting3 - 1))

      inp2 <- LETTERS[C26(out3 + (RotorPos2 - 1) - (RingSetting2 - 1))]
      out2 <- Rotor2[Rotor2[,1] == inp2, 2]
      out2 <- C26(which(LETTERS == out2) - (RotorPos2 - 1) + (RingSetting2 - 1))

      inp1 <- LETTERS[C26(out2 + (RotorPos1 - 1) - (RingSetting1 - 1))]
      out1 <- Rotor1[Rotor1[,1] == inp1, 2]
      out1 <- C26(which(LETTERS == out1) - (RotorPos1 - 1) + (RingSetting1 - 1))
      outL <- LETTERS[out1]
      outL <- Plugb[Plugb[,2] == outL,1]

      if(Figure){
        EnigmaExtF(InpL = TextIn[i], OutL = outL, RotorPos = c(RotorPos3,RotorPos2,RotorPos1))
        readline()
        if(i != length(TextIn)) dev.off()
      }

      TextOut[i] <- outL
    }
  }

  TextOutString <- paste(TextOut,collapse = "")
#   cat(TextIn,sep = "")
#   cat("\n \n")
#   cat(TextOut,sep = "")
  if(!is.null(Helper)){
        CleanUp <- Helper
    if(Helper == "Wehrmacht") CleanUp <- list(c("\\<KLAM\\>","'"),c("\\<ZZ\\>",","),c("\\<X\\>"," "),c("\\<YY\\>","."))
    if(Helper == "Kriegsmarine") CleanUp <- list(c("\\<XX\\>",":"),c("\\<UD\\>","?"),c("\\<X\\>","."),c("\\<Y\\>","."),c("\\<YY\\>","-"))

    gsub2 <- function(pattern, replacement, x, ...) {
      for(i in 1:length(pattern))
        x <- gsub(pattern[i], replacement[i], x, ...)
      x
    }
#     cat("\n \n")
    TextCleaned <- gsub2(unlist(lapply(CleanUp,function(x) x[1])), unlist(lapply(CleanUp,function(x) x[2])), TextOut)
#     cat(TextCleaned,sep = "")
  }

  Output <- list(StartSettings = StartSettings,
                 EndSettings = list(RotorPos = list(Letters = c(LETTERS[RotorPos3],LETTERS[RotorPos2],LETTERS[RotorPos1]),
                                                  Numeric = c(RotorPos3,RotorPos2,RotorPos1))),
                 InputText = Text,
                 OutputText=paste(substring(TextOutString, seq(1,nchar(TextOutString),5), seq(5,nchar(TextOutString),5)),collapse = " "))
  if(!is.null(Helper)) Output <- c(Output,CleanedText=paste(unlist(TextCleaned),collapse = ""))
  return(Output)
}

Enigma(Rotors = c("II","IV","V"), RingSetting = c(02,21,12), RotorPos = c(2,12,1), Reflector = "RefB", Plugboard = c('AV','BS','CG','DL','FU','HZ','IN','KM','OW','RX'),Helper="Wehrmacht",
       Text = "EDPUD NRGYS ZRCXN UYTPO MRMBO FKTBZ REZKM LXLVE FGUEY SIOZV EQMIK UBPMM YLKLT TDEIS MDICA GYKUA CTCDO MOHWX MUUIA UBSTS LRNBZ SZWNR FXWFY SSXJZ VIJHI DISHP RKLKA YUPAD TXQSP INQMA TLPIF SVKDA SCTAC DPBOP VHJK",Figure=FALSE)


#  James Rekow

aggBaseCaseDOCCreator = function(M = 40, N = 20, iStrength = 1, univ = 1,
                                 sigmaMax = 0.1, thresholdMult = 10 ^ (-2), maxSteps = 10 ^ 4,
                                 tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01,
                                 lambda = NULL, numDOC = 10){

  #  ARGS: numDOC - number of DOCs from which the aggregate points should be assembled
  #
  #  RETURNS: aggDOCDF - an aggregate DOC comprised of points from numDOC number of cohorts
  #                      with streamlined interaction steps (e.g. there is a completely connected
  #                      subset of interacting samples and a constellation of non-interacting samples
  #                      that don't interact at all). Each point also has a replicate ID associated with
  #                      it that tracks which replicate it was from, and the number of interacting
  #                      samples (0, 1, or 2) corresponding to it (e.g. if two interacting samples
  #                      are compared to create a DOC point this number would be 2)

  source("abdListCreator_optimizedBaseCase.r")
  source("intraCohortInteraction_optimizedBaseCase.r")
  source("DOCProcedure.r")

  #  set default value of lambda
  if(is.null(lambda)){

    lambda = -0.5 * M * log(0.5)

  } #  end if

  #  let half of the samples be interacting samples
  numI = floor(M / 2)

  produceDOCDF = function(n){

    #  ARGS: n - replicate number
    #
    #  RETURNS: DOCDF - data frame with the DOC points from a single cohort labeled with the number of
    #                   interacting samples corresponding to each point and the replicate from which
    #                   the point is from

    #  select the indices of the interacting samples
    intIx = sample(M, numI)

    #  create abundance list
    abdList = abdListCreator_optimizedBaseCase(intIx = intIx, M = M, N = N, iStrength = iStrength,
                                               univ = univ, sigmaMax = sigmaMax,
                                               thresholdMult = thresholdMult, maxSteps = maxSteps,
                                               tStep = tStep, intTime = intTime,
                                               interSmplMult = interSmplMult, lambda = lambda)

    #  create DOC
    doc = DOCProcedure(abdList)

    #  create a numerical vector with 1's in positions with the indices of interacting elements
    #  and 0's elsewhere
    intSmpls = rep(0, M)
    intSmpls[intIx] = 1

    #  create a matrix whose columns are each unique pair of sample indices
    pairMat = combn(M, 2)

    #  function to count the number of interacting samples in a vector of sample indices
    intCounter = function(ixVec) sum(intSmpls[ixVec])

    #  numerical vector of the number of samples in each sample pair that were interacting samples
    intCount = apply(pairMat, 2, intCounter)

    #  store data in a data frame
    DOCDF = data.frame(replicateID = n, intCount = intCount, over = doc$x, diss = doc$y)

    return(DOCDF)

  } #  end produceDOC function

  #  create a list of replicate data frames
  DOCDFList = lapply(as.list(1:numDOC), produceDOCDF)

  #  aggregate data from the replicates
  aggDOCDF = Reduce(rbind, DOCDFList)

  #  make the intCount variable a factor (mostly for plotting purposes)
  aggDOCDF$intCount = as.factor(aggDOCDF$intCount)

  return(aggDOCDF)

} #  end aggBaseCaseDOCCreator function


# Calculate aspect, slope and TPI of an input DEM, with resampling to a reference raster
# This file should be sourced
library(raster)

CalculateDEMStatistics = function(input, outdir, reference)
{
    SlopeFilename = paste0(outdir,"/slope.tif")
    TPIFilename = paste0(outdir,"/tpi.tif")
    PVHeightFilename = paste0(outdir,"/pv-height.tif")
    PVSlopeFilename = paste0(outdir,"/pv-slope.tif")
    PVTPIFilename = paste0(outdir,"/pv-tpi.tif")
    PVAspectFilename = paste0(outdir,"/pv-aspect.tif")

    # Calculate slope
    if (file.exists(SlopeFilename)) DEMSlope = raster(SlopeFilename)
    else DEMSlope = terrain(input, c("slope"), neighbors=4, datatype="FLT4S", filename=SlopeFilename)

    # Resample all to PROBA-V pixels
    if (file.exists(PVHeightFilename)) PVHeight = raster(PVHeightFilename)
    else PVHeight = raster::resample(input, reference, method="bilinear", datatype="INT2S", filename=PVHeightFilename)
    if (file.exists(PVSlopeFilename)) PVSlope = raster(PVSlopeFilename)
    else PVSlope = raster::resample(DEMSlope, reference, method="bilinear", datatype="FLT4S", filename=PVSlopeFilename)

    # Calculate aspect and TPI from the resampled data
    if (file.exists(PVAspectFilename)) PVAspect = raster(PVAspectFilename)
    else PVAspect = terrain(PVHeight, c("aspect"), datatype="FLT4S", filename=PVAspectFilename)
    if (file.exists(PVTPIFilename)) PVTPI = raster(PVTPIFilename)
    else PVTPI = terrain(PVHeight, "tpi", datatype="FLT4S", filename=PVTPIFilename)
}