library(ggplot2)
theme_set(theme_bw(18))
setwd("~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/sinking-marbles-production/results/")
source("rscripts/helpers.r")
load("data/priors.RData")
r = read.table("data/sinking_marbles_nullutterance-production.txt", sep="\t", header=T)
nrow(r)
names(r)
r$trial = r$slide_number_in_experiment - 2
r = r[,c("assignmentid","workerid", "rt", "effect", "language","gender.1","age","gender","other_gender", "object_level", "response", "object","slider_id","num_objects","trial","enjoyment","asses","comments","Answer.time_in_minutes","num_objects_affected")]
row.names(priors) = paste(priors$effect, priors$object)
r$Prior = priors[paste(r$effect, r$object),]$response
r$object_level = factor(r$object_level, levels=c("object_high", "object_mid", "object_low"))
r$Quantifier = r$slider_id
r$Half = as.factor(ifelse(r$trial < 16, 1, 2))
r$Quarter = as.factor(ifelse(r$trial < 8, 1, ifelse(r$trial < 16, 2, ifelse(r$trial < 24, 3, 4))))
summary(r)
r$Combination = as.factor(paste(r$cause,r$object,r$effect))
table(r$Combination)

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

r$Proportion = r$num_objects_affected/r$num_objects
r$ProportionBin = 3
r[r$Proportion < 1,]$ProportionBin = cut(r[r$Proportion < 1,]$Proportion,breaks=quantile(r[r$Proportion < 1,]$Proportion, probs=seq(0,1,.5)))

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

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

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

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

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

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

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

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

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

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

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

unique(r$comments)

table(r$num_objects_affected,r$num_objects)

########################################
# compute speaker probabilities for model
########################################
# first exclude all the trials on which there were no affected objects
atleastone = subset(r, Proportion > 0)
atleastone = droplevels(atleastone)
nrow(atleastone)
summary(atleastone)

# simplest model:
r$State = as.factor(ifelse(r$Proportion == 1, "all", "not-all"))
table(r$State)

probs = aggregate(normresponse ~ Quantifier + State, FUN=mean, data=r)
probs # probs for model
priors = unique(r$Prior)
sort(unique(round(priors/100,2))) # priors to run model with
length(sort(unique(round(priors/100,2))) ) # 52 unique priors


library(raster)
library(WatershedTools)
library(sp)
library(data.table)
library(RSQLite)

metabDB <- dbConnect(RSQLite::SQLite(), "../metabolismDB/metabolism.sqlite")
dbExecute(metabDB, "PRAGMA foreign_keys = ON")

metadat <- fread("catchment_list.csv")[catchment == "vjosa"]
shareDir <- file.path(metadat$dir, metadat$catchment, metadat$version)

drain <- raster(file.path(shareDir, "drainage.tif"))
accum <- raster(file.path(shareDir, "accumulation.tif"))
elev <- raster(file.path(shareDir, "filled_dem.tif"))
vjosaChannel <- raster(file.path(shareDir, "vjosa_stream.tif"))
catchmentAreas <- raster(file.path(shareDir, "catchment_area.tif"))

# get discharge
qry <- "SELECT sites.siteName, (expeditions.watershed || expeditions.season || expeditions.year)
	AS expedition, date, hydromorphology.value AS discharge, x, y, epsg FROM hydromorphology
	LEFT JOIN sites ON siteID = sites.id
	LEFT JOIN variableLookUp ON variableCode = variableLookUp.id
	LEFT JOIN expeditions on expeditionID = expeditions.id
	WHERE variableLookUp.variable LIKE 'Q' AND expedition LIKE 'Vjosa%'"
qSites <- data.table(dbGetQuery(metabDB, qry))
coordinates(qSites) <- c('x', 'y')
proj4string(qSites) <- CRS(paste0("+init=epsg:", qSites$epsg[1]))
qSites$catchmentArea <- raster::extract(catchmentAreas, qSites)
qSites <- as.data.table(qSites)
qSites <- qSites[, .(siteName = siteName, expedition = expedition, Q = discharge,
	A = catchmentArea, x, y)]

caDF <- cbind(values(catchmentAreas), coordinates(catchmentAreas))
caDF <- caDF[complete.cases(caDF),]
qByExpedition <- by(qSites, factor(qSites$expedition), function(x) {
	q <- discharge_scaling(caDF[,1], x)
	q <- data.frame(Q = q, x = caDF[,2], y = caDF[,3])
	q <- rasterFromXYZ(q[, c('x', 'y', 'Q')])
	proj4string(q) <- proj4string(catchmentAreas)
	q
})

lapply(names(qByExpedition), function(x) writeRaster(qByExpedition[[x]],
	file = file.path(shareDir, "tmp", paste0("discharge", x, ".tif"))))

par(mfrow=c(2,2))

lapply(names(qByExpedition), function(x) {
	val <- values(qByExpedition[[x]])
	val <- val[!is.na(val)]
	ind <- which(qSites$expedition == x)
	dat <- qSites[ind,]
	plot(log(caDF[,1]), log(val), xlab="log(Catchment Area)", ylab="log(discharge)",
		pch='x', cex=0.3, col='red', main=x)
	points(log(dat$A), log(dat$Q), pch=16, cex=0.7, col='blue')
})

geom <- lapply(qByExpedition, function(x) {
	df <- data.frame(x = coordinates(x)[,1], y = coordinates(x)[,2], q = values(x))
	df <- df[complete.cases(df),]
	geom <- hydraulic_geometry(df[,3])
	coordinates(geom) <- df[,1:2]
	gridded(geom) <- TRUE
	geom <- stack(geom)
	proj4string(geom) <- proj4string(catchmentAreas)
	geom
})

nms <- names(geom)
for(x in nms) {
	gdir <- file.path(shareDir, paste0("geometry_", x))
	dir.create(gdir, showWarnings=FALSE)
	for(y in names(geom[[x]])) {
		writeRaster(geom[[x]][[y]], file.path(gdir, paste0(y, "_", x, ".tif")),
			options = c("COMPRESS=LZW", "PREDICTOR=3"))
	}
}

# only if needed due to non-matching extents
# catchmentAreas <- extend(catchmentAreas, vjosaChannel)
# geom <- lapply(geom, extend, vjosaChannel)

vjosaWS <- list()
for(x in nms) {
	geom <- stack(list.files(paste0(shareDir, "/geometry_", x), pattern="*.tif",
		full.names = TRUE))
	vjosaWS[[x]] <- Watershed(stream = vjosaChannel, drainage = drain, elevation = elev,
		accumulation = accum, catchmentArea = catchmentAreas,
		otherLayers = geom)
}

## get slope and add to all watersheds
slope = wsSlope(vjosaWS[[1]])
for(x in nms) {
	vjosaWS[[x]]$data$slope = slope
	saveRDS(vjosaWS[[x]], paste0(shareDir, "/watershed_", x, ".rds"))
}

dbDisconnect(metabDB)


library(ggplot2)
library(readr)
library(dplyr)
library(geosphere)
library(tibble)
library(dplyr)
library(ggplot2)
library(cowplot)
library(stringr)
library(knitr)
library(leaflet)
library(ggmap)
library(maps)
library(mapdata)
library(rvest)
library(magrittr)
library(stringr)
library(tibble)
library(tidyr)
library(dplyr)
library(purrr)
library(readr)
library(shiny)
library(shinydashboard)

city_data <- read_csv("./city_data.csv")
categ_data <- read_csv("./categ_data.csv")
allCateg = unique(categ_data$normTitleCategory)

sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Annual Statistics", tabName = "AnnualStat", icon = icon("th")),
    menuItem("Dynamic Trend by Industry", icon = icon("dashboard"), tabName = "DyTrend1"),
    menuItem("Dynamic Trend by States", icon = icon("institution"), tabName = "DyTrend2"),
    menuItem("Models", icon = icon("graduation-cap"), tabName = "FittedModels"),

    br(),
    br(),
    br(),

    actionButton("do", "See Results")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "AnnualStat",
            h2("Annual Information by City"),
            div(style="display:inline-block",selectInput("categSelect", label = "Industry",
                                                         choices = c("All",allCateg),
                                                         selected = "All")),
            div(style="display:inline-block",selectInput("dataSelect", label = "Variable for city map",
                                                         choices = c("Annual Salary", "Clicks per job",
                                                                     "Local clicks ratio"),
                                                         selected = "Annual Salary")),

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

    tabItem(tabName = "DyTrend1",
            h2("Monthly Changes by Industry"),
            div(style="display:inline-block",selectInput("categDataSelect",
                                                         label = "Variable for Changes in Industry",
                                                         choices = c("Number of jobs", "Number of clicks"),
                                                         selected = "Number of jobs")),
            div(style="display:inline-block",selectInput("categDataSort",
                                                         label = "Way to sort industries",
                                                         choices = c("By value", "By name"),
                                                         selected = "By value")),

            uiOutput("categImage")
    ),

    tabItem(tabName = "DyTrend2",
            h2("Monthly Changes by State"),
            selectInput("monthDataSelect",
                        label = "Variable for monthly trend",
                        choices = c("Number of jobs", "Number of clicks",
                                    "Number of local clicks", "Proportion of local clicks"),
                        selected = "Number of jobs"),
            uiOutput("MapTrendImage")
    ),

    tabItem(tabName = "FittedModels",
            h2("Model"),
            selectInput("modelSelect",
                        label = "Select Model",
                        choices = c("Gaussian Process", "Time Series", "SAR model"),
                        selected = "Gaussian Process"),
            uiOutput("ModelImage")
    )
  )
)

ui <- dashboardPage(
  dashboardHeader(title = "Indeed Job Data Visualization by BrunchLadies",
                  titleWidth = 450),
  sidebar,
  body
)

server = function(input, output, session)
{
  output$map<-renderLeaflet({
    leaflet() %>%
      addTiles()
  })

  output$categImage <- renderUI({
    img(src = "animation_1.gif", width="800")
  })

  output$MapTrendImage <- renderUI({
    img(src = "total_jobs.gif", width="1000")
  })

  output$ModelImage <- renderUI({
    img(src = "GP_Model.png", width="600")
  })

  observeEvent(input$do,{

    ## Get Dataset
    if(input$categSelect=="All"){
      data = city_data
      r = data$n/180
    }else{
      data = categ_data %>%
        filter(normTitleCategory==input$categSelect)
      r = data$n/15
    }

    if(input$dataSelect=="Annual Salary"){
      pal <- colorNumeric(palette = c("lightpink", "red4"), domain = data$medianSalary)
      p1 = leaflet() %>%
        addTiles() %>%
        addCircleMarkers(lng=data$lng, lat=data$lat, popup=data$SalaryInfo,
                         color = pal(data$medianSalary), stroke = FALSE,
                         radius = r, fillOpacity = 0.8) %>%
        addLegend("bottomright", pal = pal, values = data$medianSalary,
                  title = "Median Salary",
                  labFormat = labelFormat(prefix = "$"),
                  opacity = 0.8)
    }else if(input$dataSelect=="Clicks per job"){
      pal <- colorNumeric(palette = c("lightblue", "darkblue"), domain = data$cityMeanClick)
      p1 = leaflet() %>%
        addTiles() %>%
        addCircleMarkers(lng=data$lng, lat=data$lat, popup=data$ClickInfo,
                         color = pal(data$cityMeanClick), stroke = FALSE,
                         radius = r, fillOpacity = 0.8) %>%
        addLegend("bottomright", pal = pal, values = data$cityMeanClick,
                  title = "Average Click per job",
                  opacity = 0.8)
    }else{
      pal <- colorNumeric(palette = c("lightpink", "red4"), domain = data$localRatio)

      p1 = leaflet() %>%
        addTiles() %>%
        addCircleMarkers(lng=data$lng, lat=data$lat, popup=data$LocalClickInfo,
                         color = pal(data$localRatio), stroke = FALSE,
                         radius = r, fillOpacity = 0.8) %>%
        addLegend("bottomright", pal = pal, values = data$localRatio,
                  title = "Local Click Ratio per job",
                  opacity = 0.8)
    }

    if(input$categDataSort=="By value"){
      if(input$categDataSelect=="Number of clicks"){
        imageName = "haha_1.gif"
      }else{
        imageName = "animation_1.gif"
      }
    }else{
      if(input$categDataSelect=="Number of clicks"){
        imageName = "haha_0.gif"
      }else{
        imageName = "animation_0.gif"
      }
    }

    if(input$monthDataSelect=="Number of jobs"){
      mapName = "total_jobs.gif"
    }else if(input$monthDataSelect=="Number of clicks"){
      mapName = "total_clicks.gif"
    }else if(input$monthDataSelect=="Number of local clicks"){
      mapName = "total_localClicks.gif"
    }else{
      mapName = "localClicks_ratio.gif"
    }

    if(input$modelSelect=="Gaussian Process"){
      modelName = "GP_Model.png"
    }else if (input$modelSelect=="Time Series"){
      modelName = "TS_model.png"
    }else{
      modelName = "SAR_model.png"
    }

    output$categImage <- renderUI({
      img(src = imageName, width="800")
    })

    output$MapTrendImage <- renderUI({
      img(src = mapName, width="1000")
    })

    output$ModelImage <- renderUI({
      img(src = modelName, width="600")
    })

    output$map<-renderLeaflet({
      p1
    })
  })
}

