#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

#Load required dependencies

library(shiny)
library(ggplot2)

# Define UI for application
ui <- fluidPage(

    # Application title
    titlePanel("Linear Modeling"),

    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(

            # Input: Select a file ----
            fileInput("file1", "Choose CSV File",
                      multiple = FALSE,
                      accept = c("text/csv",
                                 "text/comma-separated-values,text/plain",
                                 ".csv")),

            # Horizontal line ----
            tags$hr(),

            # Input: Checkbox if file has header ----
            checkboxInput("header", "Header", TRUE),

            # Input: Select separator ----
            radioButtons("sep", "Separator",
                         choices = c(Comma = ",",
                                     Semicolon = ";",
                                     Tab = "\t"),
                         selected = ","),

            # Input: Select quotes ----
            radioButtons("quote", "Quote",
                         choices = c(None = "",
                                     "Double Quote" = '"',
                                     "Single Quote" = "'"),
                         selected = '"'),

            # Horizontal line ----
            tags$hr(),

            # Input: Select number of rows to display ----
            radioButtons("disp", "Display",
                         choices = c(Head = "head",
                                     All = "all"),
                         selected = "head"),

            #Create action button to plot linear model and associated data values
            actionButton("plotData", "Plot scatterplot"),
            actionButton("addModel", "Plot linear model")
        ),

        # Plotting the scatterplot and associated information
        mainPanel(
            plotOutput("scatter"),
            plotOutput("lmod"),
            tableOutput("contents")
        )
    )
)

# Define server logic
server <- function(input, output) {

    dataInput <- reactive({
        req(input$file1)

        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
        return(df)
    })

    scatterplot <- eventReactive(input$plotData, {
        lm(y ~ x, data = dataInput())

    })

    output$scatter <- renderPlot( {
        ggplot(scatterplot()$model, aes_string(x = names(scatterplot()$model)[2], y = names(scatterplot()$model)[1])) +
            theme(plot.title = element_text(hjust = 0.5, face = "bold")) +
            geom_point() +
            ggtitle("Scatterplot")

    })

    linmod <- eventReactive(input$addModel, {
        lm(y ~ x, data = dataInput())

    })

    output$lmod <- renderPlot( {
        ggplot(linmod()$model, aes_string(x = names(linmod()$model)[2], y = names(linmod()$model)[1])) +
            theme(plot.title = element_text(hjust = 0.5, face = "bold")) +
            geom_point() +
            ggtitle("Scatterplot with Linear Model") +
            stat_smooth(method = "lm", col = "blue") +
            geom_label(aes(x = 0, y = 7.5), hjust = 0,
                label = paste("Adj R2 = ",signif(summary(linmod())$adj.r.squared, 5),
                              " \nIntercept =",signif(linmod()$coef[[1]],5 ),
                              " \nSlope =",signif(linmod()$coef[[2]], 5),
                              " \nP =",signif(summary(linmod())$coef[2,4], 5)))

    })

    # Show the table of plotted x and y values
    output$contents <- renderTable({

        if(input$disp == "head") {
            return(head(dataInput()))
        }
        else {
            return(dataInput())
        }

    })

}

# Run the application

shinyApp(ui = ui, server = server)


# ============================================ #
# ICR BIC GDSC workshop
# https://github.com/DrJCampbell/genexdrugdemo
# ============================================ #

# ---------- #
# get set up
# ---------- #

# change the next line to the directory where
# the project files are
setwd("./")

# run the next line if gplots is not installed
# install.packages("gplots", dependencies=TRUE)
require(gplots)

# source (read in) some code from the following file
source("./run_gdsc_functions.r")

# --------------------------------------- #
# read in the mutation and drug data sets
# --------------------------------------- #

# read a file with gene mutation and copy number data
mutation_data <- read.table(
	file="gdsc_CNV_mutation_predictors.txt",
	sep="\t",
	header=TRUE,
	row.names=1
	)
	# mutation data now contains a table (data.frame) with
	# 624 rows corresponding to cancer cell lines and 510
	# columns corresponding to either mutation status [0/1]
	# or infered absolute copy number values

# read file with drug IC50 values
drug_data <- read.table(
	file="gdsc_ic50_data.txt",
	sep="\t",
	header=TRUE,
	row.names=1,
	stringsAsFactors=FALSE
	)
	# Similarly, mutation data now contains a table
	# 707 rows corresponding to cancer cell lines and 140
	# columns corresponding to IC50 values of compounds

# ------------------------------- #
# join the data sets for analysis
# ------------------------------- #

# find the common set of cell lines in the drug
# and mutation data and sort asciibetically
common_cell_lines <- sort(
	intersect(
		rownames(mutation_data),
		rownames(drug_data)
		)
	)
	# sort() sorts a list of things
	# intersect() finds the common things in two lists
	# rownames() gets the names of the rows in a table

# make a list holding the tables of data with
# the common cell lines
comb_data <- list(
	mutations = mutation_data[common_cell_lines,],
	drugs = drug_data[common_cell_lines,]
	)
	# mutation_data[common_cell_lines,] chooses rows
	# from mutation_data that are in common_cell_lines
	# and orders the rows as per common_cell_lines

# ----------------------- #
# visualise the data sets
# ----------------------- #

# create a colour pallete and breaks (data bin ranges)
ic50_breaks=seq(-10, 10, by=0.2)
ic50_breaks=append(ic50_breaks, 40)
ic50_breaks=append(ic50_breaks, -40, 0)
ic50_col <- colorpanel(n=length(ic50_breaks)-1,low="blue", high="white")

# Make a really basic heatmap of the drug IC50s
pdf("ic50_data_heatmap_default.pdf", width=50, height=50)
image(
	as.matrix(comb_data$drugs),
	col=ic50_col
	)
dev.off()

# Make a heatmap of mutation and copy number values
cnv_breaks=seq(0, 10, by=1)
cnv_col <- colorpanel(n=length(cnv_breaks)-1,low="white",  high="red")
pdf("mutation_data_heatmap_default.pdf", width=50, height=50)
heatmap(
	as.matrix(comb_data$mutations),
	breaks=cnv_breaks,
	col=cnv_col
	)
dev.off()
# look at heatmap.2() for improved heatmap controls

# ------------------------------------ #
# Analyse a single gene x drug pairing
# ------------------------------------ #

# We can now run an analysis to identify drugs with
# IC50 values that differ between cell lines with
# different mutation status or CNV

# look at the distribution
hist(
	comb_data$drugs[,"PLX4720_RAF"],
	breaks=50,
	xlab="PLX4720 (RAFi) IC50 (µM)",
	main="Histogram showing PLX4720 log10 IC50 distribution"
	)

# non-parametric correlation test
cor_example <- cor.test(
	comb_data$mutations[,"BRAF.MUT"],
	comb_data$drugs[,"PLX4720_RAF"],
	na.rm=TRUE,
	method="spearman"
	)

# look at what is available in cor_example
str(cor_example)

# output visualisations of RAFi response dependent on BRAF mutation to a PDF
pdf("box_and_stripchart_BRAF_RAFi.pdf", width=3, height=4.5)
	# visualise the distribution by group using stripchart
	stripchart(
		comb_data$drugs[,"PLX4720_RAF"] ~ comb_data$mutations[,"BRAF.MUT"],
		vertical=TRUE,
		pch=19,
		col=rgb(0,0,0,0.5),
		method="jitter",
		group.names=c("WT", "mutant"),
		ylab="PLX4720 (RAFi) log10 IC50 (µM)"
		)

	# visualise the distribution by group using boxplot
	boxplot(
		comb_data$drugs[,"PLX4720_RAF"] ~ comb_data$mutations[,"BRAF.MUT"],
		group.names=c("WT", "mutant"),
		ylab="PLX4720 (RAFi) log10 IC50 (µM)"
		)
dev.off()

# ggplot module is good for highly customisable data visualisation

# -------------------------------- #
# Analyse all gene x drug pairings
# -------------------------------- #

# try looping over the sets of measurements for
# each mutation/CNV and each drug and then perform
# a spearman rank correlation test
comb_data_all_spearman_results <- data.frame(
	marker=character(),
	drug=character(),
	rho=numeric(),
	pval=numeric(),
	row.names=NULL,
	stringsAsFactors=FALSE
	)

r <- 0 # use to add index rows in the data.frame

for(marker in colnames(comb_data$mutations)){
	# marker now has the name of a column containing
	# one of the mutated genes or genes altered by CNA
	for(drug in colnames(comb_data$drugs)){
		# likewise, drug is now the column name of
		# one of the columns in the drugs table

		r <- r + 1		# initially r goes from
							# 0 to 1 (first row), then
							# r increments by 1

		result <- NULL	# clear any previous result
								# in case cor.test() fails
								# and the result is stale
		result <- cor.test(
			comb_data$mutations[,marker],
			comb_data$drugs[,drug],
			method="spearman",
			na.action=na.omit
			)
		comb_data_all_spearman_results[r,] <- c(
			marker,
			drug,
			result$estimate,
			result$p.value
			)
	}
}

colnames(comb_data_all_spearman_results) <- c(
	"marker",
	"drug",
	"rho",
	"p.value"
	)

write.table(
	comb_data_all_spearman_results,
	file="comb_data_all_spearman_results.txt",
	col.names=TRUE,
	row.names=FALSE,
	sep="\t",
	quote=FALSE
	)

# now look at the following link for why this is not considered
# good R coding style.
# http://architects.dzone.com/articles/some-tips-r-data-frames

# sort out the types... marker and drug are character strings
# rho and p.value are numeric
comb_data_all_spearman_results <- data.frame(
	marker=as.character(comb_data_all_spearman_results$marker),
	drug=as.character(comb_data_all_spearman_results$drug),
	rho=as.numeric(comb_data_all_spearman_results$rho),
	p.value=as.numeric(comb_data_all_spearman_results$p.value),
	stringsAsFactors=FALSE
	)

# or just read the file back in as a dataframe
comb_data_all_spearman_results <- read.table(
	file="comb_data_all_spearman_results.txt",
	header=TRUE,
	sep="\t",
	stringsAsFactors=FALSE
	)

# separate the predictor (marker) rows the end in
# '.CP' from those that end in '.MUT' and any others

comb_data_cnv_spearman_results <- comb_data_all_spearman_results[
	grep(".CP", comb_data_all_spearman_results$marker),]

comb_data_mut_spearman_results <- comb_data_all_spearman_results[
	grep(".MUT", comb_data_all_spearman_results$marker),]

# To save time for the demo, the correlation tests have
# already been run. We can read these in and visualise the
# results

# read in the previously run test results for the
# mutation data
comb_data_mut_spearman_results <- read.table(
	file="comb_data_mut_spearman_results.txt",
	sep="\t",
	header=TRUE,
	stringsAsFactors=FALSE
	)

# read in the previously run test results for the
# copy number data
comb_data_cnv_spearman_results <- read.table(
	file="comb_data_cnv_spearman_results.txt",
	sep="\t",
	header=TRUE,
	stringsAsFactors=FALSE
	)

# -------------------------- #
# Visualise the test results
# -------------------------- #

# call a function (defined in the file we sourced earlier)
# that ouputs a pdf file with multiple boxplots showing
# IC50 for drugs in mutant and non-mutant groups of cell
# lines
boxplot_drugIC50_by_mutation(
	results=comb_data_mut_spearman_results[which(
		comb_data_mut_spearman_results$p.value <= 1e-06
		),],
	scores=comb_data$drugs,
	mutations=comb_data$mutations,
	filename="boxplots_drug_IC50_by_mutations.pdf"
	)

# call another function that makes boxplots of
# drug IC50 where cell lines were split by gene
# copy number
boxplot_drugIC50_by_copy_number(
	results=comb_data_cnv_spearman_results[which(
		comb_data_cnv_spearman_results$p.value <= 0.001
		),],
	scores=comb_data$drugs,
	mutations=comb_data$mutations,
	filename="boxplots_drug_IC50_by_copy_number.pdf"
	)

# call another function that makes scatter plots
# of drug IC50 where cell lines were split by gene
# copy number
scatterplot_drugIC50_by_copy_number(
	results=comb_data_cnv_spearman_results[which(
		comb_data_cnv_spearman_results$p.value <= 0.001
		),
	],
	scores=comb_data$drugs,
	mutations=comb_data$mutations,
	filename="scatterplots_drug_IC50_by_copy_number.pdf"
	)

# ======= #
# The end
# ======= #


# title: fleet_classtree_r_score.r
# author: SAS Institute
# date: July 30, 2020

library (rpart)

