#We've now added interactivity to the plot. The user can (a) specify the Variable (Var) scenario they wish to plot the PCA of, and (b) adjust the text's cex values. The server.r script now includes code to add colors that correspond to each selected variable's parameter values (param), as well as a legend.

library(shiny)	#First load shiny library
load("../pcas.RDATA")	#Load data

#Define a server for the Shiny app
shinyServer(function(input, output) {

	#Create a reactive Shiny plot to send to the ui.r called "pcaplot"
	output$pcaplot <- renderPlot({
		#Match user's variable input selection by subsetting for when foo$Var==input$var
		fbar<-droplevels(foo[which(foo$Var==input$var),])

		#Generate colors to correspond to the different Variables' parameters. E.g., for the variable "colless", different colors for "loIc","midIc", and "hiIc"
		cols<-c("#1f77b4","#ff7f0e","#2ca02c")[1:length(levels(fbar$param))]

		#Render the scatterplot of PCA
		plot(PC2 ~ PC1, data=fbar,  type="n", xlab="PC1", ylab="PC2")

		#For each of the different parameter values (different colors), plot the text names of the metrics
		for(i in levels(fbar$param)){
			foo2<-subset(fbar,param==i)
			text(PC2 ~ PC1, data=foo2, labels=foo2$metric, col=cols[which(levels(fbar$param)==i)],  cex=input$cexSlider)
		}
		#Add a legend for the different parameter values (with corresponding colors) of the selected Variable
		legend("topright", fill=cols, legend=levels(fbar$param))
  })
})

#TASKS:
#1. Depending on the variable that people choose (input$var), we now want to display the chosen variable's parameter (param) values as a check box group. Even though logically we would begin with the checkboxGroupInput function on the ui.R script to display check box options, first remember what the capabilities of the user side (ui.R) are. ui.R cannot evaluate/process information, but only displays output values calculated on the server side (server.R). In other words, the ui.R only takes in the values a user specifies and then sends this information to be evaluated/processed on the server side.
#	So to create a checkboxgroup of param values that will change based on what the user selects for a variable (input$var), our first step is to evaluate what the user selects as a variable. This evaluation can only take place on the server side. We therefore need to create an object on the server side (output$paramchkbxgrp) that will evaluate the user's Variable selection (input$var), which will then decide which check box options to display.  This decision of what to display is then fed back to the ui.R with the object uiOutput.

#	1.a. Depending on what Variable is selected by the user (input$var), generate a different set of check box options to display (with the function checkboxGroupInput). For instance, if "colless" is selected as the variable, display the parameters values that correspond to "colless", e.g., loIc, midIc and hiIc. This switch function takes the given value (input$var) and then evaluates it. When input$var=="colless", then it evaluates the checkboxGroupInput function with the choices of  c("Low" = "loIc", "Mid" = "midIc", "High" = "hiIc").
#Use the following script as a framework for the paramchkbxgrp object:

	#	output$paramchkbxgrp <- renderUI({
			# if (is.null(input$var))
			  # return()
		## Depending on input$var, we'll generate a different
		## UI component and send it to the client.
			# switch(input$var,
			# "colless" = checkboxGroupInput(inputId = "PARAMS", label = "",
				# choices = c(
					# "Low" = "loIc",
					# "Mid" = "midIc",
					# "High" = "hiIc"
					# ),
				# selected = c("loIc","midIc","hiIc")),
			##Fill in the ellipses with the corresponding parameter values
			# "numsp" = checkboxGroupInput(...),
			# "spatial" = checkboxGroupInput(...),
			# )
		  # })

	# })
#2. When certain checkboxes are unselected, display the text as grey with some transparency. To do this, within the renderPlot function, adjust the cols object such that the unselected are black with high transparency (display as grey). To do this for the cols object, subset for when input$PARAMS is not in levels(fbar$PARAMS):
#	cols[which(!(levels(fbar$param) %in% input$PARAMS))]
#Then assign all of these instances as black rgb(0,0,0, maxColorValue=255) with very high transparency rgb(0,0,0, alpha =25, maxColorValue=255):
#	cols[which(!(levels(fbar$param) %in% input$PARAMS))]<- rgb(0,0,0, alpha=25,maxColorValue=255)

# #HINTS
# 1.a 	Drop-down menu to select Factor
	# output$paramchkbxgrp <- renderUI({
		# if (is.null(input$var))
		  # return()

		# # Depending on input$var, we'll generate a different
		# # UI component and send it to the client.
		# switch(input$var,
		  # "colless" = checkboxGroupInput("PARAMS", "",
			# choices = c("Low" = "loIc",
						# "Mid" = "midIc",
						# "High" = "hiIc"
						# ),
			# selected = c("loIc","midIc","hiIc")),
		  # "numsp" = checkboxGroupInput("PARAMS", "",
			# choices = c("16 Species" = 16,
						# "64 Species" = 64,
						# "256 Species" = 256),
			# selected = c(16,64,256)),
		  # "spatial" = checkboxGroupInput("PARAMS", "",
			# choices = c("True" = "TRUE",
						# "False" = "FALSE"),
			# selected = c("TRUE","FALSE")),
		# )
	  # })

# 2.
# output$pcaplot <- renderPlot({
		# #Match user's variable input selection by subsetting for when foo$Var==input$var
		# fbar<-droplevels(foo[which(foo$Var==input$var),])

		# #Generate colors to correspond to the different Variables' parameters. E.g., for the variable "colless", different colors for "loIc","midIc", and "hiIc"
		# cols<-c("#1f77b4","#ff7f0e","#2ca02c")[1:length(levels(fbar$param))]

		# #***********************ADD THIS TO EXISTING SCRIPT *************************
		# #If the param is not selected, set the color value to grey with transparency
		# cols[which(!(levels(fbar$param) %in% input$PARAMS))]<- rgb(0,0,0, alpha=25,maxColorValue=255)
		# #****************************************************************************

		# #Render the scatterplot of PCA
		# plot(PC2 ~ PC1, data=fbar, type="n", xlab="PC1", ylab="PC2")

		# #For each of the different parameter values (different colors), plot the text names of the metrics
		# for(i in levels(fbar$param)){
			# foo2<-subset(fbar,param==i)
			# text(PC2 ~ PC1, data=foo2, labels=foo2$metric, col=cols[which(levels(fbar$param)==i)],  cex=input$cexSlider)
		# }

		# #Add a legend for the different parameter values (with corresponding colors) of the selected Variable
		# legend("topright", fill=cols, legend=levels(fbar$param))

  # })


#!/usr/bin/Rscript --slave

#usage: chmod +x bibliobypubmed.r
#usage: ./bibliobypubmed.r "your name"

argv<-commandArgs(TRUE)
query<-toString(argv[1])

#query <- "your name"

#install require R packages if necessary and load them
if(!require(RISmed)){
    install.packages("RISmed")
    library(RISmed)
}

if(!require(ggplot2)){
    install.packages("ggplot2")
    library(ggplot2)
}

if(!require(dplyr)){
    install.packages("dplyr")
    library(dplyr)
}

#library(RISmed)
#library(ggplot2)

#get the time machine
time<-toString(Sys.time())

cat("The Query concerned: ", query, "\n")

#perform the pubmed query with the input name
search <- EUtilsSummary(query, type="esearch",db = "pubmed", retmax=30000)
nb <- QueryCount(search)

nb<-toString(nb)
cat ("Number of articles found on Pubmed: ",nb , "\n")

records <- EUtilsGet(search)
years <- YearPubmed(records)
pubs_count <- as.data.frame(table(years))

#print the query time on the screen
cat(time, "\n")
str(pubs_count)
write.table(pubs_count,file="bibliobyyear.txt")
pdf('bibliobyyear.pdf')

#build the graph barplot with ggplot2
ggplot(pubs_count,aes(years, Freq,fill=years)) + geom_bar (stat="identity") +
xlab("Year") +
ylab("PUBMED articles by year")+
coord_flip() +
ggtitle(query, time)+
theme_classic()+
labs(caption = nb )+
theme(legend.position="none")+
theme(
  plot.title = element_text(color = "red", size = 20, face = "bold"),
  plot.subtitle = element_text(color = "blue", size = 18),
  plot.caption = element_text(color = "darkgreen", face = "italic", size = 16)
)
dev.off()

#journal analysis
journal <- MedlineTA(records)
journal_count <- as.data.frame(table(journal))
journal_count_order <- journal_count[order(-journal_count[,2]),]
str(journal_count_order)
write.table(journal_count_order, file="bibliobyjournal.txt")

#attribute levels to reorder journals with their frequencies
journal_count$journal <- factor(journal_count$journal, levels = journal_count$journal[order(journal_count$Freq)])

#make journal graph
pdf('bibliobyjournal.pdf')
ggplot(journal_count,aes(journal, Freq, fill=journal)) + geom_bar (stat="identity") +
xlab("Journals") +
ylab("Counts")+
coord_flip() +
ggtitle(query, time)+
theme_classic()+
labs(caption = nb )+
theme(axis.text.x = element_text(angle = 90, hjust = 1))+
theme(legend.position="none")+
theme(
  plot.title = element_text(color = "red", size = 20, face = "bold"),
  plot.subtitle = element_text(color = "blue", size = 18),
  plot.caption = element_text(color = "darkgreen", face = "italic", size = 16)
)
dev.off()


## Need to generate a heatmap that has all 4 celltypes
## at the 1, 2,and 18hr marks. Need to generate one
## heatmap per timepoint and readout. The readouts are
## Smad23, and CTNNB1.

timepoints = c('1hr','2hr','18hr')
datafiles  = c('data/TI04.60_summaryStats.csv',
               'data/TI04.120_summaryStats.csv',
               'data/TI16.18_summaryStats.csv')
reps       = 1
readouts   = c('Smad23','CTNNB1')
colors     = matrix(c(rgb(0,(0:10)*.1,0),
                      rgb((0:10)*.1,0,0)),ncol=2)
colnames(colors)=readouts
channels   = 2:3
celltypes  = c('HCEC','SKMEL2','MALME3M','IEC6')
treatments = c('ctrl+ctrl','TGFB3+ctrl',
               'ctrl+Wnt3A','TGFB3+Wnt3A')
setToOne   = c('TGFB3+ctrl','ctrl+Wnt3A')
feature    = 'mean_nucleus'
minHeat    = -.2
maxHeat    = 1.5

for( rIdx in 1:length(readouts) ){
  heatmap = matrix(0,nrow=reps*length(treatments),
                   ncol=length(timepoints)*length(celltypes))

  for( tIdx in 1:length(timepoints)){
    data = read.table(datafiles[tIdx],sep=',',header=T,
                      stringsAsFactors=F )
    for( cIdx in 1:length(celltypes) ){
      readout  = readouts[ rIdx]
      channel  = channels[ rIdx]
      marker   = paste('marker',channel,sep='.')
      celltype = celltypes[cIdx]

      subdata  = data[data$celltype==celltype &
                      data$marker.2==readouts[1]  &
                      data$marker.3==readouts[2]  &
                      data$treatment %in% treatments,]

      # Convert to ctrl-based Z-scores
      thisFeature = paste(feature,'median',channel,sep='.')
      ctrls   = subdata[subdata$treatment == 'ctrl+ctrl',
                        thisFeature,]
      subdata[,thisFeature] = subdata[,thisFeature]-mean(ctrls)
      subdata[,thisFeature] = subdata[,thisFeature]/
        mean(subdata[subdata$treatment==setToOne[rIdx],thisFeature])

      # Get it into the correct matrix coords
      for( treatIdx in 1:length(treatments)){
        treatment = treatments[treatIdx]
        rows      = (treatIdx-1)*reps+1:reps
        cols      = (tIdx-1)*length(celltypes)+ cIdx
        heatmap[rows,cols] = mean(subdata[subdata$treatment==treatment,thisFeature])

      }
    }
  }
  tempMap = heatmap
  tempMap[tempMap < minHeat] = minHeat
  tempMap[tempMap > maxHeat] = maxHeat
  heatmap(tempMap,Rowv=NA,Colv=NA,col=colors[,readout],scale='none',
          labRow = rep(treatments,each=reps),
          labCol = paste(rep(celltypes,length(timepoints)),
                   rep(timepoints,each=length(celltypes))))
}


library(speedyseq)
library(phyloseq2ML)
library(futile.logger)
flog.threshold(TRACE)

data(TNT_communities)

# modify phyloseq object
TNT_communities2 <- add_unique_lineages(TNT_communities)
testps <- standardize_phyloseq_headers(
  phyloseq_object = TNT_communities2, taxa_prefix = "ASV", use_sequences = FALSE)

# translate ASVs to genus
levels_tax_dictionary <- c("Family", "Genus")
taxa_vector_list <- create_taxonomy_lookup(testps, levels_tax_dictionary)
translate_ID(ID = c("ASV02", "ASV17"), tax_rank = "Genus", taxa_vector_list)

# phyloseq objects as list
second_phyloseq_object <- subset_samples(testps, Technical_replicate == 1)
subset_list <- list(
  vignette_V4_surface = testps,
  vignette_V4_replicate2 = second_phyloseq_object
)