shinyApp(ui, server)


library("arrow")
library("abc")
library("optparse")

main <- function(opt){
    df_true_ss <- read_f(input=opt$df_true_ss)
    df_simu_space_knn_params <- read_f(input=opt$df_simu_space_knn_params)
    df_simu_space_knn_ss <- read_f(input=opt$df_simu_space_knn_ss)
    df_simu_space_knn_chainID <- read_f(input=opt$df_simu_space_knn_chainID)
    df_knn <- as.data.frame(abc(
        target = df_true_ss,
        param = df_simu_space_knn_params,
        sumstat = df_simu_space_knn_ss,
        tol = 1,
        method = opt$reg_model,
        transf = opt$transf,
        hcorr = opt$hcorr,
        kernel = opt$kernel,
        sizenet = 1)$adj.values)
    df_knn_ <- cbind(df_simu_space_knn_chainID,df_knn)
    write_f(df=df_knn_, output=opt$output)
}

read_f <- function(input) {
    df <- read_feather(file = input, as_data_frame = TRUE)
    return(df)
}

write_f <- function(df, output) {
    write_feather(x = as.data.frame(df),sink = output, version=2)
}

option_list = list(
    make_option("--reg_model", type="character", default=NULL,help="--reg_model", metavar="character"),
    make_option("--hcorr", type="character", default=NULL,  help="--hcorr", metavar="character"),
    make_option("--kernel", type="character", default=NULL, help="--kernel", metavar="character"),
    make_option("--transf", type="character", default=NULL, help="--transf", metavar="character"),
    make_option("--output", type="character", default=NULL, help="--output", metavar="character"),
    make_option("--df_true_ss", type="character", default=NULL, help="--df_true_ss", metavar="character"),
    make_option("--df_simu_space_knn_params", type="character", default=NULL,  help="--df_simu_space_knn_params", metavar="character"),
    make_option("--df_simu_space_knn_ss", type="character", default=NULL, help="--df_simu_space_knn_ss", metavar="character"),
    make_option("--df_simu_space_knn_chainID", type="character", default=NULL, help="--df_simu_space_knn_chainID", metavar="character")
)
opt_parser = OptionParser(option_list=option_list)
opt = parse_args(opt_parser)

if (is.null(opt$reg_model)){
  print_help(opt_parser)
   stop("", call.=FALSE)
}

main(opt=opt)


########################################################################################################################
####
#### R-Script to reproduce the results (Figures and Tables) of the paper
#### "Asymmetric latent semantic indexing for gene expression experiments visualization"
#### Submitted to Advances in data analysis and classifciation.
####
#### Authors: Javier Gonzalez, Alberto Munoz and Gabriel Martos
####
#### 15/02/2014
####
########################################################################################################################
# requiered libraries
library(geneplotter)
library(RColorBrewer)
library(genefilter)
library(MASS)
library(mclust)
library(gplots)
library(mclust)
library(xtable)

### Load the data
data      <- read.table("nci.data")
labels    <- read.table("labels.txt")[,1]

# Expression estimates on the UN-LOGGED scale
e.mat     <- exp(data)

# look at mean, sd, & cv for each gene across arrays
gene.mean <- apply(e.mat,1,mean)
gene.sd   <- apply(e.mat,1,sd)
gene.cv   <- gene.sd/gene.mean

# Plot of the gene.sd over the gene mean and histogram of those with cv. larger that 7.7
blues.ramp <- colorRampPalette(brewer.pal(9,"Blues")[-1])
dCol       <- densCols(log(gene.mean),log(gene.sd), colramp=blues.ramp)

###########
# Figure 3: cut-off for differential expression analysis
###########
par(mfrow=c(1,2))
plot(gene.mean,gene.sd,log='xy',col=dCol,pch=16,cex=0.1,xlim = c(1,2),ylim = c(0.2,5),xlab="Gene mean", ylab="Gene sd.",main="A",cex.main=2)
abline(v=100,lwd=3,col='red')
hist(log(gene.cv),xlab = "Gene CV (log. scale)",col="grey",main="B",cex.main=2)
abline(v=log(.5),lwd=3,col='red')
text(0.8,800,"Theshold: CV>0.5")

# We select those genes with CV larger.5 (genes differentially expressed in the data)
ffun          <- filterfun(cv(0.5,100))
t.fil         <- genefilter(e.mat,ffun)

# Apply filter and transform back on log scale
small.eset    <- e.mat[t.fil,]
small.noeset  <- e.mat[!t.fil,]

# Threshod to consider that a gene is expressed (the maximum value of the not expressed).
thres = max(small.noeset)

###########
# Figure 2: diff-expressed vs. not diff-expressed gene.
###########
par(mfrow=c(1,2))
par(mar=c(5,5,3,3))
plot(1:64,small.eset[99,],ylim=c(0,15),pch =20,xlab="Experiment",ylab="Expression",main="Differentially expressed gene",cex=2)
abline(h = thres ,lwd=2, col = "red",lty=2)
plot(1:64,small.noeset[2,],ylim=c(0,15),pch =20,xlab="Experiment",ylab="Expression",main="Non differentially expressed gene",cex=2)
abline(h = thres ,lwd=2, col = "red",lty=2)

# Select those genes expressed at least one time
ffun2         <- filterfun(pOverA(0.025,thres))
t.fil2        <- genefilter(small.eset,ffun2)
small.eset2   <- small.eset[t.fil2,]

# Create genes by experiments matrix of differentially expressed genes
colnames(small.eset2) <- labels
X                     <- as.matrix((sign(small.eset2 - thres)+1)/2)  # genes by experiments matrix
colnames(X)           <- labels
n.genes               <- nrow(X)

###########
# Figure 2: Zipf's law, histogram of the norm of the genes
###########
par(mfrow=c(1,1))
norm.genes = apply(X,1,sum)
hist(norm.genes,nclass=25,col = "grey",main = " ",xlab="Genes Norm",ylab="Frequency")
text(16,600,paste(n.genes," differentially expressed genes"),cex=1.7)

###########
# Figure 1 (A and B): Heatmaps pf raw data and differentially expressed genes
###########
heatmapA <- heatmap(log(t(small.eset2)), Rowv=NA, Colv=NA,scale="column",margins = c(0.5, 15))
heatmapB <- heatmap(t(X), Rowv=NA, Colv=NA, scale="none",margins = c(0.5, 15))

# Define the degree of membership of each gene to each type of experiment
n.groups                          <- length(table(labels))
membership.genes.probs            <- matrix(0,n.genes,n.groups )
membership.genes                  <- matrix(0,n.genes,n.groups )
colnames(membership.genes.probs)  <- levels(labels)
colnames(membership.genes)        <- levels(labels)

for (i in 1:n.genes)
  {
  membership.genes.probs[i,] = table(labels[X[i,]==1])/norm.genes[i]
  membership.genes[i,which(membership.genes.probs[i,] == max(membership.genes.probs[i,]))]=1
  }

### Calculate the (asymmetric) matrix of similarities between genes with respect to the experiments
S0 		            <- X %*% t(X)
Matrix.norms.inv	<- diag(1/norm.genes)
S 		            <- Matrix.norms.inv %*% S0

## Calculate the polar decomposition
svdS              <- svd(S)
M1                <- svdS$u%*%diag(svdS$d)%*%t(svdS$u)
M2                <- svdS$v%*%diag(svdS$d)%*%t(svdS$v)

### Calculate the (asymmetric) matrix of similarities between genes with respect to the classes
Z                 <- membership.genes%*%t(membership.genes)%*%diag(1/apply(membership.genes,1,sum))
svdZ              <- svd(Z)
R1                <- svdZ$u%*%diag(svdZ$d)%*%t(svdZ$u)
R2                <- svdZ$v%*%diag(svdZ$d)%*%t(svdZ$v)

## Matrix combination of the two asymmetric similarities
A                 <- (M1+M2)/2 + 0.2*(R1+R2)

## Extract components
eigA              <- eigen(A)
XX                <- Re(eigA$vectors[,Re(eigA$values)>0.0001])%*%diag(sqrt(Re(eigA$values)[Re(eigA$values)>0.0001]))

# Extract components of the mixture
cluster.lsa       <- Mclust(XX, G =14)

# Cross the clusters with the original classes
cross = matrix(NA,14,14)
for (k in 1:14){cross[k,] = table(membership.genes[,k],cluster.lsa$classification)[2,]}
rownames(cross)   <- levels(labels)
colnames(cross)   <- c("C1","C2","C3","C4","C5","C6","C7","C8","C9","C10","C11","C12","C13","C14")

###########
# Table 2: clusters vs. orignal classes
###########
xtable(cross)

###########
# Figure 6: MDS of the groups
##########
X.cross = sammon(dist(cross))
plot(X.cross$points,xlab= "Component 1",ylab= "Component 2",type="n",col=1:14,xlim=c(-270,270),ylim=c(-270,270),main = "aLSI mapping of types of Cancer")
text(X.cross$points,rownames(X.cross$points),col="blue",cex=1.1)

### Obtain genes with higest probability in each cluster
mp                <- matrix(NA,5,14)
for (i in 1:14){mp[,i] = order(cluster.lsa$z[,i],decreasing = TRUE)[1:5]}
colnames(mp)      <- c("C1","C2","C3","C4","C5","C6","C7","C8","C9","C10","C11","C12","C13","C14")
rownames(mp)      <- c("gene 1","gene 2","gene 3","gene 4","gene 5")

###########
# Table 1: most probable genes of each cluster
###########
xtable(t(mp))

## Sammon mapping for the combination
mds.S12         <- prcomp(XX)$x[,c(1,2)]  ## save similarity matrix
mds.S13         <- prcomp(XX)$x[,c(1,3)]  ## save s
cluster.lsa     <- hclust(dist(XX),method="ward")

### MDS-Correlation
C               <- cor(log(t(small.eset2)))
mds.C12         <- cmdscale(1-C,k=3)[,c(1,2)]
mds.C13         <- cmdscale(1-C,k=3)[,c(1,3)]

### MDS-Euclidean
D               <- dist(log(small.eset2))
mds.D12         <- cmdscale(D,k=3)[,c(1,2)]
mds.D13         <- cmdscale(D,k=3)[,c(1,3)]