rScoreFunction <- function(Speed_sensor, Vibration, Engine_Load, Coolant_Temp, Intake_Pressure, Engine_RPM, Speed_OBD,
                           Intake_Air, Flow_Rate, Throttle_Pos, Voltage, Ambient, Accel, Engine_Oil_Temp, Speed_GPS,
                           GPS_Longitude, GPS_Latitude, GPS_Bearing, GPS_Altitude, Turbo_Boost, Trip_Distance,
                           Litres_Per_km, Accel_Ssor_Total, CO2, Trip_Time)
{
   #Output: EM_EVENTPROBABILITY, EM_CLASSIFICATION, R_FUNC_ELAPSED

   # Measure execution time of this function
   start_time <- Sys.time()

   # Load the R model object if necessary
   if (!exists("myClassTree"))
   {
      assign("myClassTree", readRDS(file = paste(rdsPath, 'fleet_classtree_r.rds', sep = '')), envir = .GlobalEnv)
   }

   # Threshold for the misclassification error
   threshPredProb <- 0.226917057902973

   input_array <- data.frame('Speed_sensor' = Speed_sensor, 'Vibration' = Vibration, 'Engine_Load' = Engine_Load,
                             'Coolant_Temp' = Coolant_Temp, 'Intake_Pressure' = Intake_Pressure, 'Engine_RPM' = Engine_RPM,
                             'Speed_OBD' = Speed_OBD, 'Intake_Air' = Intake_Air, 'Flow_Rate' = Flow_Rate,
                             'Throttle_Pos' = Throttle_Pos, 'Voltage' = Voltage, 'Ambient' = Ambient, 'Accel' = Accel,
                             'Engine_Oil_Temp' = Engine_Oil_Temp, 'Speed_GPS' = Speed_GPS, 'GPS_Longitude' = GPS_Longitude,
                             'GPS_Latitude' = GPS_Latitude, 'GPS_Bearing' = GPS_Bearing, 'GPS_Altitude' = GPS_Altitude,
                             'Turbo_Boost' = Turbo_Boost, 'Trip_Distance' = Trip_Distance, 'Litres_Per_km' = Litres_Per_km,
                             'Accel_Ssor_Total' = Accel_Ssor_Total, 'CO2' = CO2, 'Trip_Time' = Trip_Time)

   predProb <- predict(myClassTree, newdata = input_array, type = 'prob', na.action = na.omit)

   # Retrieve the event probability and determine the predicted target category
   if (!is.na(predProb[2]))
   {
      EM_EVENTPROBABILITY = predProb[2]
      EM_CLASSIFICATION <- ifelse(EM_EVENTPROBABILITY >= threshPredProb, '1', '0')
   }
   else
   {
      EM_EVENTPROBABILITY <- NA
      EM_CLASSIFICATION <- ' '
   }

   # Measure execution time of this function
   end_time <- Sys.time()
   elapsed_second <- end_time - start_time

   output_list <- list('EM_EVENTPROBABILITY' = EM_EVENTPROBABILITY, 'EM_CLASSIFICATION' = EM_CLASSIFICATION,
                       'R_FUNC_ELAPSED' = elapsed_second[[1]])
   return(output_list)
}


### Merge high similarity terms

#' Merge terms with a high mutual direction conditional probability
#'
#' Merge terms that are likely to occur together. Specifically, terms of which the conditinal probability is higher than min.similarity in both directions. Or: P(A|B) >= min.similarity & P(B|A) >= min.similarity)
#' Not that this is not always a good thing. Unrelated terms that always occur together will also be merged. Whether this makes sense depends on the type of analysis.
#'
#' @param m A sparse matrix in which columns are terms. Can be a DocumentTermMatrix class from the tm package
#' @param min.similarity The minimum conditional probability. The conditional probability of two terms in both directions needs to be higher than min.similarity for terms to be merged
#' @param max.label_length Terms that are merged together will be collapsed into a single label. To prevent very long labels, this is cut of from the [max.label_length] term.
#' @return a matrix (or document term matrix)
#' @export
mergeTermClusters <- function(m, min.similarity=0.95, max.label_length=3){
  if('DocumentTermMatrix' %in% class(m)) {
    m = dtmToSparseMatrix(m)
    return_dtm = T
  } else return_dtm = F
  message('Calculating term similarities')
  sim = termSimilarityNetwork(m, min.similarity)
  sim = decompose.graph(sim)
  N = length(sim)
  message('Merging ', N, ' word clusters')
  for(i in 1:N){
    if(i %% 1000 == 0) print(paste(i, '/', N))
    ids = as.numeric(V(sim[[i]])$name)
    label = collapseLabels(colnames(m)[ids], max.label_length)
    colnames(m)[ids] = label
  }

  m = collapseColumns(m)
  if(return_dtm) m = as.DocumentTermMatrix(m, weighting = weightTf)
  m
}

termSimilarityNetwork <- function(m, min.similarity){
  if('DocumentTermMatrix' %in% class(m)) m = dtmToSparseMatrix(m)
  m@x[m@x > 0] = 1
  sim = Matrix::crossprod(m) / Matrix::colSums(m)

  sim@x = ifelse(sim@x >= min.similarity, 1, 0)
  sim = Matrix::triu(Matrix::triu(sim) + Matrix::triu(Matrix::t(sim))) # sum upper and lower triangle, and only take one
  sim = Matrix::which(sim == 2, arr.ind = T) # select all word pairs where conditinal probability is higher than min.similarity in both ways (undirected because of lower tri)
  sim = sim[!sim[,1] == sim[,2],]
  graph.data.frame(sim, directed = F)
}

collapseLabels <- function(labels, max_length=3){
  if(length(labels) > max_length) {
    label = paste(paste(labels[1:max_length], collapse = '|'), paste('+', length(labels)-max_length, sep=''), sep='|')
  } else{
    label = paste(labels, collapse='|')
  }
  label
}

collapseColumns <- function(m, as_mean=T){
  m = as(m, 'dgTMatrix')
  cnames = unique(colnames(m))
  j = match(colnames(m)[m@j+1], cnames)
  newm = spMatrix(nrow(m), length(cnames), m@i+1, j, m@x)
  newm = as(as(newm, 'dgCMatrix'), 'dgTMatrix')
  if(as_mean){
    cnames_count = table(colnames(m))
    cnames_count = as.numeric(cnames_count[match(cnames, names(cnames_count))])
    newm = Matrix::t(Matrix::t(newm) / cnames_count)
  }
  colnames(newm) = cnames
  rownames(newm) = rownames(m)
  newm
}

####

#' Reduce overlap of labels in igraph network
#'
#' This function does not yet work properly. The idea is to use the wordlayout function of the wordcloud package to arrange nodes in order to prevent label overlap.
#'
#' @param g A graph in the Igraph format, which has the g$layout attribute (set by using the layout. functions)
#' @param fontsize_multiplier The wordlayout function takes fontsize into account to determine overlap. As a temporary solution, increasing font size decreased label overlap (but messes up the network if done extremely)
#' @return a network layout, to be assigned to g$layout
#' @export
reduceLabelOverlap <- function(g, fontsize_multiplier=5){
  layout_matrix = g$layout
  fontsize = V(g)$label.cex * fontsize_multiplier
  newlayout = wordlayout(layout_matrix[,1], layout_matrix[,2], V(g)$name, cex=fontsize)
  as.matrix(newlayout[,1:2])
}

#' Organize isolates next to network
#'
#' Under development (if it proves usefull). Sometimes ignoring isolated words might seem bad, but having them placed randomly within and around the network is just plain annoying. This is an attempt to combine both sentiments.
#'
#' @param g A graph in the Igraph format, which has the g$layout attribute (set by using the layout. functions)
#' @param fontsize_multiplier The wordlayout function takes fontsize into account to determine overlap. As a temporary solution, increasing font size decreased label overlap (but messes up the network if done extremely)
#' @return a network layout, to be assigned to g$layout
#' @export
arrangeIsolates <- function(g){
  if(is.null(g$layout)) g$layout = layout.fruchterman.reingold(g)
  l = g$layout
  l[degree(g) == 0,1] = 0
  l[degree(g) == 0,2] = 0
  l = apply(l, 2, function(x) rescale(x, to=c(-100,100)))
  if(sum(degree(g)==0) == 0) return(l)

  isosizes = data.frame(id=1:sum(degree(g) == 0 ), size=V(g)$size[degree(g) == 0])
  isosizes = isosizes[order(-isosizes$size),]
  isosizes$y = 100 - cumsum(isosizes$size)
  isosizes = isosizes[order(isosizes$id),]

  isolayout = data.frame(x=rep(-130, nrow(isosizes)),y=isosizes$y)
  while(min(isolayout[,2]) < -100){
    isolayout[isolayout[,2] < -100,1] = isolayout[isolayout[,2] < -100,1] - 40
    isolayout[isolayout[,2] < -100,2] = isolayout[isolayout[,2] < -100,2] + 200
  }
  l[degree(g)==0,1] = isolayout[,1]
  l[degree(g)==0,2] = isolayout[,2]

  l = apply(l, 2, function(x) rescale(x, to=c(-100,100)))
  l
}

plotCluster <- function(g, cluster, redo_layout=F, ...){
  V(g)$cluster[is.na(V(g)$cluster)] = 0
  gs = delete.vertices(g, which(!V(g)$cluster == cluster))
  if(redo_layout) {gs$layout = layout.fruchterman.reingold(gs)
  }else gs$layout = gs$layout[V(g)$cluster == cluster,]
  plot(gs, ...)
  gs
}