# define subsetting parameters
selected_taxa_1 <- setNames(c("To_Genus", "To_Family"), c("Genus", "Family"))
subset_list_rel <- to_relative_abundance(subset_list)
subset_list_tax <- create_community_table_subsets(
  subset_list = subset_list_rel,
  thresholds = c(5, 1.5),
  taxa_prefix = "ASV",
  num_samples = 1,
  tax_ranks = selected_taxa_1)
subset_list_df <- otu_table_to_df(subset_list = subset_list_tax)
# add sample data columns to the count table
#names(sample_data(testps))
desired_sample_data <- c("TOC", "P_percent", "Munition_near", "Run")
subset_list_extra <- add_sample_data(phyloseq_object = testps,
  community_tables = subset_list_df, sample_data_names = desired_sample_data)
# get response variables
desired_response_vars <- c("UXO_sum")
response_variables <- extract_response_variable(
  response_variables = desired_response_vars, phyloseq_object = testps)
# cut response numeric values into 3 classes
responses_multi <- categorize_response_variable(
  ML_mode = "classification",
  response_data = response_variables,
  my_breaks = c(-Inf, 10, 20, Inf),
  class_labels = c("below_10", "below_20", "above_20"))

# or for two classes
responses_binary <- categorize_response_variable(
  ML_mode = "classification",
  response_data = response_variables,
  my_breaks = c(-Inf, 20, Inf),
  class_labels = c("below_20", "above_20"))

responses_regression <- categorize_response_variable(
  ML_mode = "regression",
  response_data = response_variables)

# merge the input tables with the response variables
merged_input_binary <- merge_input_response(subset_list_extra, responses_binary)
merged_input_multi <- merge_input_response(subset_list_extra, responses_multi)
merged_input_regression <- merge_input_response(subset_list_extra, responses_regression)

###### for keras

# dummify input tables for keras ANN
keras_dummy_binary <- dummify_input_tables(merged_input_binary)
keras_dummy_multi <- dummify_input_tables(merged_input_multi)
keras_dummy_regression <- dummify_input_tables(merged_input_regression)
splitted_keras_binary <- split_data(keras_dummy_binary, c(0.6, 0.8))
splitted_keras_multi <- split_data(keras_dummy_multi, c(0.6, 0.8))
splitted_keras_regression <- split_data(keras_dummy_regression, c(0.6, 0.8))

keras_dummy_multi[[1]]

# augmentation
augmented_keras_binary <- augment(splitted_keras_binary, 2, 0.5)
augmented_keras_multi <- augment(splitted_keras_multi, 2, 0.5)
augmented_keras_regression <- augment(splitted_keras_regression, 2, 0.5)

# scaling
scaled_keras_binary <- scaling(augmented_keras_binary)
scaled_keras_multi <- scaling(augmented_keras_multi)
scaled_keras_regression <- scaling(augmented_keras_regression)

scaled_keras_multi[[1]][["train_set"]]

# keras format
ready_keras_binary <- inputtables_to_keras(scaled_keras_binary)
ready_keras_multi <- inputtables_to_keras(scaled_keras_multi)
ready_keras_regression <- inputtables_to_keras(scaled_keras_regression)
str(ready_keras_binary, max = 2)

ready_keras_multi[[1]][["trainset_labels"]]

###### for ranger

# split merged list into training and test parts
splitted_input_binary <- split_data(merged_input_binary, c(0.6, 0.8))
splitted_input_multi <- split_data(merged_input_multi, c(0.6, 0.8))
splitted_input_regression <- split_data(merged_input_regression, c(0.6, 0.8))

# augmentation
augmented_input_binary <- augment(splitted_input_binary, 1, 0.5)
augmented_input_multi <- augment(splitted_input_multi, 1, 0.5)
augmented_regression <- augment(splitted_input_regression, 1, 0.5)

####### ranger classification
# set up a parameter data.frame
parameter_df <- extract_parameters(augmented_input_multi)

hyper_grid <- expand.grid(
  ML_object = names(augmented_input_multi),
  Number_of_trees = c(151),
  Mtry_factor = c(1),
  Importance_mode = c("none"),
  Cycle = 1:5,
  step = "training")

master_grid <- merge(parameter_df, hyper_grid, by = "ML_object")
# string arguments needs to be passed as character, not factor level
master_grid$Target <- as.character(master_grid$Target)

test_grid <- head(master_grid, 2)

#master_grid$results <- purrr::pmap(cbind(master_grid, .row = rownames(master_grid)),
#    ranger_classification, the_list = augmented_input_multi, master_grid = master_grid)
#results_df <-  as.data.frame(tidyr::unnest(master_grid, results))

#### ranger regression
parameter_regress <- extract_parameters(augmented_regression)

hyper_grid_regress <- expand.grid(
  ML_object = names(augmented_regression),
  Number_of_trees = c(151),
  Mtry_factor = c(1),
  Importance_mode = c("none"),
  Cycle = 1:5,
  step = "prediction")

master_grid_regress <- merge(parameter_regress, hyper_grid_regress, by = "ML_object")
master_grid_regress$Target <- as.character(master_grid_regress$Target)
test_grid_regress <- head(master_grid_regress, 1)

# running ranger
#master_grid_regress$results <- purrr::pmap(cbind(master_grid_regress, .row = rownames(master_grid_regress)),
#    ranger_regression, the_list = augmented_regression, master_grid = master_grid_regress)
#results_regress <-  as.data.frame(tidyr::unnest(master_grid_regress, results))

#test_grid_regress$results <- purrr::pmap(cbind(test_grid_regress, .row = rownames(test_grid_regress)),
#    ranger_regression, the_list = augmented_regression, master_grid = test_grid_regress)
#results_regress_test <-  as.data.frame(tidyr::unnest(test_grid_regress, results))

####### for keras multi
# set up a parameter data.frame
parameter_keras_multi <- extract_parameters(ready_keras_multi)

hyper_keras_multi <- expand.grid(
  ML_object = names(ready_keras_multi),
  Epochs = 5,
  Batch_size = 2,
  k_fold = 1,
  current_k_fold = 1,
  Early_callback = "accuracy", #prediction: "accuracy", training: "val_loss"
  Layer1_units = 20,
  Layer2_units = 8,
  Dropout_layer1 = 0.2,
  Dropout_layer2 = 0.0,
  Dense_activation_function = "relu",
  Output_activation_function = "softmax", # sigmoid for binary
  Optimizer_function = "rmsprop",
  Loss_function = "categorical_crossentropy", # binary_crossentropy for binary
  Metric = "accuracy",
  Cycle = 1:3,
  step = "prediction",
  Classification = "multiclass",
  Delay = 2)

master_keras_multi <- merge(parameter_keras_multi, hyper_keras_multi, by = "ML_object")
# order by current_k_fold
master_keras_multi <- master_keras_multi[order(
  master_keras_multi$ML_object,
  master_keras_multi$Cycle,
  master_keras_multi$current_k_fold), ]
rownames(master_keras_multi) <- NULL
test_keras_multi_prediction <- head(master_keras_multi, 2)

#test_keras_multi_prediction$results <- purrr::pmap(cbind(test_keras_multi_prediction, .row = rownames(test_keras_multi_prediction)),
#  keras_classification, the_list = ready_keras_multi, master_grid = test_keras_multi_prediction)
#keras_df_multi_prediction <-  as.data.frame(tidyr::unnest(test_keras_multi_prediction, results))

####### for keras binary
# set up a parameter data.frame
parameter_keras_binary <- extract_parameters(ready_keras_binary)

hyper_keras_binary <- expand.grid(
  ML_object = names(ready_keras_binary),
  Epochs = 5,
  Batch_size = 2,
  k_fold = 4,
  current_k_fold = 1:4,
  Early_callback = "val_loss", #prediction: "accuracy", training: "val_loss"
  Layer1_units = 20,
  Layer2_units = 8,
  Dropout_layer1 = 0.2,
  Dropout_layer2 = 0.0,
  Dense_activation_function = "relu",
  Output_activation_function = "softmax", # sigmoid for binary
  Optimizer_function = "rmsprop",
  Loss_function = "categorical_crossentropy", # binary_crossentropy for binary
  Metric = "accuracy",
  Cycle = 1:3,
  step = "training",
  Classification = "binary",
  Delay = 2)

master_keras_binary <- merge(parameter_keras_binary, hyper_keras_binary, by = "ML_object")
master_keras_binary <- master_keras_binary[order(
  master_keras_binary$ML_object,
  master_keras_binary$Cycle,
  master_keras_binary$current_k_fold), ]
rownames(master_keras_binary) <- NULL
test_keras_binary_training <- head(master_keras_binary, 2)

#test_keras_binary_training$results <- purrr::pmap(cbind(test_keras_binary_training, .row = rownames(test_keras_binary_training)),
#  keras_classification, the_list = ready_keras_binary, master_grid = test_keras_binary_training)
#keras_df_binary_training <-  as.data.frame(tidyr::unnest(test_keras_binary_training, results))

####### for keras regression
# set up a parameter data.frame
parameter_keras_regression <- extract_parameters(ready_keras_regression)

hyper_keras_regression_training <- expand.grid(
  ML_object = names(ready_keras_regression),
  Epochs = 5,
  Batch_size = 2,
  k_fold = 4,
  current_k_fold = 1:4,
  Early_callback = "mae",
  Layer1_units = 20,
  Layer2_units = 8,
  Dropout_layer1 = 0.2,
  Dropout_layer2 = 0.0,
  Dense_activation_function = "relu",
  Optimizer_function = "rmsprop",
  Loss_function = "mse",
  Metric = "mae",
  Cycle = 1:3,
  step = "training",
  Delay = 2)

master_keras_regression_training <- merge(parameter_keras_regression, hyper_keras_regression_training, by = "ML_object")
master_keras_regression_training <- master_keras_regression_training[order(
  master_keras_regression_training$ML_object,
  master_keras_regression_training$Cycle,
  master_keras_regression_training$current_k_fold), ]
rownames(master_keras_regression_training) <- NULL
test_keras_regression_training <- head(master_keras_regression_training, 2)

#test_keras_regression_training$results <- purrr::pmap(cbind(test_keras_regression_training, .row = rownames(test_keras_regression_training)),
#  keras_regression, the_list = ready_keras_regression, master_grid = test_keras_regression_training)
#keras_df_regression_training <-  as.data.frame(tidyr::unnest(test_keras_regression_training, results))

#### regression prediction
hyper_keras_regression_prediction <- expand.grid(
  ML_object = names(ready_keras_regression),
  Epochs = 5,
  Batch_size = 2,
  k_fold = 1,
  current_k_fold = 1,
  Early_callback = "mae",
  Layer1_units = 20,
  Layer2_units = 8,
  Dropout_layer1 = 0.2,
  Dropout_layer2 = 0.0,
  Dense_activation_function = "relu",
  Optimizer_function = "rmsprop",
  Loss_function = "mse",
  Metric = "mae",
  Cycle = 1:3,
  step = "prediction",
  Delay = 2)

master_keras_regression_prediction <- merge(parameter_keras_regression, hyper_keras_regression_prediction, by = "ML_object")
master_keras_regression_prediction <- master_keras_regression_prediction[order(
  master_keras_regression_prediction$ML_object,
  master_keras_regression_prediction$Cycle,
  master_keras_regression_prediction$current_k_fold), ]
rownames(master_keras_regression_prediction) <- NULL
test_keras_regression_prediction <- head(master_keras_regression_prediction, 2)

#test_keras_regression_prediction$results <- purrr::pmap(cbind(test_keras_regression_prediction, .row = rownames(test_keras_regression_prediction)),
#  keras_regression, the_list = ready_keras_regression, master_grid = test_keras_regression_prediction)
#keras_df_regression_prediction <-  as.data.frame(tidyr::unnest(test_keras_regression_prediction, results))


#PRI SEMINARSKI NALOGI SEM UPORABIL NASLEDNJE KNJIZNICE:

library(knitr)
library(rvest)
library(gsubfn)
library(tidyr)
library(shiny)
library(readr)
library(dplyr)
library(tmap)
library(ggplot2)
library(grid)
library(rworldmap)
library(cowplot)
library(googleway)
library(ggrepel)
library(ggspatial)
library(rnaturalearth)
library(rnaturalearthdata)
library(RColorBrewer)
library(mgcv)
library(tidyverse)
library(shiny)
library(leaflet)


context("Alpha")

hex <- function(x) {
  rgb <- col2rgb(x, TRUE) / 255
  rgb(rgb[1, ], rgb[2, ], rgb[3, ], rgb[4, ])
}

test_that("missing alpha preserves existing", {
  cols <- col2rgb(rep("red", 5), TRUE) / 255
  cols[4, ] <- seq(0, 1, length.out = ncol(cols))

  reds <- rgb(cols[1, ], cols[2, ], cols[3, ], cols[4, ])

  expect_equal(reds, alpha(reds, NA))
  expect_equal(reds, alpha(reds, rep(NA, 5)))
})

test_that("alpha values recycled to match colour", {
  cols <- hex(c("red", "green", "blue", "pink"))

  expect_equal(cols, alpha(cols, NA))
  expect_equal(cols, alpha(cols, 1))
})

test_that("col values recycled to match alpha", {
  alphas <- round(seq(0, 255, length.out = 3))
  reds <- alpha("red", alphas / 255)
  reds_alpha <- col2rgb(reds, TRUE)[4, ]

  expect_equal(alphas, reds_alpha)
})