###########
# Figure 5: genes maps produced by the aLSI, Pearson's correlation and Euclidean distance.
###########
par(mfrow = c(3,2))
par(mar= c(5,5,1.5,1))
plot(mds.S12,pch=19,cex=0.8,col="grey",type="n",main = "Asymmetric LSI",xlab="1st component",ylab="2nd component",xlim=c(-1,1.4))
for(k in 1:14)
points(mds.S12[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9)
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

plot(mds.S13,pch=19,cex=0.8,col="grey",type="n",main = "Asymmetric LSI",xlab="1st component",ylab="3th component",xlim=c(-1,1.4))
for(k in 1:14)
points(mds.S13[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9,xlab="1st component")
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

plot(mds.C12,pch=19,cex=0.8,col="grey",main = "Correlation",xlab="1st component",ylab="2nd component",xlim=c(-1,1.2))
for(k in 1:14)
points(mds.C12[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9)
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

plot(mds.C13,pch=19,cex=0.8,col="grey",main = "Correlation",xlab="1st component",ylab="3th component",xlim=c(-1,1.2))
for(k in 1:14)
points(mds.C13[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9)
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

plot(mds.D12,pch=19,cex=0.8,col="grey",main = "Euclidean distance",xlab="1st component",ylab="2nd component",xlim=c(-20,20))
for(k in 1:14)
points(mds.D12[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9)
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

plot(mds.D13,pch=19,cex=0.8,col="grey",main = "Euclidean distance",xlab="1st component",ylab="3th component",xlim=c(-20,20))
for(k in 1:14)
points(mds.D13[which(apply(membership.genes,1,sum)==1 & membership.genes[,k]==1), ],col=k,pch=k,cex=0.9)
legend("topleft",  c("G1","G2","G3","G4","G5","G6","G7"), col=1:7,pch=1:7)
legend("topright", c("G8","G9","G10","G11","G12","G13","G14"), col=8:14,pch=8:14)

code/Script for aLSI for gene expression visualization.r


context("data-nycflights13")

library(nycflights13)

test_that("nycflights13_h2 has flights table", {
  # when
  flights_db <- tbl(nycflights13_h2(), "flights")

  # then
  expect_is(flights_db, "tbl_h2")
  expect_equal(nrow(flights_db), 336776)
  expect_equal(ncol(flights_db), 19)
})

test_that("filter", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  filtered <- filter(flights_db, month == 1, day == 1)

  expect_is(filtered, "tbl_h2")
})

test_that("arrange", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  arranged <- arrange(flights_db, year, month, day)

  expect_is(arranged, "tbl_h2")
})

test_that("select", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  selected <- select(flights_db, year, month, day)

  expect_is(selected, "tbl_h2")
})

test_that("distinct", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  distinct_tailnum <- distinct(select(flights_db, tailnum))

  expect_is(distinct_tailnum, "tbl_h2")
})

test_that("group_by", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  grouped <- group_by(flights_db, tailnum)

  expect_is(grouped, "tbl_h2")
})

test_that("summarize", {
  flights_db <- tbl(nycflights13_h2(), "flights")

  summarized <- summarise(flights_db,
    count = n(),
    distinct = n_distinct("flight"),
    dist = mean(distance),
    delay = mean(arr_delay),
    min_delay = min(arr_delay),
    max_delay = max(arr_delay),
    sum_delay = sum(arr_delay),
    sd_delay = sd(arr_delay)
  )

  expect_is(summarized, "tbl_h2")
})


get.data <- function(fnc.path,loading.path,target.path) {
fnc_df = read.csv(fnc.path)
loading_df = read.csv(loading.path)
labels_df = read.csv(target.path)
library(tidyr)#drop_na()
df <- merge(fnc_df,loading_df,by="Id")
labels_df$is.train  = T
df <- merge(x=labels_df, y=df, all.x=TRUE)
df<-drop_na(df)
df<-df[,-c(1,7)]
head(df)
return(df)
}

data<-get.data("../input/trends-assessment-prediction/fnc.csv","../input/trends-assessment-prediction/loading.csv","../input/trends-assessment-prediction/train_scores.csv")

smp_size <- floor(0.75 * nrow(data))
## set the seed to make your partition reproducible
set.seed(123)
train_ind <- sample(seq_len(nrow(data)), size = smp_size)
train <- data[train_ind, ]
test <- data[-train_ind, ]
dim(train)
dim(test)


# ==== US County Map Data ====
COUNTIES_GEO <- geojsonio::geojson_read("data/geography/gz_2010_us_050_00_20m.json",
                                    what = "sp")

# Lowercase names
names(COUNTIES_GEO@data) = tolower(names(COUNTIES_GEO@data))

# ==== Helper Functions ====
get_label <- function(data, n, output='', transform=c()) {
  # n:      Number of bins data was separated into
  # output:
  #  * "":          Don't change output
  #  * "percent":   Output percentage values
  # transform:      A list of transformations to apply to the labels

  # Get the breaks that colorQuantile uses
  # quantile(geog_demo_data$black_percent,
  #          probs = seq(0, 1, length.out = 9), na.rm=TRUE)
  breaks <- quantile(data, probs = seq(0, 1, length.out = n + 1),
                     na.rm=TRUE)

  labels <- c()

  for (i in 1:n) {
    if (length(transform) > 0) {
      for (func in transform) {
        lower_bound <- do.call(what=func, args=list(breaks[i]))
        upper_bound <- do.call(what=func, args=list(breaks[i + 1]))
      }
    } else {
      lower_bound <- breaks[i]
      upper_bound <- breaks[i + 1]
    }

    if (output == 'percent') {
      labels <- append(labels,
                       paste0(round(lower_bound, 3) * 100, "%",
                              " - ",
                              round(upper_bound, 3) * 100, "%"))
    } else {
      labels <- append(labels, paste0(lower_bound, " - ", upper_bound))
    }
  }

  return(labels)
}

as.money <- function(value, currency.sym="$", digits=2, sep=",", decimal=".") {
  # Credits: http://stackoverflow.com/questions/14028995/money-representation-in-r
  paste(
    currency.sym,
    formatC(value, format = "f", big.mark = sep, digits=digits, decimal.mark=decimal),
    sep=""
  )
}

as.td_yr <- function(year) {
  # Convert four-digit year to two-digit

  if (is.character(year)) {
    year <- as.numeric(year)
  }

  return(as.character(substrRight(year, 2)))
}

# From: https://stackoverflow.com/questions/7963898/extracting-the-last-n-characters-from-a-string-in-r
substrRight <- function(x, n){
  substr(x, nchar(x)-n+1, nchar(x))
}


#!/usr/bin/env Rscript

#CALL: Rscript rapidNorm.R <configFile> <AnnotationFile> <OutputFolder> <LengthRestrictionIfAny>

#load libraries
library("scales")

####FUNCTIONS####
readStatistics <- function(path){
  full=paste(path,"/Statistics.dat",sep="")
  stats=read.table(full,header=T,sep=" ",stringsAsFactors=FALSE)
  return(stats)
}

readTotal <- function(path){
  full=paste(path,"/TotalReads.dat",sep="")
  total=read.table(full,header=F,sep=" ")
  return(total$V1)
}

#This function compute the region lengths from the Annotation file given
#to the RAPID pipeline and used for intersection
computeRegionLengths <- function(data){
  #process
  names(data)=c("chr","start","end","label","type","strand")
  #compute lengths
  singleLengths=apply(data,1,function(x){return(as.numeric(x[3])-as.numeric(x[2])+1)})
  dummyDF=data.frame(label=data$label,lens=singleLengths)
  res=by(dummyDF,dummyDF$label,function(x){sum(x$lens)})
  return(data.frame(region=as.character(names(res)),lens=as.numeric(res)))
}

addLengthColumnToStats <- function(Stats,lens){
  Lengths=computeRegionLengths(lens)
  for(i in 1:length(Stats)){
    df=Stats[[i]]
    Stats[[i]] = merge(df,Lengths,by="region")
  }
  return(Stats)
}

getMax <- function(Total){
  return(max(unlist(Total)))
}

normalizeEntries <- function(Stats,oldTotal,adjustForBackground=TRUE,normalizeByLength=TRUE, normalizeByDESeq=FALSE){
  #the default is to adjust the counts for any small RNA background counts obtained and for region length
  #Note: that if the 3rd column of the config file has the entry none, then no count is substracted
  Total=oldTotal
  if(adjustForBackground){
    for (i in 1:length(Stats)){
      Total[i]=Total[[i]]-countBackgroundReads(Stats[[i]],conf$background[i])
    }
  }

  if(normalizeByDESeq){
    library("DESeq2")
    newList=Stats
    readData=as.data.frame(Stats[[1]]$region)
    for(i in 1:length(Stats)){
      readData=cbind(readData,Stats[[i]]$reads)
    }
    colnames(readData)=c("Regions",c(1:length(Stats)))
    readData$Regions=NULL
    sizes=estimateSizeFactorsForMatrix(readData)
    for (i in 1:length(Stats)){
      newList[[i]]$reads_norm=round(newList[[i]]$reads/sizes[i],digits = 0)
      newList[[i]]$asreads_norm=round(newList[[i]]$antisenseReads/sizes[i],digits = 0)
      newList[[i]]$asratio_norm=round(newList[[i]]$asreads_norm/newList[[i]]$reads_norm,digits=2)
      newList[[i]]$asratio_norm[is.na(newList[[i]]$asratio_norm)]=0
      newList[[i]]$asratio_norm[is.infinite(newList[[i]]$asratio_norm)]=0
      if(normalizeByLength){
        newList[[i]]$reads_avg=round( (newList[[i]]$reads_norm/newList[[i]]$lens),digits=3)
      }
      newList[[i]]$RPK=(newList[[i]]$reads_norm/newList[[i]]$lens)*1000
      newList[[i]]$TPM=round(newList[[i]]$RPK/(sum(newList[[i]]$RPK)/1e+06), digits = 3)
      newList[[i]]$RPK=NULL
    }
  }
  else {
    Max=getMax(Total)
    newList=Stats
    for (i in 1:length(Stats)){
      newList[[i]]$reads_norm=round(newList[[i]]$reads*(Max/Total[[i]]),digits=0)
      newList[[i]]$asreads_norm=round(newList[[i]]$antisenseReads*(Max/Total[[i]]),digits=0)
      newList[[i]]$asratio_norm=round(newList[[i]]$asreads_norm/newList[[i]]$reads_norm,digits=2)
      newList[[i]]$asratio_norm[is.na(newList[[i]]$asratio_norm)]=0
      newList[[i]]$asratio_norm[is.infinite(newList[[i]]$asratio_norm)]=0
      if(normalizeByLength){
        newList[[i]]$reads_avg=round( (newList[[i]]$reads_norm/newList[[i]]$lens),digits=3)
      }
      newList[[i]]$RPK=(newList[[i]]$reads_norm/newList[[i]]$lens)*1000
      newList[[i]]$TPM=round(newList[[i]]$RPK/(sum(newList[[i]]$RPK)/1e+06),digits = 3)
      newList[[i]]$RPK=NULL
    }
  }
  return(newList)
}
#this function gets as input a string with region names. The total read count of these regions
#will be returned.
countBackgroundReads <- function(Stats,string){
  if(string=="none"){
    return(c(0))
  }
  else{
    entries=unlist(strsplit(string, ","))
    return(sum(subset(Stats,region %in% entries)$reads))
  }
}