\name{HilbertCurve-class}
\docType{class}
\alias{HilbertCurve-class}
\title{
The HilbertCurve class
}
\description{
The HilbertCurve class
}
\details{
Hilbert curve (\url{https://en.wikipedia.org/wiki/Hilbert_curve} ) is a type of space-filling curves
that folds one-dimensional axis into a two-dimensional space, but still keeps the locality.
It has advantages to visualize data with long axis with high resolution.

This package aims to provide an easy and flexible way to visualize data through Hilbert curve.
The implementation and example figures are based on following sources:

\itemize{
  \item \url{http://mkweb.bcgsc.ca/hilbert/}
  \item \url{http://corte.si/posts/code/hilbert/portrait/index.html}
  \item \url{http://bioconductor.org/packages/devel/bioc/html/HilbertVis.html}
}
}
\section{Methods}{
The \code{\link{HilbertCurve-class}} provides following methods:

\itemize{
  \item \code{\link{HilbertCurve}}: constructor method;
  \item \code{\link{hc_points,HilbertCurve-method}}: add points;
  \item \code{\link{hc_segments,HilbertCurve-method}}: add lines;
  \item \code{\link{hc_rect,HilbertCurve-method}}: add rectangles;
  \item \code{\link{hc_polygon,HilbertCurve-method}}: add polygons;
  \item \code{\link{hc_text,HilbertCurve-method}}: add text;
  \item \code{\link{hc_layer,HilbertCurve-method}}: add layers, works under "pixel" mode;
  \item \code{\link{hc_png,HilbertCurve-method}}: save plot as PNG format, works under "pixel" mode.
}}
\seealso{
The \code{\link{GenomicHilbertCurve-class}} inherits \code{\link{HilbertCurve-class}} and is designed specifically for handling genomic data.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
NULL
}


# Shows a PCoA plot colored by taxon gradients
# x is the taxon
# pc contains the two pc axes
# filename: if not NULL, must be a string of the pdf output file name
# scale.axes: e.g. c(1,-1) means to flip the second axis, not the first
"show.gradients" <- function(x, pc, filename=NULL,
                                incl.legend=FALSE,
                                pt.alpha='FF',bin.type=c('raw','log','quantile')[3],
                                title.text='',
                                axis.labels=c('PC1','PC2')){
    gradcols <- rev(rainbow(100,start=0,end=2/3))
    gradcols <- sprintf('%s%s',sapply(gradcols,function(x) substring(x,1,7)),pt.alpha)
	# reorder points randomly for drawing order
    scrambleix <- sample(nrow(pc))
    x <- x[scrambleix]
    pc <- pc[scrambleix, ]

    pdf.width <- 5
    if(incl.legend) pdf.width <- 6.5
    if(!is.null(filename)) pdf(filename, width=5, height=5)

    par(cex.main=.65)
	par(cex.axis=.6)

    xlim <- range(pc[,1]) * 1.05
    ylim <- range(pc[,2]) * 1.05
    if(incl.legend) xlim[2] <- xlim[2] + diff(range(xlim)) * .25
	newx <- x

    if(bin.type=='quantile'){
	    # quantiles require 11 gradient points, to include 0%, 10%, ... 100%
        legend.gradcols <- rev(rainbow(11,start=0,end=2/3))
    	quantiles <- quantile(as.numeric(newx),probs=seq(0,1,length=length(gradcols)))
        gradixs <- sapply(newx, function(xx) min(which(quantiles >= xx)))
	} else if(bin.type=='log'){
		legend.gradcols <- rev(rainbow(10,start=0,end=2/3))
		newx[newx==0] <- min(newx[newx>0])/2
		newx <- log(newx,10)
		gradixs <- get.gradient.ixs(newx,length(gradcols))
	} else if(bin.type=='raw'){
		legend.gradcols <- rev(rainbow(10,start=0,end=2/3))
		gradixs <- get.gradient.ixs(newx,length(gradcols))
	}
    plot(pc[,1], pc[,2],type='p',pch=16, cex=1.5,
                 col=gradcols[gradixs],
                 xlab=axis.labels[1],ylab=axis.labels[2],main=title.text,
                 xlim=xlim, ylim=ylim)
    if(incl.legend){
		legend.pos <- best.legend.location(pc[,1],pc[,2])
		if(bin.type=='quantile'){
			quantiles <- quantile(as.numeric(newx),probs=seq(0,1,length=length(legend.gradcols)))
			legend.text <- sprintf('%.3f', quantiles)
		} else {
			legend.text <- sprintf('%.2f',seq(min(newx), max(newx),length=length(legend.gradcols)))
		}
		legend.pos <- 'right'
		legend(legend.pos, legend.text, fill=legend.gradcols, cex=.65, y.intersp=1)
	}

    if(!is.null(filename)) dev.off()
}

# Shows a PCoA plot colored by taxon gradients
# x is a factor to color by
# pc contains the two pc axes
# filename: if not NULL, must be a string of the pdf output file name
# scale.axes: e.g. c(1,-1) means to flip the second axis, not the first
"show.metadata" <- function(y, pc, filename=NULL,
                                incl.legend=TRUE,
                                pt.alpha='FF',
                                title.text='',
                                axis.labels=c('PC1','PC2')){
                                    #require('RColorBrewer')
	y.colors <- c(brewer.pal(9,'Set1'),brewer.pal(9,'Pastel1'),brewer.pal(8,'Dark2'),brewer.pal(8,'Accent'))
	y.colors <- sprintf('%s%s',y.colors,pt.alpha)

	# reorder points randomly for drawing order
    scrambleix <- sample(nrow(pc))
    y <- y[scrambleix]
    pc <- pc[scrambleix, ]

    y <- as.factor(as.character(y))

    pdf.width <- 5
    if(incl.legend) pdf.width <- 6.5
    if(!is.null(filename)) pdf(filename, width=5, height=5)
    color.ix <- as.numeric(y)
    if(max(color.ix) > length(y.colors)) stop(paste('y has more than',y.colors,'values.',sep=' '))
    par(cex.main=.8)

    xlim <- range(pc[,1]) * 1.05
    ylim <- range(pc[,2]) * 1.05
    if(incl.legend) xlim[2] <- xlim[2] + diff(range(xlim)) * .25

    plot(pc[,1], pc[,2],type='p',pch=16, cex=1.5,
                 col=y.colors[color.ix],
                 xlab=axis.labels[1],ylab=axis.labels[2],main=title.text,
                 xlim=xlim, ylim=ylim)
    if(incl.legend){
		legend.pos <- 'right'
		legend(legend.pos, legend=levels(y), fill=y.colors, cex=.65, y.intersp=1)
	}

    if(!is.null(filename)) dev.off()
}

# converts real values to indices between 1 and n
"get.gradient.ixs" <- function(x,n=10){
    stdx <- x-min(x)
    stdx <- stdx/abs(diff(range(stdx)))
    gradientix <- 1 + round((n-1)*stdx)
    return(gradientix)
}

# returns the best location from ('bottomleft','bottomright','topleft','topright')
"best.legend.location" <- function(x,y,xlim=NULL,ylim=NULL){
    if(is.null(xlim)) xlim <- range(x)
    if(is.null(ylim)) ylim <- range(y)

    # get boundaries for a 3x3 grid
    xbounds <-seq(xlim[1],xlim[2],length=4)
    ybounds <-seq(ylim[1],ylim[2],length=4)
    density <- numeric(4)
    # bottom left
    density[1] <- sum(x < xbounds[2] & y < ybounds[2])
    # bottom right
    density[2] <- sum(x > xbounds[3] & y < ybounds[2])
    # top left
    density[3] <- sum(x < xbounds[2] & y > ybounds[3])
    # top right
    density[4] <- sum(x > xbounds[3] & y > ybounds[3])
    return(c('bottomleft','bottomright','topleft','topright')[which.min(density)])
}


library(lmerTest)
library("pscl")
library("lmtest")
library(plyr)
library(glmmADMB)

#optional set working directory
#setwd("")

codeRuns = read.csv("code_runs.csv",sep=";")
codeRunScores = read.csv("code_run_scores.csv")
codeProbSess = read.csv("coding_problem_session.csv",sep=";")
participantInfo = read.csv("participantInfo.csv",sep=";")
demographics = read.csv("demographics.csv",sep=";")
schwartz = read.csv("schwartz_survey.csv",sep=";")
follow_up_questions = read.csv("follow_up_questions.csv",sep=";")
countryMatch = read.csv("country-matching-file.csv")
hofstede = read.csv("hofstede-fixed.csv")
st_ratio = read.csv("world-bank pupil-teacher ratio.csv")
gdp_per_capita = read.csv("world-bank gdp per capita.csv")

#########################################
#         General stats
#########################################

# PDI vs. Student teacher ratio and GDP per capita

tmp <- merge(gdp_per_capita, st_ratio, by="Country")

st_ratio_hofstede <- merge(hofstede, tmp, by.x="country", by.y="Country")

cor.test(st_ratio_hofstede[, c("Student.teacher.ratio")], st_ratio_hofstede[, c("pdi")])

cor.test(st_ratio_hofstede[, c("GDP.per.capita")], st_ratio_hofstede[, c("pdi")])

#percentage with forward steps and back-steps

#join for to make sure we only count compelete data for viz sessions
# Note: not all users made viz sessions, so this is just for viz sessions
# data and user counts who made those viz sessions
tmp = codeRuns

tmp = merge(tmp,
            codeProbSess[c("codeProbId", "participantId", "problemNum", "isTimed", "totalExecutionVizSessions", "score")]
            , by="codeProbId")

tmp = merge(tmp,
            demographics
            , by="participantId")

tmp = merge(tmp,
            schwartz
            , by="participantId")

tmp = merge(tmp,
            participantInfo
            , by="participantId")

codeRunsSummary = tmp
nrow(codeRunsSummary)

#clean (don't count our automatically started code sessions for grading)
codeRunsSummaryCleaned = codeRunsSummary[codeRunsSummary["isUserStarted"] == 1, ]

nrow(codeRunsSummaryCleaned)
nrow(unique(codeRunsSummaryCleaned["participantId"]))

#how many forward step sessions?
fwdStepSessions = codeRunsSummaryCleaned[codeRunsSummaryCleaned["fwdSteps"] >= 1, ]
nrow(fwdStepSessions)
nrow(fwdStepSessions) / nrow(codeRunsSummaryCleaned)
nrow(unique(fwdStepSessions["participantId"]))

# how many backward step sessions?
backStepSessions = codeRunsSummaryCleaned[codeRunsSummaryCleaned["backsteps"] >= 1, ]
nrow(backStepSessions)
nrow(backStepSessions) / nrow(codeRunsSummaryCleaned)
nrow(unique(backStepSessions["participantId"]))

#########################################
# PDI and conservation stats and relation
#########################################

tmp = participantInfo

tmp = merge(tmp,
            demographics
            , by="participantId")

tmp = merge(tmp,
            schwartz
            , by="participantId")

tmp = merge(tmp,
            countryMatch
            , by.x=c("country0"), by.y = c("demo.country"), all.x = TRUE)

tmp = merge(tmp,
            hofstede
            , by="ctr")

participantJoined = tmp

summary(participantJoined[, c("conservation")])
summary(participantJoined[, c("age")])
sd(participantJoined[, c("age")])

length(participantJoined[, c("conservation")])
sd(participantJoined[, c("conservation")])
table(participantJoined[, c("gender")])

participantJoinedPDI = participantJoined[!is.na(participantJoined["pdi"]), ]
summary(participantJoinedPDI[, c("pdi")])
sd(participantJoinedPDI[, c("pdi")])

# test conservation and PDI correlation
cor.test(participantJoined[, c("conservation")], participantJoined[, c("pdi")])

#make sure conservation, pdi and country name are set for country averages
participantJoinedWCons = participantJoined[!is.na(participantJoined["conservation"]), ]
participantJoinedWCons = participantJoinedWCons[!is.na(participantJoinedWCons["pdi"]), ]
participantJoinedWCons = participantJoinedWCons[!is.na(participantJoinedWCons["short.name"]), ]

library(Rmisc)
countryConsAvgs <- summarySE(participantJoinedWCons, measurevar="conservation", groupvars=c("short.name"))

countryPDIAvgs <- aggregate(participantJoinedWCons[c("pdi")], participantJoinedWCons["short.name"], mean)

countrySummary <- cbind(countryConsAvgs, countryPDIAvgs)

cor.test(countrySummary[, c("conservation")], countrySummary[, c("pdi")])

countrySummaryFiltered = countrySummary[countrySummary["N"] >= 5, ]

#########################################
#         backstep regression models
#########################################

tmp = codeRuns

tmp = merge(tmp,
            codeProbSess[c("codeProbId", "participantId", "problemNum", "isTimed", "totalExecutionVizSessions", "score")]
            , by="codeProbId")

tmp = merge(tmp,
            demographics
            , by="participantId")

tmp = merge(tmp,
            schwartz
            , by="participantId")

tmp = merge(tmp,
            participantInfo
            , by="participantId")

tmp = merge(tmp,
            countryMatch
            , by.x=c("ipCountry"), by.y = c("ip.Country"), all.x = TRUE)

tmp = merge(tmp,
            hofstede
            , by="ctr", all.x = TRUE)

codeRunsJoined = tmp

codeRunsJoined <- transform(codeRunsJoined,
        participantId = as.factor(participantId),
        gender = as.factor(gender),
        isTimed = as.factor(isTimed),
        pythonBefore = as.factor(pythonBefore),
        problemNum = as.factor(problemNum),
        education = ordered(education, levels=c("pre-high school", "high school", "professional school", "college", "PhD", "postdoctoral")),
        programmingExperience = ordered(codeRunsJoined$programmingExperience, levels = c("none", "3m", "6m", "1yr", "more")),
        pythonTutorBefore = ordered(codeRunsJoined$pythonTutorBefore, levels = c("0", "1-2", "3-5", "6+"))
)

#(don't count our automatically started code sessions for grading)
codeRunsJoinedAndFixed = codeRunsJoined
codeRunsJoinedAndFixed = codeRunsJoined[codeRunsJoined["isUserStarted"] == 1, ]

####compare Canada and Japan

Canada = codeRunsJoinedAndFixed[codeRunsJoinedAndFixed["ipCountry"] == "Canada", ]
sd(Canada[, c("backsteps")])

Japan = codeRunsJoinedAndFixed[codeRunsJoinedAndFixed["ipCountry"] == "Japan", ]
sd(Japan[, c("backsteps")])

CanadaJapan <- codeRunsJoinedAndFixed[codeRunsJoinedAndFixed["ipCountry"] == "Canada" | codeRunsJoinedAndFixed["ipCountry"] == "Japan", ]
t.test(backsteps ~ ipCountry, CanadaJapan)

#make sure age and gender are not blank for regression model
codeRunsJoinedAndFixed = codeRunsJoinedAndFixed[!is.na(codeRunsJoinedAndFixed["gender"]), ]
codeRunsJoinedAndFixed = codeRunsJoinedAndFixed[!is.na(codeRunsJoinedAndFixed["age"]), ]

# check conservation and backsteps
model = glmmadmb(backsteps ~
                   conservation
                 + fwdSteps
                 + programmingExperience
                 + (1 | participantId),
         data=codeRunsJoinedAndFixed,
         zeroInflation=TRUE,
         family="nbinom")

summary(model)

# check PDI and backsteps

# make sure PDI is set
codeRunsJoinedAndFixedPDI = codeRunsJoinedAndFixed[!is.na(codeRunsJoinedAndFixed["pdi"]), ]

model = glmmadmb(backsteps ~
                   pdi
                 + fwdSteps
                 + age + gender
                 + programmingExperience
                 + (1 | participantId),
                 data=codeRunsJoinedAndFixedPDI,
                 zeroInflation=TRUE,
                 family="nbinom")
summary(model)

#########################################
#       Delta run score per session
#########################################

tmp = codeRuns

tmp = merge(tmp,
            codeRunScores
            , by="codeRunId")

tmp = merge(tmp,
            codeProbSess[c("codeProbId", "participantId", "problemNum", "isTimed", "totalExecutionVizSessions", "score")]
            , by="codeProbId")

tmp = merge(tmp,
            demographics
            , by="participantId")

tmp = merge(tmp,
            schwartz
            , by="participantId")

tmp = merge(tmp,
            participantInfo
            , by="participantId")

tmp = merge(tmp,
            countryMatch
            , by.x=c("ipCountry"), by.y = c("ip.Country"), all.x = TRUE)

tmp = merge(tmp,
            hofstede
            , by="ctr", all.x = TRUE)

codeRunsJoined = tmp

codeRunsJoined <- transform(codeRunsJoined,
                            participantId = as.factor(participantId),
                            gender = as.factor(gender),
                            isTimed = as.factor(isTimed),
                            pythonBefore = as.factor(pythonBefore),
                            problemNum = as.factor(problemNum),
                            education = ordered(education, levels=c("pre-high school", "high school", "professional school", "college", "PhD", "postdoctoral")),
                            programmingExperience = ordered(codeRunsJoined$programmingExperience, levels = c("none", "3m", "6m", "1yr", "more")),
                            pythonTutorBefore = ordered(codeRunsJoined$pythonTutorBefore, levels = c("0", "1-2", "3-5", "6+"))
)

#(don't count our automatically started code sessions for grading)
codeRunsJoinedAndFixed = codeRunsJoined
codeRunsJoinedAndFixed = codeRunsJoined[codeRunsJoined["isUserStarted"] == 1, ]

consBackStepModel<-lmer(formula =deltaRunScore ~
                          runScore
                        +  backsteps * conservation
                        + fwdSteps
                        + programmingExperience
                        + (1 | participantId)
                        , data = codeRunsJoinedAndFixed
)

consBackStepModel
summary(consBackStepModel)
anova(consBackStepModel)

#########################################
#       Final score per problem
#  (similar results to delta score)
#########################################

tmp = codeProbSess

tmp = merge(tmp,
            demographics
            , by="participantId")

tmp = merge(tmp,
            schwartz
            , by="participantId")

tmp = merge(tmp,
            participantInfo
            , by="participantId")

tmp = merge(tmp,
            countryMatch
            , by.x=c("ipCountry"), by.y = c("ip.Country"),  all.x = TRUE)

tmp = merge(tmp,
            hofstede
            , by="ctr", all.x = TRUE)

codeProbSessJoined = tmp

codeProbSessJoined <- transform(codeProbSessJoined,
                                participantId = as.factor(participantId),
                                gender = as.factor(gender),
                                isTimed = as.factor(isTimed),
                                pythonBefore = as.factor(pythonBefore),
                                problemNum = as.factor(problemNum),
                                education = ordered(education, levels=c("pre-high school", "high school", "professional school", "college", "PhD", "postdoctoral")),
                                programmingExperience = ordered(codeProbSessJoined$programmingExperience, levels = c("none", "3m", "6m", "1yr", "more")),
                                pythonTutorBefore = ordered(codeProbSessJoined$pythonTutorBefore, levels = c("0", "1-2", "3-5", "6+"))
)

# only for when they are working on the problems during the timed portion (not freely working on them at the end of the study)
codeProbSessJoinedAndFixed = codeProbSessJoined[codeProbSessJoined["isTimed"] == 1, ]

consScoreModel<-lmer(formula = score ~
                       + fwdSteps + backSteps * conservation
                     + programmingExperience
                     + (1 | participantId)
                     , data = codeProbSessJoinedAndFixed
)

consScoreModel
summary(consScoreModel)
anova(consScoreModel)


#
# DESCRIPTION:
#     This is a special purpose script for looking at pressure below the balloon (GP1.SYS) of two animals
#     to determine if they can be reclassified.
#
# REQUIREMENTS:
#     Must load setup.r and vitals_h5.r before using this script.
#

require( knitr)
require( ggplot2 )

animal_id = "9309"  # "2875"  #
v <- read_drager_vitals( animal_id )
anno <- read_annotations( animal_id )
anno$txt = tolower(anno$txt )
tp <- subset( anno, txt == "start bleed" )
tm0 <- tp$dt

# txt == 9309 "insert REBOA"
# txt == 2875 "INSERT BALLOON"

dt <- as.difftime( 180, format = "%M", unit="mins" )
end_tm <- tm0 + dt

anno$rel_tm <- dt

p0 <- ggplot(data=v, aes(x=dt,y=GP1.SYS)) +
	geom_point() + ylim(0, 120) + xlim(tm0, end_tm) +
	geom_text(data=anno, aes(anno$dt, -1, label=anno$txt), show.legend=FALSE, color="black", angle=90) +
	ylab( "GP1 Systolic" ) + xlab(animal_id)

# p1 <- ggplot(data=v, aes(x=dt,y=GP1.SYS,group=group,color=group)) +
#    geom_smooth(method="loess") + guides(colour=FALSE) +
# scale_color_manual(values=group.colors) +


#' Bumblebee: Quantify Disease Transmission Within and Between Population Groups
#'
#' @description
#' Bumblebee uses counts of directed transmission pairs identified between samples
#' from population groups of interest to estimate the flow of transmissions within
#' and between those population groups accounting for sampling heterogeneity.
#'
#' Population groups might include: communities, geographical regions, age-gender
#' groupings or arms of a randomized-clinical trial.
#'
#' Counts of observed directed transmission pairs can be obtained from deep-sequence
#' phylogenetic data (via phyloscanner) or known epidemiological contacts. Note:
#' Deep-sequence data is also commonly referred to as high-throughput or
#' next-generation sequence data. See references to learn more about phyloscanner.
#'
#' @section The \code{estimate_transmission_flows()} function:
#' To estimate transmission flows, that is, the relative probability of transmission
#' within and between population groups accounting for variable sampling the among
#' the population groups the function: \code{estimate_transmission_flows_and_ci()}
#' computes the conditional probability, \code{theta_hat} that a pair of pathogen
#' sequences is from a specific population group pairing given that the pair is
#' linked.
#'
#' For two population groups of interest \eqn{(u,v)} \code{theta_hat} is denoted by
#'
#' \deqn{\hat{\theta_{ij}} = Pr(pair from groups (i,j) | pair is linked), where i = u,v and j = u,v .}
#'
#' To learn more and try some examples, see documentation of the
#' \code{estimate_transmission_flows()} function and the bumblebee package
#' website \url{https://magosil86.github.io/bumblebee/}.
#'
#' @seealso See the following functions for details on estimating transmission flows
#' and corresponding confidence intervals: \code{estimate_transmission_flows_and_ci},
#' \code{estimate_theta_hat} and \code{estimate_multinom_ci}.
#'
#' @section Cite the package:
#' Please cite the package using the following reference:
#' Lerato E. Magosi, Marc Lipsitch (2021). Bumblebee: Quantify Disease
#' Transmission Within and Between Population Groups. R package version
#' 0.1.0 \url{https://magosil86.github.io/bumblebee/}
#'
#' @author
#' Lerato E. Magosi \email{lmagosi@hsph.harvard.edu} or
#' \email{magosil86@gmail.com}
#'
#' @references
#' \enumerate{
#'
#'    \item Magosi LE, et al., Deep-sequence phylogenetics to quantify patterns of
#'          HIV transmission in the context of a universal testing and treatment
#'          trial – BCPP/ Ya Tsie trial. To submit for publication, 2021.
#'
#'    \item Carnegie, N.B., et al., Linkage of viral sequences among HIV-infected
#' 		 village residents in Botswana: estimation of linkage rates in the
#' 		 presence of missing data. PLoS Computational Biology, 2014. 10(1):
#' 		 p. e1003430.
#'
#'    \item Goodman, L. A. On Simultaneous Confidence Intervals for Multinomial Proportions
#' 		 Technometrics, 1965. 7, 247-254.
#'
#'    \item Glaz, J., Sison, C.P. Simultaneous confidence intervals for multinomial proportions.
#' 		 Journal of Statistical Planning and Inference, 1999. 82:251-262.
#'
#'    \item May, W.L., Johnson, W.D. Constructing two-sided simultaneous confidence intervals for
#' 		 multinomial proportions for small counts in a large number of cells.
#' 		 Journal of Statistical Software, 2000. 5(6).
#' 		 Paper and code available at https://www.jstatsoft.org/v05/i06.
#'
#'    \item Ratmann, O., et al., Inferring HIV-1 transmission networks and sources of
#' 		 epidemic spread in Africa with deep-sequence phylogenetic analysis.
#' 		 Nature Communications, 2019. 10(1): p. 1411.
#'
#'    \item Sison, C.P and Glaz, J. Simultaneous confidence intervals and sample size determination
#' 		 for multinomial proportions. Journal of the American Statistical Association,
#' 		 1995. 90:366-369.
#'
#'    \item Wymant, C., et al., PHYLOSCANNER: Inferring Transmission from Within- and
#' 		 Between-Host Pathogen Genetic Diversity. Molecular Biology and Evolution,
#' 		 2017. 35(3): p. 719-733.
#' }
#'
#' @docType package
#' @name bumblebee-package
#' @aliases bumblebee
#'
#' @keywords internal
#' @importFrom dplyr %>%
"_PACKAGE"


#' met_rate
#'
#' Calculate metabolic
#'
#' @param BSA numeric Body are surface.
#' @param isolevel numeric Metabolic rate class following level of ISO FDIS 7243.
#'
#' @return basal metabolic rate
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references  Ergonomics of the thermal environment – Assessment of heat stress using the WBGT (wet bulb globe temperature)   index, ISO FDIS 7243 (2016)
#' @keywords  MET
#' @export
#'
#'
#'
#'

met_rate=function(BSA, isolevel)   {
  ct$assign("BSA", as.array(BSA))
  ct$assign("isolevel", as.array(isolevel))
  ct$eval("var res=[]; for(var i=0, len=BSA.length; i < len; i++){ res[i]=met_rate(BSA[i],isolevel[i])};")
  res=ct$get("res")
  return(res)
}


library(pROC)
library(cowplot)
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","high")) %>%
  mutate(Response = factor(Response, levels=c("low","high")))

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

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

roc.df = data.frame()
df.text = data.frame()
N_perm = 1000

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

  r = roc(Response ~ CD38_score, data=tinfo, direction="<", quiet = T)
  set.seed(123)
  r.null = vector("numeric", N_perm)
  for(i in 1:N_perm) {
    r.null[i] = roc(Response~sample(CD38_score), data=tinfo, direction="<", quiet = T)$auc
  }
  r.p = sum(r.null > r$auc) / N_perm

  r.df = data.frame(Specificity = r$specificities, Sensitivity=r$sensitivities, Study=study) %>%
    arrange(Sensitivity)

  roc.df = rbind(roc.df, r.df)
  X = tinfo$CD38_score
  Y = tinfo$Response
  w.pv = wilcox.test(X[Y=="high"], X[Y=="low"], exact=F, alternative="greater")$p.value

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

roc.df = roc.df %>%
  mutate(Study=factor(Study)) %>%
  arrange(Sensitivity, Specificity) %>%
  inner_join(sdy, by="Study")

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()

p1 = 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", clr[1:3]), name="Response",
                    breaks=c(0,2), labels=c("low","high")) +
  geom_text(data = df.text, aes(label=label.w.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, 2.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())

p2 = list()
for(tm in levels(df.text$label)) {
  p2[[tm]] = ggplot(roc.df %>% dplyr::filter(label==tm), aes(x=Specificity, y=Sensitivity)) +
    geom_line(size=1) +
    geom_abline(intercept = 1, slope = 1, lty=2) +
    scale_x_reverse() +
    geom_text(data=df.text %>% dplyr::filter(label==tm), aes(x=x,y=y,label=label.auc)) +
    coord_fixed() +
    theme_bw() + theme(panel.grid = element_blank())
}

bottom_row <- do.call("plot_grid", c(p2, align = "h", nrow=1))
plot_grid(p1, bottom_row, ncol=1, rel_heights = c(2, 1))

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


runsimWR<-function(K,nd,wrange,runs,sims,simname,identifier){

  output_array<-c('Computer','SimulationDate','nI','J','K','non_dominated','dstbn','variance','wr','thinning_factor','tau','lambda',
                  'e','model','runs','mautbest','mautworst','r1_scor','r1_util_loss','r1_mro4mautbest',
                  'r1_mautbestintop3','r1_mautbestintop5','r1_mautro4modelbest','r1_modelbestintop3','r1_modelbestintop5',
                  'r3_scor','r3_util_loss','r3_mro4mautbest','r3_mautbestintop3','r3_mautbestintop5','r3_mautro4modelbest',
                  'r3_modelbestintop3','r3_modelbestintop5','r5_scor','r5_util_loss','r5_mro4mautbest','r5_mautbestintop3',
                  'r5_mautbestintop5','r5_mautro4modelbest','r5_modelbestintop3','r5_modelbestintop5','timetaken')

  computer = 'local'
  alpha = NA
  beta = NA
  e = 0

  wt6 = c(0,1,2,3,4,5)
  wt12 = c(0,1,3,5,8,11)
  for(wtx in c(1,2,3,4,5,6))
  {
    print(wtx)

    for (config in 2:2)
    {

      if (config==1){
        nI <<- 9
        J <<- 6
        nC <<- wt6[wtx]
        wr = nC
        dstbn <<- 'normal'
        par1 <<- 'lowvar'
        utau <<- 'low'
        ulambda <<- 'low'
      }
      else {
        nI <<- 19
        J <<- 12
        nC <<- wt12[wtx]
        wr = nC
        dstbn <<- 'skew'
        par1 <<- 'highvar'
        utau <<- 'low'
        ulambda <<- 'high'
      }

      for (s in 1:sims)
      {

        #set.seed(1)
        ta = if(utau == "low"){runif(J,0.2,0.4)}else{runif(J,0.6,0.8)}
        la = if(ulambda == "low"){runif(J,0.2,0.4)}else{runif(J,0.6,0.8)}

        d1<-gendata(nI,J,K,nd,dstbn,par1)
        tmaut<-maut(d1$stdata,nI,J,K,ta,la,u_c)
        tw<<-tmaut$w
        egsum<-applyerror(d1$gsum,nI,J,e)

        input0=d1$stdata
        input1=egsum
        input2=egsum[,,7]
        input3=list(v1=as.matrix(egsum[,,7]),v2=as.matrix(egsum[,,8]))
        input4=list(v1=as.matrix(egsum[,,9]),v2=as.matrix(egsum[,,10]),v3=as.matrix(egsum[,,11]))

        time0=system.time(newraim<-SMAABoot(nI,J,runs,input0,dstbn,ta,la),gcFirst=FALSE)
        output0=t(c(computer,simname,nI,J,K,nd,dstbn,par1,wr,thin.f,utau,ulambda,e,"SMAABoot",runs))
        output0=c(output0,outputmeasures(newraim,tmaut$utility),time0[3])
        #                     write(output0,file=paste("testsim_output",identifier,".csv",sep=""),ncolumns=44,append="T", sep=",")
        output_array<-cbind(output_array,output0)

        time1=system.time(newraim<-SMAA1(nI,J,runs,input1,dstbn,ta,la),gcFirst=FALSE)
        output1=t(c(computer,simname,nI,J,K,nd,dstbn,par1,wr,thin.f,utau,ulambda,e,"SMAA1",runs))
        output1=c(output1,outputmeasures(newraim,tmaut$utility),time1[3])
        #                     write(output1,file=paste("testsim_output",identifier,".csv",sep=""),ncolumns=44,append="T", sep=",")
        output_array<-cbind(output_array,output1)

        time2=system.time(newraim<-SMAA2(nI,J,runs,input2,dstbn,ta,la),gcFirst=FALSE)
        output2=t(c(computer,simname,nI,J,K,nd,dstbn,par1,wr,thin.f,utau,ulambda,e,"SMAA2",runs))
        output2=c(output2,outputmeasures(newraim,tmaut$utility),time2[3])
        #                     write(output2,file=paste("testsim_output",identifier,".csv",sep=""),ncolumns=44,append="T", sep=",")
        output_array<-cbind(output_array,output2)

        time3=system.time(newraim<-SMAA3(nI,J,runs,input3,dstbn,ta,la,riskp=4),gcFirst=FALSE)
        output3=t(c(computer,simname,nI,J,K,nd,dstbn,par1,wr,thin.f,utau,ulambda,e,"SMAA3",runs))
        output3=c(output3,outputmeasures(newraim,tmaut$utility),time3[3])
        #                     write(output3,file=paste("testsim_output",identifier,".csv",sep=""),ncolumns=44,append="T", sep=",")
        output_array<-cbind(output_array,output3)

        time4=system.time(newraim<-SMAA4(nI,J,runs,input4,dstbn,ta,la),gcFirst=FALSE)
        output4=t(c(computer,simname,nI,J,K,nd,dstbn,par1,wr,thin.f,utau,ulambda,e,"SMAA4",runs))
        output4=c(output4,outputmeasures(newraim,tmaut$utility),time4[3])
        #                     write(output4,file=paste("testsim_output",identifier,".csv",sep=""),ncolumns=44,append="T", sep=",")
        output_array<-cbind(output_array,output4)

      }

    }
  }

  write.csv(t(output_array),file=paste("output_array_",identifier,".csv",sep=""))

}


#' Scatterplot of SSB, R with 2-digit year
#'
#' Standard stock-recruitment plot with years labeled. Also creates R/SSB time series plot.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotRecrSSByr <- function(asap,save.plots,od,plotf){

  par(mfrow=c(1,1) )

  ssb <- asap$SSB
  recr <- asap$N.age[,1]
  years <- seq(asap$parms$styr, asap$parms$endyr)
  nyears <- length(years)
  SR <- matrix(NA, (nyears-1), 4)
  SR[,1] <- years[1:(nyears-1)]
  SR[,2] <- ssb[1:(nyears-1)]
  SR[,3] <- recr[2:nyears]
  SR[,4] <- SR[,3] / SR[,2]  # R per SSB

  yr.text=substr(SR[,1],3,4)
  npts<-length(years)-1

  plot( SR[,2], SR[,3], type='n', col='black',
        xlab="SSB ", ylab="Recruits ",
        ylim=c(0, 1.1*max(SR[,3])), xlim=c(0,1.2*max(SR[,2]))  )

  points (SR[npts,2], SR[npts,3], pch=19, col="#ffaa22", cex=2.5)
  text(SR[,2], SR[,3], yr.text[1:(nyears-1)], cex=0.9, col="black")

  if (save.plots==T) savePlot(paste0(od, "S_R.Yr.",plotf), type=plotf)

  plot(SR[,1],SR[,4], type='o', col='black', pch=16,
       xlab="Year", ylab="R/SSB")
  abline(h=mean(SR[,4]), lty=2)
  if(save.plots==TRUE) savePlot(paste0(od, "RpSSB_time_series.",plotf), type=plotf)

  return()

}  #end function


enthal <- function(tdb, w) {
    .Call('biometeoR_enthal', PACKAGE = 'biometeoR', tdb, w)
}


suppressMessages(library(tidyverse))
suppressMessages(library(patchwork))
suppressMessages(library(cowplot))

args <- commandArgs(trailingOnly=TRUE)

if (length(args) != 2)
    stop("Expected two arguments")

input_file <- args[1]
output_file <- args[2]

df <- read.csv(input_file) %>%
    group_by(graph,type,targetbalance,phi) %>%
    summarize(conductanceratio=sum(conductance[strategy=="default"])/sum(conductance[strategy=="balanced"]))

plotWithData <- function(data) {
    ggplot(data, aes(x=reorder(factor(type), conductanceratio),
                     y=conductanceratio,
                     fill=ifelse(conductanceratio < 1, "Original", "Balanced"))) +
        geom_bar(stat="identity") +
        geom_hline(yintercept=1) +
        labs(y="Ratio",
             x="",
             fill="Which is better?") +
        theme(axis.text.x = element_text(size = 6, angle = 90, vjust = 0.5, hjust = 1)) +
        scale_fill_manual(values = c('Original' = "blue", 'Balanced' = "red"))
}

p1 <- plotWithData(filter(df, near(targetbalance, 0.0), near(phi, 0.01)))
p2 <- plotWithData(filter(df, near(targetbalance, 0.25), near(phi, 0.01)))
p3 <- plotWithData(filter(df, near(targetbalance, 0.45), near(phi, 0.01)))

# See https://github.com/wilkelab/cowplot/blob/master/vignettes/shared_legends.Rmd
legend <- get_legend(p3 + theme(legend.justification = "top"))

plot <- plot_grid(
    p1 + theme(legend.position="none"),
    p2 + theme(legend.position="none"),
    p3 + theme(legend.position="none"),
    legend,
    labels=c('a','b','c')
)

ggsave(output_file, plot)


library(party)

### Titanic: Machine Learning from Disaster ###
# Conditional inference trees solution
setwd("/your-path/titanic-ml")

# reading feature engineered data
train <- read.csv("./engineered-data/train_notenc.csv")
test <- read.csv("./engineered-data/test_notenc.csv")

# reading raw data
train_raw <- read.csv("train.csv")
test_raw <- read.csv("test.csv")

train <- train[,!(names(train) %in% c('Survived'))]

# joining datasets for processing
combi <- rbind(train, test)

# factorizing variables
combi['deck'] <- factor(combi[['deck']])
combi['Sex'] <- factor(combi[['Sex']])
combi['room_pos'] <- factor(combi[['room_pos']])

# splitting data again
new_train <- combi[1:length(train[,1]),]
new_test <- combi[(length(train[,1])+1):length(combi[,1]),]

# removing unwanted features
drops <- c("PassengerId", "Cabin", "Name", "Ticket")
new_train <- new_train[,!(names(new_train) %in% drops)]
new_test <- new_test[,!(names(new_test) %in% drops)]

# appending dependent variable
new_train['Survived'] <- train_raw['Survived']

# training...
set.seed(0)
fit <- cforest(as.factor(Survived) ~ ., data = new_train, controls=cforest_unbiased(ntree=2000, mtry=3))

# predicting...
predictions <- predict(fit, new_test, OOB=TRUE, type = "response")

# preparing and writing submission...
submit <- data.frame(PassengerId = 892:1309, Survived = predictions)
write.csv(submit, 'sub27.csv', row.names=FALSE, quote=FALSE)


#' ptoolkit.
#'
#'p_toolkit is a package designed to help adjust and visualize p-values when using multiple comparisons.
#'As computing power has become powerful enough to run hundreds or even thousands of statistical tests,
#'it is important to look at small p-values and try to understand whether the result is small simply by chance,
#'or whether it truly is significant.
#'
#'
#' @name ptoolkit
#' @docType package
NULL


## FUNCTIONS FOR COMPARING DOCUMENTS

cosineSimilarity <- function(m1, m2=m1){
  norm.x = sqrt(Matrix::colSums(m1^2))
  norm.y = sqrt(Matrix::colSums(m2^2))
  mat = Matrix::crossprod(m1,m2)
  mat = mat / Matrix::tcrossprod(norm.x, norm.y)
  mat[is.na(mat)] = 0
  mat
}

termOverlap <- function(m1, m2=m1){
  m2@x[Matrix::which(m2@x > 0)] = 1
  Matrix::crossprod(m1,m2)
}

termProduct <- function(m1, m2=m1){
  #m2@x[Matrix::which(m2@x > 0)] = 1
  Matrix::crossprod(m1,m2)
}

termOverlap_pct <- function(m1, m2=m1){
  totalterms = Matrix::colSums(as(m1, 'dgCMatrix'))
  m2@x[Matrix::which(m2@x > 0)] = 1
  Matrix::crossprod(m1,m2) / totalterms
}

termIndex <- function(m1, m2=m1){
  m2@x[Matrix::which(m2@x > 0)] = 1
  totalterms = Matrix::colSums(as(m1, 'dgCMatrix'))
  Matrix::crossprod(m1,m2) / totalterms
}

#' Get the overlapping terms between two documents in a dtm
#'
#' @return a list or data.frame with the corpora.compare results for each dtm.
#' @export
getOverlapTerms <- function(x, y, dtm.x, dtm.y=NULL, similarity=NULL, termfreq=T){
  filterterms = colnames(dtm.x)[col_sums(dtm.x) > 0]
  dtm.x = dtm.x[,filterterms]
  dtm.y = dtm.y[,filterterms]
  m.x = Matrix::t(dtmToSparseMatrix(dtm.x))
  m.y = if(is.null(dtm.y)) m.x else Matrix::t(dtmToSparseMatrix(dtm.y))

  matches = data.frame(x=x, y=y)
  if(!is.null(similarity)) matches$similarity = similarity

  termids_list = llply(unique(x), getTermIds, matches, m.x=m.x, m.y=m.y, .progress='text')
  times_match = unlist(llply(termids_list, laply, length)) # get length of lists in lists, which can be used to replicate the rows in 'matches'
  matches_i = rep(1:nrow(matches), times_match)
  matches = matches[matches_i,]
  matches$term = colnames(dtm.x)[unlist(termids_list)]
  if(termfreq){
    matches$freq.x = m.x[cbind(match(matches$term, rownames(m.x)), match(matches$x, colnames(m.x)))]
    matches$freq.y = m.y[cbind(match(matches$term, rownames(m.y)), match(matches$y, colnames(m.y)))]
  }
  matches
}

getTermIds <- function(x.id, matches, m.x, m.y){
  xmatches = matches[matches$x == x.id,]
  m.x = m.x[,as.character(x.id), drop=F]
  m.y = m.y[,as.character(xmatches$y), drop=F]
  termids_list = slam_crossapply(m.x, m.y, function(x,y) which(x*y>0))
  termids_list[1,,drop=F]
}

slam_crossapply <- function(m1, m2=m1, FUN=function(x,y) sum(x*y), ...){
  m1 = as(m1, 'dgTMatrix')
  m2 = as(m2, 'dgTMatrix')
  m1 = simple_triplet_matrix(m1@i+1, m1@j+1, m1@x, nrow(m1), ncol(m1), dimnames(m1))
  m2 = simple_triplet_matrix(m2@i+1, m2@j+1, m2@x, nrow(m2), ncol(m2), dimnames(m2))
  if(ncol(m1)==1 & ncol(m2)==1) {
    matrix(list(FUN(as.vector(m1),as.vector(m2), ...)), nrow=1, dimnames=list(colnames(m1),colnames(m2)))
  } else slam::crossapply_simple_triplet_matrix(m1, m2, FUN, ...)
}

#' Transform a dtm into a sparse matrix.
#'
#' @param dtm a document-term matrix
#' @return a sparse matrix
#' @export
dtmToSparseMatrix <- function(dtm){
  if('DocumentTermMatrix' %in% class(dtm)){
    sm = Matrix::spMatrix(nrow(dtm), ncol(dtm), dtm$i, dtm$j, dtm$v)
    rownames(sm) = rownames(dtm)
    colnames(sm) = colnames(dtm)
  }
  sm
}

Nth.max <- function(x, N){
  N = min(N, length(x))
  -sort(-x, partial=N)[N]
}

filterResults <- function(results, min.similarity, n.topsim){
  if(!is.null(min.similarity)) results@x[Matrix::which(results@x < min.similarity)] = 0
  if(!is.null(n.topsim)) {
    simthres = apply(results, 1, Nth.max, N=n.topsim)
    results@x[Matrix::which(results < simthres)] = 0
  }
  results
}

#' Compare the documents in two corpora/dtms
#'
#' Compare the documents in corpus dtm.x with reference corpus dtm.y.
#'
#' @param dtm.x the main document-term matrix
#' @param dtm.y the 'reference' document-term matrix. If NULL, documents of dtm.x are compared to each ohter
#' @param measure the measure that should be used to calculate similarity/distance/adjacency. Currently only cosine is supported
#' @param min.similarity a threshold for similarity. lower values are deleted. Set to 0.1 by default.
#' @param n.topsim An alternative or additional sort of threshold for similarity. Only keep the [n.topsim] highest similarity scores for x. Can return more than [n.topsim] similarity scores in the case of duplicate similarities.
#' @param only.from A vector of ids that match the documents (rownames) in dtm. Use to compare only these documents to other documents.
#' @param return.zeros If true, all comparison results are returned, including those with zero similarity (quite possibly the worst thing to do with large data)
#' @return A data frame with sets of documents and their similarities.
#' @export
documents.compare <- function(dtm.x, dtm.y=NULL, measure='cosine', min.similarity=0.1, n.topsim=NULL, only.from=NULL, return.zeros=F) {
  if(!is.null(only.from)) dtm.x = dtm.x[rownames(dtm.x) %in% only.from,]
  m.x = Matrix::t(dtmToSparseMatrix(dtm.x))
  m.y = if(is.null(dtm.y)) m.x else Matrix::t(dtmToSparseMatrix(dtm.y))
  if(measure == 'cosine') results = cosineSimilarity(m.x, m.y)
  if(measure == 'overlap') results = termOverlap(m.x, m.y)
  if(measure == 'overlap_pct') results = termOverlap_pct(m.x, m.y)
  if(measure == 'product') results = termProduct(m.x, m.y)

  results = filterResults(results, min.similarity, n.topsim)

  results = as(results, 'dgTMatrix')
  if(return.zeros) {
    results = Matrix(which(!is.na(results), arr.ind=T))
    results = data.frame(x=colnames(m.x)[results[,1]], y=colnames(m.y)[results[,2]], similarity=as.vector(results))
  } else{
    results = data.frame(x=colnames(m.x)[results@i+1], y=colnames(m.y)[results@j+1], similarity=results@x)
    results = results[results$similarity > 0 & !is.na(results$similarity),]
  }
  results[!as.character(results$x) == as.character(results$y),]
}

aggregateTimeUnits <- function(datetime, unit='hours'){
  datetime = as.POSIXct(datetime)
  if(!unit %in% c('mins','hours','days','months','years')) stop('Could not recognize "', unit, '" as valid time.unit')

  if(unit == 'mins') return(as.POSIXct(format(datetime, '%Y-%m-%d %H:%M:00')))
  if(unit == 'hours') return(as.POSIXct(format(datetime, '%Y-%m-%d %H:00:00')))
  if(unit == 'days') return(as.POSIXct(format(datetime, '%Y-%m-%d 00:00:00')))
  if(unit == 'months') return(as.POSIXct(format(datetime, '%Y-%m-01 00:00:00')))
  if(unit == 'years') return(as.POSIXct(format(datetime, '%Y-01-01 00:00:00')))
}

getWindow <- function(window.size, window.direction){
  if(window.direction == '<=>') window = -window.size:window.size
  if(window.direction == '<>') window = c(-window.size:-1, 1:window.size)
  if(window.direction == '<=') window = -window.size:0
  if(window.direction == '<') window = -window.size:-1
  if(window.direction == '>=') window = 0:window.size
  if(window.direction == '>') window = 1:window.size
  if(window.direction == '=') window = 0
  window
}

#' Compare the documents in a dtm per time frame
#'
#' Compare all documents within a document term matrix that are dated (e.g., pubished) within a given number of days (window.size) from each other.
#'
#' @param dtm a document-term matrix in the tm format
#' @param document.date a vector of date class, of the same length and order as the documents (rows) of the dtm.
#' @param window.size the timeframe in days within which articles must occur in order to be compared. e.g., if 0, articles are only compared to articles of the same day. If 1, articles are compared to all articles of the previous, same or next day.
#' @param time.unit a string indicating what time unit to use. Can be 'mins','hours','days','months' or 'years'.
#' @param window.direction For a more specific selection of which articles in the window to compare to. This is given with a combination of the symbols '<' (before x) '=' (simultanous with x) and '>' (after x). default is '<=>', which means all articles. '<>' means all articles before or after the [time.unit] of an article itself. '<' means all previous articles, and '<=' means all previous and simultaneous articles. etc.
#' @param measure the measure that should be used to calculate similarity/distance/adjacency. Currently only cosine is supported
#' @param min.similarity a threshold for similarity. lower values are deleted
#' @param n.topsim An alternative or additional sort of threshold for similarity. Only keep the [n.topsim] highest similarities for x.
#' @param only.from A vector of ids that match the documents (rownames) in dtm. Use to compare only these documents to other documents.
#' @param get.overlap.terms Add the overlapping terms of documents to the output.
#' @param only.complete.window if True, only compare articles (x) of which a full window of reference articles (y) is available. Thus, for the first and last [window.size] days, there will be no results for x.
#' @param return.date If true, the dates for x and y are given in the output
#' @param return.zeros If true, all comparison results are returned, including those with zero similarity (quite possibly the worst thing to do with large data)
#' @return A data frame with columns x, y and similarity. If return.date == T, date.x and date.y are returned as well.
#' @export
documents.window.compare <- function(dtm, document.date, window.size=3, time.unit='days', window.direction='<=>', measure='cosine', min.similarity=NULL, n.topsim=NULL, only.from=NULL, return.date=F, return.datedif=T, return.zeros=F, only.complete.window=F){
  message('Indexing articles by date/time')
  datetime = as.POSIXct(document.date)
  datetime = aggregateTimeUnits(datetime, time.unit)
  datetimeseq = seq.POSIXt(min(datetime), max(datetime), by=time.unit)
  if(time.unit %in% c('days','months','years')) datetimeseq = as.POSIXct(format(datetimeseq, '%Y-%m-%d')) # because f! you POSIXt

  nonempty = which(datetimeseq %in% unique(datetime))
  nonempty_datetime_ids = llply(datetimeseq[nonempty], function(dtime) which(datetime == dtime), .progress='text')
  datetime_ids = vector("list", length(datetimeseq))
  datetime_ids[nonempty] = nonempty_datetime_ids
  #datetime_ids = llply(datetimeseq, function(dtime) which(datetime == dtime))
  #nonempty = which(laply(datetime_ids, length) > 0)

  message('Comparing documents')
  window = getWindow(window.size, window.direction)
  if(only.complete.window & '<' %in% window.direction) nonempty = nonempty[nonempty > window.size]
  if(only.complete.window & '>' %in% window.direction) nonempty = nonempty[nonempty <= length(datetime_ids)-window.size]
  output = ldply(nonempty, function(i) ldply_documents.compare(i, dtm, datetime_ids, window, measure, min.similarity, n.topsim, only.from, return.zeros), .progress='text')
  output = output[,!colnames(output) == '.id']
  if(return.date | return.datedif) {
    message('Matching document dates')
    date.x = document.date[match(output$x, rownames(dtm))]
    date.y = document.date[match(output$y, rownames(dtm))]
    if(return.datedif){
      output$daydif = difftime(date.y, date.x, units = 'days')
    }
    if(return.date){
      output$date.x = date.x
      output$date.y = date.y
    }
  }
  output
}

ldply_documents.compare <- function(i, dtm, datetime_ids, window, measure, min.similarity, n.topsim, only.from, return.zeros){
  ## special function to be used in ldply in document.window.compare
  dtm.x_indices = unique(datetime_ids[[i]])
  dtm.y_indices = unique(unlistWindow(datetime_ids,i,window))
  if(is.null(dtm.y_indices)) return(NULL)
  documents.compare(dtm[dtm.x_indices,], dtm[dtm.y_indices,], measure, min.similarity, n.topsim, only.from, return.zeros)
}


# Delete current environment variables --------
rm(list = ls(all.names = TRUE))

# Load required packages -------
library(irr)
library(dplyr)

# Read data ------------
raw <- read.csv("interrater-results.csv")
str(raw)
summary(raw)

# Calculate interrater reliability ------------

#iteration <- c(1, 2, 3, 4)
iteration <- c(4)
data <- raw %>%
  filter(round %in% iteration) %>%
  # filter(source != "SE") %>%
  select(rater1, rater2)

# Percentage of agreement
agree(data)

# Cohen's Kappa (0: no agreement, 1: total agreement)
kappa2(data)


#-------------------------------------------------------------------------------
#	Create grouping for cross validation.
#
#	Args:
#		object (cv.models):
#			a cv.models object having settings.
#			'seed', 'adapter', 'folds', 'stratify' and 'group' fields are used.
#-------------------------------------------------------------------------------
cv.group <- function(object) {
	# Fix random number before using random process.
	set.seed.if.possible(object)
	# Create group.
	if (!is.null(object$group)) {
		return(cv.group.from.group(object))
	}
	if (object$stratify) {
		return(cv.group.stratified(object))
	}
	return(cv.group.random(object))
}

#-------------------------------------------------------------------------------
#	Create group index by random manner.
#-------------------------------------------------------------------------------
cv.group.random <- function(object) {
	# Create groups based on row numbers.
	cv.group <- ((0:(nrow(object$adapter$data) - 1)) %% object$folds) + 1
	# Reorder them randomly.
	cv.group <- sample(cv.group, length(cv.group))
	return(cv.group)
}

#-------------------------------------------------------------------------------
#	Create group index with class stratification.
#-------------------------------------------------------------------------------
cv.group.stratified <- function(object) {
	# Check the number of response variables.
	y <- object$adapter$y.vars
	if (ncol(y) > 1) {
		stop("Currently, multiple response variables are not supported.")
	}
	y <- y[[1]]
	# Check the class of reponse variable.
	if (object$adapter$model.type == "regression") {
		message <- paste0(
			"Currently, class stratification is not supported for \n",
			"regression models."
		)
		stop(message)
	}
	# Check the minimum number of observation in a class of response variable.
	if (min(tapply(y, y, length)) < object$folds) {
		message <- paste0(
			"Number(s) of observations in a class of response variable \n",
			"is smaller than the number of 'fold'."
		)
		warning(message)
	}
	# Create groups.
	shuffled.y <- unlist(tapply(1:length(y), y, sample), use.names = FALSE)
	cv.group <- (((0:(length(y) - 1)) %% object$folds) + 1)[order(shuffled.y)]
	return(cv.group)
}

#-------------------------------------------------------------------------------
#	Create group index from specified group.
#-------------------------------------------------------------------------------
cv.group.from.group <- function(object) {
	# Error check
	if (length(object$group) != nrow(object$adapter$data)) {
		stop("Length of 'group' should be same as the number of observation.")
	}
	# Create grouping values depending on the atomic type of 'object$group'.
	if (is.logical(object$group) | is.factor(object$group)) {
		return(as.integer(object$group))
	}
	if (is.character(object$group)) {
		return(as.integer(as.factor(object$group)))
	}
	if (is.numeric(object$group)) {
		if (all(object$group %% 1 == 0)) {
			return(as.integer(as.factor(object$group)))
		}
	}
	stop("'group' should be one of logical, factor, character or integer")
}


#  this script create the n_proportion_M2.in file with  "1" values
dat<-Read.summary.data(read.init.function=T)
dat<-droplevels(subset(dat,Species.n>=first.VPA))

M<-tapply(dat$M,list(dat$Quarter,dat$Age,dat$Species.n),mean)  # template
M[]<- 1

outf<-file.path(data.path,'n_proportion_M2.in')
cat('# Proportion of N used for calculation of M2 values\n',file=outf)

for (sp in (first.VPA:nsp)) {
  for (y in (SMS.control@first.year:SMS.control@last.year )) {

  cat(paste('# ',sp.names[sp],y,'\n'),file=outf,append=T)
  write.table(round(M[,,as.character(sp)],3),append=T,file=outf,row.names = F,col.names = F)
 }
}

cat(-999," # checksum",file=outf,append=T)


thresh<-function(x,lam){
	# s=solve(A)%*%x
# 	if(lam==0) return(s)
# 	max(1-lam/crossprod(x,s)^(1/2),0)*s
	if(lam==0) return(x)
	max(1-lam/sum(x^2)^(1/2) , 0)*x
}

admmSel<-function(dat,lam,m1,m2,rho=1,cores=1,elist=NULL){
	n=dim(dat)[1]
	print("Calculating Statistics:")
	d=dim(dat)[2]
	if(is.null(elist)) elist= get.edgelist(graph.full(d))
	g=graph.edgelist(elist,directed=F)
	K = Kvec2(dat,m1,m2,elist)
	G = Gamma.ret2(dat,m1,m2,cores=dim(dat)[2],ge=elist)
	dd=dim(G[[1]]$v)[1]
	#dd=dim(G[[1]])[1]

	Ginv=mclapply(1:d,function(x) G[[x]]$v %*% ((1/((1/n)*G[[x]]$d^2+rho)) * t(G[[x]]$v)),mc.cores=d)
	#Ginv=mclapply(1:d,function(x) solve(G[[x]]+rho*diag(dd)),mc.cores=cores)
	print("Done.")
	znode = matrix(rnorm(d*m1)*1e-10,d,m1)
	zedge = array(rnorm(m2*m2*dim(elist)[1])*1e-10,dim=c(m2,m2,dim(elist)[1]))
	tol=Inf
	x=xold=y=zz=lapply(1:d,function(x)rep(0,dim(G[[x]]$v)[1]))
	admmout=list()
	lam=rev(sort(lam))
	if(d>=100) cores = detectCores()
	for(lamind in 1:length(lam)){
		print(paste("Run ",lamind," Begun"))
		if(lamind>1){
			x=admmout[[lamind-1]]$x
			y=admmout[[lamind-1]]$y
			zz=admmout[[lamind-1]]$zz
		}
		tol=Inf
		iter=0
		while(tol>1e-3 & iter<500){
		iter=iter+1
		# x step
		xold=x
		zedge_old=zedge
		znode_old=znode
		#print(lapply(y,function(x)length(x)))
		x=mclapply(1:d,function(i){
		#	print(dim(Ginv[[i]]))
		#	print(length(K[[i]]))
		#	print(length(y[[i]]))
			Ginv[[i]]%*%(-K[[i]] - y[[i]] + rho*zz[[i]])
		},mc.cores=cores)
		#z-y step
		for(i in 1:d){
			ii=sum(neighbors(g,i)<i)
			c= (ii)*m2^2+1
			ind=c: (c+m1-1)
			znode[i,] = (x[[i]][ind] + y[[i]][ind]/rho )
			znode[i,] = thresh(znode[i,],.01*lam[lamind]/rho)
			y[[i]][ind] = y[[i]][ind] + rho*( x[[i]][ind] - znode[i,])
			zz[[i]][ind] = znode[i,]
			for(j in neighbors(g,i)){

						jj =which(neighbors(g,i)==j)
						ii = which(neighbors(g,j)==i)

					if(i<j){
						c1 = m1+(jj-1)*m2^2+1
						c2 = (ii-1)*m2^2+1
					}else{
						c2 = m1+(ii-1)*m2^2+1
						c1 = (jj-1)*m2^2+1
					}

					e= which(elist[,1]%in%c(i,j) & elist[,2]%in%c(i,j))
					#c1 = ifelse(j>i , m1 + (j-2)*m2+1 ,(j-1)*m2+1 )
					#c2 = ifelse(j<i , m1 + (i-2)*m2+1 ,(i-1)*m2+1 )
					#if(length(e)==0) next
					#c1 = m1+(jj-1)*m2^2+1
					#c2 = (ii-1)*m2^2+1
					ind1 =c1:(c1+m2^2-1)
					ind2 =c2:(c2+m2^2-1)
					#print(ind1)
					#print(length(y[[i]]))
					#print(ind2)
					#print(length(y[[j]]))
					zedge[,,e] = .5* (x[[i]][ind1] + x[[j]][ind2] +
									y[[i]][ind1]/rho + y[[j]][ind2]/rho)
					zedge[,,e]=matrix( thresh(zedge[,,e],lam[lamind]/rho) , m2 , m2)

					y[[i]][ind1] = y[[i]][ind1] + rho*(x[[i]][ind1] - c(zedge[,,e]))
					y[[j]][ind2] = y[[j]][ind2] + rho*(x[[j]][ind2] - c(zedge[,,e]))
					zz[[i]][ind1] = c(zedge[,,e])
					zz[[j]][ind2] = c(zedge[,,e])
				}
			}

		#print(mean(abs(unlist(x)-unlist(zz))))
		#tol = mean(abs(unlist(xold)-unlist(x)))/mean(abs(unlist(xold))) #+ .5*mean(abs(unlist(x)-unlist(zz)))
		tol = ( sum(abs(zedge-zedge_old)) + sum(abs(znode-znode_old)) ) #/(sum(abs(znode_old))+sum(abs(zedge_old)))
			print(paste("tol:",tol))
		}
		#return(list(znode=znode,zedge=zedge))#list(z=zz,x=x,y=y,znode=znode,zedge=zedge))
		admmout[[lamind]]= list(x=x,y=y,zz=zz,znode=znode,zedge=zedge)
	}
	return(admmout)
}

admmSel2<-function(dat,lam,m1,m2,rho=1,cores=1,elist=NULL){
	n=dim(dat)[1]
	print("Calculating Statistics:")
	d=dim(dat)[2]
	if(is.null(elist)) elist= get.edgelist(graph.full(d))
	g=graph.edgelist(elist,directed=F)
	K = Kvec2(dat,m1,m2,elist)
	G = Gamma.ret2(dat,m1,m2,cores=dim(dat)[2],ge=elist)
	dd=dim(G[[1]]$v)[1]
	#dd=dim(G[[1]])[1]

	Ginv=mclapply(1:d,function(x) G[[x]]$v %*% ((1/((1/n)*G[[x]]$d^2+rho)) * t(G[[x]]$v)),mc.cores=d)
	#Ginv=mclapply(1:d,function(x) solve(G[[x]]+rho*diag(dd)),mc.cores=cores)
	print("Done.")
	znode = matrix(rnorm(d*m1)*1e-10,d,m1)
	zedge = array(rnorm(m2*m2*dim(elist)[1])*1e-10,dim=c(m2,m2,dim(elist)[1]))
	tol=Inf
	x=xold=y=zz=lapply(1:d,function(x)rep(0,dim(G[[x]]$v)[1]))
	admmout=list()
	lam=rev(sort(lam))
	if(d>=100) cores = detectCores()
	for(lamind in 1:length(lam)){
		print(paste("Run ",lamind," Begun"))
		if(lamind>1){
			x=admmout[[lamind-1]]$x
			y=admmout[[lamind-1]]$y
			zz=admmout[[lamind-1]]$zz
		}
		tol=Inf
		iter=0
		while(tol>1e-3 & iter<500){
		iter=iter+1
		# x step
		xold=x
		zedge_old=zedge
		znode_old=znode
		#print(lapply(y,function(x)length(x)))
		x=mclapply(1:d,function(i){
		#	print(dim(Ginv[[i]]))
		#	print(length(K[[i]]))
		#	print(length(y[[i]]))
			Ginv[[i]]%*%(-K[[i]] - y[[i]] + rho*zz[[i]])
		},mc.cores=cores)
		#z-y step
		for(i in 1:d){
			ii=sum(neighbors(g,i)<i)
			c= (ii)*m2^2+1
			ind=c: (c+m1-1)
			znode[i,] = (x[[i]][ind] + y[[i]][ind]/rho )
			znode[i,] = thresh(znode[i,],.01*lam[lamind]/rho)
			y[[i]][ind] = y[[i]][ind] + rho*( x[[i]][ind] - znode[i,])
			zz[[i]][ind] = znode[i,]
			for(j in neighbors(g,i)){

						jj =which(neighbors(g,i)==j)
						ii = which(neighbors(g,j)==i)

					if(i<j){
						c1 = m1+(jj-1)*m2^2+1
						c2 = (ii-1)*m2^2+1
					}else{
						c2 = m1+(ii-1)*m2^2+1
						c1 = (jj-1)*m2^2+1
					}

					e= which(elist[,1]%in%c(i,j) & elist[,2]%in%c(i,j))
					#c1 = ifelse(j>i , m1 + (j-2)*m2+1 ,(j-1)*m2+1 )
					#c2 = ifelse(j<i , m1 + (i-2)*m2+1 ,(i-1)*m2+1 )
					#if(length(e)==0) next
					#c1 = m1+(jj-1)*m2^2+1
					#c2 = (ii-1)*m2^2+1
					ind1 =c1:(c1+m2^2-1)
					ind2 =c2:(c2+m2^2-1)
					#print(ind1)
					#print(length(y[[i]]))
					#print(ind2)
					#print(length(y[[j]]))
					zedge[,,e] = .5* (x[[i]][ind1] + x[[j]][ind2] +
									y[[i]][ind1]/rho + y[[j]][ind2]/rho)
					zedge[,,e]=matrix( thresh(zedge[,,e],lam[lamind]/rho) , m2 , m2)

					y[[i]][ind1] = y[[i]][ind1] + rho*(x[[i]][ind1] - c(zedge[,,e]))
					y[[j]][ind2] = y[[j]][ind2] + rho*(x[[j]][ind2] - c(zedge[,,e]))
					zz[[i]][ind1] = c(zedge[,,e])
					zz[[j]][ind2] = c(zedge[,,e])
				}
			}

		#print(mean(abs(unlist(x)-unlist(zz))))
		#tol = mean(abs(unlist(xold)-unlist(x)))/mean(abs(unlist(xold))) #+ .5*mean(abs(unlist(x)-unlist(zz)))
		tol = ( sum(abs(zedge-zedge_old)) + sum(abs(znode-znode_old)) ) #/(sum(abs(znode_old))+sum(abs(zedge_old)))
			print(paste("tol:",tol))
		}
		#return(list(znode=znode,zedge=zedge))#list(z=zz,x=x,y=y,znode=znode,zedge=zedge))
		admmout[[lamind]]= list(x=x,y=y,zz=zz,znode=znode,zedge=zedge)
	}
	return(admmout)
}

#hyvar_score<-function(

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

# coorDesc<-function(dat,lam,m1,m2){
# 	gr=Gamma.ret(dat,m1,m2)
# 	gn=Gamma.node(dat,m1,m2)
# 	kvn=Kvec.node(dat,m1)
# 	kve=Kvec.edge(dat,m2)
# 	tol=Inf
# 	d=dim(dat)[2]
# 	out.node.old=out.node=matrix(0,d,m1)
# 	out.edge.old=out.edge=array(0,dim=c(m2,m2,d*(d-1)/2))
# 	elist=get.edgelist(graph.full(d))
# 	while(tol>1e-3){
# 		for(i in 1:d){
# 			for(j in i:d){
# 				A = (gn[[i]][[j]]+gn[[j]][[i]])
# 				if(i!=j){
# 					ee= which(elist[,1]==i & elist[,2]==j)
# 					ind11 = which( (elist[,1]==j | elist[,2]==j) & elist[,1]!=i)
# 					ind12 = which( (elist[,1]==i | elist[,2]==i) & elist[,2]!=j)
# 					xx=crossprod(gr[[i]][[ee]] , out.node[i,])+
# 					    gr[[j]][[ee]] %*% out.node[j,] +
# 					    c(kve[,,ee])
# 				}else{
# 					ind11 = which( (elist[,1]==j | elist[,2]==j) )
# 					ind12 = which( (elist[,1]==i | elist[,2]==i) )
# 					xx = kvn[i,]
# 				}
# 				#print(paste(i," " ,j))
# 				#print(elist[ind11,])
# 				#print(elist[ind12,])
# 				xx=xx+Reduce("+",lapply(1:length(ind11), function(x){
# 					 if(elist[ind11[x],1]==j){
# 					 	gr[[i]][[ind11[x]]] %*% c(out.edge[,,ind12[x]])
# 					 }else{
# 					 	t(gr[[i]][[ind11[x]]]) %*% c(out.edge[,,ind12[x]])
# 					 }
# 					 }))
# 				xx=xx+Reduce("+",lapply(1:length(ind11), function(x){
# 				 if(elist[ind12[x],1]==i){
# 					 gr[[j]][[ind12[x]]] %*% c(out.edge[,,ind11[x]])
# 				}else{
# 					t(gr[[j]][[ind12[x]]]) %*% c(out.edge[,,ind11[x]])
# 				}
#
# 				 }))
# 				if(i==j){
# 					out.node[i,]=thresh(-xx,A,lam)
# 				}else{
# 					out.edge[,,ee] = matrix( thresh(-xx,A,lam) , m2,m2)
# 				}
# 			}
# 		}
# 		#print(out.edge)
# 		#print(out.node)
# 		#break
# 		tol = mean(abs(out.edge-out.edge.old))
# 		tol= tol + mean(abs(out.node.old-out.node))
# 		print(tol)
# 		out.node.old = out.node
# 		out.edge.old=out.edge
# 	}
# 	return(list(edge=out.edge,node=out.node))
# }


# takes g_inputdir,g_filetable and g_outputdir
##and g_supress_paints
# return occupancy plots

### R CODE ###
##############
message("starting occupancy.r")

### create ocupancy plot

# get the x,y coordinates of all the individuals
xy_table = data.frame()
for (i in c(1:nrow(id_table))) {
	itraj = traj[id(traj)==id_table$id[i]]

#### center data
	x=itraj[[1]]$x - env[[i]]$cx
	y=itraj[[1]]$y - env[[i]]$cy

# delete paints when the fly is not moving
	if (g_supress_paints) {
		dx = itraj[[1]]$dx
		dy = itraj[[1]]$dy
		dx[is.na(dx)] = 0
		dy[is.na(dy)] = 0
		new_x = c()
		new_y = c()
		moved_distance = 0
		for (j in c(1:length(x))) {
			moved_distance = moved_distance + sqrt(dx[j]*dx[j]+dy[j]*dy[j])
			# if the fly moved 2 mm, add a point to xy_table
			if (moved_distance< g_treshold) {
				new_x = c(new_x,x[j])
				new_y = c(new_y,y[j])
				moved_distance = 0
			}
		}
	} else {
		new_x = x
		new_y = y
	}

	xy = data.frame(x=new_x,y=new_y)
	id = rep(id_table$id[i],nrow(xy))
	group = rep(id_table$group[i],nrow(xy))
	xy_table = rbind(xy_table,data.frame(xy,id,group))
}

# paint the diagram for each group
group_names = levels(id_table$group)

# weights for smoothing
weights = c(21,16,4,1)

for (i in c(1:length(group_names))) {
	x = xy_table[xy_table$group==group_names[i],]$x
	y = xy_table[xy_table$group==group_names[i],]$y

	hbin = hexbin(x,y,xbins=60)
	hbin = hsmooth(hbin,wts=weights)

	#calculate the color-cuts for the plot
	maxval = quantile(hbin@count,0.95) # 95% quantil
	maxcut = maxval/max(hbin@count)
	cuts = seq(0,maxcut,length=255)
	cuts = c(cuts,1)

	plot(hbin,colorcut=cuts,colramp=blue2red,
		main=paste("Occupancy plot for",group_names[i]),legend=FALSE)
}


\name{hc_points-HilbertCurve-method}
\alias{hc_points,HilbertCurve-method}
\title{
Add points to the Hilbert curve
}
\description{
Add points to the Hilbert curve
}
\usage{
\S4method{hc_points}{HilbertCurve}(object, ir = NULL, x1 = NULL, x2 = x1,
    np = max(c(2, 10 - hc_level(object))), size = unit(1, "char"),
    pch = 1, gp = gpar(), mean_mode = c("w0", "absolute", "weighted", "max_freq"),
    shape = "circle")
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{ir}{an \code{\link[IRanges:IRanges-constructor]{IRanges}} object which specifies the input intervals.}
  \item{x1}{if start positions are not integers, they can be set by \code{x1}.}
  \item{x2}{if end positions are not integers, they can be set by \code{x2}.}
  \item{np}{number of points (a circle or a square, ...) that are put in a segment. \code{np} controls the mode of how to add the points to the curve. See 'Details' section.}
  \item{size}{size of the points. It should be a \code{\link[grid]{unit}} object. Only works if \code{np <= 1}}
  \item{pch}{shape of points, used for points if \code{np <= 1}.}
  \item{gp}{graphic parameters for points. It should be specified by \code{\link[grid]{gpar}}.}
  \item{mean_mode}{when \code{np >= 2}, each segment on the curve is split into \code{np} windows and each window actually represents an small interval in the axis. When overlapping input intervals to the windows on the curve and when the window can not completely cover the input intervals, some averaging method should be applied to get a more accurate estimation for the value in the window. Here the HilbertCurve package provides four modes: "w0", "weighted", "absolute" and "max_freq" which calculate the mean value in the window with respect to different scenarios. See 'Details' section and the vignette for more informative explanation.}
  \item{shape}{shape of points, used for points if \code{np >= 2}. Possible values are "circle", "square", "triangle", "hexagon", "star".}

}
\details{
If \code{np} is set to 1 or \code{NULL}, points will be added in the middle for each interval in \code{ir} (or \code{x1}, \code{x2}).

If \code{np} is set to a value larger or equal to 2, every segment on the curve is split by \code{np} points (e.g. circles).
In this case, each point actually represent a window on the curve and when the window is not fully covered by
the input intervals, there are three different metrics to average the values in the window.

Following illustrates different settings for \code{mean_mode}:

  \preformatted{
       100    80     60    values in ir
    ++++++   +++   +++++   ir
      ================     window (width = 16)
        4     3     3      overlap

    absolute: (100 + 80 + 60)/3
    weighted: (100*4 + 80*3 + 60*3)/(4 + 3 + 3)
    w0:       (100*4 + 80*3 + 60*3 + 0*6)/16  }

So which mode to use depends on specific scenario. If the background is not of interest, \code{absolute} and \code{weighted}
modes may be proper and if the value also needs to be averaged with background, \code{w0} is the proper choice. Section "Averaging models"
in the vignette gives a more detailed explanation for this argument.

There is one more value for \code{mean_mode} which is \code{max_freq}. \code{max_freq} is mainly for discrete signals and in a segment,
value with the highest frequency (or with the highest length) is selected for this segment

If \code{np >= 2}, the value of \code{np} also controls the size of points.

Graphic parameters is always represented as numeric values (e.g. colors can be converted into numeric RGB values)
and they will be averaged according to above rules.

Internally, it will depatch to \code{\link{hc_normal_points,HilbertCurve-method}} or \code{\link{hc_segmented_points,HilbertCurve-method}}
depending on the value of \code{np}.
}
\value{
A data frame which contains coordinates (in the 2D space) of points.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(1, 100, level = 4, reference = TRUE)

x = sort(sample(100, 20))
s = x[1:10*2 - 1]
e = x[1:10*2]
require(IRanges)
ir = IRanges(s, e)

hc_points(hc, ir)

hc = HilbertCurve(1, 100, level = 4, reference = TRUE)
hc_points(hc, x1 = c(1.5, 50.5), x2 = c(10.5, 60.5))

require(circlize)
value = runif(length(ir))
col_fun = colorRamp2(range(value), c("white", "red"))
hc = HilbertCurve(1, 100, level = 4, reference = TRUE)
hc_points(hc, ir, np = 3, shape = "star", gp = gpar(fill = col_fun(value)))

hc = HilbertCurve(1, 100, level = 4, reference = TRUE)
hc_points(hc, ir, np = 0)

hc = HilbertCurve(1, 100, level = 4, reference = TRUE)
hc_points(hc, np = 0, x1 = c(1.5, 50.5), x2 = c(10.5, 60.5))
hc_points(hc, np = 0, x1 = 70.5, gp = gpar(col = "red"))
}


# Looking at Titanic data through R

# File in C:/R/Titanic.csv

# Import dplyr package
library(dplyr)

# Change working directory
setwd('C:/R')

# Save dataframe from CSV
Titanic <- read.csv('Titanic.csv')

head(Titanic)

# Average of survival rate = percentage
Data <- Titanic %>%
  group_by(sex) %>%
  summarize(percent_surviving=mean(survived))

titanic - lesson 30 in Baseball Database Inquiries.r


library(data.table)
library(ggplot2)
library(viridis)

options(scipen = 100)

sppdem <- fread('../../data/species-info/demographic-parameters-processed.csv')

load('../../generated/modeldata.rdata')

spplist <- fread('../../data//species-info/species-list.csv')

make_heatmap <- function(dat, xvar, yvar, fillvar, textvar=NULL, textsubvar=NULL,
                 xlab = '', ylab = '', filllab = '', axis.x.lab.rot = 45, axis.x.lab.hadj = 1,
                 nudge_y_main = ifelse(is.null(textsubvar), 0, 0.1), nudge_y_sub = -0.1, size_main = 3, size_sub = 2,
                 trans = 'log2') {
    dat <- copy(dat)
    dat[, xvar := get(xvar)]
    dat[, yvar := get(yvar)]
    dat[, fillvar := get(fillvar)]
    if (is.null(textvar)) {
        dat[, textvar := round(fillvar, 3)]
    } else dat[, textvar := get(textvar)]
    if (is.null(textsubvar)) {
        dat[, textsubvar := '']
    } else dat[, textsubvar := get(textsubvar)]
    g <- ggplot(dat, aes(x = xvar, y = yvar, fill = fillvar)) +
        geom_tile() +
        geom_text(aes(label = textvar), colour = 'white', nudge_y = nudge_y_main, size = size_main) +
        geom_text(aes(label = textsubvar), colour = 'white', nudge_y = nudge_y_sub, size = size_sub) +
        scale_fill_gradientn(name = filllab, colours = c("#B9B9B9", "#E31A1C"), trans = trans) +
        coord_equal(expand=F) +
        theme_bw() +
        theme(panel.grid = element_blank(),
              legend.position='none',
              axis.text.x = element_text(angle = axis.x.lab.rot, hjust = axis.x.lab.hadj),
              plot.margin = unit(rep(0.2, 4), 'cm')) +
        labs(x = xlab, y = ylab)
    return(g)
}

## * Estimated vulnerabilities

load('assets/mcmc-results.rdata', v=T)
vulsumm <- fread('assets/vulnerabilities-all.csv')

vul <- merge(mcmc, vulsumm, by='variable', all.x=F, all.y=T)

fgroups <- vulsumm[vartype == 'q_f0', .N, .(fishery_group, fg_lab)]
spg <- vulsumm[vartype == 'q_g0', .N, .(species_group, sp_lab)]
spp <- vulsumm[vartype == 'q_gf0', .N, .(species, sp_lab)]
spp[, spg := spplist[match(species, code), vul_group]]

q_samples <- rbindlist(lapply(spp[, species], function(sp) {
    rbindlist(lapply(fgroups[, fishery_group], function(fg) {
        q0 <- vul[variable == 'q0']
        qf0 <- vul[vartype == 'q_f0' & fishery_group == fg]
        qg0 <- vul[vartype == 'q_g0' & species_group == spp[species == sp, spg]]
        qgf0 <- vul[vartype == 'q_gf0' & species == sp & fishery_group == fg]
        if (length(unique(c(nrow(q0), nrow(qf0), nrow(qg0), nrow(qgf0)))) != 1)
            stop('Pb selecting samples')
        q <- q0$value * qf0$value * qg0$value * qgf0$value
        data.table(sp = sp, fg = fg, q = q)
    }))
}))

q_summ <- q_samples[, .(mean = mean(q),
                       lcl = quantile(q, 0.025, names = F),
                       ucl = quantile(q, 0.975, names = F)), .(sp, fg)]

q_summ[, sp_lab := spp[match(sp, species), 'sp_lab']]
q_summ[, fg_lab := fgroups[match(fg, fishery_group), 'fg_lab']]
q_summ[, mean_rnd := round(mean, 3)]
q_summ[, ci := sprintf('(%0.3f - %0.3f)', lcl, ucl)]

ggsave('assets/vulnerability-total-matrix.png',
       make_heatmap(q_summ, 'sp_lab', 'fg_lab', 'mean', 'mean_rnd', 'ci'),
       width = 10, height = 6, scale = 0.7)

ggsave('assets/vulnerability-total-matrix-lcl.png',
       make_heatmap(q_summ, 'sp_lab', 'fg_lab', 'lcl', 'mean_rnd', 'ci'),
       width = 10, height = 6, scale = 0.7)

save(q_samples, q_summ, file = 'vulnerabilities_total.rdata')

## * Observed captures / overlap

agg_vul[sppdem[parameter=='population_total'], pop := i.mean, on = 'species']
agg_vul[, ratio := captures / (overlap * pop)]
agg_vul[, spgroup := sprintf('%s-%s', species_group, species)]

agg_vul[, sp_lab := spp[match(agg_vul$species, spp$species), 'sp_lab']]
agg_vul[, fg_lab := fgroups[match(agg_vul$fishery_group, fgroups$fishery_group), 'fg_lab']]

agg_vul[, ratio_rnd := round(ratio, 4)]

ggsave('assets/vulnerability-empirical-matrix.png',
       make_heatmap(agg_vul, 'sp_lab', 'fg_lab', 'ratio', 'ratio_rnd', trans='log1p'),
       width = 10, height = 6, scale = 0.7)


# 3. faza: Izdelava zemljevida

# Uvozimo funkcijo za pobiranje in uvoz zemljevida.
source("lib/uvozi.zemljevid.r")

# Uvozimo zemljevid.
cat("Uvažam zemljevid...\n")
slo <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2/shp/SVN_adm.zip",
                       "slovenija", "SVN_adm1.shp", mapa = "zemljevid",
                       encoding = "Windows-1250")
# Funkcija, ki podatke preuredi glede na vrstni red v zemljevidu
preuredi <- function(podatki, zemljevid) {
  nove.slo <- c()
  manjkajo <- ! nove.slo %in% rownames(podatki)
  M <- as.data.frame(matrix(nrow=sum(manjkajo), ncol=length(podatki)))
  names(M) <- names(podatki)
  row.names(M) <- nove.slo[manjkajo]
  podatki <- rbind(podatki, M)
  ord <- rank(levels(zemljevid$NAME_1)[rank(zemljevid$NAME_1)])
  out <- data.frame(podatki[order(rownames(podatki)), ])[ord, ]
  if (ncol(podatki) == 1) {
    out <- data.frame(out)
    names(out) <- names(podatki)
    rownames(out) <- rownames(podatki)[ord]
  }
  return(out)
}

# Narišimo zemljevid v PDF.
cat("Rišem zemljevid Slovenije...\n")
pdf("slike/Slo.pdf")

#Preuredimo podatke
povprecje <- preuredi(apply(DODANAVRED[445, c(6:9, 11:18)], 1, c), slo)

#spremenjene koordinate

koordinate <- coordinates(slo)
rownames(koordinate) <- as.character(slo$NAME_1)
koordinate["Obalno-kraška",1] <- koordinate["Obalno-kraška",1]-0.02#levo,desno
koordinate["Obalno-kraška",2] <- koordinate["Obalno-kraška",2]-0.085 #dol,gor
koordinate["Zasavska",2] <- koordinate["Zasavska",2]+0.01
koordinate["Spodnjeposavska",1] <- koordinate["Spodnjeposavska",1]+0.08
koordinate["Spodnjeposavska",2] <- koordinate["Spodnjeposavska",2]

# Izračunamo povprečno vrednost
#dodanavrednost$X2013 <- apply(DODANAVRED["445", (5:18)], 1, function(x) (dodan/sum(dodan)*100)

min.povprecje <- min(povprecje, na.rm=TRUE)
max.povprecje <- max(povprecje, na.rm=TRUE)
norm.2012 <- (povprecje-min.povprecje)/(max.povprecje-min.povprecje)

n = 100
barve =rgb(1, 1, (n:1)/n)[unlist(1+(n-1)*norm.2012)]
plot(slo, col = barve,bg="lightgreen")
text(koordinate,labels=as.character(slo$NAME_1),cex=0.3)
title("Povprečna bruto dodana vrednost leta 2012 po regijah")
LJUBLJANA <- slo$VARNAME_1 == "Ljubljana"
#points(coordinates(slo), pch = ifelse(LJUBLJANA, 18, 0), cex = ifelse(LJUBLJANA, 0.5 ,0), col = ifelse(LJUBLJANA, "red", "white"))
points(14.51000, 46.06000, pch = 18, cex = 0.5, col = "red")

legend("bottomright", legend = round(seq(min.povprecje, max.povprecje, (max.povprecje-min.povprecje)/5)),
       fill = rgb(1, 1, (6:1)/6), bg = "white")
slo$dv2012 <- povprecje[c(1:12),]

dev.off()

pdf("slike/Slov.pdf")

print(spplot(slo, "dv2012" ,col.regions  = topo.colors(50),
             main = "Povprečna bruto dodana vrednost leta 2012 po regijah",
             sp.layout = list(list("sp.text", koordinate,slo$NAME_1, cex = 0.3))))

dev.off()


# devtools::install_github('kasperwelbers/semnet')
# devtools::install_github('alessandrobessi/disparityfilter')
library(semnet)
library(disparityfilter)

######################## undirected networks. Gives the same results
set.seed(1)
g <- sample_pa(n = 500, m = 5, directed = FALSE)
E(g)$weight <- sample(1:25, ecount(g), replace = TRUE)

## same edges and alpha, though from/to can be switched (undirected network)
disparityfilter::backbone(g)
get.data.frame(semnet::getBackboneNetwork(g, delete.isolates = F))

######################## directed network. Gives the same results
set.seed(1)
g <- sample_pa(n = 500, m = 5, directed = TRUE)
E(g)$weight <- sample(1:25, ecount(g), replace = TRUE)

disparityfilter::backbone(g)
get.data.frame(semnet::getBackboneNetwork(g, delete.isolates = F))

######################### directed network with parallel edges. Does not work with semnet
set.seed(1)
g <- sample_pa(n = 500, m = 5, directed = TRUE, algorithm = 'psumtree-multiple')
E(g)$weight <- sample(1:25, ecount(g), replace = TRUE)

disparityfilter::backbone(g)
get.data.frame(semnet::getBackboneNetwork(g, delete.isolates = F))


#!/usr/bin/env Rscript

# a script to process the data from nonpareil and generate a meaningful figure

#functions
# check.packages function: install and load multiple R packages.
# (downloaded from: https://gist.github.com/smithdanielle/9913897)
# Check to see if packages are installed. Install them if they are not, then load them into the R session.
check.packages <- function(pkg){
  new.pkg <- pkg[!(pkg %in% installed.packages()[, "Package"])]
  if (length(new.pkg))
    install.packages(new.pkg, dependencies = TRUE, repos="https://cran.uib.no/")
  sapply(pkg, require, character.only = TRUE)
}

#Libraries to load and install if needed.
packages<-c("Nonpareil")
check.packages(packages)

# create list of npo files to process with this script, and count element of list
npo_files <- list.files(".", pattern = "*.npo",full.names = TRUE)

number <- length(npo_files)

# Create a list of colors to use.
all_colors <- colorRampPalette(c("#CBD588", "#5F7FC7", "orange","#DA5724", "#508578", "#CD9BCD",
                                 "#AD6F3B", "#673770","#D14285", "#652926", "#C84248",
                                 "#8569D5", "#5E738F","#D1A33D", "#8A7C64", "#599861"))

# creating a textfile to collect the summary of the Nonpareil.Curve results
headers <- c("kappa","C","LR","modelR","LRstar","diversity")
write(headers, "Curves_summary.txt", append=TRUE, ncolumns=6, sep="\t")

# plotting each sample as an individual graph with an dispersion distribution around it.
#system("mkdir single_plots")

for (i in 1:number){
  myfile <- file.path("single_plots", paste0(npo_files[i], ".np_plot.png"))
  png(filename= myfile,
      width = 12, height = 9, units="in", res=300, bg="white")
  p <- Nonpareil.curve(npo_files[i], plot.dispersion="sd", col="black")
  Nonpareil.legend(p)
  dev.off()

  #wr #writting to Curves_summary.txt file
  Values_p <- summary.Nonpareil.Curve(p)
  write(Values_p, "Curves_summary.txt", append=TRUE, ncolumns=6,sep="\t")
}

## printing all samples in one graph
png(filename= "non_pareil_plot.png",
    width = 12, height = 9, units="in", res=300, bg="white")
p <- Nonpareil.curve.batch(npo_files, col=all_colors(number))
dev.off()