## Cord blood reference data generated by Kristina Gervin and Robert Lyle.

## Kristina Gervin <kristina.gervin@medisin.uio.no>
##     Robert Lyle <robert.lyle@ibv.uio.no>

create.gervin.lyle.reference <- function(data.dir, verbose=T) {
    number.pcs <- 8

    samplesheet <- meffil.read.samplesheet(data.dir, "csv$")

    ds <- meffil.normalize.dataset(samplesheet,
                                   just.beta=F,
                                   qc.file="gervin-and-lyle-qc-report.html",
                                   author="Kristina Gervin and Robert Lyle",
                                   study="Purified cord blood cell type methylation",
                                   number.pcs=number.pcs,
                                   norm.file="gervin-and-lyle-normalization-report.html",
                                   chip="450k",
                                   featureset="common",
                                   verbose=verbose)

    ## pc.plot <- meffil.plot.pc.fit(ds$norm.objects)
    ## suggests that number.pcs should be 8

    samplesheet <- samplesheet[match(colnames(ds$M), samplesheet$Sample_Name),]
    samplesheet$cell.type <- toupper(samplesheet$cellType)
    samplesheet$cell.type[which(samplesheet$cell.type == "CD19")] <- "Bcell"
    samplesheet$cell.type[which(samplesheet$cell.type == "GRAN")] <- "Gran"
    samplesheet$cell.type[which(samplesheet$cell.type == "CD4")] <- "CD4T"
    samplesheet$cell.type[which(samplesheet$cell.type == "CD8")] <- "CD8T"
    cell.types <- c("CD14", "Bcell", "CD4T", "CD8T", "NK","Gran")
    selected <- samplesheet$cell.type %in% cell.types
    meffil.add.cell.type.reference("gervin and lyle cord blood",
                                   ds$M[,selected], ds$U[,selected],
                                   cell.types=samplesheet$cell.type[selected],
                                   chip="450k",
                                   featureset="common",
                                   verbose=verbose)
}


ns = "Neuroscience"
no = "Neurology"
pb = "Psychological and Brain Sciences"
bme = "Biomedical Engineering"
bio = "Biology"
cs = "Computer Science"
ece = "Electrical Engineering"
mb = "Molecular Biology"
pc = "Pharmacology"
ro = "Radiology"
cbe = "Chemical and Biomolecular Engineering"
ams = "Applied Mathematics and Statistics"
phy = "Physics"
apl = "Applied Physics Laboratory"
bs = "Biostatistics"
mse = "Materials Science & Engineering"
depts <- c(ns, bme, bs, no, bs, phy, ns, bme, ns, ns, ns, cbe, cs, ams, bme, ns, bio, ro,ns, ns, ns, bme, pb, bme, mse, ns, ams, pc, bme, ns, bs, bme, ams, pb, ns, apl, no, bme, ece, pb, cs, cs, bme, ams, ro, mb, cbe)

library("igraph")
gg = read.graph('jhu_neuro.graphml', format=c("graphml"))
V(gg)$dept <- depts

V(gg)$color=V(gg)$dept
V(gg)$color=gsub(ns, "indianred2", V(gg)$color)
V(gg)$color=gsub(no, "lightslateblue", V(gg)$color)
V(gg)$color=gsub(pb, "royalblue", V(gg)$color)
V(gg)$color=gsub(bme, "powderblue", V(gg)$color)
V(gg)$color=gsub(mb, "orchid", V(gg)$color)
V(gg)$color=gsub(bio, "seagreen", V(gg)$color)
V(gg)$color=gsub(cs, "aquamarine", V(gg)$color)
V(gg)$color=gsub(ece, "pink2", V(gg)$color)
V(gg)$color=gsub(pc, "lightsteelblue", V(gg)$color)
V(gg)$color=gsub(ro, "lightpink", V(gg)$color)
V(gg)$color=gsub(cbe, "khaki1", V(gg)$color)
V(gg)$color=gsub(ams, "lawngreen", V(gg)$color)
V(gg)$color=gsub(apl, "magenta3", V(gg)$color)
V(gg)$color=gsub(phy, "lightseagreen", V(gg)$color)
V(gg)$color=gsub(bs, "orange2", V(gg)$color)
V(gg)$color=gsub(mse, "wheat1", V(gg)$color)

tkplot(gg, edge.width=ceiling(log(E(gg)$weight)), layout=layout.fruchterman.reingold)
png(filename="/Users/gkiar/git/neuro-pub-graph/graphs/org_network.png", height=800, width=600)


# Packages
library(dplyr)
library(tidyr)
library(tidygraph)
library(ggraph)
library(stringr)
library(reshape2)

# Mac Uni Data commented out
# macq_units.df <- read.csv("macquarie-unsw.csv", na.strings = "null", stringsAsFactors = F)
#
# named_edges <- macq_units.df %>%
#     na.omit() %>%
#     mutate(source = str_extract(unit.codes, "[A-Z]{3,4}[0-9]{3,4}")) %>%
#     select(source, destination=prereqs)

# UNSW Data
unsw_courses.df <- read.csv("unsw-courses.csv", na.strings = "null",
                            stringsAsFactors = F)

# DF of prereq links and faculty wrangled from raw data
named_edges <- unsw_courses.df %>%
    na.omit() %>%
    mutate(destination = str_extract(courses, "[A-Z]{4}\\d{4}(?!\\d)")) %>%
    mutate(prereqs = str_extract_all(conditions, "[A-Z]{4}\\d{4}(?!\\d)")) %>%
    unnest(prereqs) %>%
    distinct() %>%
    select(source = prereqs, destination, faculties)

# igraph DF of nodes (id, label and faculty)
#   Also filters by subject code or faculty
nodes <- melt(named_edges, id.vars = 'faculties') %>%
    select(label = value, faculties) %>%
    unique() %>%
    filter(str_detect(faculties, "Law")) %>%
    mutate(id = 1:n()) %>%
    select(id, label, faculties)

# igraph DF of edges by node id
edges <- named_edges %>%
    inner_join(nodes, by = c("source" = "label")) %>%
    rename(from = id) %>%
    inner_join(nodes, by = c("destination" = "label")) %>%
    rename(to = id) %>%
    select(from, to)

# Tidygraph routes data from nodes and edges
routes <- tbl_graph(nodes = nodes, edges = edges, directed = T)

# Plot the routes data
ggraph(routes,
       # Uses first number of subj code as layer number.
       # layers = as.numeric(str_extract(nodes$label, "\\d{1}")),
       layout = "sugiyama",
       hgap = 4,
       maxiter = 10000) +
    geom_edge_diagonal(alpha = 0.1,
                       colour = 'white') +
    geom_node_point(size = 1.5, aes(colour = faculties)) +
    theme_graph() +
    theme(
        panel.background = element_rect(fill = "black"),
        plot.background = element_rect(fill = "black"),
        legend.text = element_text(colour = "white"),
        legend.title = element_text(colour = "white")
    ) +
    scale_colour_brewer(palette = "Set1")


library("dplyr")
find_start_node <- function(edges) {
  start <- sort(edges$Parent)[1] # reasonable guess
  if(is.factor(start)) start <- levels(start)[start]
  repeat {
    if(move_up(edges, start) == start) break
    start <- move_up(edges, start)
  }
  return(start)
}
move_up <- function(edges, identity) {
  if(!(identity %in% edges$Identity) & !(identity %in% edges$Parent)) stop("Invalid identity.")
  parent <- filter_(edges, ~Identity == identity)$Parent
  if(length(parent) == 0) return(identity) # if it is the initial genotype then don't move
  if(is.factor(parent)) parent <- levels(parent)[parent]
  return(parent)
}
move_right <- function(edges, identity) {

  if(!(identity %in% edges$Identity) & !(identity %in% edges$Parent)) stop("Invalid identity.")
  parent <- filter_(edges, ~Identity == identity)$Parent
  if(length(parent) == 0) return(identity) # if it is the initial genotype then don't move
  siblings <- sort(filter_(edges, ~Parent == parent)$Identity)
  siblings <- siblings[which(siblings == identity) + 1]
  if(length(siblings) == 0) return(identity) # if it is the initial genotype then don't move
  if(is.na(siblings)) return(identity) # if it is the initial genotype then don't move
  if(is.factor(siblings)) siblings <- levels(siblings)[siblings]
  return(siblings)
}
move_down <- function(edges, parent) {

  if(!(parent %in% edges$Identity) & !(parent %in% edges$Parent)) stop("Invalid parent.")
  daughters <- filter_(edges, ~Parent == parent)$Identity
  if(length(daughters) == 0) return(parent) # if it is not a parent then don't move
  if(is.factor(daughters)) daughters <- levels(daughters)[daughters]
  return(sort(daughters)[1])
}

path_vector <- function(edges) {
  n <- 1
  path <- find_start_node(edges)
  debugvaluepath = path[n]
  upped <- FALSE
  repeat {
    if(!upped) repeat { # a downwards move should never follow an upwards move
      n <- n + 1
      path[n] <- move_down(edges, path[n - 1])
      upped <- FALSE
      if(path[n] == path[n - 1]) break
    }
    if(move_right(edges, path[n]) != path[n]) {
      n <- n + 1
      path[n] <- move_right(edges, path[n - 1])
      upped <- FALSE
    } else if(move_up(edges, path[n]) != path[n]) {
      n <- n + 1
      path[n] <- move_up(edges, path[n - 1])
      upped <- TRUE
    }
    if(path[n] == path[1]) break
    if(n > 2 * dim(edges)[1] + 2) stop("Error: stuck in a loop")
    if(max(table(path) > 2)) stop("Error: adjacency matrix seems to include loops.")
  }
  if(length(path) != 2 * dim(edges)[1] + 2) stop("Error: adjacency matrix seems to be bipartite.")
  return(path)
}

args = commandArgs(trailingOnly=TRUE)

table_edges <- read.table(args[1], sep = "\t", header = TRUE)

result <- path_vector(table_edges)
write(result, file = args[2])


library(progeny)
library(dplyr)
library(tibble)
library(ggplot2)

message("STARTING PROGENY PROCESS")

message("Reading input arguments:")
args = commandArgs(trailingOnly = TRUE)
progeny_file = args[1]
organism = args[2] # "Human"
zscores = as.logical(args[3]) # T
top = as.numeric(args[4]) # 100

message(progeny_file)
message(organism)
message(zscores)
message(top)

message("Creating output file")

file_csv = paste0("progeny_scores_", organism, "_", top, ".csv")
message(file_csv)

message("Reading input file")

progeny_data <- as.matrix(read.csv(progeny_file, row.names = 1))

message("Running Progeny")

PathwayActivity_counts <- progeny::progeny(progeny_data,
                                           scale = TRUE,
                                           organism = organism,
                                           top = top,
                                           perm = 10000,
                                           z_scores = zscores)

PathwayActivity_counts <- as.data.frame(t(PathwayActivity_counts))

message("Writing output file")

write.csv(PathwayActivity_counts, file_csv, quote = F)

message("FINISHING PROGENY PROCESS")


#!/usr/bin/env Rscript

#sink(file("/dev/null", "w"), type = "message");

library(affy)
library(GEOquery);
library(pathprint);

# Figure out the relative path to the galaxy-pathprint.r library.
script.args  <- commandArgs(trailingOnly = FALSE);
script.name  <- sub("--file=", "", script.args[grep("--file=", script.args)])
script.base  <- dirname(script.name)
library.path <- file.path(script.base, "galaxy-pathprint.r");
source(library.path)

data(GEO.metadata.matrix);

usage <- function() {
  sink(stderr(), type = "message");
  stop("Usage: fingerprint.r [ARGS]", call. = FALSE)
}

## Get the command line arguments.
args <- commandArgs(trailingOnly = TRUE)

type <- ifelse(! is.na(args[1]), args[1], usage())

if (type == "geo") {
   geoID       <- ifelse(! is.na(args[2]), args[2], usage());
   output      <- ifelse(! is.na(args[3]), args[3], usage());

   fingerprint <- generateFingerprint(geoID);
} else if (type == "cel") {
   input       <- ifelse(! is.na(args[2]), args[2], usage());
   output      <- ifelse(! is.na(args[3]), args[3], usage());

   fingerprint <- loadFingerprintFromCELFile(input);
} else if (type == "expr") {
   input       <- ifelse(! is.na(args[2]), args[2], usage());
   platform    <- ifelse(! is.na(args[3]), args[3], usage());
   output      <- ifelse(! is.na(args[4]), args[4], usage());

   fingerprint <- loadFingerprintFromExprsFile(input, platform);
} else {
  usage();
};

saveFingerprint(fingerprint, output);

quit("no", 0)


library(lattice)

win_metrics <- read.csv('metrics_win_clf.csv')

colors <- palette(rainbow(nrow(win_metrics)))

win_table <- data.matrix(win_metrics, rownames.force=NA)

win_table <- win_table[, -1]

barplot(win_table, main="Winner Metrics", xlab="Metric", col=colors, beside=TRUE)

par(xpd=TRUE)
legend(17, 0.67, win_metrics$Algorithm, lty=c(1,1), lwd=c(2.5, 2.5), col=colors)