createPlottingData <- function(Stats,conf){
  rows=nrow(Stats[[1]])
  numDatasets=length(Stats)
  readCounts=rep(Stats[[1]]$reads,numDatasets)
  readCountsNormTPM=rep(Stats[[1]]$TPM,numDatasets)
  readCountsNorm=rep(Stats[[1]]$reads_norm,numDatasets)
  ASreadCountsNorm=rep(Stats[[1]]$asreads_norm,numDatasets)
  readCountsAvg=rep(Stats[[1]]$reads_avg,numDatasets)
  #ASratio=rep(Stats[[1]]$ASratio,numDatasets)
  ASratioNorm=rep(Stats[[1]]$asratio_norm,numDatasets)

  names=rep(conf$name[1],numDatasets*rows)
  for(i in 1:(numDatasets-1)){
    readCounts[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$reads
    readCountsNormTPM[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$TPM
    readCountsNorm[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$reads_norm
    ASreadCountsNorm[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$asreads_norm
    readCountsAvg[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$reads_avg
    #ASratio[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$ASratio
    ASratioNorm[(i*rows+1):((i+1)*rows)] = Stats[[i+1]]$asratio_norm
    names[(i*rows+1):((i+1)*rows)] = rep(conf$name[i+1],rows)
  }
  df=data.frame(region = rep(Stats[[1]]$region,numDatasets), readCounts=readCounts, readCountsNormTPM=readCountsNormTPM, readCountsNorm=readCountsNorm, readCountsAvg=readCountsAvg, ASreadCountsNorm=ASreadCountsNorm, ASratioNorm=ASratioNorm, samples=names)
  return(df)
}

####DONE FUNCTIONS####
args <- commandArgs(trailingOnly = TRUE)

config=args[1]
annot=args[2]
out=args[3]
useDEseq=args[4]
restrictLength=args[5]

#load datasets
conf=read.table(config,header=T,sep="\t",stringsAsFactors=FALSE)
lens=read.table(annot,header=F,stringsAsFactors=FALSE)
names(lens)=c("chr","start","end","region","type","strand")
Stats=lapply(conf$location,readStatistics)
Total=lapply(conf$location,readTotal)

#check if variable is defined then updated Stats values
if(!is.na(restrictLength)){
  # update reads column in each Stats entry to the sum of the counts
  # in the columns of given read counts
  restrictPattern=gsub(',','|',restrictLength)
  #show(paste(restrictPattern))
  for (i in 1:length(Stats)){
    indices=grep(restrictPattern,names(Stats[[i]]))
    negindices=indices[-c(1:(length(indices)/2))]
    #show(paste(indices))
    if(length(indices) > 0){
      Stats[[i]]$reads=apply(Stats[[i]][,indices],1,sum)
      if(length(negindices)>1){
        Stats[[i]]$antisenseReads=apply(Stats[[i]][,negindices],1,sum)
      } else {
        Stats[[i]]$antisenseReads=Stats[[i]][,negindices]
      }
    }
  }
}

#add length column
Stats=addLengthColumnToStats(Stats,lens)

#normalize read counts
if(useDEseq){
  normalized=normalizeEntries(Stats,Total,normalizeByDESeq=TRUE)
} else {
  normalized=normalizeEntries(Stats,Total,normalizeByDESeq=FALSE)
}

allowed= unique(subset(lens,type == "region")$region)

#Filter only the non-background regions. Also enables to use different bed files while using rapidStats, although it is not advised.
normalizedSub = normalized
for(i in 1:length(normalized)){
  normalizedSub[[i]]=subset(normalized[[i]], region %in% allowed)
}

df=createPlottingData(normalizedSub,conf)
#save data.frame in output folder
write.table(subset(df,region %in% allowed),paste(out,"NormalizedValues.dat",sep=""),quote=F,row.names=F,sep="\t")


library(leaflet)
library(jsonlite)

###
# Visualization of free market long-term room rentals in Amsterdam.
# idea: opacity ~ time on market | to fade old "sold but not removed" ones?
###

# Constants.
ALLOWED_TYPES <- c("Kamer", "Studio")
SIZE_UPPER_LIMIT <- 30
COLOR_RANGE <- c("#1d0540", "#0f9b0f", "#15d915")
HIGHLIGHTED_COLOR_RANGE <- c("#5614B0", "#5614B0", "#9b5fed") # For "early bird" adverts.

# Reading in the JSON.
json_file <- "./data/example_rooms.json"
rooms <- fromJSON(json_file)

# Filtering the data.
rooms <- rooms[rooms$type %in% ALLOWED_TYPES, ]
rooms <- rooms[rooms$size <= SIZE_UPPER_LIMIT, ]

# Colors.
pricePal <- colorNumeric(rev(COLOR_RANGE), domain = rooms$price) # Rev, because we want cheaper ones to be green.
sizePal <- colorNumeric(COLOR_RANGE, domain = rooms$size) # Normal, because we want bigger ones to be green.

specialPricePal <- colorNumeric(rev(HIGHLIGHTED_COLOR_RANGE), domain = rooms$price)
specialSizePal <- colorNumeric(HIGHLIGHTED_COLOR_RANGE, domain = rooms$size)

valuesToColorBySpeciality <- function(is_special, values, pal, specialPal) {
  normalColors <- pal(values);
  specialColors <- specialPal(values);
  colors <- is_special;

  for(i in seq_along(is_special)) {
    if(is_special[i]) {
      colors[i] <- specialColors[i];
    } else {
      colors[i] <- normalColors[i];
    }
  }

  colors;
}

# Display the map.
# Fill: the greener the cheaper.
# Stroke: the greener the bigger.
# Size: grows with the room.
leaflet(data = rooms) %>%
  addTiles() %>%
  addCircleMarkers(
    ~lon,
    ~lat,
    color = ~valuesToColorBySpeciality(is_early_bird, size, sizePal, specialSizePal),
    fillColor = ~valuesToColorBySpeciality(is_early_bird, price, pricePal, specialPricePal),
    opacity = 1,
    fillOpacity = 1,
    radius = ~size*0.6,
    label = ~paste(as.character(price), " € - ",  as.character(size), "m²"),
    popup = ~url
  ) %>%
  addLegend(
    "bottomright",
    title = "Room Size (stroke color)",
    values = ~size,
    pal = sizePal,
    labFormat = labelFormat(suffix = "m²"),
    opacity = 1
  ) %>%
  addLegend(
    "bottomright",
    title = "Room Price (fill color)",
    values = ~price,
    pal = pricePal,
    labFormat = labelFormat(suffix = "€"),
    opacity = 1
  )


require(gdxtools)
require(tidyverse)

myfile = file.path('P:/is-wel/indus/message_indus/input/fuel_cost/MsgOutput_MESSAGEix-GLOBIOM_res-test_baseline_res_eq_test.gdx')

mygdx <- gdx(myfile)
fuel_price_rw <- mygdx['PRICE_COMMODITY']

# chose SAS as region, prices differe regionally (check the variation is the same)
fuel_price <- fuel_price_rw %>%
  filter(commodity %in% c("gas","coal","crudeoil")) %>%
  filter(level == "primary") %>%
  filter(year_all >= "2020") %>%
  filter(node == "R11_SAS") %>%
  dplyr::select(-time,-level)

# cost variation wrt 2020
cost_variation <- fuel_price %>%
  group_by(commodity) %>%
  mutate(ref = fuel_price$value[fuel_price$commodity == commodity & fuel_price$year_all == "2020"]) %>%
  mutate(variation = (value-ref)/ref)

to_save <- cost_variation %>%
  dplyr::select(commodity,year_all,variation)

write.csv(to_save, 'P:/is-wel/indus/message_indus/input/fuel_cost/cost_variation_gams.csv',row.names = FALSE)


#!/usr/bin/env Rscript

library(pophelper)
x <- readQ("input_pophelper.txt")

qmat <- lapply(x, as.matrix)
p <- aperm(simplify2array(qmat), c(3, 1, 2))
perm <- label.switching::stephens(p)

write.table(perm$permutations, file="permutations.csv", quote=F, row.names=F, col.names=F)


#' Class shaq
#'
#' An S4 container for a distributed tall/skinny matrix.
#'
#' @details
#' The (conceptual) global (non-distributed) matrix should be distributed by
#' row, meaning that each submatrix should own all of the columns of the global
#' matrix.  Most methods assume no other real structure, however for best
#' performance (and for the methods which require it), one should try to
#' organize their distributed data in a particular way.
#'
#' First, adjacent MPI ranks should hold adjacent rows.  So if the last row that
#' rank \code{k} owns is \code{i}, then the first row that rank \code{k+1} owns
#' should be row \code{i+1}.  Additionally, any method that operates on two (or
#' more) shaq objects, the two shaqs should be distributed identically.  By this
#' we mean that if the number of rows shaq \code{A} owns on rank \code{k} is
#' \code{k_i}, then the number of rows shaq \code{B} owns on rank \code{k}
#' should also be \code{k_i}.
#'
#' Finally, for best performance, one should generally try to keep the number of
#' rows "balanced" (roughly equal) across processes, with perhaps the last "few"
#' having one less row than the others.
#'
#' @slot DATA
#' The local submatrix.
#' @slot nrows, ncols
#' The global matrix dimension.
#'
#' @seealso
#' \code{\link{shaq}}
#'
#' @name shaq-class
#' @docType class
setClass(
  Class="shaq",
  representation=representation(
    Data="matrix",
    nrows="numeric",
    ncols="numeric"
    # balanced="logical"
  ),

  prototype=prototype(
    Data=matrix(nrow=0, ncol=0),
    nrows=0,
    ncols=0
    # balanced=NA
  )
)


# Input the data file into a named table
data_times <- read.table("times.data", sep=",", col.names=c("Siscs","Steps"))

# Specify the output file and format and open it
pdf("times.pdf")

# Graph the table using blue points overlayed by a line
plot(data_times, type="o", col="blue")

# Create a title with a red, bold/italic font
title(main="Number of steps needed", col.main="red", font.main=4)

# Close the output device
dev.off()

# quit the system
q()


library(pROC)

fn.poB = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_percent_of_B_filtered_day0.txt")
flow.poB = fread(fn.poB) %>%
  select(sample, matches("Gate")) %>%
  dplyr::rename(CD38high = Gate3,
                CD38high.CD10pos = Gate2,
                CD38high.CD10neg = Gate1,
                CD38pos = Gate4)

fn.info = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_sample_info_filtered_day0.txt")
flow.info = fread(fn.info) %>%
  mutate(subject = as.integer(subject))

fn.titer = file.path(PROJECT_DIR, "data", "CHI", "phenotypes", "titer_processed.txt")
df.titer = fread(fn.titer) %>%
  # mutate(Subject = as.character(Subject)) %>%
  mutate(Response = ifelse(adjMFC_class==0, "low",
                           ifelse(adjMFC_class==2, "high", "middle")))

flow.titer = flow.info %>%
  left_join(df.titer %>% dplyr::select(Subject, Response), by=c("subject"="Subject")) %>%
  dplyr::filter(Response %in% c("low","high"),
         time %in% c(-7,0,70)) %>%
  mutate(Response = factor(Response,levels=c("low","high")))

# get originally gated flow data
fn.old = file.path(PROJECT_DIR, "data", "CHI/flow/original_gates", "day0.log10.txt")
flow.old = read.table(fn.old, sep="\t", header=T, row.names=1, stringsAsFactors=F)
flow.old = as.data.frame(t(flow.old)) %>%
  dplyr::select(ID87) %>%
  tibble::rownames_to_column("subject") %>%
  mutate(subject=sub("X","",subject) %>% as.integer())

flow = flow.poB %>%
  inner_join(flow.titer, by="sample") %>%
  inner_join(flow.old, by="subject")

pops = names(flow)[c(rev(2:5),ncol(flow))]
pops.name = pops
pops.name[1:4] = 1:4
pops.group = (1:3)[c(2,2,2,2,3)] %>% factor()

df.auc = data.frame(Population=factor(pops, levels=rev(pops)), group=pops.group, AUC=NA)
for (p in seq_along(pops)) {
  df.auc$AUC[p] = roc(flow[["Response"]],flow[[pops[p]]], direction="<", quiet = T)$auc
}

ggplot(df.auc, aes(Population, AUC, fill=group)) + geom_bar(stat="identity") +
  geom_hline(yintercept = 0.5, col="black", lty=1, size=1) +
  scale_x_discrete(labels=rev(pops.name)) +
  xlab("") +
  coord_flip() +
  theme_bw() + theme(legend.position="none")

fn.fig = file.path(PROJECT_DIR, "figure_generation", sprintf("CHI_flow_selected_gates_AUC"))
ggsave(paste0(fn.fig, ".png"), w=4,h=3)
ggsave(paste0(fn.fig, ".pdf"), w=4,h=3)


library(ggsignif)

df.test = fread("results/test_sig.genes_in_clusters_high_vs_low_responders.txt") %>%
  dplyr::filter(w.pv < 0.05, test.dir == "IN", test == "SigScore",
                clustering == "K0") %>%
  dplyr::mutate(sig.name = sig %>%
          str_replace("SLE.sig", "SLE-Sig") %>%
          str_replace("CD40.act", "CD40act") %>%
          str_replace("IFN26", "IFN-I-DCact")) %>%
  dplyr::mutate(sig = factor(sig)) %>%
  dplyr::arrange(sig, cluster)

clustering = 0
sigs = levels(df.test$sig)
sig.label = sigs %>%
  str_replace("SLE.sig", "SLE-Sig") %>%
  str_replace("CD40.act", "CD40act") %>%
  str_replace("IFN26", "IFN-I-DCact") %>%
  setNames(sigs)

dn.fig = "figures/sig_test_boxplots"
dir.create(dn.fig, showWarnings = F, recursive = T)

for(s in sigs) {
  cat(s, "\n")
fn.score = glue::glue("results/sig_scores/scores_{s}_{clustering}.txt")
df.sc = fread(fn.score, data.table = F) %>%
  dplyr::mutate(subject = factor(subject)) %>%
  gather("cluster","score", -subject) %>%
  left_join(df.subj, by="subject") %>%
  dplyr::mutate(response = factor(response, levels=c("low","high"))) %>%
  dplyr::arrange(cluster, response) %>%
  dplyr::mutate(resp_cl = ifelse(response=="low", -0.15, 0.15))

df.txt = df.test %>%
  dplyr::filter(sig == s) %>%
  dplyr::mutate(x=-Inf, y=Inf, label=glue::glue("p = {format(w.pv, digits=2)}"))
yrng = c(-1, 1.55)
cm = pals::glasbey(13)[c(1:3,5:9,13,11)]
dotsz = diff(yrng)/(max(df.sc$score) - min(df.sc$score))
p = ggplot(df.sc, aes(response, score, group=response)) +
  coord_flip(ylim=yrng) +
  geom_boxplot(width=0.6, aes(fill=cluster), position = position_dodge2(preserve = "total"), lwd = 0.3, alpha = 0.5, outlier.shape = NA, show.legend = F) +
  geom_dotplot(aes(fill = response), binaxis = "y", stackdir = "center", dotsize = dotsz,
               position=position_dodge(), show.legend = F) +
  scale_fill_manual(values = c("black", "white", "white")) +
  geom_text(aes(x, y, label=label), col="red", hjust=1, vjust=-0.5, data=df.txt, inherit.aes = F) +
  xlab("") + ylab(paste(sig.label[s], "score")) +
  theme_classic()

ggsave(glue::glue("{dn.fig}/sig_scores_box_{s}_K{clustering}.png"), plot=p, w=2.5, h=1.2)
ggsave(glue::glue("{dn.fig}/sig_scores_box_{s}_K{clustering}.pdf"), plot=p, w=2.5, h=1.2, useDingbats=F)
}


##' Rank forecasts by calculating an average across targets
##'
##' @param x a data frame with scored forecasts
##' @return a data frame with ranked forecasts, and mean/sd of the weighted interval score
##' @importFrom dplyr filter group_by mutate ungroup filter summarise
##' @author Sebastian Funk
rank_forecasts <- function(x) {
  ranked_forecasts <- x %>%
    group_by(value_type, ensemble_type, model) %>%
    mutate(min_date = min(creation_date)) %>%
    group_by(value_type) %>%
    mutate(max_min_date = max(min_date)) %>%
    ungroup() %>%
    filter(creation_date >= max_min_date) %>%
    group_by(ensemble_type, model, value_type,
             geography, creation_date, value_date) %>%
    summarise(score = mean(score), .groups = "drop") %>%
    group_by(ensemble_type, model) %>%
    summarise(mean = mean(score),
              sd = sd(score),
              .groups = "drop") %>%
    ungroup() %>%
    arrange(mean)

  return(ranked_forecasts)
}


##
## Figure 1: kernel density
##

rm(list = ls()) # This clears everything from memory.
before0 <- proc.time()
setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20150611.RData")
source("~/Dropbox/MS/TurnoverBCI/TurnoverBCImain/source.R")

library(ggplot2)
library(gridExtra)
library(dplyr)
theme_set(theme_bw())

# - convex = concave
kernel.20 <- data.frame(WSG=unlist(WSG20),
             convex= -unlist(convex20),
             slope=unlist(slope20),
             moist=unlist(Moist20),
             time=c(rep(1982,50),
                    rep(1985,50),
                    rep(1990,50),
                    rep(1995,50),
                    rep(2000,50),
                    rep(2005,50),
                    rep(2010,50)))

kernel.100 <- data.frame(WSG=unlist(WSG100),
             #convex=unlist(convex.100.rare[[10]),
             #slope=unlist(slope.100.rare[[10]),
             convex= - unlist(convex100),
             slope=unlist(slope100),
             moist=unlist(Moist100),
             time=c(rep(1982,50),
                    rep(1985,50),
                    rep(1990,50),
                    rep(1995,50),
                    rep(2000,50),
                    rep(2005,50),
                    rep(2010,50)))

temp <- sapply(WSG.ind,length)
k.ind.WSG <- data.frame(WSG=unlist(WSG.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

temp <- sapply(Moist.ind,length)
k.ind.moist <- data.frame(moist=unlist(Moist.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))
# temp <- sapply(slope.ind.rare[[1]],length)
temp <- sapply(slope.ind,length)
k.ind.slope <- data.frame(slope=unlist(slope.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

# temp <- sapply(convex.ind.rare[[1]],length)
temp <- sapply(convex.ind, length)
k.ind.convex <- data.frame(convex= - unlist(convex.ind),
            time=c(rep(1982,temp[1]),
                  rep(1985,temp[2]),
                  rep(1990,temp[3]),
                  rep(1995,temp[4]),
                  rep(2000,temp[5]),
                  rep(2005,temp[6]),
                  rep(2010,temp[7])))

temp100 <- kernel.100 %>%
  mutate(size = "1ha")

temp20 <- kernel.20 %>%
  mutate(size = "0.04ha")

fig_dat <- bind_rows(temp100, temp20) %>%
  tidyr::gather(., "trait", "val", 1:4)

temp1 <- data_frame(time = k.ind.WSG$time,
    size = "All individuals (50ha)",
    trait = "WSG",
    val = k.ind.WSG[,1])

temp2 <- data_frame(time = k.ind.moist$time,
    size = "All individuals (50ha)",
    trait = "moist",
    val = k.ind.moist[,1])

temp3 <- data_frame(time = k.ind.convex$time,
    size = "All individuals (50ha)",
    trait = "convex",
    val = k.ind.convex[,1])

temp4 <- data_frame(time = k.ind.slope$time,
    size = "All individuals (50ha)",
    trait = "slope",
    val = k.ind.slope[,1])

fig_dat2 <- bind_rows(fig_dat, temp1, temp2, temp3, temp4) %>%
  mutate(size = factor(size, levels = c("All individuals (50ha)","1ha", "0.04ha"))) %>%
  mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
  mutate(size2 = factor(size, labels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
  mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moisture", "Concavity~(m)", "Slope~(degrees)")))

dummy1 <- data_frame(time = 1982,
    size = "1ha",
    trait = "WSG",
    val = c(0.55, 0.65))

dummy2 <- data_frame(time = 1982,
    size = "1ha",
    trait = "moist",
    val = c(0.3, 0.9))

dummy3 <- data_frame(time = 1982,
    size = "All individuals (50ha)",
    trait = "moist",
    val = c(-2, 4))

dummy4 <- data_frame(time = 1982,
    size = "1ha",
    trait = "slope",
    val = c(4, 6))

dummy5 <- data_frame(time = 1982,
    size = "0.04ha",
    trait = "slope",
    val = c(4, 6))

dummy0 <- fig_dat2 %>%
    filter(., size != "0.04ha" | trait != "convex" | (val < -0.035 & val > -0.085)) %>%
    filter(., size != "All individuals (50ha)" | trait != "convex" | (val < 0.15 & val > -0.25)) %>%
    filter(., size != "0.04ha" | trait != "slope" | (val > 4 & val < 6)) %>%
    filter(., size != "All individuals (50ha)" | trait != "slope" | (val > 2 & val < 8))
    # filter(size != "0.04ha") %>%# new

dummy <- bind_rows(dummy0, dummy1, dummy2, dummy3, dummy4, dummy5) %>%
  # filter(size != "0.04ha") %>%# new
  mutate(size = factor(size, levels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
  mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
  mutate(size2 = factor(size, labels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
  mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moisture", "Concavity~(m)", "Slope~(degrees)")))

###
# small data for test
###
# dummy <- dummy %>% filter(size == "1ha")
#
# temp1 <- dummy %>% mutate(size = "0.04ha")
# temp2 <- dummy %>% mutate(size = "All individuals (50ha)")
#
# dummy <- bind_rows(dummy, temp1, temp2) %>%
#   mutate(size = factor(size, levels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
#   mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
#   mutate(size2 = factor(size, labels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
#   mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moist", "Concavity~(m)", "Slope~(degrees)")))
#
#
#
# dummy0 <- dummy0 %>% filter(size == "1ha")
#
# dummy0 <- bind_rows(dummy0, temp1, temp2) %>%
#   mutate(size = factor(size, levels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
#   mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
#   mutate(size2 = factor(size, labels = c("All individuals (50ha)", "1ha", "0.04ha"))) %>%
#   mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moist", "Concavity~(m)", "Slope~(degrees)")))

## need to redcued to 6inches
before <- proc.time()
#postscript("~/Dropbox/MS/TurnoverBCI/TurnoverBCI_MS/fig/fig1_new.eps",
#  width = 9, height = 8, paper = "special")

postscript("~/Desktop/fig1_new.eps",
  width = 6, height = 5, paper = "special")

p <- ggplot(dummy0, aes(x = val)) +
  facet_wrap(~ size2 + trait2, nrow = 3, scale = "free",
  labeller = labeller(trait2 = label_parsed, sizes = label_value)) +
  geom_blank(data = dummy) +
  geom_density(data = dummy0 %>% filter(size != "All individuals (50ha)"), adjust = 1,
    aes(colour = as.factor(time))) +
  guides(colour = guide_legend(title = NULL), size = 21) +
  # guides(fill = guide_legend(override.aes = list(fill = as.factor(time)))) +
  theme(
   legend.position = c(0.99, 0.99), legend.justification = c(0.8,0.9),
    #legend.text = element_text(size = 9),
    legend.background = element_rect(fill=alpha('blue', 0)),
    legend.key.size = unit(0.3, "cm"),
    strip.text = element_text(size = 7, lineheight=0.5),
    axis.title = element_text(size = 7),
    axis.text.x = element_text(size = 5, angle = 45),
    axis.text.y = element_text(size = 5),
    legend.text = element_text(size = 7),
    plot.margin = unit(c(0.5, 0.2, 0.2 , 0.2), units = "cm")) +
  geom_density(data = filter(dummy0, size == "All individuals (50ha)"), adjust = 4, aes(colour = as.factor(time))) +
  ylab("Density") +
  xlab("Trait values")

g <- ggplotGrob(p)

g$heights
g
for (i in c(6, 11, 16)) g$heights[[i]] <- unit(0.35, "cm")
for (i in c(62:73)) g$grobs[[i]]$heights <- unit(c(1,1), "npc")

grid.draw(g)
dev.off()
after <- proc.time()
after - before
# after - before0


pdf_file<-"pdf/timeseries_stacked_areas.pdf"
cairo_pdf(bg="grey98", pdf_file,width=9,height=7)

library(plotrix)
library(gdata)
par(mai=c(0.5,1.75,0,0.5),omi=c(0.5,0.5,0.8,0.5),family="Lato Light",las=1)

# Import data and prepare chart

myData<-read.xls("myData/Power_generation_Bavaria.xlsx", encoding="latin1")

myC1<-"brown"
myC2<-"black"
myC3<-"grey"
myC4<-"forestgreen"
myC5<-"blue"
myC6<-"lightgoldenrod"

myYears<-myData$Year
myData$Year<-NULL
Complete<-myData$Complete
myData$Complete<-NULL

fg_org<-par("fg")
par(fg=par("bg"))

# Create chart and other elements

stackpoly(myData,main="",xaxlab=rep("", nrow(myData)),border="white",stack=TRUE,col=c(myC1,myC2,myC3,myC4,myC5,myC6), axis2=F, ylim=c(0,95000))
lines(Complete, lwd=4, col="lightgoldenrod4")
par(fg=fg_org)
mtext(seq(1990,2010,by=5), side=1, at=seq(1,21,by=5), line=0.5)
segments(0.25,0,22.25,0,xpd=T)
ypos<-c(7000,12000,16000,24000,30500,55000)
myDes<-names(myData)
text(rep(0.5,6), ypos, myDes, xpd=T, adj=1)

# Titling

mtext("Gross electricity generation in Bavaria 1990-2011",3,line=1.5,adj=0,family="Lato Black",cex=1.75,outer=T)
mtext("All values in mil. kWh, annual figures",3,line=-0.2,adj=0,font=3,cex=1.25,outer=T)
mtext("Source: www.statistik.bayern.de",1,line=1,adj=1,cex=0.9,font=3,outer=T)
dev.off()


#!/usr/bin/env Rscript

# Parse the --file= argument out of command line args and
# determine where base directory is so that we can source
# our common sub-routines
arg0 <- sub("--file=(.*)", "\\1", grep("--file=", commandArgs(), value = TRUE))
dir0 <- dirname(arg0)
source(file.path(dir0, "common.r"))

theme_set(theme_grey(base_size = 17))

# Setup parameters for the script
params = matrix(c(
  'help',    'h', 0, "logical",
  'width',   'x', 2, "integer",
  'height',  'y', 2, "integer",
  'outfile', 'o', 2, "character",
  'indir',   'i', 2, "character",
  'tstart',  '1',  2, "integer",
  'tend',    '2',  2, "integer",
  'ylabel1stgraph', 'Y',  2, "character"
  ), ncol=4, byrow=TRUE)

# Parse the parameters
opt = getopt(params)

if (!is.null(opt$help))
  {
    cat(paste(getopt(params, command = basename(arg0), usage = TRUE)))
    q(status=1)
  }

# Initialize defaults for opt
if (is.null(opt$width))   { opt$width   = 5120 }
if (is.null(opt$height))  { opt$height  = 6000 }
if (is.null(opt$indir))   { opt$indir  = "current"}
if (is.null(opt$outfile)) { opt$outfile = file.path(opt$indir, "summary.png") }
if (is.null(opt$ylabel1stgraph)) { opt$ylabel1stgraph = "Op/sec" }

# Load the benchmark data, passing the time-index range we're interested in
b = load_benchmark(opt$indir, opt$tstart, opt$tend)

# If there is no actual data available, bail
if (nrow(b$latencies) == 0)
{
  stop("No latency information available to analyze in ", opt$indir)
}

png(file = opt$outfile, width = opt$width, height = opt$height, res = 300)

# First plot req/sec from summary
plot_throughput <- qplot(elapsed, successful / window, data = b$summary,
                geom = c("smooth", "point"),
                xlab = "Elapsed Secs", ylab = opt$ylabel1stgraph,
                main = "Throughput") +

                geom_smooth(aes(y = successful / window, colour = "ok"), size=0.5) +
                geom_point(aes(y = successful / window, colour = "ok"), size=2.0) +

                scale_colour_manual("Response", values = c("#188125"))

plot_error <- qplot(elapsed, failed / window, data = b$summary,
                geom = c("smooth", "point"),
                xlab = "Elapsed Secs", ylab = opt$ylabel1stgraph,
                main = "Errors") +

                geom_smooth(aes(y = failed / window, colour = "error"), size=0.5) +
                geom_point(aes(y = failed / window, colour = "error"), size=2.0) +

                scale_colour_manual("Response", values = c("#FF665F"))

plot_sessions_running <- qplot(elapsed, running, data = b$sessions,
                 geom = c("point"),
                 xlab = "Elapsed Secs", ylab = "# sessions",
                 main = "Sessions Running") +

                 geom_point(aes(y = running, colour = "running"), size=2.0) +
                 geom_line( aes(y = running, colour = "running"), size=0.1) +

                 scale_colour_manual("Starts", values = c("#000000"))

plot_sessions_started <- qplot(elapsed, starts / window, data = b$sessions,
                 geom = c("point"),
                 xlab = "Elapsed Secs", ylab = opt$ylabel1stgraph,
                 main = "Sessions Started") +

                 geom_point(aes(y = starts / window, colour = "starts"), size=2.0) +
                 geom_line( aes(y = starts / window, colour = "starts"), size=0.1) +

                 scale_colour_manual("Starts", values = c("#188125"))

# Setup common elements of the latency plots
latency_plot <- ggplot(b$latencies, aes(x = elapsed)) +
                   facet_grid(. ~ op) +
                   labs(x = "Elapsed Secs", y = "Latency (ms)")

# Plot median, mean and 95th percentiles
plot_median_mean <- latency_plot + labs(title = "Mean and Median Latency") +
            geom_smooth(aes(y = mean, color = "mean"), size=0.5) +
            geom_point(aes(y = mean, color = "mean"), size=2.0) +

            geom_smooth(aes(y = median, color = "median"), size=0.5) +
            geom_point(aes(y = median, color = "median"), size=2.0) +

            scale_colour_manual("Percentile", values = c("#FFA700", "#188125"))
            # scale_color_hue("Percentile",
            #                 breaks = c("X95th", "mean", "median"),
            #                 labels = c("95th", "Mean", "Median"))

# Plot median, mean and 95th percentiles
plot_95 <- latency_plot + labs(title = "95th Percentile Latency") +
            geom_smooth(aes(y = X95th, color = "95th"), size=0.5) +
            geom_point(aes(y = X95th, color = "95th"), size=2.0) +

            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91"))
            # scale_color_hue("Percentile",
            #                 breaks = c("X95th", "mean", "median"),
            #                 labels = c("95th", "Mean", "Median"))

# Plot 99th percentile
plot_99 <- latency_plot + labs(title = "99th Percentile Latency") +
            geom_smooth(aes(y = X99th, color = "99th"), size=0.5) +
            geom_point(aes(y = X99th, color = "99th"), size=2.0) +
            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91"))
            # scale_color_hue("Percentile",
            #                 breaks = c("X99_9th","X99th" ),
            #                 labels = c("99.9th", "99th"))

# Plot 99.9th percentile
plot_999 <- latency_plot + labs(title = "99.9th Percentile Latency") +
            geom_smooth(aes(y = X99_9th, color = "99.9th"), size=0.5) +
            geom_point(aes(y = X99_9th, color = "99.9th"), size=2.0) +
            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91", "#FFA700"))

# Plot 100th percentile
plot_max <- latency_plot + labs(title = "Maximum Latency") +
            geom_smooth(aes(y = max, color = "max"), size=0.5) +
            geom_point(aes(y = max, color = "max"), size=2.0) +
            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91", "#FFA700"))

plot_upper_percentiles <- latency_plot + labs(title = "95th, 99th, 99.9th and 100th Percentile") +
            geom_smooth(aes(y = X95th, color = "95th"), size=0.5) +
            geom_point(aes(y = X95th, color = "95th"), size=2.0) +
            geom_smooth(aes(y = X99th, color = "99th"), size=0.5) +
            geom_point(aes(y = X99th, color = "99th"), size=2.0) +
            geom_smooth(aes(y = X99_9th, color = "99.9th"), size=0.5) +
            geom_point(aes(y = X99_9th, color = "99.9th"), size=2.0) +
            geom_smooth(aes(y = max, color = "max"), size=0.5) +
            geom_point(aes(y = max, color = "max"), size=2.0) +
            scale_colour_manual("Percentile", values = c("#FFFE00", "#FFA900", "#FF5600", "#FF0000"))

grid.newpage()

pushViewport(viewport(layout = grid.layout(6, 1)))

vplayout <- function(x,y) viewport(layout.pos.row = x, layout.pos.col = y)

print(plot_throughput, vp = vplayout(1,1))
print(plot_error, vp = vplayout(2,1))
print(plot_sessions_running, vp = vplayout(3,1))
print(plot_sessions_started, vp = vplayout(4,1))
print(plot_median_mean, vp = vplayout(5,1))
print(plot_upper_percentiles, vp = vplayout(6,1))

dev.off()


#' @export
define_latent_growth_curve_model = function(df, variable_of_interest_name, model_type, model_strength = "CONFIGURAL", unconstrained_parcel_indices = c(), slope_weights=c(), time_invariant_covariate_name = "", is_multiple_group_model = FALSE){
  slope_weights_provided = length(slope_weights) > 0
  slope_weights_to_pass = if(slope_weights_provided) {
    slope_weights
  } else {
    base=c(0)
    tail = sapply(2:length(df[,1]), function(e) {NA})
    append(base,tail)
    base
  }

  is_weak <- model_strength == "WEAK"
  is_strong <- model_strength == "STRONG" || model_strength == "PARTIAL_STRONG"
  is_strict <- model_strength == "STRICT"

  include_slope = model_type == "LINEAR" || model_type == "LATENT_BASIS"
  should_set_time_invariant_covariate <- time_invariant_covariate_name != ""
  paste0(
    "# Define factors\n\n",
    define_factors(df, is_weak || is_strong || is_strict),
    "\n\n# Intercepts\n",
    define_intercepts(df, is_strong || is_strict, unconstrained_parcel_indices),
    "\n\n# Unique variances and covariances\n",
    define_variances(df, is_strict),
    "\n\n",
    define_covariances(df),
    "\n\n# Latent variable means\n",
    define_latent_variable_means(df, TRUE),
    "\n\n# Latent variable variances and covariances\n",
    define_latent_variable_variances(df),
    "\n\n# Level factor loadings\n",
    define_level_factor(df, variable_of_interest_name),
    if(include_slope) "\n\n# Slope factor loadings\n" else "",
    if(include_slope) define_slope_factor(df, variable_of_interest_name, slope_weights_to_pass) else "",
    "\n\n# Means\n",
    define_means(variable_of_interest_name, include_slope, is_multiple_group_model),
    "\n\n# Variances\n",
    define_level_slope_variances(variable_of_interest_name, include_slope, is_multiple_group_model),
    if(should_set_time_invariant_covariate) "\n\n# Time invariant covariate\n" else "",
    if(should_set_time_invariant_covariate) set_time_invariant_covariate(variable_of_interest_name, time_invariant_covariate_name, include_slope) else ""
  )
}


# The MIT License (MIT)
# Copyright (c) 2017 Louise AC Millard, MRC Integrative Epidemiology Unit, University of Bristol
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
# documentation files (the "Software"), to deal in the Software without restriction, including without
# limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
# the Software, and to permit persons to whom the Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions
# of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
# TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.

# Tests an unordered categorical phenotype with multinomial regression
# and saves this result in the multinomial logistic results file
testCategoricalUnordered <- function(varName, currentVar, varType, thisdata) {

	pheno = thisdata[,phenoStartIdx:ncol(thisdata)]
	#geno = thisdata[,"geno"]

	numNotNA = length(which(!is.na(pheno)))
	if (numNotNA<500) {
		cat("CATUNORD-SKIP-500 (", numNotNA, ") || ",sep="");
		incrementCounter("unordCat.500")
	}
	else {

		# check there are not too many levels and skip if there are
		numUnique = length(unique(na.omit(pheno)))

		# num outcome values * (num confounders and trait of interest and bias term)
		numWeights=(numUnique-1)*((numPreceedingCols-2)+1+1)
		if (numWeights>1000) {
			cat("Too many weights in model: ", numWeights, " > 1000, (num outcomes values: ", numUnique, ") || SKIP ", sep="")
			incrementCounter("unordCat.cats")
			return(NULL)
		}

		phenoFactor = chooseReferenceCategory(pheno);

		if (opt$save == TRUE) {
			# add pheno to dataframe
			#storeNewVar(thisdata[,"userID"], phenoFactor, varName, 'catUnord')
			storeNewVar(thisdata[,"userID"], phenoFactor, currentVar, 'catUnord')
			cat("SUCCESS results-notordered-logistic ");
			incrementCounter("success.unordCat")
		}

		reference = levels(phenoFactor)[1];

		sink()
		sink(modelFitLogFile, append=TRUE) # hide output of model fitting
		print("--------------")
		print(varName)

		require(nnet)
		if (opt$standardise==TRUE) {
			geno = scale(thisdata[,"geno"])
		} else {
			geno = thisdata[,"geno"]
		}
		#cat("genoMean=", mean(geno), " genoSD=", sd(geno), " || ", sep="")

		confounders=thisdata[,3:numPreceedingCols, drop = FALSE]

		###### BEGIN TRYCATCH
		tryCatch({

			fit <- multinom(phenoFactor ~ geno + ., data=confounders, maxit=1000)

			## baseline model with only confounders, to which we compare the model above
			fitB <- multinom(phenoFactor ~ ., data=confounders, maxit=1000)

			## compare model to baseline model
			require(lmtest)
			lres = lrtest(fit, fitB)
			modelP = lres[2,"Pr(>Chisq)"];

			## save result to file
			maxFreq = length(which(phenoFactor==reference));
			numNotNA = length(which(!is.na(pheno)))
			write(paste(paste0("\"",varName,"-",reference,"\""), paste0("\"", currentVar, "\""), varType, paste(maxFreq,"/",numNotNA,sep=""), -999, -999, -999, modelP, sep=","), file=paste(opt$resDir,"results-multinomial-logistic-",opt$varTypeArg,".txt",sep=""), append="TRUE")

			sink()
			sink(resLogFile, append=TRUE)

			sumx <- summary(fit)

			z <- sumx$coefficients/sumx$standard.errors
			p = (1 - pnorm(abs(z), 0, 1))*2

			ci <- confint(fit, "geno", level=0.95)
			ci = data.frame(ci)

			## get result for each variable category
			uniqVar = unique(na.omit(pheno))
			for (u in uniqVar) {

				## no coef for baseline value, and values <0 are assumed to be missing
				if (u == reference || u<0) {
					next
				}

				pvalue = p[paste(eval(u),sep=""),"geno"]
				beta = sumx$coefficients[paste(eval(u),sep=""),"geno"]

				if (opt$confidenceintervals == TRUE) {
					lower = ci[1, paste("X2.5...", u, sep="")]
					upper =	ci[1, paste("X97.5...", u, sep="")]
				}
				else {
					lower = NA
					upper = NA
				}

				numThisValue = length(which(phenoFactor==u));

				## save result to file
				write(paste(paste("\"", varName,"-",reference,"#",u,"\"", sep=""), paste0("\"", currentVar, "\""), varType, paste(maxFreq,"#",numThisValue,sep=""), beta, lower, upper, pvalue, sep=","), '')
				#write(paste(paste("\"", varName,"-",reference,"#",u,"\"", sep=""), paste0("\"", currentVar, "\""), varType, paste(maxFreq,"#",numThisValue,sep=""), beta, lower, upper, pvalue, sep=","), file=paste(opt$resDir,"results-multinomial-logistic-",opt$varTypeArg,".txt",sep=""), append="TRUE")
			}

			cat("SUCCESS results-notordered-logistic ");
			incrementCounter("success.unordCat")

			isExposure = getIsExposure(varName)
			if (isExposure == TRUE) {
				incrementCounter("success.exposure.unordCat")
			}

			## END TRYCATCHf
		}, error = function(e) {
			sink()
			sink(resLogFile, append=TRUE)
			cat(paste("ERROR:", varName,gsub("[\r\n]", "", e), sep=" "))
			incrementCounter("unordCat.error")
		})

	}
}

# find reference category - category with most number of examples
chooseReferenceCategory <- function(pheno) {

	uniqVar = unique(na.omit(pheno));
	phenoFactor = factor(pheno)

	maxFreq=0;
	maxFreqVar = "";
	for (u in uniqVar) {
		withValIdx = which(pheno==u)
		numWithVal = length(withValIdx);
		if (numWithVal>maxFreq) {
			maxFreq = numWithVal;
			maxFreqVar = u;
		}
	}

	cat("reference: ", maxFreqVar,"=",maxFreq, " || ", sep="");

	## choose reference (category with largest frequency)
	phenoFactor <- relevel(phenoFactor, ref = paste("",maxFreqVar,sep=""))

	return(phenoFactor);
}


#' Metacell layout using force directed projection of a low degree mc graph
#'
#' @param mc2d_id 2d object to add
#' @param mc_id meta cell id to work with
#' @param graph_id graph_id of the similarity graph on cells from the metacell
#' @param symetrize should the mc confusion matrix be symmetrized before computing layout?
#' @param ignore_mismatch
#' @param feats_gset gene set name for use in parametric graph and/or umap 2d projection
#' @param feats_exclude list of genes to exclude from the features gene set
#' @param graph_parametric if this is True, mc edges will be determined using parametric distances and not the cells k-nn graph.
#' @param logist_loc the "location" parametr of the logistic function used to determine parametric distances between metacelles
#' @param logist_scale the "lscale" parametr of the logistic function used to determine parametric distances between metacelles
#'
#' @export
mcell_mc2d_force_knn = function(mc2d_id, mc_id, graph_id,
			ignore_mismatch=F, symmetrize=F,
			ignore_edges = NULL,
			feats_gset = NULL,
			feats_exclude =NULL,
			graph_parametric = F, logist_loc = 1, logist_scale = 0.2,
			logist_eps = 4e-5, max_d_fold = 3,
			use_umap_for_2d_pos=F, umap_mgraph=F,
			uconf=NULL)
{
	mc = scdb_mc(mc_id)
	if (is.null(mc)) {
		stop(sprintf("mc %s not found"), mc_id)
	}
	feat_genes = NULL
	if(!is.null(feats_gset)) {
		gset = scdb_gset(feats_gset)
		if(is.null(gset)) {
			stop("Unkown gset ", feats_gset, " defined in mc2d graph construction")
		}
		feat_genes = names(gset@gene_set)
		if(!is.null(feat_genes)) {
			feat_genes = setdiff(feat_genes, feats_exclude)
		}
		message("got ", length(feat_genes), " feat genes for mc graph construction")
	}

	if(!graph_parametric) {
		mgraph = mc2d_comp_mgraph(mc_id, graph_id, ignore_mismatch=ignore_mismatch, symmetrize=symmetrize)
	} else {
		if(is.null(feat_genes)) {
			stop("must specify feat gene set to build parametric mc2d graph")
		}
		mgraph = mc2d_comp_mgraph_param(mc, feat_genes, logist_loc, logist_scale, logist_eps, max_d_fold)
	}
	if(!is.null(ignore_edges)) {
		all_e = paste(mgraph$mc1, mgraph$mc2, sep="-")
		ig_e = paste(ignore_edges$mc1, ignore_edges$mc2, sep="-")
		ig_re = paste(ignore_edges$mc2, ignore_edges$mc1, sep="-")
		f = all_e %in% c(ig_e,ig_re)
		mgraph= mgraph[!f,]
		message("igoring ", sum(f), " edges")
	}
	if(use_umap_for_2d_pos) {
		if(is.null(feat_genes)) {
			stop("Specifiy a gene set for layout using umap on mc egc")
		}
		if(is.null(uconf)) {
			#uconf = umap.defaults
			uconf =
			uconf$n_neighbors=6
			uconf$min_dist=0.9
			uconf$bandwidth=1.3
		}
		mc_xy = mc2d_comp_graph_coord_umap(mc, feat_genes, mgraph, uconf, umap_mgraph)
	} else {
		mc_xy = mc2d_comp_graph_coord(mgraph, N=ncol(mc@mc_fp))
	}
	xy = mc2d_comp_cell_coord(mc_id, graph_id, mgraph, mc_xy, symmetrize=symmetrize)
	scdb_add_mc2d(mc2d_id, tgMC2D(mc_id, mc_xy$mc_x, mc_xy$mc_y, xy$x, xy$y, mgraph))
}

#' Compute cells 2d coordinates based on the mc graph when the mc coordinates are supplied externally
#'
#' @param mc2d_id 2d object to add
#' @param mc_id meta cell id to work with
#' @param graph_id graph_id of the similarity graph on cells from the metacell
#' @param mc_xy pre-defined metacells coordinates (so only coordinates of cells will be computed). Data frame with 2 columns named mc_x and mc_y (x and y coodinates, respectively).
#' @param ignore_mismatch
#'
#' @export
mcell_mc2d_force_knn_on_cells = function(mc2d_id, mc_id, graph_id, mc_xy, ignore_mismatch=F)
{
	mgraph = mc2d_comp_mgraph(mc_id, graph_id, ignore_mismatch=ignore_mismatch)
	xy = mc2d_comp_cell_coord(mc_id, graph_id, mgraph, mc_xy)
	scdb_add_mc2d(mc2d_id, tgMC2D(mc_id, mc_xy$mc_x, mc_xy$mc_y, xy$x, xy$y, mgraph))
}

#' @export
mc2d_comp_mgraph = function(mc_id, graph_id, ignore_mismatch=F, symmetrize=F)
{
	mc2d_K = get_param("mcell_mc2d_K")
	mc2d_T_edge = get_param("mcell_mc2d_T_edge")
	mc2d_max_confu_deg = get_param("mcell_mc2d_max_confu_deg")
	mc2d_edge_asym = get_param("mcell_mc2d_edge_asym")
	mc2d_k_expand_inout_factor = get_param("mcell_mc2d_expand_inout_factor")
	mc2d_max_fpcor_indeg = get_param("mcell_mc2d_max_fpcor_indeg")
	mc2d_max_fpcor_outdeg = get_param("mcell_mc2d_max_fpcor_outdeg")

	if(is.null(mc2d_max_confu_deg) & is.null(mc2d_max_fpcor_outdeg)) {
		stop("MC-ERR: Either max_confu_deg or max_fpcor_deg must be defined - currently both are null")
	}

	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing when mc 2d projection")
	}
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("MC-ERR: mc id ", mc_id, " is missing when running add_mc_from_graph")
	}
	restrict_in_degree = T

	if(!is.null(mc2d_max_confu_deg)) {

		message("comp mc graph using the graph ", graph_id, " and K ", mc2d_K)
		confu = mcell_mc_confusion_mat(mc_id, graph_id, mc2d_K,
													ignore_mismatch=ignore_mismatch)
		if(symmetrize) {
			confu =confu + t(confu)
		}
# k_expand_inout_factor=k_expand_inout_factor

		csize = as.matrix(table(mc@mc))
		csize = pmax(csize, 20)
		csize2 = csize %*% t(csize)
		csize2 = csize2 / median(csize)**2
		confu = confu / csize2

		confu_p_from = confu/rowSums(confu)
		confu_p_to = t(confu)/colSums(confu)

		if(!is.null(mc2d_max_confu_deg)) {
			rank_fr = t(apply(confu_p_from, 1, rank))
			rank_to = t(apply(confu_p_to, 1, rank))
			rank2 = rank_fr * rank_to
			diag(rank2) = 1e+6
			amgraph = apply(rank2, 1, function(x) {  rank(-x) <= (1+mc2d_max_confu_deg) })
			mgraph = amgraph * ((confu_p_from + confu_p_to) > mc2d_T_edge)
			if(restrict_in_degree) {
				amgraph2 = t(apply(rank2, 2, function(x) {  rank(-x) <= (1+mc2d_max_confu_deg) }))
				mgraph = mgraph * amgraph2
			}

			if(mc2d_edge_asym) {
				mgraph = amgraph * (confu_p_from>mc2d_T_edge)
				mgraph = amgraph * (t(confu_p_to)>mc2d_T_edge)
			}
			mgraph = mgraph>0 | t(mgraph>0)
		} else {
			mgraph = (confu_p_from + confu_p_to) > mc2d_T_edge
		}
	}

	if(!is.null(mc2d_max_fpcor_outdeg)) {
		f = apply(abs(log2(mc@mc_fp)),1,max)>0.5
		fp_cor = tgs_cor(log2(mc@mc_fp[f,]))
		fp_rnk = t(apply(-fp_cor,1,function(x) rank(x)<=(mc2d_max_fpcor_outdeg+1)))
		fp_rnk_in = apply(-fp_cor,1,function(x) rank(x)<=(1+mc2d_max_fpcor_indeg))
		if(!is.null(mc2d_max_confu_deg)) {
				  mgraph = mgraph * fp_rnk * fp_rnk_in
		} else {
				  mgraph = fp_rnk * fp_rnk_in
		}
	}

	N = nrow(mgraph)
	e = which(mgraph>0)
	n1 = ceiling((e)/N)
	n2 = 1+((e-1) %% N)
	return(data.frame(mc1 = n1, mc2 = n2))
}

#' @export
mc2d_comp_mgraph_param = function(mc, genes, loc, scale, eps, max_d_fold)
{
	max_deg = get_param("mcell_mc2d_max_confu_deg")
	legc = log2(mc@e_gc[genes,] + eps)

	logist_d = function(x) {
		d = abs(legc - x)
		d = plogis(d, loc, scale)
		return(colSums(d))
	}
	a = apply(legc, 2, logist_d)

#connect - d-best outgoing. filter by d_best_ratio < 2
	diag(a) = 1000;
	d_T = apply(a, 1, function(x) sort(x,partial=2)[2])
	a_n = a/d_T
	diag(a) = 0;
	diag(a_n) = 0;

   rank_fr = t(apply(a, 1, rank))
   rank_fr_m = rank_fr
   rank_fr_m[a_n > max_d_fold] = 1000
   rank_fr_m2 = rank_fr_m
   rank_fr_m2[t(a_n) > max_d_fold] = 1000

   edges = apply(rank_fr_m2, 1, function(x) {
                        mc2 = which(x > 0 & x <= max_deg+1);
                        mc1 = rep(which.min(x), length(mc2));
                        return(data.frame(mc1 = mc1, mc2=mc2)) })
   ed_df = as.data.frame(do.call(rbind, edges))
	ed_df$dist = apply(ed_df, 1, function(x) 1+a[x[1],x[2]])
	return(ed_df)
}

#' @export
mc2d_comp_graph_coord_umap = function(mc, genes, mgraph, uconf, use_mgraph)
{
	legc = log2(mc@e_gc[genes,] + 1e-5)
#	um = umap(t(legc), uconf)
if(0) {
	um = umap(t(legc), n_neighbors=uconf$n_neighbors, min_dist=uconf$min_dist,bandwidth=uconf$bandwidth, local_connectivity=uconf$local_connectivity, metric="cosine")
	return(list(mc_x=um[,1], mc_y=um[,2]))
} else {
	if(use_mgraph) {
		m = sparseMatrix(mgraph$mc1, mgraph$mc2, x=1/mgraph$dist)
		m = as.matrix(m)
		diag(m) = 0
		m = m/(0.5+rowSums(m))
		diag(m) = 0.5+apply(m,1, max)
		m  = m %*% m
		um = umap(as.matrix(m), uconf);
	} else {
		um = umap(t(legc) , uconf)
	}
	return(list(mc_x = um$layout[,1], mc_y = um$layout[,2]))
}
}

#' @importClassesFrom graph graphNEL
#' @importFrom graph plot addEdge addNode nodeRenderInfo
#' @importFrom Rgraphviz layoutGraph
#' @export
mc2d_comp_graph_coord = function(mc_graph, N)
{
	n1 = mc_graph$mc1
	n2 = mc_graph$mc2
	rEG <- new("graphNEL", nodes=as.character(1:N), edgemode="undirected")

	rEG = addEdge(as.character(n1[n1!=n2]), as.character(n2[n1!=n2]), rEG, rep(1, length(n1[n1!=n2])))

	g = layoutGraph(rEG, layoutType="neato")
	x_cl = nodeRenderInfo(g)$nodeX
	y_cl = nodeRenderInfo(g)$nodeY
	names(x_cl) = 1:N
	names(y_cl) = 1:N
	return(list(g=g, mc_x=x_cl, mc_y=y_cl))
}

#' @export
mc2d_comp_cell_coord = function(mc_id, graph_id, mgraph, cl_xy, skip_missing=F, symmetrize=F)
{
	mc2d_proj_blur = get_param("mcell_mc2d_proj_blur")
	mc2d_K_cellproj = get_param("mcell_mc2d_K_cellproj")

	mc = scdb_mc(mc_id)
	graph = scdb_cgraph(graph_id)

	x_cl = cl_xy$mc_x
	y_cl = cl_xy$mc_y

	N_mc = length(x_cl)
	N_c = length(mc@mc)+length(mc@outliers)
	if(N_mc != length(mc@colors)) {
		stop("MC-ERR: Length mismatch in number of projected MC and overal mc")
	}

	blurx = mc2d_proj_blur*(max(x_cl) - min(x_cl))
	blury = mc2d_proj_blur*(max(y_cl) - min(y_cl))

#defining all pairs of MCs that are connected on the mc graph sekelton as active
	is_active = rep(FALSE, N_mc*N_mc)
	is_active[(mgraph$mc1-1) * N_mc + mgraph$mc2] = TRUE
	if(symmetrize) {
		message("project on symmetrized graph")
		is_active[(mgraph$mc2-1) * N_mc + mgraph$mc1] = TRUE
	}
#including the diagnoal
	is_active[((1:N_mc)-1) * N_mc + 1:N_mc] = TRUE

	mc_key1 = mc@mc[levels(graph@edges$mc1)]
	mc_key2 = mc@mc[levels(graph@edges$mc2)]
	mc1 = mc_key1[graph@edges$mc1]
	mc2 = mc_key2[graph@edges$mc2]
	e_wgts = graph@edges$w
	if(symmetrize) {
		amc1 = c(mc1, mc2)
		amc2 = c(mc2, mc1)
		mc1 = amc1
		mc2 = amc2
		e_wgts = c(e_wgts, e_wgts)
	}

	f_in_mc = !is.na(mc1) & !is.na(mc2) #missing mc's, for example orphans
	f_active = is_active[(mc1-1)*N_mc + mc2]
	f = !is.na(f_active) & f_in_mc & f_active

	deg = nrow(graph@edges[f,])/length(graph@nodes)
	if(symmetrize) {
		deg = 2*deg
	}
	T_w = 1-(mc2d_K_cellproj+1)/deg
	f = f & e_wgts > T_w

	to_x = x_cl[mc2]
	to_y = y_cl[mc2]
	if(symmetrize) {
		edges_mcs = c(as.character(graph@edges$mc1), as.character(graph@edges$mc2))[f]
		c_x = tapply(to_x[f], edges_mcs, mean)
		c_y = tapply(to_y[f], edges_mcs, mean)
		c_x = c_x[names(mc@mc)]
		c_y = c_y[names(mc@mc)]
		names(c_x) = names(mc@mc)
		names(c_y) = names(mc@mc)
	} else {
		c_x = tapply(to_x[f], as.character(graph@edges$mc1[f]), mean)
		c_y = tapply(to_y[f], as.character(graph@edges$mc1[f]), mean)
	}

	base_x = min(c_x)
	base_y = min(c_y)
	max_x = max(c_x)
	base_x = base_x - (max_x-base_x)*0.1

	miss = setdiff(names(mc@mc), names(c_x))
	if(length(miss) > 0) {
		message("Missing coordinates in some cells that are not ourliers or ignored - check this out! (total ", length(miss), " cells are missing, maybe you used the wrong graph object?", " first nodes ", head(miss,10))
#		stop("existing")
	}
	x = c_x[names(mc@mc)]
	y = c_y[names(mc@mc)]
	x = x + rnorm(mean=0, sd=blurx, n=length(x))
	y = y + rnorm(mean=0, sd=blury, n=length(y))

	return(list(x=x, y=y))
}


# Tab Panel for Chart 1: Mental Health vs Hours of Gaming

# defines ui
select_test <- selectInput(
  inputId = "test",
  label = "Mental Health Test",
  choices = list("Generalized Anxiety" = "GAD_T", "Satisfaction With Life" = "SWL_T",
                 "Social Phobia" = "SPIN_T"),
  selected = "Generalized Anxiety"
)

tab_panel_chart1 <- tabPanel(
  "Gender and Time Influences",
  h3("How genders and time spent on gaming influence gamers' Mental Health"),
  sidebarLayout(
    sidebarPanel(
      select_test,
    ),
    mainPanel(
      plotlyOutput("scatterplot"),
      br(),
      p(strong("This scatter plot was intended to demonstrate the relationship between
        mental health and hours of games played per week, with respect to gender.
        The plot can display the Generalized Anxiety Disorder (GAD) Assessment scores,
        the Satisfaction with Life (SWL) Scale scores, or the Social Phobia Inventory (SPIN)
        scores versus the average hours of games played in a week by everyone with that
        score. 'Female', 'Male', and 'Other' were averaged and graphed separately.
        'Female' data points are colored red, 'Male' data points are colored green
        and 'Other' data points are colored blue, as shown in the key. The relationship
        shown by all 3 graphs is that higher hours of gaming is correlated with worse
        mental health. Both the GAD and SPIN graphs had positive slopes and the
        SWL graph had a negative slope for every gender. Higher GAD and SPIN scores
        indicate more severe anxiety and social phobia. Lower SWL scores mean less
        satisfaction with life. People with higher GAD and SPIN scores consistently
        averaged more hours of gaming per week than people with lower scores and
        vice versa for the SWL graph. For all graphs females had lower hours of
        gaming than males. People classified as other had varying trends between
        graphs."))
    )
  )
)


plot.whiskers_cluster_length <- function(df.posts, df.users, df.threads){

    # Prepare the data
    df.cluster_length <- merge(merge(df.posts, df.users), df.threads) %>%
      mutate(cluster=factor(cluster)) %>%
      select(cluster, length)

    # Plot
    p <- ggplot(df.cluster_length, aes(x=cluster, y=length)) +
      scale_fill_manual(values = c("white", cluster.colors)) + # no role -> white color
      geom_boxplot(aes(fill=cluster)) +
      theme_bw() +
      theme(text        = element_text(size = 15),
            legend.key  = element_blank()) +
      ggtitle("Participations vs threads length")
    print(p)

    # Save to file
    dev.copy(png, paste0('2016-01-15-whiskers_roles_vs_length.png'), width=800)
    dev.off()
}

plot.by_thread_cluster <- function(df.posts, df.users){

  df.threads <- plyr::count(df.posts, "thread")
  names(df.threads)[2] <- "length"

  df.participations <- merge(merge(df.posts, df.users), df.threads)
  df.participations$cluster <- factor(df.participations$cluster)

  by_thread_cluster <- acast(df.participations, thread~cluster)
  by_thread_cluster.perc <- as.data.frame(t(apply(by_thread_cluster, 1, function(x) x/sum(x))))

  # Add length and sort by length
  df.lengths <- plyr::count(df.participations, "thread")
  names(df.lengths) <- c('thread', 'length')
  by_thread_cluster.perc$thread <-rownames(by_thread_cluster.perc)
  by_thread_cluster.perc <- merge(by_thread_cluster.perc, df.lengths) # add lengths
  by_thread_cluster.perc <- by_thread_cluster.perc[order(by_thread_cluster.perc$length),] # sort by length
  by_thread_cluster.perc <- subset(by_thread_cluster.perc, select=-c(thread)) # drop again thread column
  by_thread_cluster.norm <- by_thread_cluster.perc
  by_thread_cluster.norm$length <-  by_thread_cluster.norm$length/max(by_thread_cluster.perc$length)

  # Plot
  heatmap(as.matrix(by_thread_cluster.norm),
          Colv=NA, Rowv=NA, labRow=NA, ylab="Threads", xlab="Roles",
          main = "Participations by role")

  # Save to file
  dev.copy(png, paste0('2016-01-15-thread_role_composition.png'), width=600)
  dev.off()
}

by_thread_cluster_nfirst <- function(df.posts, nfirst=15){

  # Sort posts by their position in the thread
  df.posts <- df.posts[with(df.posts, order(thread, date)),]
  df.posts$rank <- sapply(1:nrow(df.posts),
                          function(i) sum(df.posts[1:i, c('thread')]==df.posts$thread[i]))
  # Thread lengths
  df.threads <- plyr::count(df.posts, 'thread')
  names(df.threads)[2] <- "length"

  # Add lengths to dataframe so that we can filter by length later
  df.posts <- merge(df.posts, df.threads)

  # Posts before NFIRST and in threads longer than NFIRST
  mask <- df.posts$rank <= nfirst & df.posts$length>nfirst
  df.first <- df.posts[mask,]

  return(df.first)
}