#' wiki_graph
#'
#' data.frame with three variables (v1, v2 and w) that contains the edges of the
#' graph (from v1 to v2) with the weight of the edge (w)
#'
#' @format A data frame with 18 rows and 3 variables:
#' \describe{
#'   \item{v1}{first edge}
#'   \item{v2}{second edge}
#'   \item{w}{weight between edges}
#' }
#' @source \url{https://en.wikipedia.org/wiki/Graph}
"wiki_graph"


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

par(mai=c(0.25,0.25,0.25,0.5),omi=c(0.25,0.25,0.25,0.25), family="Lato Light",las=1)

library(igraph)
library(sqldf)
library(gdata)

# Import data and prepare chart

X2013_2014 <- read.csv("myData/2013_2014.txt",sep="\t", head=FALSE)
X2014_2015 <- read.csv("myData/2014_2015.txt",sep="\t", head=FALSE)
X2015_2016 <- read.csv("myData/2015_2016.txt",sep="\t", head=FALSE)
links<-rbind(X2013_2014, X2014_2015, X2015_2016)

teams<-as.data.frame(unique(c(links$V1, links$V2)))
teams<-sqldf("select team, count(*) games from (select V1 team from links union all select V2 team from links) a group by team")
teams$col<-"grey55"
teams$col[c(11, 12, 13, 14, 24, 51)]<-"#f768a1"

mySeed <- as.POSIXlt(Sys.time())
mySeed <- 1000*(mySeed$hour*3600 + mySeed$min*60 + mySeed$sec)
mySeed

set.seed(56313585)
net2 <- graph_from_data_frame(d=links, directed=F, vertices=teams)
net2simp<-simplify(net2, edge.attr.comb=list(weight="sum","ignore"))

# Crete chart

plot(net2simp, vertex.shape="none", vertex.label=V(net2simp)$media, vertex.label.font=2, vertex.label.color=teams$col, vertex.label.cex=0.7*sqrt(teams$games/23), edge.color="grey80", vertex.label.family=ifelse(teams$col=="grey95", "Avenir Next Condensed Ultra Light", "Avenir Next Condensed Demi Bold"))

# Titling

mtext("Champions League - Matches", line=-1.5, adj=0, cex=2, family="Lato Black", col="grey40", outer=T)
mtext("Base: all matches 2013-2016", line=-2.75, adj=0, cex=0.9, family="Lato Bold", col="grey40", outer=T)
mtext("Source: http://www.weltfussball.de/alle_spiele/champions-league-2015-2016/", side=1, line=-1, adj=1, cex=0.9, font=3, outer=T)

dev.off()


pdf_file<-"pdf/maps_nrw_symbols.pdf"
cairo_pdf(bg="grey98", pdf_file,width=8,height=6.5)

par(mai=c(0.5,0.0,0.0,0.5),omi=c(0,0.5,0.75,0),family="Lato Light")
library(sp); library(plotrix); library(gdata)

# Import data and prepare chart

akwnrw<-read.xls("myData/akwnrw.xlsx",head=T, encoding="latin1")
myX<-akwnrw$long; myY<-akwnrw$lat
dm<-rep(0.2,length(myX))
myNpp<-function(myX,myY,dm,... ){
floating.pie(myX,myY,c(1,1,1,1,1,1),radius=dm,startpos=45,border=F,col=c("yellow","black","yellow","black","yellow","black"))
points(myX,myY,pch=19,cex=2,col="yellow")
points(myX,myY,pch=19,cex=1,col="black")
}
load("myData/gadm2/DEU_adm1.RData")
myNrw<-gadm[gadm$NAME_1=="Nordrhein-Westfalen",]

# Create chart

plot(myNrw,border="black",axes=F,lwd=0.5)
n<-length(myX)
for (i in 1:n) myNpp(myX[i],myY[i],dm[i])
text(akwnrw$namlong,akwnrw$namlat-0.2,akwnrw$name,xpd=T)

# Titling

mtext("Nuclear Country North Rhine-Westphalia",3,line=1,adj=0,cex=2,family="Lato Black",outer=T)
mtext("important companies of the nuclear industry are located in NRW",3,line=-0.5,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: www.bund-nrw.de",1,line=-1,adj=1.0,cex=0.95,font=3)
dev.off()


## stan model specific utilities to wrangle data and provide initial values to Stan

## normalize galaxy and stellar library fluxes by mean over all good data points

prep_data_avg <- function(gdat, dz, nnfits, which.spax) {
  i <- which.spax
  z <- gdat$meta$z+dz[i]
  flux <- gdat$flux[i, ]
  ivar <- gdat$ivar[i, ]
  lambda.rest <- gdat$lambda/(1+z)
  logl <- log10(lambda.rest)
  T.gyr <- 10^(ages-9)
  dT <- diff(c(0, T.gyr))

  lib.ssp$lambda <- airtovac(lib.ssp$lambda)
  lib.st <- regrid(lambda.rest, lib.ssp)
  x.st <- blur.lib(lib.st, nnfits$vdisp.st[i])
  n.st <- ncol(x.st)
  nz <- length(Z)
  nt <- n.st/nz
  ind.young <- (0:(nz-1))*nt+1
  allok <- complete.cases(flux, ivar, x.st)
  nl <- length(which(allok))
  norm_g <- mean(pmax(flux[allok], 0))
  norm_st <- colMeans(x.st[allok,])
  x.st <- scale(x.st[allok,], center=FALSE, scale=norm_st)

  x.em <- make_emlib(emlines, nnfits$vdisp.em[i], logl, allok)
  in.em <- x.em$in_em
  x.em <- x.em$x_em
  n.em <- ncol(x.em)
  norm_em <- 1

  list(nt=nt, nz=nz, nl=nl, n_em=n.em,
       ind_young=ind.young,
       lambda=lambda.rest[allok],
       gflux=flux[allok]/norm_g,
       g_std=1/sqrt(ivar[allok])/norm_g,
       norm_g=norm_g,
       norm_st=norm_st,
       norm_em=norm_em,
       sp_st=x.st,
       dT=rep(dT, nz),
       sp_em=x.em[allok,],
       in_em=in.em
      )
}

## normalize by mean over wavelength interval (5375, 5625)

prep_data_mod <- function (gdat, dz, nnfits, which.spax) {
  i <- which.spax
  z <- gdat$meta$z + dz[i]
  flux <- gdat$flux[i, ]
  ivar <- gdat$ivar[i, ]
  lambda.rest <- gdat$lambda/(1 + z)
  logl <- log10(lambda.rest)
  T.gyr <- 10^(ages - 9)
  dT <- diff(c(0, T.gyr))
  lib.ssp$lambda <- airtovac(lib.ssp$lambda)
  lib.st <- regrid(lambda.rest, lib.ssp)
  x.st <- blur.lib(lib.st, nnfits$vdisp.st[i])
  n.st <- ncol(x.st)
  nz <- length(Z)
  nt <- n.st/nz
  ind.young <- (0:(nz - 1)) * nt + 1
  allok <- complete.cases(flux, ivar, x.st)
  lambda <- lambda.rest[allok]
  gflux <- flux[allok]
  x.st <- x.st[allok,]
  wl_ind <- findInterval(c(5375,5625), lambda)
  nl <- length(which(allok))
  norm_g <- mean(pmax(gflux[wl_ind[1]:wl_ind[2]], 0))
  norm_st <- colMeans(x.st[wl_ind[1]:wl_ind[2], ])
  x.st <- scale(x.st, center = FALSE, scale = norm_st)
  x.em <- make_emlib(emlines, nnfits$vdisp.em[i], logl, allok)
  in.em <- x.em$in_em
  x.em <- x.em$x_em
  n.em <- ncol(x.em)
  norm_em <- 1
  list(nt = nt, nz = nz, nl = nl, n_em = n.em, ind_young = ind.young,
    lambda = lambda, gflux = gflux/norm_g,
    g_std = 1/sqrt(ivar[allok])/norm_g, norm_g = norm_g,
    norm_st = norm_st, norm_em = norm_em, sp_st = x.st,
    dT = rep(dT, nz), sp_em = x.em[allok, ], in_em = in.em)
}

## initialize Stan's optimizer to estimate MAP solution

init_opt_mod <- function(spm_data, nnfits, which.spax, jv) {
  n_st <- ncol(spm_data$sp_st)
  n_em <- spm_data$n_em
  norm_st <- spm_data$norm_st
  norm_em <- spm_data$norm_em
  norm_g <- spm_data$norm_g
  b <- nnfits$nnfits[which.spax,]
  b_st_s <- b[1:n_st] * norm_st/norm_g + runif(n_st, min=jv/10, max=jv)
  a <- sum(b_st_s)
  b_st_s <- b_st_s/a
  b_em <- b[(n_st+1):(n_st+n_em)] * norm_em/norm_g + runif(n_em, min=jv/10, max=jv)
  tauv <- nnfits$tauv[which.spax]
  if (tauv == 0) tauv=runif(1, min=jv/10, max=jv)
  delta <- rnorm(1, 0, jv)
  list(a=a, b_st_s=b_st_s, b_em=b_em, tauv=tauv, delta=delta)
}

## initialize Stan's sampler

init_sampler_mod <- function(X, stan_opt, jv) {
  a <- as.numeric(stan_opt$a + rnorm(1, sd=jv))
  b_st_s <- stan_opt$b_st_s + runif(length(stan_opt$b_st_s), min=jv/10, max=jv)
  b_st_s <- b_st_s/sum(b_st_s)
  b_em <- stan_opt$b_em + runif(length(stan_opt$b_em), min=jv/10, max=jv)
  tauv <- as.numeric(stan_opt$tauv + runif(1, min=jv/10, max=jv))
  delta <- as.numeric(stan_opt$delta + rnorm(1, sd=jv))
  list(a=a, b_st_s=b_st_s, b_em=b_em, tauv=tauv, delta=delta)
}

## Stan model specific data to track in stanfit_batch

init_tracked_mod <- function(nsim, n_st, n_em, nr) {
  assign("b_st", array(NA, dim=c(nsim, n_st, nr)), parent.frame())
  assign("b_em", array(NA, dim=c(nsim, n_em, nr)), parent.frame())
  assign("a", matrix(NA, nrow=nsim, ncol=nr), parent.frame())
  assign("tauv", matrix(NA, nrow=nsim, ncol=nr), parent.frame())
  assign("delta", matrix(NA, nrow=nsim, ncol=nr), parent.frame())
  assign("in_em", matrix(NA, nrow=n_em, ncol=nr), parent.frame())
  assign("ll", matrix(NA, nrow=nsim, ncol=nr), parent.frame())
  assign("walltime", rep(NA, nr), parent.frame())
  assign("divergences", rep(NA, nr), parent.frame())
  assign("max_treedepth", rep(NA, nr), parent.frame())
  assign("norm_g", rep(NA, nr), parent.frame())
  assign("norm_st", matrix(NA, nrow=n_st, ncol=nr), parent.frame())
  assign("norm_em", rep(NA, nr), parent.frame())
}

update_tracked_mod <- function(i, sfit, fpart) {
  post <- rstan::extract(sfit$stanfit)
  env <- parent.frame()
  env$b_st[,,i] <- post$b_st
  env$b_em[,sfit$in_em,i] <- post$b_em
  env$a[,i] <- post$a
  env$tauv[,i] <- post$tauv
  env$delta[,i] <- post$delta
  env$in_em[sfit$in_em,i] <- sfit$in_em
  env$ll[,i] <- post$ll
  env$walltime[i] <- max(rowSums(rstan::get_elapsed_time(sfit$stanfit)))
  sp <- rstan::get_sampler_params(sfit$stanfit, inc_warmup=FALSE)
  env$divergences[i] <- sum(sapply(sp, function(x) sum(x[, "divergent__"])))
  env$max_treedepth[i] <- max(sapply(sp, function(x) max(x[, "treedepth__"])))
  env$norm_g[i] <- sfit$norm_g
  env$norm_st[,i] <- sfit$norm_st
  env$norm_em[i] <- sfit$norm_em
  save(b_st, b_em, tauv, delta, a, in_em, ll,
       walltime, divergences, max_treedepth,
       norm_g, norm_st, norm_em, envir=env, file = fpart)
}

return_tracked_mod <- function() {
  env <- parent.frame()
  retval <- list(b_st= env$b_st, b_em= env$b_em, a= env$a, tauv= env$tauv, delta= env$delta, in_em= env$in_em, ll= env$ll,
       walltime= env$walltime, divergences= env$divergences, max_treedepth= env$max_treedepth,
       norm_g= env$norm_g, norm_st= env$norm_st, norm_em= env$norm_em)
  retval
}

## replace a single stan run in batch fits

replace_sfit_mod <- function(sfit.all, sfit.one, which.spax) {
  post <- rstan::extract(sfit.one$stanfit)
  sp <- rstan::get_sampler_params(sfit.one$stanfit, inc_warmup=FALSE)
  sfit.all$b_st[,,which.spax] <- post$b_st
  sfit.all$b_em[,sfit.one$in.em,which.spax] <- post$b_em
  sfit.all$a[,which.spax] <- post$a
  sfit.all$tauv[,which.spax] <- post$tauv
  sfit.all$delta[,which.spax] <- post$delta
  sfit.all$in_em[sfit.one$in.em,which.spax] <- sfit.one$in.em
  sfit.all$ll[,which.spax] <- post$ll
  sfit.all$walltime[which.spax] <- max(rowSums(rstan::get_elapsed_time(sfit.one$stanfit)))
  sfit.all$divergences[which.spax] <- sum(sapply(sp, function(x) sum(x[, "divergent__"])))
  sfit.all$max_treedepth[which.spax] <- max(sapply(sp, function(x) max(x[, "treedepth__"])))
  sfit.all$norm_g[which.spax] <- sfit.one$norm_g
  sfit.all$norm_st[,which.spax] <- sfit.one$norm_st
  sfit.all$norm_em[which.spax] <- sfit.one$norm_em
  sfit.all
}


REBOL [
	Title:   "Generates Red/System float! tests"
	Author:  "Peter W A Wood"
	File: 	 %make-float32-auto-test.r
	Version: 0.1.0
	Rights:  "Copyright (C) 2012-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

;; initialisations
tests: copy ""							;; string to hold generated tests
test-number: 0							;; number of the generated test
make-dir %auto-tests/
file-out: %auto-tests/float32-auto-test.reds

;; create a block of values to be used in the binary ops tests
test-values: [
            0.0
     -2147483.0
      2147483.0
           -1.0
            3.0
           -7.0
            5.0
          456.7890
       123456.7
            1.222944E+22
            9.99999E-7
            7.7E18
]

tol: 1e-6

;; create blocks of operators to be applied
test-binary-ops: [
	+
	-
	*
	/
]

test-comparison-ops: [
	=
	<>
	<
	>
	>=
	<=
]

test-comparison-values: [			;; these are relative not absolute
	-1E-6
	0.0
	+1E-6
]

;; create test file with header
append tests "Red/System [^(0A)"
append tests {  Title:   "Red/System auto-generated float! tests"^(0A)}
append tests {	Author:  "Peter W A Wood"^(0A)}
append tests {  File: 	 %floa32-auto-test.reds^(0A)}
append tests {  License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"^(0A)}
append tests "]^(0A)^(0A)"
append tests "^(0A)^(0A)comment {"
append tests "  This file is generated by make-float32-auto-test.r^(0A)"
append tests "  Do not edit this file directly.^(0A)"
append tests "}^(0A)^(0A)"
append tests join ";make-length:"
                  [length? read %make-float32-auto-test.r "^(0A)^(0A)"]
append tests "#include %../../../../../quick-test/quick-test.reds^(0A)^(0A)"
append tests {~~~start-file~~~ "Auto-generated tests for float32"^(0A)^(0A)}
append tests {===start-group=== "Auto-generated tests for float32"^(0A)^(0A)}

write file-out tests
tests: copy ""

;; binary operator tests - in global context
foreach op test-binary-ops [
	foreach operand1 test-values [
		foreach operand2 test-values [
			;; only write a test if REBOL produces a result
			if all [
				attempt [expected: to decimal! do reduce [operand1 op operand2]]
				expected < 3.3E38
				expected > 0.2E-37
			][

				;; test with literal values
				test-number: test-number + 1
				append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
				append tests "  --assertf32~= "
				append tests reform [
					"as float32! " expected " ((" "as float32! " operand1 ")"
					op "( as float32! " operand2 ") ) " "as float32! " tol "^(0A)"
			  ]

			  ;; test with variables
			  test-number: test-number + 1
			  append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
			  append tests join "      i: " ["as float32! " operand1 "^(0A)"]
			  append tests join "      j: " ["as float32! " operand2 "^(0A)"]
			  append tests rejoin ["      k:  i " op " j^(0A)"]
			  append tests "  --assertf32~= "
			  append tests reform ["as float32! " expected " k " "as float32! " tol "^(0A)"]
			  ;; write tests to file
			  write/append file-out tests
			  tests: copy ""
			]
			recycle
		]
	]
]

;; binary operator tests - inside a function

;; write function spec
tests: {
float-auto-test-func: func [
	/local
		i [float32!]
		j [float32!]
		k [float32!]
][
}

write/append file-out tests
tests: copy ""

foreach op test-binary-ops [
	foreach operand1 test-values [
		foreach operand2 test-values [
			;; only write a test if REBOL produces a result
			if all [
				attempt [expected: to decimal! do reduce [operand1 op operand2]]
				expected < 3.3E38
				expected > 0.2E-37
			][

				;; test with variables inside the function
				test-number: test-number + 1
				append tests join {    --test-- "float-auto-} [test-number {"^(0A)}]
				append tests join "      i: " ["as float32! " operand1 "^(0A)"]
				append tests join "      j: " ["as float32! " operand2 "^(0A)"]
				append tests rejoin ["      k:  i " op " j^(0A)"]
				append tests "    --assertf32~= "
				append tests reform ["as float32! " expected " k " "as float32! " tol "^(0A)"]

				;; write tests to file
				write/append file-out tests
				tests: copy ""
			]
			recycle
		]
	]
]

;; write closing bracket and function call
append tests "  ]^(0a)"
append tests "float-auto-test-func^(0a)"
write/append file-out tests
tests: copy ""

;; comparison tests
foreach op test-comparison-ops [
	foreach operand1 test-values [
		foreach oper2 test-comparison-values [
			;; only write a test if REBOL produces a result
			if all [
				attempt [operand2: operand1 + (operand1 * oper2)]
				oper2 < 3.3E+38
				oper2 > 0.2E-37
				none <> attempt [expected: do reduce [operand1 op operand2]]
			][
				test-number: test-number + 1
				append tests join {  --test-- "float-auto-} [test-number {"^(0A)}]
				append tests "  --assert "
				append tests reform [
				  expected " = (" "(as float32! " operand1 ")" op
				  "(as float32! " operand2 ") )^(0A)"
				]

				;; write tests to file
				write/append file-out tests
				tests: copy ""
			]
		]
	]
]

;; write file epilog
append tests "^(0A)===end-group===^(0A)^(0A)"
append tests {~~~end-file~~~^(0A)^(0A)}

write/append file-out tests

print ["Number of assertions generated" test-number]


compute.proportions = function( x, var="egg" ) {

  x$dummy = 1
  ncrab=tapply( x$dummy, x$timevalue, FUN=length )    # number of primi crab on each day
  ncrab = as.data.frame( ncrab )
  ncrab$timevalue = as.numeric( rownames( ncrab))
  sub1=which( x[,var]==1 )
  ncrab1=tapply( x$dummy[sub1], x$timevalue[sub1], FUN=length )
  ncrab1= as.data.frame (ncrab1)
  ncrab1$timevalue = as.numeric (rownames(ncrab1))
  prop = merge( ncrab, ncrab1, by=c("timevalue"), all.x=T, all.y=F) # combine total number of crab with var==1
  prop[is.na(prop)]=0   # turn na's to zero
  prop$fraction=NA
  prop$fraction= prop$ncrab1/prop$ncrab
  return ( prop)

}


testData <- data.frame(Strata = paste("size ",1:5), numberTotalBoxes = c(1:3,4,4), numberSampledBoxes = 1)

# kg/fish
testData$totalWeightBoxes <- testData$numberTotalBoxes*10

testData$sampledWeightBoxes <- c(10, 10, 10, 10, 10)

testData$fishSampled<-testData$sampledWeight*1/c(7, 5.5, 3, 1.5, 1)


library(cummeRbund)

args = commandArgs(trailingOnly=TRUE)

setwd(args[1])

cuff = readCufflinks(args[2])

samples = strsplit(args[3], ",", fixed = TRUE)[[1]]
samples = gsub("-","_",samples)
samples = gsub("\\.", "_", samples)
for (i in 1:length(samples)) {samples[i] = paste("X",samples[i],sep="")}

write.table(replicates(cuff), "replicates.csv", sep=",", quote=F)
write.table(annotation(genes(cuff)), "annotations.csv", sep=",", quote=F)
write.table(fpkm(genes(cuff)), "fpkm-genes.csv", sep=",", quote=F)
write.table(repFpkm(genes(cuff)), "repFpkm-genes.csv", sep=",", quote=F)
write.table(count(genes(cuff)), "count-genes.csv", sep=",", quote=F)
write.table(fpkm(isoforms(cuff)), "repFpkm-genes.csv", sep=",", quote=F)
write.table(diffData(genes(cuff)), "diffData-genes.csv", sep=",", quote=F)
##write.table(, "repFpkm-genes.csv", sep=",", quote=F)
##write.table(, "repFpkm-genes.csv", sep=",", quote=F)

csDensity(genes(cuff))
csDendro(genes(cuff))
dispersionPlot(genes(cuff))
fpkmSCVPlot(genes(cuff))
fpkmSCVPlot(isoforms(cuff))
csBoxplot(genes(cuff))

csScatterMatrix(genes(cuff))
csVolcanoMatrix(genes(cuff))
sigMatrix(cuff,level='genes',alpha=0.05)
PCAplot(genes(cuff),"PC1","PC2")
csDistHeat(genes(cuff))

gene_diff_data=diffData(genes(cuff))
sig_gene_data = subset(gene_diff_data,significant=='yes')
sig_genes = getGenes(cuff,sig_gene_data$gene_id)

write.table(sig_gene_data,'sig-diff-genes.csv',sep=',',quote=F)

pdf(file="expression-barplot.pdf")
lclsigs = getSig(cuff,alpha=0.05,level='genes')[1:10]
expressionBarplot(getGenes(cuff,lclsigs),logMode=T,showErrorbars=T)
dev.off()

pdf(file="expression-heatmap.pdf")
lclsigs = getSig(cuff,alpha=0.05,level='genes')[1:10]
csHeatmap(getGenes(cuff,lclsigs),cluster='both')
dev.off()


library(openair)

timep <- function(data, pollutants, window) {
    timestamp <- as.POSIXct(window$center, tz="GMT")

    chart <- timePlot(data,
                      cols = "hue",
                      group = FALSE,
                      key.columns = 5,
                      lwd = 1.5,
                      pollutant = pollutants,
                      windflow = list(col = "grey50", lwd = 1, scale = 0.05, length=0.05),
                      ref.x = (list(v = timestamp, col = "grey70", lty = 2, lwd = 1.5)),
                      y.relation = "free")

    chart$plot
}

corrp <- function(data, pollutants) {
    chart <- corPlot(data, cols = "default", pollutant = pollutants)
    chart$plot
}

prosep <- function(data, pollutant) {
    data$dayHour <- format(data$date, "%Y-%m-%d %H:00")

    chart <- pollutionRose(data,
                           angle=22.5,
                           annotate = FALSE,
                           cols = "default",
                           grid.line = 25,
                           key.position = "right",
                           layout = c(5, 5),
                           paddle = FALSE,
                           pollutant = pollutant,
                           type = "dayHour")
    chart$plot
}

windp <- function(data) {
    data$dayHour <- format(data$date, "%Y-%m-%d %H:00")

    chart <- windRose(data,
                      angle=22.5,
                      breaks = c(0, 3, 6, 9, 12),
                      cols = "default",
                      grid.line = 25,
                      key.footer = "(km/h)",
                      key.position = "right",
                      layout = c(5, 5),
                      paddle = FALSE,
                      type = "dayHour")

        chart$plot
}


library(cn.mops)

BAMFiles <- list.files(pattern="sort.bam$")

# Setting the window length is important because the default will be extremely large.
bamDataRanges <- getReadCountsFromBAM(BAMFiles, refSeqName = c("Ha4", "Ha16"), mode = "paired", WL = 100)
res <- cn.mops(bamDataRanges, normType = "mean")
res <- calcIntegerCopyNumbers(res)

segm <- as.data.frame(segmentation(res))
CNVs <- as.data.frame(cnvs(res))
CNVRegions <- as.data.frame(cnvr(res))

write.table(segm,file="segmentation.tsv",sep="\t",quote=FALSE)
write.table(CNVs,file="cnvs.tsv",sep="\t",quote=FALSE)
write.table(CNVRegions,file="cnvr.tsv",quote=FALSE)

# Look in the cnvs file to get the CNV IDs. The code below prints only the first called region
plot(res, which=1)

# By default this prints all chromosomes in the same plot.
segplot(res)


# Methods to find the best alpha, beta, tau parameters in the
# likelihood function of the EM
##############################################################
library(doParallel)
library(foreach)

opt.grid <- function(Q, params0, ...){
  source('likelihood.r')

  # Grid search
  cl <- makeCluster(detectCores()-3);
  registerDoParallel(cl)
  df.results <- foreach(alpha = seq(0.01, 0.1, by=0.01), .combine = rbind, .packages=c('foreach'), .export=c("likelihood.post")) %dopar% {
                  foreach(beta = seq(0.01, 0.14, by=0.01), .combine = rbind) %do% {
                    foreach(tau = seq(0.01, 0.1, by=0.01), .combine = rbind) %do% {
                      like <- Q(alpha, beta, tau, ...)
                      data.frame(alpha = alpha, beta = beta, tau = tau, like = like)
                    }
                  }
  }
  stopCluster(cl)
  df.results$like <- df.results$like - max(df.results$like)
  df.results#[which.max(df.results$like),]
}

#pis_k <- c(0.5,0.5)
if(FALSE){
  df.results <- opt.grid(Qopt, params0=c(1,2,3),
                         resp_k = responsabilities_k,
                         df.trees = df.trees)
}

########################################################
########################################################
if(FALSE){
outfun <- function(x, optimValues, state){
  cat('\n', x)
}
opt <- optimset(OutputFcn=outfun, MaxFunEvals=10)
opt.fminnd <- function(Q){

  fminbnd(fun = cost.function, x0=c(alphas[k],betas[k],taus[k]),
          xmin=c(0.09,0.09,0.09), xmax=c(10,200,0.99), optimset(OutputFcn=outfun.bar))
  xopt <- neldermead.get(sol, "xopt")
}
}


library(lattice)

nom_metrics <- read.csv('metrics_nom_clf.csv')

colors <- palette(rainbow(nrow(nom_metrics)))

nom_table <- data.matrix(nom_metrics, rownames.force=NA)

nom_table <- nom_table[, -1]

barplot(nom_table, main="Nominee Metrics", xlab="Metric", col=colors, beside=TRUE)

par(xpd=TRUE)
legend(17, 1.07, nom_metrics$Algorithm, lty=c(1,1), lwd=c(2.5, 2.5), col=colors)


library(SparkR)
# sparkR.session()
sparkR.session(master = "local[*]", sparkConfig = list(spark.driver.memory = "2g"))

sparkDF <- read.df("../data/flight-data/csv/2015-summary.csv",
         source = "csv", header="true", inferSchema = "true")
take(sparkDF, 5)

# COMMAND ----------

collect(orderBy(sparkDF, "count"), 20)

# COMMAND ----------

library(magrittr)
sparkDF %>%
  orderBy(desc(sparkDF$count)) %>%
  groupBy("ORIGIN_COUNTRY_NAME") %>%
  count() %>%
  limit(10) %>%
  collect()

# COMMAND ----------


options(scipen=999)

# read in window summary
x <- read.table("wbnu_window_summary.txt", header=T, stringsAsFactors=F)

# define window size
window_size <- x$end[1] - x$start[1] + 1

# define number of windows for line plots
num_windows <- 10

# set up row numbers for line plots
line_rows <- seq(from=1,to=nrow(x), by=1)[seq(from=1,to=nrow(x), by=1) %% num_windows == 0]

# what are the unique chromosomes and their bounding areas for plotting?
total_windows <- nrow(x)
scaffold <- unique(x$scaffold)
chr_polygons <- list()
# make the plotting polygons
for(a in 1:length(scaffold)) {
	a1 <- as.numeric(rownames(x))[x[,1] == scaffold[a]]
	a2 <- a1[length(a1)]
	a1 <- a1[1]
	chr_polygons[[a]] <- rbind(c(a1, 0), c(a2, 0), c(a2, 0.5), c(a1, 0.5), c(a1, 0))
}

########################################################################
########################################################################
########################################################################
########################################################################
# set up plotting dimensions
par(mfrow=c(2,1))
par(mar=c(1,5,1,0))

########################################################################
########################################################################
########################################################################
########################################################################
# plot CDS
plot(c(-1,-1), ylim=c(0,0.2), xlim=c(1, total_windows), xaxt="n", col="white", bty="n", cex.axis=1.1, cex.lab=1.3, ylab="CDS Content")
odd <- 0
for(a in 1:length(chr_polygons)) {
	if(odd == 1) {
		polygon(chr_polygons[[a]], col="snow2", border="white")
		odd <- 0
	} else {
		odd <- 1
	}
}
# plot
points(as.numeric(rownames(x)), x$cds, pch=19, cex=0.1, col="gray85")

# plot sliding mean line plots
x_windows <- as.numeric(rownames(x))
line_x_axis <- line_rows
line_y_axis <- list()
line_scaffold <- list()
for(b in line_rows) {
	line_y_axis[[b]] <- mean(na.omit(x$cds[x_windows %in% (b - (floor(num_windows / 2))):(b + (floor(num_windows / 2))) & x$scaffold == x$scaffold[as.numeric(rownames(x)) == b]][1:num_windows]))
	line_scaffold[[b]] <- x$scaffold[x_windows == b]
}
line_plotting <- data.frame(line_x_axis=as.numeric(line_x_axis), line_y_axis=as.numeric(unlist(line_y_axis)), line_scaffold=as.character(unlist(line_scaffold)))
# plot each scaffold at a time (so lines don't connect between scaffolds)
for(a in 1:length(unique(scaffold))) {
	a_rep <- line_plotting[line_plotting[,3] == unique(scaffold)[a],]
	lines(a_rep[,1:2], lwd=0.8, col="gray55")
}
########################################################################
########################################################################
########################################################################
########################################################################
# plot repeats
plot(c(-1,-1), ylim=c(0,0.4), xlim=c(1, total_windows), xaxt="n", col="white", bty="n", cex.axis=1.1, cex.lab=1.3, ylab="Repeat Content")
odd <- 0
for(a in 1:length(chr_polygons)) {
	if(odd == 1) {
		polygon(chr_polygons[[a]], col="snow2", border="white")
		odd <- 0
	} else {
		odd <- 1
	}
}
# plot
points(as.numeric(rownames(x)), x$repeats, pch=19, cex=0.1, col="gray85")

# plot sliding mean line plots
x_windows <- as.numeric(rownames(x))
line_x_axis <- line_rows
line_y_axis <- list()
line_scaffold <- list()
for(b in line_rows) {
	line_y_axis[[b]] <- mean(na.omit(x$repeats[x_windows %in% (b - (floor(num_windows / 2))):(b + (floor(num_windows / 2))) & x$scaffold == x$scaffold[as.numeric(rownames(x)) == b]][1:num_windows]))
	line_scaffold[[b]] <- x$scaffold[x_windows == b]
}
line_plotting <- data.frame(line_x_axis=as.numeric(line_x_axis), line_y_axis=as.numeric(unlist(line_y_axis)), line_scaffold=as.character(unlist(line_scaffold)))
# plot each scaffold at a time (so lines don't connect between scaffolds)
for(a in 1:length(unique(scaffold))) {
	a_rep <- line_plotting[line_plotting[,3] == unique(scaffold)[a],]
	lines(a_rep[,1:2], lwd=0.8, col="gray55")
}


library(igraphdata)
library(igraph)
library(yenpathy)
data("UKfaculty")
k_shortest_paths(UKfaculty, 1, 2, 1000)

# Run this from console to check for memory leaks
# make sure valgrind is installed for this to work
# R -d "valgrind --leak-check=full" -e "source('tests/find_memory_leaks.r')"


#!/usr/bin/env Rscript

args=commandArgs(trailingOnly=TRUE)
#if (length(args)<15) {
#  stop("Must supply inputs\n",call.=FALSE)
#}

library(GSEABase)
library(GSVA)

method=args[1]
kcdf=args[2]
abs.ranking=as.logical(toupper(args[3]))
min.sz=as.numeric(args[4])
max.sz=args[5]
if(max.sz=='None') {
    max.sz = Inf
} else {
    max.sz = as.numeric(max.sz)
}
parallel.sz=as.numeric(args[6])
parallel.type=args[7]
mx.diff=as.logical(toupper(args[8]))
tau=args[9]
ssgsea.norm=as.logical(toupper(args[10]))
verbose=as.logical(toupper(args[11]))
tempdir=args[12]

geneSets = getGmt(file.path(tempdir,'gs.gmt'))
mat = as.matrix(read.csv(file.path(tempdir,'expr.csv'),header=TRUE,row.names=1,check.names=FALSE))

output = NA
if(tau != 'None') {
    if(tau=='NA') { tau=NA}
    else { tau = as.numeric(tau)}
    output = gsva(mat,geneSets,
        method=method,
        kcdf=kcdf,
        abs.ranking=abs.ranking,
        min.sz=min.sz,
        max.sz=max.sz,
        parallel.sz=parallel.sz,
        parallel.type=parallel.type,
        mx.diff=mx.diff,
        tau=tau,
        ssgsea.norm=ssgsea.norm,
        verbose=verbose
    )
} else {
    output = gsva(mat,geneSets,
        method=method,
        kcdf=kcdf,
        abs.ranking=abs.ranking,
        min.sz=min.sz,
        max.sz=max.sz,
        parallel.sz=parallel.sz,
        parallel.type=parallel.type,
        mx.diff=mx.diff,
        ssgsea.norm=ssgsea.norm,
        verbose=verbose
    )
}
ofile = file.path(tempdir,"pathways.csv")
print(ofile)
write.csv(output,ofile)


#' Generates and evolve community under given parameters.
#'
#' @param arena_size Size of square landscape.
#' @param arena_roughness Level of spatial autocorrelation of landscape.
#' @param phylo_b Birth rate of phylogenetic tree.
#' @param phylo_d Death rate of phylogenetic tree.
#' @param phylo_n_taxa A number of species in the tree.
#' @param trait_model A model, under which trait should be generated ("BM" or "OU").
#' @param trait_sigma A standard-deviation of the random component for each branch in trait simulation.
#' @param trait_alpha A strength of the selective constraint for each branch in OU model.
#' @param com_range A number, range in which modeling species interact.
#' @param betaEnv A number, coefficient for environmental filtering.
#' @param betaComp A number, coefficient for limiting similarity.
#' @param com_nu A number, rate of speciation.
#' @param com_sigma A number, niche width.
#' @param sim_n_iter A number of iterations of community simulation.
#' @param be_verbose Boolean, returns messages during the execution.
#' @param sim_verb_iter A number of iterations in community simulation after which the message is returned.
#'
#' @return A list, community data.
#' @export
#'
#' @examples
#' create_com(arena_size = 258, arena_roughness = 0.75,
#' phylo_b = 0.1, phylo_d = 0, phylo_n_taxa = 500,
#' trait_model = "BM", trait_sigma = 0.1, trait_alpha = 0.1,
#' com_range = 3, betaEnv = 0, betaComp = 0,
#' com_nu = 0.001, com_sigma = 10,
#' sim_n_iter = 2000, be_verbose = T, sim_verb_iter = 500)

create_com <- function(arena_size = 258, arena_roughness = 0.75,
                       phylo_b = 0.1, phylo_d = 0, phylo_n_taxa = 500,
                       trait_model = "BM", trait_sigma = 0.1, trait_alpha = 0.1,
                       com_range = 3, betaEnv = 0, betaComp = 0,
                       com_nu = 0.001, com_sigma = 10,
                       sim_n_iter = 2000, be_verbose = T, sim_verb_iter = 500){

  mat <- sim_arena(size = arena_size, roughness = arena_roughness)
  tree_n_traits <- sim_tree_n_traits(b = phylo_b, d = phylo_d, n_taxa = phylo_n_taxa,
                                     model = trait_model, sigma = trait_sigma, alpha = trait_alpha)

  com <- createCom(mat, tree_n_traits$trait, range = com_range,
                   betaEnv = betaEnv, betaComp = betaComp,
                   nu = com_nu, sigma = com_sigma)

  if (be_verbose){
    print('Community is generated. Initiating community simulation.')
  }
  com <- evolve_com(com, n_iter = sim_n_iter, be_verbose = be_verbose, verb_iter = sim_verb_iter)
  com <- append(com, list(tree_n_traits$phylo))
  names(com)[16] <- 'phylo'

  if (be_verbose){
    print('Community is simulated.')
  }

  return(com)

}


set.seed(1)
M = 512
N = 6
p = matrix(rnorm(M * N), N, M)
write.table(p,
  file = 'test01.512',
  row.names = FALSE,
  col.names = TRUE,
  quote = FALSE)


#+-----------------------------------------------------------------+
#|                             AV1_modelos_linguagem_programacao.r |
#|                          Copyright 2020, Carlos Bezerra Vilela. |
#|                       https://github.com/carlosvilela/exemplosR |
#+-----------------------------------------------------------------+

# definindo a estrutura dos dados
setClass(
  "vetorN",
  slots = list(
    tamanhoN          = "numeric",
    vetor             = "numeric",
    valorMaximo       = "numeric",
    valorDesvioPadrao = "numeric",
    somatorio         = "numeric"
  )
)

# Criando uma constante que definirá o range dos possíveis valores do vetor
rangeVetor = 1:100

# obtendo o tamanho do vetor
tamanhoVetor =  10

# Gerando o vetor
gerarVetor<- sample(rangeVetor, tamanhoVetor, replace=TRUE, prob=NULL)

# obtendo o numero máximo que foi registrado no vetor
numeroMaximo = as.integer(max(gerarVetor))

# Calculando o desvio padrão
desvioPadrao = sd(gerarVetor)

# Calculando o somatório
somaVetor = sum(gerarVetor)

# registrando e estruturando os dados
vetor <- new("vetorN",
             tamanhoN = tamanhoVetor,
             vetor = gerarVetor,
             valorMaximo = numeroMaximo,
             valorDesvioPadrao = desvioPadrao,
             somatorio = somaVetor
)

# exibindo resultado
print(str(vetor))

print(vetor@tamanhoN)
print(vetor@vetor)
print(vetor@valorMaximo)
print(vetor@valorDesvioPadrao)
print(vetor@somatorio)


#' @include translate-sql-helpers.r
#' @include sql-escape.r
NULL

sql_if <- function(cond, if_true, if_false = NULL) {
  build_sql(
    "CASE WHEN (", cond, ")",
    " THEN (", if_true, ")",
    if (!is.null(if_false)) build_sql(" ELSE (", if_false, ")"),
    " END"
  )
}

#' @export
#' @rdname sql_variant
#' @format NULL
base_scalar <- sql_translator(
  `+`    = sql_infix("+"),
  `*`    = sql_infix("*"),
  `/`    = sql_infix("/"),
  `%%`   = sql_infix("%"),
  `^`    = sql_prefix("power", 2),
  `-`    = function(x, y = NULL) {
    if (is.null(y)) {
      if (is.numeric(x)) {
        -x
      } else {
        build_sql(sql("-"), x)
      }
    } else {
      build_sql(x, sql(" - "), y)
    }
  },

  `!=`    = sql_infix("!="),
  `==`    = sql_infix("="),
  `<`     = sql_infix("<"),
  `<=`    = sql_infix("<="),
  `>`     = sql_infix(">"),
  `>=`    = sql_infix(">="),

  `!`     = sql_prefix("not"),
  `&`     = sql_infix("and"),
  `&&`    = sql_infix("and"),
  `|`     = sql_infix("or"),
  `||`    = sql_infix("or"),
  xor     = function(x, y) {
    sql(sprintf("%1$s OR %2$s AND NOT (%1$s AND %2$s)", escape(x), escape(y)))
  },

  abs     = sql_prefix("abs", 1),
  acos    = sql_prefix("acos", 1),
  acosh   = sql_prefix("acosh", 1),
  asin    = sql_prefix("asin", 1),
  asinh   = sql_prefix("asinh", 1),
  atan    = sql_prefix("atan", 1),
  atan2   = sql_prefix("atan2", 2),
  atanh   = sql_prefix("atanh", 1),
  ceil    = sql_prefix("ceil", 1),
  ceiling = sql_prefix("ceil", 1),
  cos     = sql_prefix("cos", 1),
  cosh    = sql_prefix("cosh", 1),
  cot     = sql_prefix("cot", 1),
  coth    = sql_prefix("coth", 1),
  exp     = sql_prefix("exp", 1),
  floor   = sql_prefix("floor", 1),
  log     = function(x, base = exp(1)) {
    build_sql(sql("log"), list(x, base))
  },
  log10   = sql_prefix("log10", 1),
  round   = sql_prefix("round", 2),
  sign    = sql_prefix("sign", 1),
  sin     = sql_prefix("sin", 1),
  sinh    = sql_prefix("sinh", 1),
  sqrt    = sql_prefix("sqrt", 1),
  tan     = sql_prefix("tan", 1),

  tolower = sql_prefix("lower", 1),
  toupper = sql_prefix("upper", 1),
  nchar   = sql_prefix("length", 1),

  `if` = sql_if,
  if_else = sql_if,
  ifelse = sql_if,

  sql = function(...) sql(...),
  `(` = function(x) {
    build_sql("(", x, ")")
  },
  `{` = function(x) {
    build_sql("(", x, ")")
  },
  desc = function(x) {
    build_sql(x, sql(" DESC"))
  },

  is.null = function(x) {
    build_sql("(", x, ") IS NULL")
  },
  is.na = function(x) {
    build_sql("(", x, ") IS NULL")
  },
  na_if = sql_prefix("NULL_IF", 2),

  as.numeric = function(x) build_sql("CAST(", x, " AS NUMERIC)"),
  as.integer = function(x) build_sql("CAST(", x, " AS INTEGER)"),
  as.character = function(x) build_sql("CAST(", x, " AS TEXT)"),

  c = function(...) escape(c(...)),
  `:` = function(from, to) escape(from:to),

  between = function(x, left, right) {
    build_sql(x, " BETWEEN ", left, " AND ", right)
  },

  pmin = sql_prefix("min"),
  pmax = sql_prefix("max"),

  `__dplyr_colwise_fun` = function(...) {
    stop("colwise verbs only accept bare functions with local sources",
      call. = FALSE)
  }
)

base_symbols <- sql_translator(
  pi = sql("PI()"),
  `*` = sql("*"),
  `NULL` = sql("NULL")
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_agg <- sql_translator(
  # SQL-92 aggregates
  # http://db.apache.org/derby/docs/10.7/ref/rrefsqlj33923.html
  n          = sql_prefix("count"),
  mean       = sql_prefix("avg", 1),
  var        = sql_prefix("variance", 1),
  sum        = sql_prefix("sum", 1),
  min        = sql_prefix("min", 1),
  max        = sql_prefix("max", 1),
  n_distinct = function(x) {
    build_sql("COUNT(DISTINCT ", x, ")")
  }
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_win <- sql_translator(
  # rank functions have a single order argument that overrides the default
  row_number   = win_rank("row_number"),
  min_rank     = win_rank("rank"),
  rank         = win_rank("rank"),
  dense_rank   = win_rank("dense_rank"),
  percent_rank = win_rank("percent_rank"),
  cume_dist    = win_rank("cume_dist"),
  ntile        = function(order_by, n) {
    over(
      build_sql("NTILE", list(as.integer(n))),
      partition_group(),
      order_by %||% partition_order()
    )
  },

  # Recycled aggregate fuctions take single argument, don't need order and
  # include entire partition in frame.
  mean  = win_recycled("avg"),
  sum   = win_recycled("sum"),
  min   = win_recycled("min"),
  max   = win_recycled("max"),
  n     = function() {
    over(sql("COUNT(*)"), partition_group())
  },

  # Cumulative function are like recycled aggregates except that R names
  # have cum prefix, order_by is inherited and frame goes from -Inf to 0.
  cummean = win_cumulative("mean"),
  cumsum  = win_cumulative("sum"),
  cummin  = win_cumulative("min"),
  cummax  = win_cumulative("max"),

  # Finally there are a few miscellaenous functions that don't follow any
  # particular pattern
  nth = function(x, order = NULL) {
    over(build_sql("NTH_VALUE", list(x)), partition_group(), order %||% partition$order())
  },
  first = function(x, order = NULL) {
    over(build_sql("FIRST_VALUE", list(x)), partition_group(), order %||% partition_order())
  },
  last = function(x, order = NULL) {
    over(build_sql("LAST_VALUE", list(x)), partition_group(), order %||% partition_order())
  },

  lead = function(x, n = 1L, default = NA, order = NULL) {
    over(
      build_sql("LEAD", list(x, n, default)),
      partition_group(),
      order %||% partition_order()
    )
  },
  lag = function(x, n = 1L, default = NA, order = NULL) {
    over(
      build_sql("LAG", list(x, n, default)),
      partition_group(),
      order %||% partition_order()
    )
  },

  order_by = function(order_by, expr) {
    old <- set_partition(partition_group(), order_by)
    on.exit(set_partition(old))

    expr
  }
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_no_win <- sql_translator(
  row_number   = win_absent("row_number"),
  min_rank     = win_absent("rank"),
  rank         = win_absent("rank"),
  dense_rank   = win_absent("dense_rank"),
  percent_rank = win_absent("percent_rank"),
  cume_dist    = win_absent("cume_dist"),
  ntile        = win_absent("ntile"),
  mean         = win_absent("avg"),
  sum          = win_absent("sum"),
  min          = win_absent("min"),
  max          = win_absent("max"),
  n            = win_absent("n"),
  cummean      = win_absent("mean"),
  cumsum       = win_absent("sum"),
  cummin       = win_absent("min"),
  cummax       = win_absent("max"),
  nth          = win_absent("nth_value"),
  first        = win_absent("first_value"),
  last         = win_absent("last_value"),
  lead         = win_absent("lead"),
  lag          = win_absent("lag"),
  order_by     = win_absent("order_by")
)


#' @export
str.float32 = function(object, digits.d=strO$digits.d, ...)
{
  strO = utils::strOptions()
  MAXLEN = 10L
  len = length(object)
  printlen = min(len, MAXLEN)

  # this is hideous, but I don't think there's any way to play the same game with S4
  s = DATA(object)[1:printlen, drop=TRUE]
  vals = dbl(float32(s))

  cat("Formal class 'float32' [package \"float\"] with 1 slot\n")

  if (isavec(object))
    cat(paste0("..@ Data: int [1:", len, "] "))
  else
    cat(paste0("..@ Data: int [1:", nrow(object), ", 1:", ncol(object), "] "))

  cat(format(vals, digits=digits.d))
  if (length(vals) < length(object))
    cat(" ...")

  cat("\n")

  invisible()
}


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

setwd("/Users/mengmengjiang/all datas/print")

library(xlsx)

# reading ux and sy

k1<-read.xlsx("doty.xlsx",sheetName="600",header=TRUE)
k2<-read.xlsx("doty.xlsx",sheetName="1khz",header=TRUE)
k3<-read.xlsx("doty.xlsx",sheetName="2khz",header=TRUE)

# par

#par(mfrow = c(2,1), mar = c(2,2.4,2,2), oma = c(1,1,1,1))
#layout(matrix(c(1,2), 2, 1,byrow = TRUE))

# errorbar
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
stop("vectors must be same length")
arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

# color setting

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

# plot

plot(k1$uy,k1$syeva, col=0,xlab = expression(italic(U["y"]) (um)),
          ylab = expression(italic(S["y"]) (um)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "", xlim = c(50,150),ylim=c(-20,70))

               mtext("Line space",3,line=0.2,font=2,cex=1.2)

               lines(k1$uy,k1$syeva,lwd=1.5,lty=2,col=yan[1],pch=pcc[1],type="b")
               lines(k2$uy,k2$syeva,lwd=1.5,lty=2,col=yan[2],pch=pcc[2],type="b")
               lines(k3$uy,k3$syeva,lwd=1.5,lty=2,col=yan[3],pch=pcc[3],type="b")

               error.bar(k1$uy,k1$syeva,k1$systd/2,col=yan[1])
               error.bar(k2$uy,k2$syeva,k2$systd/2,col=yan[2])
               error.bar(k3$uy,k3$syeva,k3$systd/2,col=yan[3])

               leg<-c("600Hz","1KHz","2KHz")

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


#version of analyseProduction script but using service calculated from cells output file
#used with data from run that do not use STELLA (no FromMaestro files created)

rm(list=ls())

library(tidyverse)
library(ggplot2)
library(readxl)
library(viridis)

#set for the run in CRAFTY (althrough runID difficult to control)
scenario <- "scenario_observed_2001-2035_2020-02-13"
#demand <- "Demand_2020-02-06b"
runID <- "0-0"
sim_yrs <- seq(2001, 2035, 1)   #consolidate these years

#output can be printed to pdf by setting following variable appropriately (TRUE/FALSE)
pdfprint <- TRUE

data_dir <- "C:/Users/k1076631/craftyworkspace/CRAFTY_TemplateCoBRA/output/Brazil/Unknown/"
#data_dir <- "C:/Users/k1076631/Google Drive/Shared/Crafty Telecoupling/CRAFTY_testing/CRAFTYOutput/Data/"

output_name <- paste0(data_dir,scenario,"/",runID,"/",scenario,"-",runID,"_ProductionAnalysis_NoSTELLA.pdf")

#year, service, Measure, value
mod_dat <- data.frame(
    year = integer(),
    service = character(),
    Measure = integer(),
    value = numeric()

  )
tbl_df(mod_dat)

for(i in seq_along(sim_yrs)){

  #i <- 11
  #Load model output data
  output <- read.csv(paste0(data_dir,scenario,"/",runID,"/",scenario,"-",runID,"-Cell-",sim_yrs[i],".csv"))

  Soy <- output %>%
    filter(`Service.Soy` > 0) %>%
    summarise(mn = mean(`Service.Soy`), sm = sum(`Service.Soy`), mm = min(`Service.Soy`), mx = max(`Service.Soy`), sd = sd(`Service.Soy`))

  Maize <- output %>%
    filter(`Service.Maize` > 0) %>%
    summarise(mn = mean(`Service.Maize`), sm = sum(`Service.Maize`), mm = min(`Service.Maize`), mx = max(`Service.Maize`), sd = sd(`Service.Maize`))

  Agri <- output %>%
    mutate(`Service.Agri` = `Service.Soy` + `Service.Maize`) %>%
    filter(`Service.Agri` > 0) %>%
    summarise(mn = mean(`Service.Agri`), sm = sum(`Service.Agri`), mm = min(`Service.Agri`), mx = max(`Service.Agri`), sd = sd(`Service.Agri`))

  Nature <- output %>%
    filter(`Service.Nature` > 0) %>%
    summarise(mn = mean(`Service.Nature`), sm = sum(`Service.Nature`), mm = min(`Service.Nature`), mx = max(`Service.Nature`), sd = sd(`Service.Nature`))

  OAgri <- output %>%
    filter(`Service.Other.Agriculture` > 0) %>%
    summarise(mn = mean(`Service.Other.Agriculture`), sm = sum(`Service.Other.Agriculture`), mm = min(`Service.Other.Agriculture`), mx = max(`Service.Other.Agriculture`), sd = sd(`Service.Other.Agriculture`))

  Other <- output %>%
    filter(`Service.Other` > 0) %>%
    summarise(mn = mean(`Service.Other`), sm = sum(`Service.Other`), mm = min(`Service.Other`), mx = max(`Service.Other`), sd = sd(`Service.Other`))

  Meat <- output %>%
    filter(`Service.Pasture` > 0) %>%
    summarise(mn = mean(`Service.Pasture`), sm = sum(`Service.Pasture`), mm = min(`Service.Pasture`), mx = max(`Service.Pasture`), sd = sd(`Service.Pasture`))

  #lserv <- c("Soy", "Maize", "Pasture", "Agri")
  lserv <- c("Soy", "Maize", "Meat")

  for(j in lserv) {

  mod_dat <- mod_dat %>%
    add_row(year = sim_yrs[i], service = j, Measure = "Mean", value = round(UQ(as.name(j))$mn,3)) %>%
    add_row(year = sim_yrs[i], service = j, Measure = "Sum", value = round(UQ(as.name(j))$sm,3)) %>%
    add_row(year = sim_yrs[i], service = j, Measure = "Min", value = round(UQ(as.name(j))$mm,3)) %>%
    add_row(year = sim_yrs[i], service = j, Measure = "Max", value = round(UQ(as.name(j))$mx,3)) %>%
    add_row(year = sim_yrs[i], service = j, Measure = "SD", value = round(UQ(as.name(j))$sd,3))

  }
}

mod_serv <- mod_dat %>%
  filter(Measure == "Sum") %>%
  #filter(service != "Other", service != "OAgri") %>%
  rename(Commodity = service) %>%
  mutate(Measure = "Production") %>%
  mutate(value_gg = if_else(Commodity == "Soy", value * 25,
    if_else(Commodity == "Maize", value * 37.5, value * 0.275)
  )) %>%
  mutate(value_gg = round(value_gg,1)) %>%
  dplyr::select(-value) %>%
  mutate(Source = "Mod") %>%
  dplyr::select(year, value_gg, Commodity, Source, Measure)

Meat_prod_Astates_Data <- read_excel(paste0(data_dir,"Cattle_Meat_production_Kg_2000_2018_all_states.xlsx"), sheet = "Plan1", skip = 1)  #data for all states Astates
maize_prod_Amunis_Data <- read_excel(paste0(data_dir,"maize_brazil.xlsx"), sheet = "Production (tons)", skip = 1, na = c("", "-", "..."))
soy_prod_Amunis_Data <- read_excel(paste0(data_dir,"soybean_brazil.xlsx"), sheet = "Production (Tons)", skip = 1, na = c("", "-", "..."))

Fstate_vals <- c(17,    29, 31, 35, 41, 42, 43, 50, 51, 52)
Fstate_abbrev <- c("TO", "BA", "MG", "SP", "PR",  "SC", "RS", "MS", "MT", "GO")

Astate_codes <- Meat_prod_Astates_Data %>%
  dplyr::select(NM_UF_SIGLA, CD_GCUF) %>%
  rename(state = NM_UF_SIGLA, stateid = CD_GCUF) %>%
  filter(!is.na(state))    #safer way to remove text line at bottom of state column

##Meat
Meat_prod_Astates <- Meat_prod_Astates_Data %>%
  rename(state = NM_UF_SIGLA) %>%
  dplyr::select(-NM_UF, -CD_GCUF) %>%      #drop columns
  filter(!is.na(state)) %>%   #safer way to remove text line at bottom of state column
  mutate_at(vars("2001":"2018"), as.numeric)

Meat_prod_Astates_long <- Meat_prod_Astates %>%
   gather(key = year, value = Meat_kg, -state) %>%
   mutate_at(vars(year), as.integer) %>%
   mutate(Meat = Meat_kg * 0.000001) %>%  #convert from kg to gg
   dplyr::select(-Meat_kg)

#MAIZE
#has the same data strucutre (with some differences in unit conversions - could write function to cover both?)
maize_prod_Amunis <- maize_prod_Amunis_Data %>%
  rename(muniID = `IBGE CODE`) %>%
  filter(!is.na(muniID)) %>%   #safer way to remove text line in muniID
  mutate(state = substr(muniID, 1, 2)) %>%     #extract the muniID
  mutate_at(vars("2001":"2018"), as.numeric) %>%  #convert values to numeric
  dplyr::select(-Municipality)   #drop unwanted columns

maize_prod_Astates <- maize_prod_Amunis %>%
  group_by(state) %>%
  summarise_all(sum, na.rm=T) %>%    #summarise munis to states
  mutate(state=replace(state, 1:length(Astate_codes$stateid), Astate_codes$state)) #re-label stated ids with state abbrevs

maize_prod_Astates_long <- maize_prod_Astates %>%
  gather(key = year, value = maize_kg, -state, -muniID) %>%
  mutate_at(vars(year), as.integer) %>%
  mutate(Maize = maize_kg * 0.001) %>%  #convert from tons to gg
  dplyr::select(-maize_kg, -muniID)

##SOY
soy_prod_Amunis <- soy_prod_Amunis_Data %>%
  rename(muniID = `IBGE CODE`) %>%
  filter(!is.na(muniID)) %>%   #safer way to remove text line in muniID
  mutate(state = substr(muniID, 1, 2)) %>%     #extract the muniID
  mutate_at(vars("2001":"2018"), as.numeric) %>%  #convert values to numeric
  dplyr::select(-Municipality)   #drop unwanted columns

soy_prod_Astates <- soy_prod_Amunis %>%
  group_by(state) %>%
  summarise_all(sum, na.rm=T) %>%    #summarise munis to states
  mutate(state=replace(state, 1:length(Astate_codes$stateid), Astate_codes$state)) #re-label stated ids with state abbrevs

soy_prod_Astates_long <- soy_prod_Astates %>%
  gather(key = year, value = soy_kg, -state, -muniID) %>%
  mutate_at(vars(year), as.integer) %>%
  mutate(Soy = soy_kg * 0.001) %>%  #convert from tons to gg
  dplyr::select(-soy_kg, -muniID)

prod_state_year <- left_join(Meat_prod_Astates_long, maize_prod_Astates_long, by = c("year", "state"))

prod_state_year <- left_join(prod_state_year, soy_prod_Astates_long, by = c("year", "state"))

#add focal states indicator
prod_state_year <- prod_state_year %>%
  mutate(simulated = state %in% Fstate_abbrev)

psy_long <- prod_state_year %>%
  gather(key = Commodity, value = gg, -state, -year, -simulated)

psimy_long <- psy_long %>%
  group_by(simulated, year, Commodity) %>%
  summarise(value_gg = sum(gg, na.rm=T)) %>%
  filter(simulated == TRUE) %>%
  mutate(Source = "Obs", Measure = "Production") %>%
  ungroup() %>%
  dplyr::select(-simulated)

######
#old observed
#######

#read Demand_Empirical.csv here and join to mod_serv...

# mod_demand_dat <- read_csv(paste0("Data/",scenario,"/Demand_Empirical.csv"))
#
# mod_demand<- mod_demand_dat %>%
#   dplyr::select(Year, Soy, Maize, Pasture) %>%
#   gather(key = Commodity, value = value, -Year) %>%
#   mutate(value_gg = if_else(Commodity == "Soy", value * 30,
#     if_else(Commodity == "Maize", value * 20, value * 1.9)
#   )) %>%
#   mutate(Source = "Mod", Measure = "Demand") %>%
#   rename(year = Year) %>%
#   dplyr::select(year, Measure, value_gg, Commodity, Source)

 odata <- read_csv(paste0(data_dir,"Production_Export_Internal.csv"))

 obs_data <- odata %>%
   filter(Year > 2000) %>%
   dplyr::select(-ends_with("export_China_gg")) %>%
   rename(year = Year)
#
# Dairy_long <- obs_data %>%
#   dplyr::select(year, starts_with("Dairy")) %>%
#   gather(key = Measure, value = value_gg, -year) %>%
#   mutate(Commodity = "Dairy") %>%
#   mutate(Measure =
#       if_else(grepl("Production", Measure), "Production",
#         if_else(grepl("Export", Measure), "Export", "Internal")
#         )
#     )
#
Maize_long <- obs_data %>%
  dplyr::select(year, starts_with("Maize")) %>%
  gather(key = Measure, value = value_gg, -year) %>%
  mutate(Commodity = "Maize") %>%
  mutate(Measure =
      if_else(grepl("Production", Measure), "Production",
        if_else(grepl("Export", Measure), "Export", "Internal")
        )
    )

Meat_long <- obs_data %>%
  dplyr::select(year, starts_with("Meat")) %>%
  gather(key = Measure, value = value_gg, -year) %>%
  mutate(Commodity = "Meat") %>%
  mutate(Measure =
      if_else(grepl("Production", Measure), "Production",
        if_else(grepl("Export", Measure), "Export", "Internal")
        )
    )

Soy_long <- obs_data %>%
  dplyr::select(year, starts_with("Soy")) %>%
  gather(key = Measure, value = value_gg, -year) %>%
  mutate(Commodity = "Soy") %>%
  mutate(Measure =
      if_else(grepl("Production", Measure), "Production",
        if_else(grepl("Export", Measure), "Export", "Internal")
        )
    )

obs_long <- bind_rows(Maize_long, Soy_long, Meat_long) %>%
   mutate(Source = "Obs")

all_dat <- bind_rows(mod_serv, psimy_long) %>%
   mutate(Source = factor(Source), Measure = factor(Measure), Commodity = factor(Commodity))

summary(all_dat)

######

all_dat <- bind_rows(mod_serv, psimy_long) %>%
   mutate(Source = factor(Source), Commodity = factor(Commodity))

summary(all_dat)

######
#output
######

cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#0072B2", "#D55E00", "#CC79A7", "#F0E442")

if(pdfprint) {
  pdf(file = output_name)
}

c <- mod_dat %>%
  filter(Measure == "Sum") %>%
  ggplot(aes(x = year, y = value, color = service)) +
      geom_line(size=1) +
      scale_y_continuous(name = "CRAFTY units", labels = scales::comma) +
      ggtitle("Sum Service")
print(c)

# a <- all_dat %>%
#   filter(Commodity == "Soy") %>%
#   ggplot(aes(x=year, y=value_gg, color=Measure, linetype=Source)) +
#   geom_line() +
#   scale_colour_manual(values=cbPalette) +
#   ylab("Value (gg)") +
#   xlab("Year") +
#   ggtitle("Soy")
# print(a)

agriplot <- all_dat %>%
  #filter(Commodity != "Meat") %>%
  ggplot(aes(x=year, y=value_gg, color=Commodity, linetype=Source)) +
  geom_line(size=1) +
  scale_color_viridis_d(begin=0, end=0.75) +
  scale_y_continuous(name = "Production (Gg)", labels = scales::comma) +
  #scale_colour_manual(values=cbPalette) +
  #ylab("Production (gg)") +
  xlab("Year") +
  guides(color = guide_legend(order = 1),
        linetype = guide_legend(order = 2))

  #ggtitle("Soy")
print(agriplot)

agriplot <- all_dat %>%
  filter(Commodity != "Meat") %>%
  ggplot(aes(x=year, y=value_gg, color=Commodity, linetype=Source)) +
  geom_line(size=1) +
  #scale_colour_manual(values=cbPalette) +
  ylab("Value (Gg)") +
  xlab("Year")
  #ggtitle("Soy")
print(agriplot)

# a <- all_dat %>%
#   filter(Commodity == "Maize") %>%
#   ggplot(aes(x=year, y=value_gg, color=Measure, linetype=Source)) +
#   geom_line() +
#   scale_colour_manual(values=cbPalette) +
#   ylab("Value (gg)") +
#   xlab("Year") +
#   ggtitle("Maize")
# print(a)

Meatplot <- all_dat %>%
  filter(Commodity == "Meat") %>%
  ggplot(aes(x=year, y=value_gg, linetype=Source)) +
  geom_line(size=1) +
  scale_colour_manual(values=cbPalette) +
  scale_y_continuous(limits = c(0, 10000), labels = scales::comma) +
  ylab("Value (Gg)") +
  xlab("Year") +
  ggtitle("Meat")
print(Meatplot)

if(pdfprint) {
  dev.off()
}


#' Banded Matrix Constructors
#'
#' Constructors for banded matrices. WARNING: for advanced users only.
#' Use the caster function for conversions.
#'
#' @details
#' See url in the references for an explanation of the storage.
#'
#' @param dim
#' The matrix dimension.
#' @param Data
#' The compact band matrix representation.
#' @param kl,ku
#' The lower and upper bandwidths, respectively.
#'
#' @references \url{http://www.netlib.org/lapack/lug/node124.html}
#' @seealso \code{\link{as.banded}} and \code{\link{as.matrix}}
#' @name constructors
#' @rdname constructors
NULL

#' @rdname constructors
#' @export
zeromat <- function(dim)
{
  new("ZeroMat", dim=dim)
}

#' @rdname constructors
#' @export
diagmat <- function(Data, dim)
{
  new("DiagMat", Data=Data, dim=dim)
}

#' @param triangle
#' "u" or "l" for upper or lower, as in \code{as.symmetric()}.
#' @rdname constructors
#' @export
symmat <- function(Data, dim, triangle)
{
  new("SymMat", Data=Data, dim=dim, triangle=triangle)
}

#' @rdname constructors
#' @export
genbandmat <- function(Data, dim, kl, ku)
{
  new("GenBandMat", Data=Data, dim=dim, kl=kl, ku=ku)
}