#! /usr/local/bin/RScript

library(data.table)
library(ggplot2)
library(ggthemes)
library(ggmap)

# Set working directories
setwd("~/bu/Desktop/MCMonitor")
figures.dir = "~/bu/Desktop/MCMonitor/Plots/"

# Read data
nodes.dd = data.table(read.delim("./Plots_data/hubway_plot_nodes_5.csv.gz",
                          sep=","))
edges.dd = data.table(read.delim("./Plots_data/hubway_plot_edges.csv.gz",
                          sep=","))

# Plot important stations onto map
# p1 = qmplot(lng, lat, data=nodes.dd, maptype = "toner-lite", color = I("red"), size=I(1), xlab="", ylab="", zoom=14, extent="panel")
# p1 = p1 + theme_bw()
# p1 = p1 + theme(strip.background = element_blank(),
#                 axis.text.x = element_blank(),
#                 axis.text.y = element_blank(),
#                 axis.ticks.x = element_blank(),
#                 axis.ticks.y = element_blank(),
#                 plot.margin = unit(c(0.5,0.5,0,0), "cm"))
# p1
# ggsave(paste0(figures.dir, "hubway_stations.pdf"), w=8, h=4, units="cm")

p = get_map(location = c(-71.13, 42.340, -71.05, 42.365), source = "google", zoom = 14, maptype="toner-lite")
p = ggmap(p)
p = p + geom_point(data=nodes.dd, aes(x=lng, y=lat), color="red", size=I(1))
p = p + theme_bw()
p = p + theme(strip.background = element_blank(),
              axis.title.x = element_blank(),
              axis.title.y = element_blank(),
              axis.text.x = element_blank(),
              axis.text.y = element_blank(),
              axis.ticks.x = element_blank(),
              axis.ticks.y = element_blank(),
              plot.margin = unit(c(0.5,0.5,0,0), "cm"))
p
ggsave(paste0(figures.dir, "hubway_stations_5.pdf"), w=8, h=4, units="cm")

# Plot important paths onto map

p2 = qmplot(lng, lat, data=edges.dd, maptype = "toner-lite", color=node_type, size=I(1), xlab="", ylab="")
p2 = p2 + geom_path(data=edges.dd, aes(x=lng, y=lat, group=edge_id), color="black", size=I(0.5))
p2 = p2 + labs(color="Node Type")
p2 = p2 + theme_bw()
p2 = p2 + theme(strip.background = element_blank(),
                axis.text.x = element_blank(),
                axis.text.y = element_blank(),
                legend.position = c(0.10,0.15),
                legend.text = element_text(size=3),
                legend.background = element_blank(),
                legend.key = element_blank(),
                legend.key.size = unit(0.32, "cm"),
                legend.title = element_blank())
p2
ggsave(paste0(figures.dir, "hubway_paths.pdf"), w=9, h=4.5, units="cm")


# Extract the neighborhood census of a forum
# and plot its evolution
# author: Alberto Lumbreras
#################################################
library(dplyr)
library(reshape2)
library(ggplot2)
source('R/load_participations.r')
source('R/count_motifs.r')
select <- dplyr::select # avoid confusion with MASS function

###################################################
# Load data
###################################################
df.posts <- load_posts(database='reddit', forum='podemos')
df.threads <- plyr::count(df.posts, "thread")
df.users <- plyr::count(df.posts, 'user')
names(df.threads)[2] <- "length"
names(df.users)[2] <- "posts"

######################################################
# Extract neighborhood around every post
######################################################
res <- count_motifs_by_post(df.threads$thread, database='reddit')
df.post.motif  <- res$posts.motifs
motifs <- res$motifs

# Sort by frequency
idx <- order(table(df.post.motif$motif), decreasing = TRUE)
motifs <- motifs[idx]
df.post.motif$motif <- match(df.post.motif$motif, idx)

df.posts <- merge(df.posts, df.post.motif, all.x=TRUE, sort=FALSE)

####################################################
# Plot neighborhoods by frequency
####################################################
mypalette <- c("black", "red", "white")
par(mfrow=c(3,5))
for(i in 1:length(motifs)){
  gmotif <- as.undirected(motifs[[i]])
  la = layout_as_tree(gmotif, mode='out', root=which.min(V(gmotif)$date))
  plot(gmotif,
       layout = la,
       vertex.color=mypalette[V(motifs[[i]])$color],
       vertex.label = "",
       edge.arrow.size=0.6)
  title(paste(i),sub=sum(df.post.motif$motif==i))
}

################################################
# Plot cumsum with sliding window
# Note: lay with both times, real and sequential
################################################
df.census <- arrange(df.posts, date) %>%
             acast(date~motif) %>%
             as.data.frame

# chronological dates
df.census$date <- rownames(df.census)

# sequential dates
df.census$date <- 1:nrow(df.census)

steps <- seq(min(as.numeric(df.census$date)),
         max(as.numeric(df.census$date)),
         by=3600)

df.census.window <- vector()
for(i in 1:(length(steps)-1)){
  df.census.window <- filter(df.census, date>steps[i] & date<steps[i+1]) %>%
                      select(-date) %>%
                      colSums %>%
                      rbind(df.census.window, .)
                      #rbind(df.census.window) # TODO rbind(df.census.window, .) ?
}

df.census.window <- as.data.frame(df.census.window)
df.census.window$date <- head(steps,-1)
df.census.window <- melt(df.census.window, id.vars=c("date"))

df.census.window$date <- as.POSIXct(df.census.window$date, origin="1970-01-01")

# Plot absolute values to view general trend, periodicity...
ggplot(df.census.window, aes(x=date, y=value, group=variable, color=variable, fill=variable)) +
  geom_line()

# Plot evolution of census (%) with total number of posts
ggplot(df.census.window, aes(x=date, y=value)) +
  geom_bar(aes(group=variable, color=variable, fill=variable),
           position = 'fill', stat='identity') +
  stat_summary(fun.y=function(x){sum(x)/200}, color = 'black', geom ='line')

#########################################################
# Plot relationship between length and census
#########################################################

# Compute rank of every post in its thread
# compute cumsum per group (per thread)

df.census <- arrange(df.posts, thread, date) %>%
             dcast(thread+date~motif)

df.census.length <- vector()
ranks <- vector()
for(i in 1:nrow(df.census)){
  cat('\n', i)
  ranks <- c(ranks, sum(df.census[1:i, c('thread')]==df.census$thread[i])) # store also rank of post in thread
  df.census.length <- filter(df.census[1:i,], thread==df.census$thread[i]) %>%
                      select(-thread, -date) %>%
                      colSums %>%
                      rbind(df.census.length, .) %>%
                      as.data.frame
}
#df.census.length <- df.census.length.bck
df.census.length$rank <- ranks
df.census.length$date <- df.census$date
df.census.length$thread <- df.census$thread

# Select a subsample of threads to plot
# ... at random
sample.threads <-  sample(unique(df.census.length$thread), 10)

# by length
sample.threads <- filter(df.threads, length>100) %>% select(thread)
sample.threads <- sample.threads$thread

df.census.length.sample <- filter(df.census.length, thread %in% sample.threads)
df.census.length.sample <- melt(df.census.length.sample, id.vars=c('date', 'rank', 'thread'))

ggplot(filter(df.census.length.sample, variable==1), aes(x=rank, y=value, group=thread, color=thread)) + geom_line()

p <- ggplot(filter(df.census.length.sample, variable %in% c(1,2,3,4,5,6,7,8)), aes(x=rank, y=value, group=thread, color=thread)) + geom_line()
#p + facet_grid(~ variable)
p + facet_wrap(~ variable, ncol=4, nrow=4)

################################################
# Can we predict length based on first census
################################################

# merge census matrix with thread length


################################################################################################
# Dependencies
#source("Code/get_dynamic_data.r")

GetLabData <- function(raw.data.name="train") {

	# For a specified dataset in the original contest format, returns
	# a dataset containing only lab information.
	#
	# Args:
	# 	raw.data.name: name of dataset
	#
	# Returns:
	#	A list.  The first element is a list of datasets that correspond to lab tests. The columns
	#   in each dataset consist of subject.id, test delta and test result.
	#	The second element is a vector of column names corresponding to the test result column of
	#	each dataset.
	#
	# Example usage:
	#	#source("Code/get_lab_data.R")
	#	lab.data<-GetLabData("train")

	# Check if RDA version of lab data has been stored
	rda.filename = paste("Data/lab_",raw.data.name,".rda",sep="")
	if (file.exists(rda.filename)) {
		print(paste("loading saved lab data from",rda.filename,sep=" "))
		load(rda.filename)
		print("finished loading")
		return(lab.data)
	}

	# Get raw data
	 data<-GetRawData(raw.data.name)

	# Keep only lab data
	 data <- data[data$form == "Laboratory Data", ]

	# Get list of all tests
	# test.names<-unique(data$value[data$field=="Test Name"])

	# Count the number of subjects there is data for for each test
	# NumTestSubs(test.names)

	# List of all tests with at least 709 subject ids (30)
	# test.names<-c("Bicarbonate", " HbA1c (Glycated Hemoglobin)", "Red Blood Cells (RBC)","White Blood Cells (WBC)","Creatine Kinase","Chloride","Triglycerides","Glucose", "Total Cholesterol", "Albumin", "Sodium", "Hemoglobin", "Calcium", "Monocytes", "Lymphocytes", "Hematocrit","Neutrophils","Alkaline Phosphatase","Gamma-glutamyltransferase","Protein","Eosinophils","AST(SGOT)","Basophils","Phosphorus","Creatinine","Potassium","Bilirubin (total)", "Platelets","ALT(SGPT)", "Urine Ph")

	# List of all tests with at least 709 subject ids for which there are conversions (21)
	test.names<-c("Bicarbonate", "HbA1c (Glycated Hemoglobin)","Red Blood Cells (RBC)","Creatine Kinase","Chloride","Triglycerides","Glucose", "Total Cholesterol","Sodium", "Hemoglobin", "Calcium","Hematocrit","Alkaline Phosphatase","Gamma-glutamyltransferase","AST(SGOT)","Phosphorus","Creatinine","Potassium","Bilirubin (total)","ALT(SGPT)","Urine Ph")

	# List of corresponding test names
	col.names<-c("Bicarbonate","HbA","RBC","Creatine.Kinase","Chloride","Triglycerides","Glucose","Cholesterol","Sodium","Hemoglobin","Calcium","Hematocrit","Alk.Phos","Gamma.Glutamyl","AST(SGOT)","Phosphorus","Creatinine","Potassium","Bilirubin","ALT(SGPT)","Urine.Ph")

	# Get data corresponding to each test name and put it in a list
	data.list<-lapply(test.names,TestToData,data=data)

	# Rename list elements
	names(data.list)<-test.names

	#lapply(data.list,TestUnitsUsed) # what units does each test show?

	# Get a list of conversion factors for each test in test.names
	convert.list<-GetConvertList(test.names)

	# Get a list of new datasets with converted units and only key columns
	lab.data<-lapply(1:length(data.list),ConvertTestUnits,test.data=data.list,
    conversions=convert.list,col.names=col.names)

	# Name each dataset
	names(lab.data)<-col.names[1:length(data.list)]

  # Create outlier filter if filter does not exist
  num.sd<-4
  filter.filename<-paste("Data/lab_filter",num.sd,"sd.rda",sep="_")
	if (file.exists(filter.filename)) {
	  print(paste("loading saved lab filter from",filter.filename,sep=" "))
	  load(filter.filename)
	}
  else {
    lab.filter<-lapply(lab.data,LabOutlierFilter,num.sd=num.sd)
    save(lab.filter,file=filter.filename)
  }

  # Discard outliers
  lab.data<-mapply(LabDiscardOutlier,test.data=lab.data,filter=lab.filter,
    SIMPLIFY=FALSE)

	# Save dataset to file
	save(lab.data, file = rda.filename)
	return(lab.data)
}

LabOutlierFilter<-function(test.data,num.sd) {
# Creates an outlier filter for a given dataset based on standard deviations
  test.mean<-mean(test.data[,3])
  test.sd<-sd(test.data[,3])
  filter.max<-test.mean+num.sd*test.sd
  filter.min<-test.mean-num.sd*test.sd
  return(c(filter.max,filter.min))
}

LabDiscardOutlier<-function(test.data,filter) {
# Discards outliers in dataset
  test.data<-test.data[(test.data[,3]<filter[1]&test.data[,3]>filter[2]),]
  return(test.data)
}

TestToData<-function(test.name,data) {
	# Given full data, returns a dataset containing only observations corresponding to a
	# particular test
	#
	# Args:
	#	test.name: name of test of interest
	#	data: dataset containing only the form of interest
	#
	# Returns:
	#	A dataset that contains only observations for the test specified in test.name, containing
	#	the columns subject.id, lab.delta, test.name, test.result, and test.unit

	# Fields
	fields<-c("Laboratory Delta","Test Name","Test Result","Test Unit")

	# Columns
	columns<-c("lab.delta","test.name","test.result","test.unit")

	# Get record ids for one test
	test.record<-data$record.id[data$value==test.name]

	# Get all data that matches those record ids
	test.data<-data[data$record.id %in% test.record,]

	# Get dynamic data
	test.data<-GetDynamicData(test.data,fields,columns)

	# Coerce test result to numeric and drop NAs
	# Sometimes test result includes strange entries: eg, one entry of "A" in glucose
	test.data$test.result<-as.numeric(test.data$test.result)
	test.data<-test.data[!is.na(test.data$test.result),]

	return(test.data)
}

ConvertTestUnits<-function(i,test.data,conversions,col.names) {
	# Given a test dataset, returns that dataset with test.results converted to
  # consistent units
	#
	# Args:
	#	i: the index of the dataset in the dataset list
	#	test.data: a list of test datasets
	#	conversions: a list of conversion tables
	#
	# Returns:
	#	A test dataset where test.results are converted to consistent units.
  # Columns are: subject.id, a delta column named with the test name,
  # and test.results.  In addition, missing values and duplicate deltas are
  # dropped, and the dataset is sorted by subject.id and then delta.

	# Get name of test
	name<-col.names[i]
	print(name)

	if (length(conversions[[i]])>1) {
		 # Drop all test results that do not have units found in the
		 # conversion list
		test.data[[i]]<-test.data[[i]][test.data[[i]]$test.unit %in%
		    names(conversions[[i]]),]

		# Replace old result by multiplying by conversion factor from table
		test.data[[i]]$test.result<-
			unlist(conversions[[i]][test.data[[i]]$test.unit])*
      test.data[[i]]$test.result
	}

	# Drop test name and test units
	test.data[[i]]<-test.data[[i]][,!(colnames(test.data[[i]]) %in%
    c("test.name","test.unit"))]

	# Sort by subject id and delta
	test.data[[i]]<-test.data[[i]][order(test.data[[i]]$subject.id,
    test.data[[i]]$lab.delta),]

	# Remove records with missing lab.delta, test.result, or subject.id
	test.data[[i]] <- test.data[[i]][!is.na(test.data[[i]]$lab.delta)&
    !is.na(test.data[[i]]$test.result)&
    !is.na(test.data[[i]]$subject.id),]

	# Check for duplicate deltas and delete those rows
	# Create combination of subject.ids and deltas
	id<-paste(as.integer(test.data[[i]]$subject.id),
	          as.integer(test.data[[i]]$lab.delta),sep=".")

	# Check for duplicates in id
	dup<-duplicated(id)

	# Keep only nonduplicates - throws away second record with same delta
	test.data[[i]]<-test.data[[i]][!dup,]

	# Rename test.result column
	colnames(test.data[[i]])[colnames(test.data[[i]])=="test.result"]<-name

	# Rename delta column
	colnames(test.data[[i]])[colnames(test.data[[i]])=="lab.delta"]<-
		paste(name,"delta",sep=".")

	return(test.data[[i]])
}

GetConvertList<-function(test.names) {
	# Given a vector of test names, returns a list of conversion tables for only
  # those tests
	#
	# Args:
	#	test.names: a vector of test names of interest
	#
	# Returns:
	#	A list of conversion tables

	# Create full list of conversions
	convert.list<-list(
		Bicarbonate=list("mmol/l"=1),
		`HbA1c (Glycated Hemoglobin)` = list("%"=1, "V/V"=100),
		'Red Blood Cells (RBC)' = list("10E12/L"=1,"per mm3"=1E-6,"10E6/mm3"=1,"10E9/L"=1E-3),
		#'White Blood Cells (WBC)' = list("10E9/L"=1,"per mm3"=1E-4,"g/L"=,"10E3/mm3"=100), g/L?
		'Creatine Kinase' = list("IU/L"=1,"U/L"=1,"mIU/L"=1), # the mIU/L seem like already on same order of magnitude
		Chloride=list("mmol/l"=1),
		Triglycerides=list("mmol/l"=1,"g/L"=1.13),
		Glucose=list("mmol/l"=1,"g/L"=5.55),
		'Total Cholesterol'=list("mmol/l"=1,"g/L"=2.58),
		#Albumin=list("g/l"=1,"%"=?), #% of what? blood serum protein?
		Sodium=list("mmol/l"=1),
		Hemoglobin=list("g/l"=1,"mmol/L"=1/.06206,"mg/L"=.001),
		Calcium=list("mmol/l"=1,"mg/L"=.025,"mEq/L"=0.5),
		# Monocytes=list("%"=,"10E9/L"=,"per mm3"=,"g/L"=), need WBC count to convert %
		# Lymphocytes=list("%"=,"10E9/L"=,"per mm3"=,"g/L"=), need WBC count to convert %
		Hematocrit=list("%"=1,"V/V"=100,"1"=100),
		# Neutrophils=list("%"=,"10E9/L"=,"per mm3"=,"g/L"=), need WBC count to convert %
		'Alkaline Phosphatase'=list("U/L"=1,"IU/L"=1),
		'Gamma-glutamyltransferase'=list("U/L"=1,"IU/L"=1),
		# Protein=list("g/L"=1,"g/dL"=.1,"G/L"=1,"mEq/L"=), how to convert mEq/L?
		# Eosinophils=list("%"=,"10E9/L"=,"per mm3"=,"g/L"=,"10E3/mm3"), need count to convert
		'AST(SGOT)'=list("u/l"=1,"iu/l"=1),
		# Basophils=list("%"=,"10E9/L"=,"per mm3"=,"g/L"=,"10E3/mm3"), need count to convert %
		Phosphorus=list("mmol/l"=1,"mg/L"=.0323),
		Creatinine=list("umol/l"=1,"mg/L"=8.84),
		Potassium=list("mmol/l"=1),
		'Bilirubin (total)'=list("umol/l"=1,"mg/L"=1.71),
		#Platelets=list("10E9/L"=,"per mm3"=,"g/L"=,"10E3/mm3"=), g/L?
		'ALT(SGPT)'=list("u/l"=1,"iu/l"=1),
		'Urine Ph'=list("pH"=1)
	)
	# Keep only those elements that are in test.names
	return(convert.list[test.names])
}

TestUnitsUsed<-function(data) {
	data<-as.data.frame(data)
	return(unique(data$test.unit))
}

NumTestSubs<-function(test.names) {
	n.test<-length(test.names)
	# create matrix to hold test names and how many subjects they have data for
	 num.test.subjects<-	data.frame(test.names=test.names,subjects=rep(-99,length(test.names)),stringsAsFactors=FALSE)
	# Count the number of subjects per test
	 for (i in 1:n.test) {
		num.test.subjects[i,2]<-length(unique(data$subject.id[data$value==test.names[i]]))
	}
	num.test.subjects<-num.test.subjects[order(num.test.subjects$subjects),]
	plot(num.test.subjects$subjects)
	return(num.test.subjects)
}


# Functions to take a gene signature output from featurecounts
# And a create 1) a DESEQ object
# and 2) a TPM table

#imports
library(DESeq2)
library(tidyverse)

make_genesig_from_file <- function (file_loc, ...) {
    # extra arguments should contain mappings for changing names
    # will likely only work for featureCounts output
    genesig_df <- read.csv(file_loc, header=T, sep="\t", comment="#")
    genesig_df <- rename(genesig_df, ...)[complete.cases(gene_sig),] #only things with everything

    # drop unused columns
    # still hang onto length, because we can use it in TPM calculations
    # but that would need to be dropped before DESeq
    return(select(genesig_df, -Chr, -Start, -End, -Strand))
}

# should end with a mapping of conditions that matches the order of the column names
make_meta_data <- function(genesig_df, ...) {
    # Gets column names from  genesig_df
    # Drops geneid and length
    sample_names <- colnames(genesig_df[-(1:2)])

    return(data.frame(id=sample_names, ...))
}

make_DESeq_object <- function(genesig_df, meta_data, design) {
    genesig_df <- select(genesig_df, -Length)

    dds <- DESeqDataSetFromMatrix(countData=genesig_df,
                                colData=meta_data,
                                design=design,
                                tidy=T)
    return(DESeq(dds))
}

make_results_table <- function(DESeq_object, contrast_vector) {
    # contrast should be in the form of c(column_name, perturbation, control)
    res <- results(DESeq_object, contrast=contrast_vector)

    return(res[order(res$padj),])
}

calculate_tpm <- function(genesig_df) {
        counts <- genesig_df[-(1:2)]
        counts <- counts/(genesig_df$Length/1000) # normalize by kilobase length

        sum_columns = colSums(counts)
        for (i in (1:length(counts))) { # normalize to per million reads
            counts[i] <- (counts[i] / sum_columns[i]) * 1000000
        }
        return(cbind(genesig_df[1:2], counts))
}


library(qdapTools)
library(tidyverse)
library(dplyr)

###############################################
#### D A T A    P R E P    F U N C T I O N ####
###############################################

# Function to generate data files for for analysis
data_prep <- function(df) {

  # create dependent variable y
  df <- df %>% mutate(y = ifelse(hit_module == 'long_cpu_hog_Prod126' &
                                   hit_severity >= 2, 1, 0))

  # Sort by device_id and hit_date - make y an integer
  df <- arrange(df, device_id, hit_date)
  df$y <- as.numeric(df$y)

  # Reduce table to salient features
  df <- df %>%
    select(hit_date, device_id, hit_module, hit_severity, y)

  # Filter on Issue with memory or cpu
  df <- df %>%
    filter(str_detect(hit_module, 'memory|cpu'))

  # Merge all hits with same timestamp into one event
  df1 <- df #%>%
    #group_by(hit_date,device_id,hit_severity,y) %>%
    #summarise(hit_module=paste(hit_module, collapse = ":"))

  glimpse(df1)

  xy <- mtabulate(strsplit(df1$hit_module, ':'))

  glimpse(xy)

  #Make sure all Integers are 1
  xy <- xy %>%
    mutate_if(~is.integer(.) && any(. > 0, na.rm = TRUE),
              ~ if_else(.x>0,1L,.x))

  #Removing labels/features with less than 500 hits
  xy <- xy[, colSums(xy) > 500]

  glimpse(xy)

  # Adding back in severity and dependent variable
  xy <- xy %>% add_column(df1$hit_severity) %>%
    add_column(df1$y)

  # renaming column names
  xy <- xy %>% rename(hit_severity = 'df1$hit_severity',
                      y = 'df1$y')

  #Removing 00000 rows
  zero_rows <- xy %>% select(-hit_severity) %>%
    rowSums() > 0
  xy <- xy %>%
    filter(zero_rows)

  # Remove hit_severity=0
  #xy <- xy  %>% filter(hit_severity!=0)

  xy <- xy %>%
    select(y, everything()) # %>% # move the Y variable to the "front"
  #rename_at(vars(2:ncol(.)), ~ paste("X", 1:length(.), sep = ""))

  glimpse(xy)

  return(xy)
}

###################################
####  M A I N   P R O G R A M  ####
###################################

# Import all hits of all devices with dependent issue

rm(list=ls())

setwd("D:/nils/projects/dissertation")
dependent_issue <- 'long_cpu_hog_prod126'

file_in <- paste('./', dependent_issue, '.csv', sep = '')
file_out_train <- './dataset_exp3_train.csv'
file_out_test <- './dataset_exp3_test.csv'

# Reading CSV file in
df0 <- read_csv(file_in)

cu_count <- df0 %>% count(cu_id, sort = TRUE)
cu_count

# Select train cu events #s
df_train <- df0 %>% filter(cu_id == 11 |
                             cu_id == 4 |
                             cu_id == 15 |
                             cu_id == 10 |
                             cu_id == 14)

# Select test cu events #s
df_test <- df0 %>% filter(cu_id == 17 |
                          cu_id == 1 |
                            cu_id == 7 |
                            cu_id == 21 |
                            cu_id == 12)

df_test <- data_prep(df_test)
df_train <- data_prep(df_train)

in_both = intersect(colnames(df_train), colnames(df_test))
df_train <- df_train[,in_both]
df_test <- df_test[,in_both]
all_equal(df_train, df_test, ignore_row_order = TRUE)

write_csv(df_train, file_out_train)
write_csv(df_test, file_out_test)
df_train
df_test


#!/usr/bin/env Rscript
#
# Using the methods described in the tutorial
#

library(data.table)
library(WGCNA)

options(stringsAsFactors=FALSE)

argv = commandArgs(trailingOnly=TRUE)

geno_file = argv[1]
ld_var_file = argv[2]
block_size = as.numeric(argv[3])
n_threads = as.numeric(argv[4])

enableWGCNAThreads(n_threads)

# Get list of variants
vars_to_use = scan(ld_var_file, what='character')

# Read in genotype data
geno_data = fread(geno_file, header=TRUE)

# Remove unwanted variants
geno_data = geno_data[geno_data$rs %in% vars_to_use, ]

# Transform into WGCNA format
geno_mat = t(geno_data[, -(1:3)])

# Check for excessive missing data and remove samples and variants
# if necessary
gsg = goodSamplesGenes(geno_mat, verbose=3)
cat('No missing data issues?', gsg$allOK, '\n')
if(!gsg$allOK) {
    # Optionally, print the gene and sample names that were removed:
    if (sum(!gsg$goodGenes)>0)
        printFlush(paste('Removing genes:', paste(names(geno_mat)[!gsg$goodGenes], collapse=', ')))
    if (sum(!gsg$goodSamples)>0)
        printFlush(paste('Removing samples:', paste(rownames(geno_mat)[!gsg$goodSamples], collapse=', ')))
    # Remove the offending genes and samples from the data:
    geno_mat = geno_mat[gsg$goodSamples, gsg$goodGenes]
}

# Make a sample dendrogram (the tutorial uses this step to
# check for outliers)
sample_dendro = hclust(dist(geno_mat), method='average')
pdf(file='sample_dendrogram.pdf', width=12, height=9)
par(cex=0.6)
par(mar=c(0,4,2,0))
plot(sample_dendro, main='Sample clustering to detect outliers',
     sub='', xlab='', cex.lab=1.5, cex.axis=1.5, cex.main=2)
dev.off()

# Run the threshold picking function
powers = c(1:10, seq(12, 20, 2))
sft = pickSoftThreshold(geno_mat, powerVector=powers,
                        verbose=5, blockSize=block_size)

# And make the plots
pdf('soft_threshold_plots.pdf', width=9, height=5)
par(mfrow=c(1,2))
cex1 = 0.9
plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
     xlab='Soft Threshold (power)',
     ylab='Scale Free Topology Model Fit,signed R^2',
     type='n',
     main = paste('Scale independence'))
text(sft$fitIndices[,1],
     -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
     labels=powers,
     cex=cex1, col='red')
abline(h=0.90, col='red')
plot(sft$fitIndices[,1], sft$fitIndices[,5],
     xlab='Soft Threshold (power)',
     ylab='Mean Connectivity', type='n',
     main = paste('Mean connectivity'))
text(sft$fitIndices[,1], sft$fitIndices[,5], labels=powers, cex=cex1,col='red')
dev.off()


#!/usr/bin/env Rscript

# Author: Jesse McNichol <mcnichol@alum.mit.edu>

invisible(library(oce))

args = commandArgs(trailingOnly = TRUE)
file.name = args[1]

d <- read.csv(file.name)

tmp <- split(d, d$latitude)
names(tmp) <- paste0('stn', seq_along(tmp))

#Import the stations as a CTD object
stns <- lapply(tmp, function(x) {
  o <- order(x$depth) # the depths are not always in order
  ctd <-
    as.ctd(
      x$salinity[o],
      x$temperature[o],
      swPressure(x$depth[o]),
      longitude = x$longitude,
      latitude = x$latitude
    )
  ctd <- oceSetData(ctd, 'depth', x$depth[o])
  ctd <-
    oceSetData(ctd, 'eASV_Relative_Abundance', x$Relative_Abundance[o])
})

sec <- as.section(stns) #Create a section from the CTD data
sg <-
  sectionGrid(sec, p = seq(20, 200, 5)) #For better interpolation (though be cautious with these plots!)

basename <-
  sapply(strsplit(file.name, split = '.', fixed = TRUE), function(x)
    (x[1]))
outname <- paste0(basename, 'eASV-plot-%02d.png')
invisible(png(
  outname,
  width = 7,
  height = 7,
  res = 300,
  units = 'in'
))

abun <-
  unlist(lapply(stns, function(x)
    x[['eASV_Relative_Abundance']]))

#plot(sec, showstations=TRUE, ztype="contour", showBottom=FALSE)

###Dot plot with interpolated temperature up top, only colour proportional to the abundance
par(mfrow = c(2, 1))
plot(
  sg,
  which = 'temperature',
  xtype = "latitude",
  showstations = TRUE,
  showBottom = FALSE,
  ztype = 'image',
  zcol = oceColorsTemperature,
  cex = 2,
  pch = 16
)
cm <- colormap(abun, col = oceColorsViridis)
#drawPalette(colormap=cm)
plot(
  sec,
  which = 'eASV_Relative_Abundance',
  xtype = "latitude",
  showstations = TRUE,
  grid = TRUE,
  showBottom = FALSE,
  ztype = 'points',
  zcol = oceColorsViridis,
  cex = 2,
  pch = 16
)

#Change up the sizes
#cex <- max(log10(abun))/log10(abun) #Normalized sizes
cex <- abun / max(abun) #Normalized sizes

###T-S diagram
par(mfrow = c(1, 1))
cm <- colormap(abun, col = oceColorsViridis)
drawPalette(colormap = cm)
plotTS(
  sec,
  pch = 19,
  col = cm$zcol,
  mar = c(3.5, 3.5, 2, 4),
  cex = 3 * cex
)

###Dot plot with interpolated temperature up top, color and the size proportional to the abundance
par(mfrow = c(2, 1))

plot(
  sg,
  which = 'temperature',
  xtype = "latitude",
  showstations = TRUE,
  showBottom = FALSE,
  ztype = 'image',
  zcol = oceColorsTemperature,
  cex = 2,
  pch = 16
)

plot(
  sec,
  which = 'eASV_Relative_Abundance',
  showBottom = FALSE,
  ztype = 'points',
  zcol = oceColorsViridis,
  cex = 0
)

# setup the plot
points(sec[['distance']],
       sec[['pressure']],
       pch = 19,
       cex = 3 * cex,
       col = cm$zcol)

###All interpolated (sketchy!)
par(mfrow = c(2, 1))

plot(
  sg,
  which = 'temperature',
  xtype = "latitude",
  showstations = TRUE,
  showBottom = FALSE,
  ztype = 'image',
  zcol = oceColorsTemperature,
  cex = 2,
  pch = 16
)

plot(
  sg,
  which = 'eASV_Relative_Abundance',
  xtype = "latitude",
  showstations = TRUE,
  grid = TRUE,
  showBottom = FALSE,
  ztype = 'image',
  zcol = oceColorsViridis,
  cex = 2,
  pch = 16
)

invisible(dev.off())

print('Done.')


#' Machine Learning
#'
#' TODO
#'
#' \tabular{ll}{
#'    Package: \tab pbdML \cr
#'    Type: \tab Package \cr
#'    License: \tab BSD 2-clause \cr
#'    LazyLoad: \tab yes \cr
#' }
#'
#' This package requires an MPI library (OpenMPI, MPICH2, or LAM/MPI).
#'
#' @importFrom pbdMPI allreduce comm.stop comm.print comm.cat comm.all
#' @importFrom stats runif
#' @import pbdDMAT
#'
#' @useDynLib pbdML R_check_badvals R_check_groupvar R_one_norm R_shrink_op
#'
#' @name pbdML-package
#' @docType package
#' @author Drew Schmidt \email{schmidt AT math.utk.edu}, George Ostrouchov, and Wei-Chen Chen.
#' @references Programming with Big Data in R Website: \url{http://r-pbd.org/}
#' @keywords Package
NULL


#===============================================================
# Penney's Game Task from Rosetta Code Wiki
# R implementation
#===============================================================

penneysgame <- function() {

  #---------------------------------------------------------------
  # Who goes first?
  #---------------------------------------------------------------

  first <- sample(c("PC", "Human"), 1)

  #---------------------------------------------------------------
  # Determine the sequences
  #---------------------------------------------------------------

  if (first == "PC") { # PC goes first

    pc.seq <- sample(c("H", "T"), 3, replace = TRUE)
    cat(paste("\nI choose first and will win on first seeing", paste(pc.seq, collapse = ""), "in the list of tosses.\n\n"))
    human.seq <- readline("What sequence of three Heads/Tails will you win with: ")
    human.seq <- unlist(strsplit(human.seq, ""))

  } else if (first == "Human") { # Player goest first

    cat(paste("\nYou can choose your winning sequence first.\n\n"))
    human.seq <- readline("What sequence of three Heads/Tails will you win with: ")
    human.seq <- unlist(strsplit(human.seq, "")) # Split the string into characters
    pc.seq <- c(human.seq[2], human.seq[1:2]) # Append second element at the start
    pc.seq[1] <- ifelse(pc.seq[1] == "H", "T", "H") # Switch first element to get the optimal guess
    cat(paste("\nI win on first seeing", paste(pc.seq, collapse = ""), "in the list of tosses.\n"))

  }

  #---------------------------------------------------------------
  # Start throwing the coin
  #---------------------------------------------------------------

  cat("\nThrowing:\n")

  ran.seq <- NULL

  while(TRUE) {

    ran.seq <- c(ran.seq, sample(c("H", "T"), 1)) # Add a new coin throw to the vector of throws

    cat("\n", paste(ran.seq, sep = "", collapse = "")) # Print the sequence thrown so far

    if (length(ran.seq) >= 3 && all(tail(ran.seq, 3) == pc.seq)) {
      cat("\n\nI win!\n")
      break
    }

    if (length(ran.seq) >= 3 && all(tail(ran.seq, 3) == human.seq)) {
      cat("\n\nYou win!\n")
      break
    }

    Sys.sleep(0.5) # Pause for 0.5 seconds

  }
}


#Jenny Smith

#May 8, 2017

#Purpose: Create a PCA, and MDS ordination plots given expression data and genes of interest.

plotPCoA <- function(expnData,phenovector, title="",colorCodes=NULL, geneList=NULL, size=3){
  #expnData is normalized counts, typically log2 scale.

  #factor is the name of the factor column
  suppressPackageStartupMessages(library(vegan))
  suppressPackageStartupMessages(library(ggplot2))
  suppressPackageStartupMessages(library(dplyr))

  #Ensure correct order of patients in both datasets
  expnData <- expnData[ ,intersect(names(phenovector), colnames(expnData))]
  phenovector <- phenovector[intersect(names(phenovector),colnames(expnData))]

  if (! is.null(geneList)){
    expnData <- t(expnData[geneList, ])
  }else{
    expnData <- t(expnData) #note: must remove all zero count genes or will  fail on an error
  }

  PCoA <- capscale(expnData ~ 1, distance = "bray", add=TRUE)
  scores <- data.frame(scores(PCoA, display="sites"),
                       group=phenovector) %>%
            dplyr::arrange(desc(group))

  p <- ggplot(scores, aes(x=MDS1, MDS2)) +
    geom_point(aes(color=scores[,"group"]), size=size, alpha=0.75) +
    theme_numX +
    labs(title=title)

  if(!is.null(colorCodes)){
    p <- p +
      scale_color_manual(values=colorCodes)
  }
  #If wanted to add ellipses and convex hulls use the code below

  # k <- 4
  # clust <- kmeans(scores[,1:2], k)
  # groups <- as.factor(clust$cluster)
  #
  # scores <- scores %>%
  #   mutate(group=groups,
  #          Status=clinData[rownames(expnData),factor])
  # head(scores)
  # mds.plot <- ggscatter(scores, x="MDS1", y="MDS2",
  #                       size=3.5,
  #                       color="Status",
  #                       group="group",
  #                       palette = "Set1",
  #                       ellipse =FALSE,
  #                       ellipse.type = "norm",
  #                       repel = TRUE)
  # #https://stats.stackexchange.com/questions/22805/how-to-draw-neat-polygons-around-scatterplot-regions-in-ggplot2/22855
  # find_hull <- function(df) df[chull(df$MDS1, df$MDS2), ]
  # hulls <- ddply(scores,"group",find_hull )
  #
  # #add hulls or ellipses
  # mds.plot <- mds.plot +
  #   # stat_ellipse(data = scores,
  #   # mapping = aes(group=group, fill=group), geom = "polygon", alpha=0.15, color="black", level=0.99)
  #   geom_polygon(data=hulls, aes(fill=group), alpha=0.15) +
  #   scale_fill_manual(values = rainbow_hcl(4)) +
  #   theme(text = element_text(size=20))

  # aov <- aov(scores$MDS1 ~ df[,factor]) #NOTE: This is only valid for balanced experimental designs! Equal # of obs in each factor level.

  list <- list(PCoA,scores, p)
  names(list) <- c("PCoA","scores","plot")

  return(list)
}

#from https://github.com/mikelove/DESeq2/blob/master/R/plots.R
#Want to return the whole scores matrix so can examine 3d pca plots.
plotPCA.DESeq.mod <- function(object, intgroup="condition", ntop=500, returnData=FALSE, PC3=FALSE)
{
  library(matrixStats)
  # calculate the variance for each gene
  rv <- rowVars(assay(object))

  # select the ntop genes by variance
  select <- order(rv, decreasing=TRUE)[seq_len(min(ntop, length(rv)))]

  # perform a PCA on the data in assay(x) for the selected genes
  pca <- prcomp(t(assay(object)[select,]))

  # the contribution to the total variance for each component
  percentVar <- pca$sdev^2 / sum( pca$sdev^2 )

  if (!all(intgroup %in% names(colData(object)))) {
    stop("the argument 'intgroup' should specify columns of colData(dds)")
  }

  intgroup.df <- as.data.frame(colData(object)[, intgroup, drop=FALSE])

  # add the intgroup factors together to create a new grouping factor
  group <- if (length(intgroup) > 1) {
    factor(apply( intgroup.df, 1, paste, collapse=":"))
  } else {
    colData(object)[[intgroup]]
  }

  # assembly the data for the plot - first 10 PCs
  # d <- data.frame(PC1=pca$x[,1], PC2=pca$x[,2], group=group, intgroup.df, name=colnames(object))
  n <- min(10, ncol(as.data.frame(pca$x)))
  d <- data.frame(as.data.frame(pca$x)[,1:n], group=group, intgroup.df, name=colnames(object))

  if (returnData) {
    attr(d, "percentVar") <- percentVar[1:10]
    rot <- pca$rotation[,1:10] #for first 10 PCs
    dat <- list("scores"=d,"rotation"=rot)
    return(dat)
  }

  if(PC3){
    ggplot(data=d, aes_string(x="PC1", y="PC3", color="group")) +
      geom_point(size=3, alpha=0.75) +
      xlab(paste0("PC1: ",round(percentVar[1] * 100),"% variance")) +
      ylab(paste0("PC3: ",round(percentVar[3] * 100),"% variance"))

  }else{
    ggplot(data=d, aes_string(x="PC1", y="PC2", color="group")) +
      geom_point(size=3, alpha=0.75) +
      xlab(paste0("PC1: ",round(percentVar[1] * 100),"% variance")) +
      ylab(paste0("PC2: ",round(percentVar[2] * 100),"% variance"))
    # coord_fixed()
  }
}

#Updated on 6/9/17 to use variance stabilized transformed data as input (not center scaled log2, like in princomp)
PCA <- function(expnData,phenovector,title="",round=TRUE,colorCodes=NULL,
                ntop=500,PC3=FALSE, GOI=NULL){

  suppressPackageStartupMessages(library(DESeq2))
  library(ggplot2)
  #expnData is the raw counts (not normalized) has patient IDs as colnames and genes as rownames.

  # countData <- expnData[,match(names(phenovector), colnames(expnData))]
  samples <- intersect(names(phenovector), colnames(expnData))
  countData <- expnData[,samples]
  phenovector <- phenovector[samples]

  countData <- round(countData, digits = 0)
  colData <- as.data.frame(phenovector)

  if(length(unique(phenovector)) < 2){
    dds <- DESeqDataSetFromMatrix(countData = countData,
                                  colData = colData,
                                  design = ~ 1)
  }else{
    dds <- DESeqDataSetFromMatrix(countData = countData,
                                  colData = colData,
                                  design = ~ phenovector)
  }

  #create deseq2 dataset and perform variance stabilized transformation for sample to sample comparisons
  dds <- dds[ rowSums(counts(dds)) > 10, ]
  varianceStab <- vst(dds, blind = TRUE)

  #if given a list of genes of interest
  if (! is.null(GOI)){
    GOI <- intersect(GOI, rownames(assay(varianceStab)))
  }else{
    GOI <- 1:nrow(varianceStab)
  }

  # Create a PCA plot
  plot.1 <- plotPCA.DESeq.mod(varianceStab[GOI,], intgroup = "phenovector", ntop = ntop, PC3=FALSE) +
    theme_numX +
    labs(title=title)

  if(PC3){
    plot.2 <- plotPCA.DESeq.mod(varianceStab[GOI,], intgroup = "phenovector", ntop = ntop, PC3=TRUE) +
      theme_numX +
      labs(title=title)
  }

  #change points to custom colors if provided
  if (!is.null(colorCodes)){
    plot.1 <- plot.1 +
      scale_color_manual(values=colorCodes)

    if(exists("plot.2")){
      plot.2 <- plot.2 +
        scale_color_manual(values=colorCodes)
    }

  }

  #PCA data frame with the wieghts/loadings and eigen vectors
  pca.dat <- plotPCA.DESeq.mod(varianceStab[GOI,], intgroup = "phenovector", ntop = ntop,
                               returnData=TRUE)

  #Final Results object
  res <- list(dds, varianceStab,pca.dat$scores,pca.dat$rotation, plot.1)
  names(res) <- c("dds", "vst","pca_data","pca_loadings", "pca_plot")

  if(is.character(GOI)){
    res[["GOI"]] <- GOI
  }

  if(PC3){
    res[["pca_plot2"]] <- plot.2
  }

  return(res)
}

pca_custom <- function(expnData,CDE,fillCol, colorCol, colorCode=NULL, PC3=FALSE,
                       single.col.outline=FALSE, toHighlight=NULL, ellipse=FALSE){
  library(tibble)
  library(dplyr)
  #expn data is log2, normalized counts
  #CDE has patients as rownames.
  #fillCol == character string of column name for fill colors
  #colorCol == character string of column name for border colors
  #colorCode is an option named vector of colors. If specifying color and fill manually, create a list with  length 2, with names c("fill","color")
  #single.col.outline is T/F for wether to susbet to dataframe for the border colors.
  #toHighlight is a character vector for if single.col.outline == TRUE. Gives the factor to highlight with borders from the colorColumn.
  #ellipse is T/F for an ellipse based on fillCol column
  expnData <- expnData[,intersect(rownames(CDE),colnames(expnData))]

  # print(dim(expnData))
  pca <- prcomp(t(expnData), scale=TRUE)
  summ <- summary(pca)

  scores <- as.data.frame(pca$x) %>%
    rownames_to_column("USI") %>%
    inner_join(., dplyr::select(CDE,USI=matches("USI$"), everything()), by="USI") %>%
    dplyr::select(USI,fillCol, colorCol, everything())

  #Plot function for  PC1 and either PC2 or anyother
  pca.plot_function <- function(scores,PC){

    idx <- as.numeric(gsub("[A-Za-z]{2}","", PC))

    pca.plot  <- ggplot(scores, aes_string(x="PC1", y=PC)) +
      labs(x=paste("PC1: ", round(summ$importance[2,1], digits=3)*100, "% variance"),
           y=paste(paste0(PC,": "), round(summ$importance[2,idx], digits=3)*100, "% variance")) +
      theme_numX  +
      theme(legend.text = element_text(size=14),
            legend.title = element_text(size=16))

    if(single.col.outline){
      pca.plot <- pca.plot +
        geom_point(size=5,stroke=0.2, alpha=1,shape=21,color="white",
                   aes_string(fill=fillCol)) +
        geom_point(data=subset(scores, scores[,colorCol] == toHighlight),
                   aes_string(x="PC1", y=PC, color=colorCol),
                   size=4, stroke=1, alpha=1,shape=21)

    }else{
      pca.plot <- pca.plot +
        geom_point(size=5, stroke=2, alpha=0.85,shape=21,
                   aes_string(fill=fillCol, color=colorCol))
    }

    if(!is.null(colorCode)){

        if(is.list(colorCode)){
          pca.plot <- pca.plot +
            scale_fill_manual(values=colorCode[["fill"]]) +
            scale_color_manual(values=colorCode[["color"]])
        }else{
          pca.plot <- pca.plot +
            scale_fill_manual(values=colorCode)
        }
    }

    if(ellipse){
        pca.plot <- pca.plot +
          stat_ellipse(data=scores, type="norm",
                       aes_string(x="PC1", y=PC, fill=fillCol),
                       geom="polygon", alpha=0.1)
    }

    return(pca.plot)
  }

  #PC1 and PC2 plot
  pc1.pc2 <- pca.plot_function(scores=scores,PC="PC2")

  #PC1 and PC3 plot
  if(PC3){
    pc1.pc3 <- pca.plot_function(scores=scores, PC="PC3")

  }

  res <- list("pca"=pca,"scores"=scores,"plot.1"=pc1.pc2)

  if(PC3){
    res[["plot.2"]] <- pc1.pc3
  }

  return(res)

}


library(foreach)
library(doSNOW)

r=3
ktot=c(3,3,3,3,3,3,3,3)
source("codeKfixedLOG.r")
source("codeKvariable.r")
kmax=4

n=c(100,200)
Ti=c(4,6,8)
pers=10
sepp=c(2.5,4)

ex=expand.grid(n,Ti,sepp)
nex=nrow(ex)
for(j in 1:nex) {
    n=ex[j,1]
    Ti=ex[j,2]
    sepp=ex[j,3]
    k=ktot[1:Ti]
source("doSimu.r")
}


sampleFromAGroup<-function(x, y, nsize, samp_options=list(replacement=FALSE, sample_all_available=FALSE, sample_all_available_warning = TRUE)){
# 2015-2016 WP2 FishPI

	# Adapted by Nuno Prista from great original work of Liz Clarke, Marine Scotland.

	# 2016-10-17 Nuno Prista: added option sample all when sampling without replacement [see comments]
	# 2016-10-17 Nuno Prista: added sample2 [correction of behaviour of "sample" when only 1 element is being sampled]
	# 2016-10-17 Nuno Prista: improved identification of samples in result
	# 2016-10-18 Nuno Prista: improved code at samp_options level [made independent from position in list - > now easier to add options]
	# 2016-10-18 Nuno Prista: added suppress.warnings to samp_options
	# 2018-05-29 Nuno Prista: adapted so that one of the group names can be NA (useful in, e.g., stratifying by maturity)

nGroup<-length(nsize)
xSamp<-NULL
for (i in 1:nGroup) {
#print(i)

	if(!is.na(names(nsize)[i]))
		{
		indx<-unique(x[which(y==names(nsize)[i])])
		} else {indx <- x [which(is.na(y))] } # nuno 20180529 [handles NAs in stratification]
    # nuno 20161017: condicao para amostrar todos os disponiveis without replacement
    if(samp_options$replacement == FALSE & samp_options$sample_all_available == TRUE & nsize[i]>length(indx)){
            nsize[i] <- length(indx)
            if(samp_options$sample_all_available_warning==TRUE) {print(paste("sampling all available in group",names(nsize)[i]))}
            }
    # nuno 20161017: condicao para existencia de 1 unico elemento a amostrar (corrige comportamento de funcao sample)
    if(length(indx)>1){
        samp<-sample(indx, size=nsize[i], replace = samp_options$replacement)
        } else {samp<-sample2(indx, size=nsize[i], replace = samp_options$replacement)}
    # nuno 20161017: atribui nomes
	names(samp)<-rep(names(nsize)[i], length(samp))
    if(i == 1) {
    xSamp <-samp
    } else {
        xSamp <- c(xSamp, samp)
    }
    }
    return(xSamp)
}


# Fonction R à traduire en Python
get_pca <- function(res.pca, element = c("var", "ind")){
  elmt <- match.arg(element)
  if(elmt =="var") get_pca_var(res.pca)
  else if(elmt == "ind") get_pca_ind(res.pca)
}

get_pca_ind<-function(res.pca, ...){

  # FactoMineR package
  if(inherits(res.pca, c('PCA'))) ind <- res.pca$ind

  # ade4 package
  else if(inherits(res.pca, 'pca') & inherits(res.pca, 'dudi')){
    ind.coord <- res.pca$li
    # get the original data
    data <- res.pca$tab
    data <- t(apply(data, 1, function(x){x*res.pca$norm} ))
    data <- t(apply(data, 1, function(x){x+res.pca$cent}))
    ind <- .get_pca_ind_results(ind.coord, data, res.pca$eig,
                                res.pca$cent, res.pca$norm)
  }

  # stats package
  else if(inherits(res.pca, 'princomp')){
    ind.coord <- res.pca$scores
    data <- .prcomp_reconst(res.pca)
    ind <- .get_pca_ind_results(ind.coord, data, res.pca$sdev^2,
                                res.pca$center, res.pca$scale)

  }
  else if(inherits(res.pca, 'prcomp')){
    ind.coord <- res.pca$x
    data <- .prcomp_reconst(res.pca)
    ind <- .get_pca_ind_results(ind.coord, data, res.pca$sdev^2,
                                res.pca$center, res.pca$scale)
  }
  # ExPosition package
  else if (inherits(res.pca, "expoOutput") & inherits(res.pca$ExPosition.Data,'epPCA')){
    res <- res.pca$ExPosition.Data
    ind <- list(coord = res$fi,  cos2 = res$ri, contrib = res$ci*100)
  }
  else stop("An object of class : ", class(res.pca),
            " can't be handled by the function get_pca_ind()")

  class(ind)<-c("factoextra", "pca_ind")

  ind
}

get_pca_var<-function(res.pca){
  # FactoMineR package
  if(inherits(res.pca, c('PCA'))) var <- res.pca$var
  # ade4 package
  else if(inherits(res.pca, 'pca') & inherits(res.pca, 'dudi')){
    var <- .get_pca_var_results(res.pca$co)
  }
  # stats package
  else if(inherits(res.pca, 'princomp')){
    # Correlation of variables with the principal component
    var_cor_func <- function(var.loadings, comp.sdev){var.loadings*comp.sdev}
    var.cor <- t(apply(res.pca$loadings, 1, var_cor_func, res.pca$sdev))
    var <- .get_pca_var_results(var.cor)
  }
  else if(inherits(res.pca, 'prcomp')){
    # Correlation of variables with the principal component
    var_cor_func <- function(var.loadings, comp.sdev){var.loadings*comp.sdev}
    var.cor <- t(apply(res.pca$rotation, 1, var_cor_func, res.pca$sdev))
    var <- .get_pca_var_results(var.cor)
  }
  # ExPosition package
  else if (inherits(res.pca, "expoOutput") & inherits(res.pca$ExPosition.Data,'epPCA')){
    res <- res.pca$ExPosition.Data
    data_matrix <- res$X
    factor_scores <- res$fi
    var.coord <- var.cor <- stats::cor(res$X, res$fi) # cor(t(data_matrix), factor_scores)
    var.coord <- replace(var.coord, is.na(var.coord), 0)
    var <- list(coord = var.coord, cor = var.coord, cos2 = res$rj, contrib = res$cj*100)
  }
  else stop("An object of class : ", class(res.pca),
            " can't be handled by the function get_pca_var()")
  class(var)<-c("factoextra", "pca_var")
  var
}

# compute all the results for individuals : coord, cor, cos2, contrib
# ind.coord : coordinates of variables on the principal component
# pca.center, pca.scale : numeric vectors corresponding to the pca
# center and scale respectively
# data : the orignal data used during the pca analysis
# eigenvalues : principal component eigenvalues
.get_pca_ind_results <- function(ind.coord, data, eigenvalues, pca.center, pca.scale ){

  eigenvalues <- eigenvalues[1:ncol(ind.coord)]

  if(pca.center[1] == FALSE) pca.center <- rep(0, ncol(data))
  if(pca.scale[1] == FALSE) pca.scale <- rep(1, ncol(data))

  # Compute the square of the distance between an individual and the
  # center of gravity
  getdistance <- function(ind_row, center, scale){
    return(sum(((ind_row-center)/scale)^2))
  }
  d2 <- apply(data, 1,getdistance, pca.center, pca.scale)

  # Compute the cos2
  cos2 <- function(ind.coord, d2){return(ind.coord^2/d2)}
  ind.cos2 <- apply(ind.coord, 2, cos2, d2)

  # Individual contributions
  contrib <- function(ind.coord, eigenvalues, n.ind){
    100*(1/n.ind)*(ind.coord^2/eigenvalues)
  }
  ind.contrib <- t(apply(ind.coord, 1, contrib,  eigenvalues, nrow(ind.coord)))

  colnames(ind.coord) <- colnames(ind.cos2) <-
    colnames(ind.contrib) <- paste0("Dim.", 1:ncol(ind.coord))

  rnames <- rownames(ind.coord)
  if(is.null(rnames)) rnames <- as.character(1:nrow(ind.coord))
  rownames(ind.coord) <- rownames(ind.cos2) <- rownames(ind.contrib) <- rnames

  # Individuals coord, cos2 and contrib
  ind = list(coord = ind.coord,  cos2 = ind.cos2, contrib = ind.contrib)
  ind
}

# compute all the results for variables : coord, cor, cos2, contrib
# var.coord : coordinates of variables on the principal component
.get_pca_var_results <- function(var.coord){

  var.cor <- var.coord # correlation
  var.cos2 <- var.cor^2 # variable qualities

  # variable contributions (in percent)
  # var.cos2*100/total Cos2 of the component
  comp.cos2 <- apply(var.cos2, 2, sum)
  contrib <- function(var.cos2, comp.cos2){var.cos2*100/comp.cos2}
  var.contrib <- t(apply(var.cos2,1, contrib, comp.cos2))

  colnames(var.coord) <- colnames(var.cor) <- colnames(var.cos2) <-
    colnames(var.contrib) <- paste0("Dim.", 1:ncol(var.coord))

  # Variable coord, cor, cos2 and contrib
  list(coord = var.coord, cor = var.cor, cos2 = var.cos2, contrib = var.contrib)
}


library(tidyverse)
library(osrm)
library(sf)
options(osrm.server = 'http://0.0.0.0:5000/')

#tabela RDS com localização dos municípios (source)
muni <- readRDS("./02_ dados/01_ IBGE/dados_modificados/locus_municipios.rds") %>%
          select(CD_GEOCODM, geometry)

#tabela RDS com localização das áreas de ponderação (destiny)
area <- readRDS("./02_ dados/03_ analise/03_01_areasPond&unidade.rds") %>% select(Cod_Area_Pond, geometry)
for(i in 1:nrow(area)){
  cent <- st_centroid(area$geometry[i])
  area$geometry[i] <- cent[[1]]
}
rm(i)
st_crs(area) <- st_crs(muni)

#Cruzamento de informações
l_Osm <- list();

for(i in 1:279){
  i_st <- i * 20 - 19
  i_en <- ifelse(i_st + 19 > 5565, 5565, i_st + 19)

  srcMuni <- muni %>% slice(i_st:i_en)
  outputMuni <- osrmTable(src=srcMuni, dst=area, measure= c('duration', 'distance')) #duration in minutes; distance in meters
  cat("Cruzamento número ", i, "/279 realizado. \n", sep="")
  l_Osm <- c(l_Osm, list(outputMuni))
}

saveRDS(l_Osm, '1_tempo_municipios_areas.rds')


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

source("run_netprophet_parallel.r")
library(Rmpi)
mpi.bcast.Robj2slave(targetExpressionFile)
mpi.bcast.Robj2slave(regulatorExpressionFile)
mpi.bcast.Robj2slave(allowedMatrixFile)
mpi.bcast.Robj2slave(perturbationMatrixFile)
mpi.bcast.Robj2slave(microarrayFlag)
mpi.bcast.Robj2slave(outputDirectory)

mpi.remote.exec(source("run_netprophet_parallel_single_process.r"))
mpi.remote.exec(reportid())
uniform.solution <- lars.multi.optimize.parallel()

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

de_component <- as.matrix(read.table(differentialExpressionMatrixFile))

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

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


#' Parse a Chase bank statement (saved in a PDF format) into a tidyverse-friendly dataframe
#'
#' @param file_path A file path which indicates a PDF file that contains Chase bank statement.
#' @param report_year The year in which the bank statement was reported. The data type of this argument should be numeric (e.g., 2020).
#'
#' @return A dataframe with eight columns ("Date, "Description", "Amount", "Balance", "Card", "Venmo", "Withdraw", "Deposit")
#' @import dplyr
#' @importFrom tibble enframe
#' @importFrom magrittr "%>%"
#' @importFrom tabulizer extract_tables
#' @import stringr
#' @import purrr
#' @importFrom glue glue
#' @import utils
#' @export
#'

## ---------------------------------------------------------------------------------------------------------

parse_check_statement <- function(file_path, report_year){

# Import PDF file and extract table
if (file.exists(file_path)) {

    check_statement <- extract_tables(file = file_path)

    } else {stop("File path is wrong.")}

if (length(check_statement) == 0) {stop("Something's wrong with extracting a table from the PDF file.")}

## ---------------------------------------------------------------------------------------------------------
# Turn the list of matrices into a dataframe
df <- map_dfr(check_statement, data.frame)

# Remove the first three rows
df <- df %>% filter(!str_detect(X1, "TRANSACTION|transaction|DESCRIPTION|Beginning"))

# Create date column
df <- df %>%
    mutate(Date = map(X1, ~str_extract(., "^.{1,5}")) %>%
    map_dfr(enframe) %>%
    pull(value)
    )

# Rename columns

if (ncol(df) == 4) {

    names(df) <- c("Description", "Amount", "Balance", "Date")

} else {

    # In some cases, unnecessary X2 column is created during the table extracting process.

    df <- df[,-2]

    names(df) <- c("Description", "Amount", "Balance", "Date")

}

# Add columns
df$Card <- if_else(str_detect(df$Description, "Card") == TRUE, 1, 0)
df$Venmo <- if_else(str_detect(df$Description, "Venmo") == TRUE, 1, 0)
df$Withdraw <- if_else(str_detect(df$Amount, "-") == TRUE, 1, 0)
df$Deposit <- if_else(str_detect(df$Amount, "-") != TRUE, 1, 0)

## ---------------------------------------------------------------------------------------------------------
# Reorder columns; Date comes first
df <- df %>% relocate(Date)

# Filter Date column by a special character
df$Date <- if_else(str_detect(df$Date, "/") == TRUE, df$Date, "Not date")

# Filter Date column by data type
df$Date <- map(df$Date, ~str_extract(., "[:alpha:]")) %>%
    map_dfr(enframe) %>%
    mutate(value = if_else(is.na(value), df$Date, "Not date")) %>%
    pull(value)

## ---------------------------------------------------------------------------------------------------------
# Clean Description column
df$Description <- if_else(df$Date != "Not date", str_replace_all(df$Description, df$Date, ""), df$Description)

# Filter not-date rows
df <- df %>% filter(Date != "Not date")

# Remove special characters in Amount and Balance columns
df <- df %>%
    mutate(
        Amount = str_replace_all(Amount, ",", "") %>% as.numeric(),
        Balance = str_replace_all(Balance, ",", "") %>% as.numeric()
    )

# Reformat Date variable

df$Date <- as.Date(glue("{report_year}/{df$Date}"))

return(df)

}


# -----------------------------------
# Leitura, Silvio.

library(stringr)
require(rvest) # importa a biblioteca rvest

cidades <- read_html("http://cidades.ibge.gov.br/download/mapa_e_municipios.php?lang=&uf=rn") %>% html_table(fill=TRUE)

base<-data.frame(cidades[[1]][c(1,2,4)]) # Selecionando os dados de interesse de interesse
names(base)<-c("cidade","cep","pop2010") # Nomeando as colunas
row.names(base)<-1:168
# Enumerando as linhas
base$pop2010<-str_replace_all(base$pop2010,"\\.","") # Retira os pontos
base$pop2010<-as.numeric(base$pop2010) # Converte os caracteres em numéricos
base[is.na(base)] <- 0 # Substitui valores Nas por zeros
head(base) # lista as primeiras linhas do dataframe base

library(sp)

setwd("~/Documentos/Maps/") # Define o diretório de trabalho
br <- readRDS("BRA_adm2.rds") # Importa os polígonos do arquivo no diretório de trabalho <http://gadm.org>
plot(br)

head(br) # as primeiras linhas mostram q existe um campo chamado $NAME_1 com os nomes dos estados

rn = (br[br$NAME_1=="Rio Grande do Norte",]) # Filtrando apenas os municípios do RN
plot(rn)
plot(rn[rn$NAME_2=="Natal",], add=T, col="red")

rn <- merge(x=rn, y=base, by.x="NAME_2", by.y="cidade") # Faz um merge dos dataframes

# Criando os intervalos e classificando
col_no = as.factor(as.numeric(cut(rn$pop2010.x, breaks =
                                    c(0,3000,10000,100000,300000,500000,80000,1000000), labels=c("<3k", "3k-10k", "10k-
100k","100k-300k", "300k-500k", "500k-800k", ">800k"), right= FALSE)))
# Nomeando os intervalos – irá aparecer na legenda do grafico
levels(col_no) = c("<3k", "3k-10k", "10k-100k","100k-300k", "300k-500k", "500k-800k",">800k")
# Adicionando a informação da categoria no dataframe
rn$col_no = col_no

library(RColorBrewer)
myPalette = brewer.pal(7,"Reds")

spplot(rn, "col_no", col=grey(.9), col.regions=myPalette, main="Municípios do RN")

library(ggmap) # importa a biblioteca ggmap para obter a geolocalização
# Define o nome das cidade-alvos – a ser apresentada como label no mapa
nomes = c("Natal","Mossoró","Pau dos Ferros")
# Define or argumentos de busca para as cidade-alvos – a ser usada pelo ggmap
nam = c("Natal+Brazil+RN","Mossoro+Brazil+RN","Pau dos Ferros+Brazil+RN")
# Busca a geolocalização (Google) para cada cidade
pos = geocode(nam)
# Define a posição dos labels como sendo um pouco acima dos pontos
tlat = pos$lat+0.05
# -- the city name will be above the marker
# Cria um daframe com as informações (nome da cidade, longitude, latitude e posição dolabel)
cities = data.frame(nomes, pos$lon,pos$lat,tlat)
# Nomeia as colunas de longitude e latitude
names(cities)[2] = "lon"
names(cities)[3] = "lat"

# Criando os labels
text1 = list("panel.text", cities$lon, cities$tlat, cities$nomes,col="black", cex = 0.5)
# Criando os apontamentos
mark1 = list("panel.points", cities$lon, cities$lat, col="blue")

spplot(rn, "col_no",
       sp.layout=list(text1,mark1),
       main="Municípios RN",
       col=grey(.9), col.regions=myPalette)

# -----------------------------------
# Atividade, Marcell.

# TODO


library(digest)
hexdigest <- digest("The quick brown fox jumped over the lazy dog's back",
                    algo="md5", serialize=FALSE)


processing_5p_end_positional_offset_between_identified_loci_and_small_RNA_gene<- function(fprefix='input',wdir=".") {

start_time <- proc.time()
cat("Offset between loci and genes at 5' end (M3.07) start", date(), "\n")

# Plots for Module 3 Analysis and visualization of SPAR output
# Session: Processing characteristics

# Module_3_Figure_7 (Figure 3.07)
# Description: Normalized offset between loci and genes at the 5' end (displaying relative positions of loci on the genes)
# input: input_annot.with_conservation.xls
# output: 5p_end_positional_offset_between_identified_loci_and_small_RNA_gene.png
# output: 5p_end_positional_offset_between_identified_loci_and_small_RNA_gene.pdf

# parameters for the plot
datafile=paste(wdir, "/", fprefix, "_annot.with_conservation.xls", sep="")
BASENAME="5p_end_positional_offset_between_identified_loci_and_small_RNA_gene"
PLOTTITLE="Normalized offset at 5' end, between annotated loci and sncRNA gene"
XTITLE="Normalized_offset"
YTITLE="Number_of_loci"

# libraries needed
suppressPackageStartupMessages(library(ggplot2))

#args<-commandArgs(TRUE)
#datafile1=args[1] # input file 1
#datafile2=args[2] # input file 2
#wdir=args[3] # output / working directory
#if (length(args)<1) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<2) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<3) { wdir="." }
#use current dir if no
#working dir has been specified

# output image file
pngfile= paste(wdir, "/../figures/", paste(BASENAME,".png",sep=""), sep="")
#pdffile= paste(wdir, "/", paste(BASENAME,".pdf",sep=""), sep="")

# Read in data
D = read.table(datafile,sep='\t',header=T,comment.ch="")
D_pos = subset(D,peakStrand=="+")
D_neg = subset(D,peakStrand=="-")

# for positive strand (peak start - annotation start)
D_pos$Offset_5p = D_pos$peakChrStart-D_pos$annotChrStart + D_pos$peakMostCommon5pPosition - 1
D_pos$Loci_length = D_pos$peakChrEnd-D_pos$peakChrStart
D_pos$Annot_length = D_pos$annotChrEnd-D_pos$annotChrStart

# for negative strand (peak end - annotation end)
D_neg$Offset_5p = D_neg$annotChrEnd-D_neg$peakChrEnd + D_neg$peakMostCommon5pPosition - 1
D_neg$Loci_length = D_neg$peakChrEnd-D_neg$peakChrStart
D_neg$Annot_length = D_neg$annotChrEnd-D_neg$annotChrStart

D_comb = rbind(D_pos,D_neg)
A_final = D_comb[,c("annotRNAclass","annotStrand","Offset_5p","Loci_length","Annot_length")]
colnames(A_final) = c("sncRNA_class", "Strand", "Offset_5p","Loci_length","Annot_length")

A_final = A_final[which(A_final$Loci_length<=44),]
A_final[,6] = A_final[,3]/A_final[,5]
colnames(A_final)[6] = XTITLE

# hist(mir_3p[,6],breaks=dim(mir_3p)[1],xlim=c(-0.2,0.2))

# A histogram
png(pngfile,width = 7, height = 7, units = 'in', res = 300, type="cairo")
options(scipen=10000)
print(ggplot(A_final, aes(x=Normalized_offset))+
geom_histogram(colour="white", breaks=seq(round(min(A_final[,6])-0.05,1), 1, by= 0.05)+0.025,right = TRUE)+
ggtitle(PLOTTITLE)+theme_classic()+
theme(axis.text.x = element_text(size = 14),axis.text.y = element_text(size = 8))+
facet_grid(sncRNA_class~.,scales="free_y"))
dev.off()

cat("Total time for offset between loci and genes at 5' end (M3.07) analysis:", (proc.time() - start_time)[['elapsed']], "seconds (", date(), ")\n")
}

# processing_5p_end_positional_offset_between_identified_loci_and_small_RNA_gene(fprefix=fprefix,wdir=wdir)


# Libraries
library(dplyr)
library(RSQLite)

library(tidyverse)
library(httr)
library(jsonlite)

library(ggplot2)
library(data.table)


#  James Rekow

#  when abdList[[pairs[, i][1]]] : subscript out of bounds happens, just return NA in DOCProcedure
#  function to prevent unnecessary termination of parent process. I should adopt this philosophy in
#  any helper functions that become problematic only rarely but happen to interupt slower parent
#  processes.

treatmentDFListListArrayCreator = function(M = 80, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                           thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                           intTime = 1, interSmplMult = 0.01, lambda = 10 ^ (-1),
                                           synthM = floor(M / 4), numSynthChrt = 10, numSample = 100,
                                           maxIters = 100){

  #  ARGS:
  #
  #  RETURNS:

  source("conGraphCreator.r")
  source("DOCNSDFListCreator.r")

  # lambdaVec = c(0.05, 0.1, 0.15)
  # graphTypeVec = c("smallWorld", "scaleFree", "gnp", "gnm")
  # meanDegreeVec = c(2, 4, 6)

  lambdaVec = c(0.05, 0.1, 0.15)
  graphTypeVec = c("smallWorld", "scaleFree", "gnp", "gnm")
  meanDegreeVec = c(4, 6)

  x1 = 1:length(lambdaVec)
  x2 = 1:length(graphTypeVec)
  x3 = 1:length(meanDegreeVec)

  g = function(x, y) sapply(1:length(x), function(n) list(append(x[[n]], y[[n]])))

  coordArray = outer(x1, outer(x2, x3, g), g)

  produceTreatmentDFListList = function(coords){

    #  ARGS:
    #
    #  RETURNS:

    #  unlist the coordinates in the input
    coords = unlist(coords)

    #  extract the parameter values corresponding to the coordinate vector
    lambda = lambdaVec[coords[1]]
    graphType = graphTypeVec[coords[2]]
    meanDegree = meanDegreeVec[coords[3]]

    # NOTE: coords in array of the from c(lambda, graphType, meanDegree)

    #  create connectivity graph using the graph type and mean degree parameters
    conGraph = conGraphCreator(graphType = graphType, meanDegree = meanDegree, v = M)

    treatmentDFListCreator = function(x = NULL){
      return(
        DOCNSDFListCreator(conGraph = conGraph, M = M, N = N, iStrength = iStrength,
                           univ = univ, sigmaMax = sigmaMax,
                           thresholdMult = thresholdMult, maxSteps = maxSteps,
                           tStep = tStep, intTime = intTime,
                           interSmplMult = interSmplMult, lambda = lambda,
                           synthM = synthM, numSynthChrt = numSynthChrt,
                           numSample = numSample, maxIters = maxIters)
      ) #  end return
    } #  end treatmentDFListCreator function

    treatmentDFListList = lapply(as.list(1:10), treatmentDFListCreator)

    return(treatmentDFListList)

  } #  end produceTreatmentDFListList function

  treatmentDFListListArray = apply(coordArray, 1:3, produceTreatmentDFListList)

  return(treatmentDFListListArray)

} #  end treatmentDFListListArrayCreator function


LC_Diff <- function(Input_FileName) {

# R Functions to process dataset from Load Cell Array
# It calculates the difference between two timesteps -- current vs. previsou one.
# Diff = current one - previous one
# Negetive Diff means lossing weight; Postive Diff means gaining weight
#
# Author : Kuo-Hsine Chang, Ph.D. Dept. of Plant Agricuture, University of Guelph
# Contact: changks.github.io
# Version: 04162018

  # load library
    library(zoo)
    library(data.table)

  # read the csv file
    dt = fread(Input_FileName, header = T, sep = ',');

  # calcualte difference between two timesteps (current - previous)

    Diff_dt <- dt[, lapply(.SD, function(x) {x1 <- diff(x)
            NA^(x1 <= -10 | x1 >=10)*x1}), .SDcols= 2:ncol(dt)
           ][, timestamp := dt[[1]][-1]]

    Diff_dt[, c(ncol(Diff_dt), 1:(ncol(Diff_dt)-1)), with=FALSE]

    Diff_dt <- data.frame(Diff_dt)

    Diff_dt <- Diff_dt[c(13,1:12)]

  # export to a csv file
    write.table(Diff_dt, paste0(tools::file_path_sans_ext(Input_FileName),"_Diff.csv"), row.names=FALSE, col.names=TRUE, sep=",")
}


# Packages
library(tidyverse)
library(magrittr)
library(ggplot2)
# library(geomnet)
library(ggnetwork)
library(sf)
library(ggmap)
library(sp)
library(rgdal)
library(leaflet)
# library(xlsx)
library(data.table)
library(mapview)
library(mapedit)
library(matlib)
library(nngeo)
library(writexl)
library(here)
library(plotly)
library(kableExtra)

source("./R/Simulations_functions.r")
source("./R/functions.r")

file_path <- here::here("Data/Input/With_observations/Brana/Brana.xlsx")
brana.snet <- read_surveynet(file = file_path)
snet = brana.snet
snet.adj = brana.snet.adj
net.2D = TRUE
webmap = TRUE
epsg = 3857
sp_bound =2
rii_bound = 0.3
# Summary

# TO DO: da ne prikazuje nazive kolona, da se malo oboji i da mozda ide po tabovima...

# summary.adjustment <- data.frame(Parameter = c("Type: ", "Dimension: ", "Number of iterations: ", "Max. coordinate correction in last iteration: ", "Datum definition: "),
#                  Value = c("Weighted", "2D", 1, "0.0000 m",
#                            if(all(brana.snet$points$FIX_2D == FALSE)){
#                              "Datum defined with a minimal trace of the matrix Qx"
#                            }else{"Fixed parameters - classically defined datum"}
#                            ))
#
# summary.adjustment %>%
#   kable(caption = "Adjustment settings", digits = 4, align = "c", col.names = NULL) %>%
#   kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"), full_width = TRUE)%>%
#   column_spec(1, bold = T, color = "white", background = "#D7261E")
#
#
# summary.stations <- data.frame(Parameter = c("Number of (partly) known stations: ", "Number of unknown stations: ", "Total: "),
#                                Value = c(sum(brana.snet$points$FIX_2D == TRUE),
#                                          sum(brana.snet$points$FIX_2D == FALSE),
#                                          sum(brana.snet$points$FIX_2D == TRUE) + sum(brana.snet$points$FIX_2D == FALSE)))
#
#
# summary.stations %>%
#   kable(caption = "Stations", digits = 4, align = "c") %>%
#   kable_styling(bootstrap_options = "striped", full_width = TRUE)
#
#
# summary.observations <- data.frame(Parameter = c("Directions: ", "Distances: ", "Known coordinates: ", "Total: "),
#                                    Value = c(sum(brana.snet$observations$direction == TRUE),
#                                              sum(brana.snet$observations$distance == TRUE),
#                                              sum(brana.snet$points$FIX_2D == TRUE)*2,
#                                              sum(brana.snet$observations$direction == TRUE)+sum(brana.snet$observations$distance == TRUE)+(sum(brana.snet$points$FIX_2D == TRUE)*2)))
#
# summary.observations %>%
#   kable(caption = "Observations", digits = 4, align = "c") %>%
#   kable_styling(bootstrap_options = "striped", full_width = TRUE)
#
#
# summary.unknowns <- data.frame(Parameter = c("Coordinates: ", "Orientations: ", "Total: "),
#                                Value = c(sum(brana.snet$points$FIX_2D == FALSE)*2,
#                                          length(brana.snet$observations %>% dplyr::filter(direction == TRUE) %>% .$from %>% unique()),
#                                          (sum(brana.snet$points$FIX_2D == FALSE)*2)+length(brana.snet$observations %>% dplyr::filter(direction == TRUE) %>% .$from %>% unique())))
#
# summary.unknowns %>%
#   kable(caption = "Unknowns", digits = 4, align = "c") %>%
#   kable_styling(bootstrap_options = "striped", full_width = TRUE)
#
#
# summary.degrees <- data.frame(Parameter = "Degrees of freedom: ", Value = summary.observations$Value[4]-summary.unknowns$Value[3])
#
# summary.degrees %>%
#   kable(caption = "Degrees of freedom: ", digits = 4, align = "c") %>%
#   kable_styling(bootstrap_options = "striped", full_width = TRUE)

plot_surveynet(snet = brana.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
plot_surveynet(snet = brana.snet, webmap = TRUE, net.1D = FALSE, net.2D = TRUE)
brana.snet.adj <- adjust.snet(adjust = FALSE, survey.net = brana.snet, dim_type = "2D", sd.apriori = 1, ellipse.scale = 10, all = FALSE) # promeniti sd pravca i duzina
plot_surveynet(snet.adj = brana.snet.adj, webmap = TRUE, net.1D = FALSE, net.2D = TRUE)

file_path <- here::here("Data/Input/With_observations/Makis/Makis_observations.xlsx")
makis.snet <- read_surveynet(file = file_path)
# TO DO: set_srs unutar read_surveynet
plot_surveynet(snet = makis.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
makis.snet.adj <- adjust.snet(adjust = FALSE, survey.net = makis.snet, dim_type = "2D", sd.apriori = 3 ,  all = FALSE)
plot_surveynet(snet.adj = makis.snet.adj, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)

file_path <- here::here("Data/Input/With_observations/Zadatak 1/Zadatak_1.xlsx")
zadatak1.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = zadatak1.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
zadatak1.snet$observations$sd_Hz <- 5
zadatak1.snet$observations$HD[2] <- 12500
zadatak1.snet.adj <- adjust.snet(adjust = TRUE, survey.net = zadatak1.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

file_path <- here::here("Data/Input/Without_observations/xlsx/TETO_plan opazanja1.xlsx")
teto.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = teto.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
teto.snet.adj <- adjust.snet(adjust = FALSE, survey.net = teto.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)
plot_surveynet(snet.adj = teto.snet.adj, webmap = TRUE, net.1D = FALSE, net.2D = TRUE)

adj.net_spatial_view_web(ellipses = brana.snet.adj[[1]]$ellipse.net, observations = brana.snet.adj[[2]], points = brana.snet.adj[[1]]$net.points, sp_bound = 2, rii_bound = 1)

file_path <- here::here("Data/Input/With_observations/Brana_Gorica/Brana_Gorica_nulta_serija.xlsx")
gorica0.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = gorica0.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
gorica0.snet.adj <- adjust.snet(adjust = TRUE, survey.net = gorica0.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

file_path <- here::here("Data/Input/With_observations/Brana_Gorica/Brana_Gorica_april_2019.xlsx")
gorica1.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = gorica1.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
gorica1.snet.adj <- adjust.snet(adjust = TRUE, survey.net = gorica1.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

file_path <- here::here("Data/Input/With_observations/Avala/Avala_mreza.xlsx")
avala.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = gorica0.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
gorica0.snet.adj <- adjust.snet(adjust = TRUE, survey.net = gorica0.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

file_path <- here::here("Data/Input/With_observations/Grdelica/Grdelica.xlsx")
grdelica.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = grdelica.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
grdelica.snet.adj <- adjust.snet(adjust = TRUE, survey.net = grdelica.snet, dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

file_path <- here::here("Data/Input/With_observations/Grdelica/Cut2.xlsx")
cut2.snet <- read_surveynet(file = file_path)
plot_surveynet(snet = cut2.snet, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
cut2.snet.adj <- adjust.snet(adjust = TRUE, result.units = "cm",  survey.net = cut2.snet, prob = 0.99, output = "report", dim_type = "2D", sd.apriori = 1 ,  all = FALSE)

# 1D design and adjustment
file_path <- here::here("Data/Input/With_observations/DNS_1D/DNS_1D_nulta.xlsx")
dns.snet <- read_surveynet(file = file_path)

points <- dns.snet$points
observations <- dns.snet$observations
names(observations)
observations$id <- row_number(observations$from)

plot_surveynet(snet = dns.snet, webmap = FALSE, net.1D = TRUE, net.2D = FALSE)

dns.snet.adj <- adjust.snet(adjust = FALSE, survey.net = dns.snet, wdh_model = "n_dh", dim_type = "1D", sd.apriori = 0.2 ,  all = FALSE, result.units = "mm")
plot_surveynet(snet.adj = dns.snet.adj, webmap = FALSE, net.1D = TRUE, net.2D = FALSE)

dns.snet.adj <- adjust.snet(adjust = TRUE, survey.net = dns.snet, wdh_model = "n_dh", dim_type = "1D", sd.apriori = 0.2 ,  all = FALSE, result.units = "mm")
plot_surveynet(snet.adj = dns.snet.adj, webmap = FALSE, net.1D = TRUE, net.2D = FALSE)

length(which(dns.snet$points$FIX_1D))==1
sum(dns.snet$observations$diff_level == TRUE)

dns.snet$points %<>% dplyr::mutate(FIX_1D = FALSE)

if(length(which(dns.snet$points$FIX_1D))==1 || length(which(dns.snet$points$FIX_1D))==0){
  "Free 1D geodetic network"
}else{"Unfree 1D geodetic network"}

fixed_points <- survey1net$points[(survey1net$points$FIX_1D == TRUE), ]$Name %>% .[!is.na(.)]

# proba 1d adjust=T
dns.snet.adj$Observations$id <- row_number(dns.snet.adj$Observations$from)

ggplotly(
  ggplot()+
    geom_ribbon(data = dns.snet.adj$Observations,
                aes(x = id,
                    ymin = 0,
                    ymax = f) )+
    #geom_area(data = dns.snet.adj$Observations,
    #          aes(x = from_to,
    #              y = f, fill = "blue"))+
    scale_colour_gradient(low="orange",
                          high="red", guide = FALSE)+
    xlab("Name") +
    ylab("Residuals [mm]") +
    ggtitle("GEODETIC 1D NETWORK")+
    labs(colour = "Residuals [mm]")+
    theme_bw()+
    ylim(min(dns.snet.adj$Observations$f)-sd(dns.snet.adj$Observations$f),
         max(dns.snet.adj$Observations$f)+sd(dns.snet.adj$Observations$f)), showlegend = TRUE
)


#se trabaja con constantes para ordenar el codigo fuente

#source("M:\\R\\elementary\\canaritos_dibujo.r")

#limpio la memoria
rm(list=ls())
gc()

library("data.table")
library("rpart")
library("rpart.plot")

#Parametros entrada
karchivo_entrada      <-  "M:\\datasets\\201902.txt"
kcampos_separador     <-  "\t"
kcampo_id             <-  "numero_de_cliente"
kclase_nomcampo       <-  "clase_ternaria"
kclase_valor_positivo <-  "BAJA+2"
kcampos_a_borrar      <-  c(kcampo_id)

#Parametros salida
karchivo_imagen1       <-  "M:\\work\\canaritos_010.jpg"
karchivo_imagen2       <-  "M:\\work\\canaritos_011.jpg"

#cargo los datos
dataset <- fread(karchivo_entrada)

#borro las variables que no me interesan
dataset[ ,  (kcampos_a_borrar) := NULL    ]

columnas_original <- colnames( dataset )

magic_canaritos <- 0.1
canaritos_cantidad <- as.integer( round(ncol(dataset) * magic_canaritos) )
for( i in 1:canaritos_cantidad )
{
  dataset[        , paste0( "canarito", i ) :=  runif( nrow(dataset) ) ]
}

columnas_canaritos <-   colnames( dataset )[ which( colnames( dataset ) %like% "canarito" ) ]

# generacion del modelo
formula  <-  formula(paste(kclase_nomcampo, "~ ."))

t0       <-  Sys.time()
modelo   <-  rpart(formula,   data = dataset,   cp=0.0, maxdepth=8, minsplit=20, minbucket=5,  xval=5)
t1       <-  Sys.time()

tcorrida <-  as.numeric( t1 - t0, units = "secs")
print( tcorrida)

#cuento cuantas variables canarito distintas aparecen
frame  <- modelo$frame
leaves <- frame$var == "<leaf>"
used   <- unique(frame$var[!leaves])
canaritos_muertos <- sum( unlist( used ) %like% "canarito" )
cat( "canaritos_muertos: ", canaritos_muertos )

#impresion un poco mas elaborada del arbol
jpeg(file = karchivo_imagen1,  width = 30, height = 6, units = 'in', res = 300)
prp(modelo, extra=101, digits=5, branch=1, type=4, varlen=0, faclen=0)
dev.off()

prp(modelo, extra=101, digits=5, branch=1, type=4, varlen=0, faclen=0, snip=TRUE)

#------------------------------------------------------------------------------
#Ahora hago que los canaritos sean las primeras variables del dataset
#tengo gran curiosidad por ver si sale el mismo arbol

setcolorder(  dataset,  unique( c( columnas_canaritos, columnas_original ) ) )

t0       <-  Sys.time()
modelo   <-  rpart(formula,   data = dataset,   cp=0.0, maxdepth=8, minsplit=20, minbucket=5,  xval=0)
t1       <-  Sys.time()

tcorrida <-  as.numeric( t1 - t0, units = "secs")
print( tcorrida)

#cuento cuantas variables canarito distintas aparecen
frame  <- modelo$frame
leaves <- frame$var == "<leaf>"
used   <- unique(frame$var[!leaves])
canaritos_muertos <- sum( unlist( used ) %like% "canarito" )
cat( "canaritos_muertos: ", canaritos_muertos )

#impresion un poco mas elaborada del arbol
jpeg(file = karchivo_imagen2,  width = 30, height = 6, units = 'in', res = 300)
prp(modelo, extra=101, digits=5, branch=1, type=4, varlen=0, faclen=0)
dev.off()


process.jules.file <- function(file, level, varName) {
	print(file)
	nc = try(nc_open(file))
	if (class(nc) == "try-error") return(NULL)
	vars = names(nc$var)

	if (all(vars != varName)) {
		noFileWarning(c(), varName)
		return(NULL)
	}

	getVar <- function(var) {
		var = nc$var[[which(vars == var)]]
		dat = ncvar_get( nc, var)
		return(dat)
	}

	dat = getVar(varName)
	lat = getVar("latitude")
	lon = getVar("longitude")
	tim = getVar("time_bounds")

	l = length(lat)

	multiLayer <- function(mn, leveli = level) {
		mdat = dat[, leveli, mn]
		if (!is.null(dim(mdat)))
			mdat = apply(mdat,1 , sum)
		return(mdat)
	}

	singleLayer <- function(mn) dat[, mn]

	monthizeData <- function(mn, FUN, ...) {
		mdat = FUN(mn, ...)
		r = rasterFromXYZ(cbind(lon, lat, mdat))
		return(r)
	}

	if (length(dim(dat)) == 2 && ncol(dat) == 12) r = layer.apply(1:12, monthizeData, singleLayer)
		else if (length(dim(dat)) == 3) {
			if (varName != "landCoverFrac") {
				openWeightLayer <- function(fracLevel, varLevel) {
					frac = process.jules.file(file, fracLevel, "landCoverFrac")
					r = layer.apply(1:12, monthizeData, multiLayer, varLevel)
					frac * r / 100
				}
				ri = mapply(openWeightLayer, list(1, 2, 3:5, 6:8, 9), 1:5)
				r = ri[[1]] + ri[[2]] + ri[[3]] + ri[[4]] + ri[[5]]
			} else r = layer.apply(1:12, monthizeData, multiLayer)
		} else r = sum(rasterFromXYZ(cbind(lon, lat, dat))[[level]])

	return(r)
}


library(ggplot2)
library(geofacet)
library(broom)
library(maptools)
library(rgeos)
library(rgdal)
library(colorspace)
library(sf)
library(dplyr)
library(tidyr)

make_rt_map <- function(JOBID,  StanModel, last_date_data,
                        ext = ".png"){

  load(paste0('usa/results/', StanModel, '-', JOBID, '-stanfit.Rdata'))
  out <- rstan::extract(fit)

  percentages <- vector(length = length(states))
  percentage_group <- vector(length = length(states))
  for (i in 1:length(states)){
    dates_states <- dates[[i]]
    idx <- which(dates_states == last_date_data)
    rts <- rowMeans(out$Rt_adj[,(idx-6):idx,i])

    percentages[i] <- mean(rts < 1)

    if (percentages[i] < 0.20){
      percentage_group[i] <- 1
    } else if (percentages[i] < 0.40){
      percentage_group[i] <- 2
    } else if (percentages[i] < 0.60){
      percentage_group[i] <- 3
    } else if (percentages[i] < 0.80){
      percentage_group[i] <- 4
    } else {
      percentage_group[i] <- 5
    }
  }

  data <- data.frame("code" = states,
                     "less" = percentages,
                     "more" = 1-percentages)
  data_long <- gather(data, "key" = key, "value" = value, -code)

  # Load in shape file
  shp0 <-
    readOGR("usa/data/cb_2018_us_state_20m/cb_2018_us_state_20m.shp",
            encoding = "UTF-8",
            use_iconv = TRUE,
            stringsAsFactors = FALSE
    )
  shp0 <- spTransform(shp0, CRS=CRS("+init=epsg:26978"))

  alaska <- shp0[shp0$STATEFP=="02",]
  alaska <- elide(alaska, rotate=-39)
  alaska <- elide(alaska, scale=max(apply(bbox(alaska), 1, diff)) / 4)
  alaska <- elide(alaska, shift=c(-2400000, -1000000))
  proj4string(alaska) <- proj4string(shp0)

  hawaii <- shp0[shp0$STATEFP=="15",]
  hawaii <- elide(hawaii, rotate=-35)
  hawaii <- elide(hawaii, shift=c(5200000, -1400000))
  proj4string(hawaii) <- proj4string(shp0)

  shp0 <- shp0[!shp0$STATEFP %in% c("02", "15"),] # Remove old AK and HI
  shp0 <- rbind(shp0, alaska, hawaii) # Add in shifted AK and HI

  shp0_broom <- tidy(shp0, region = "NAME")
  df <- data.frame(shp0_broom)

  names(df) <- c("long",  "lat",   "order", "hole",  "piece", "group", "state_name")

  nam <- read.csv("usa/data/states.csv")
  names(nam) <- c("state_name", "code")
  df <- left_join(df, nam, by = "state_name")

  rt_percentage <- data.frame("code" = states,
                              "percentage" = percentages,
                              "percentage_group" = factor(percentage_group))
  df <- left_join(df, rt_percentage, by = "code")

  df = df[!df$state_name %in% c("Puerto Rico"),]
  p1 <- ggplot(data = df) +
    geom_polygon(data = df,
                 aes(x = long, y = lat, group = group, fill = percentage_group),
                 colour = "black") +
    #scale_fill_continuous_diverging(name = expression("Probability R"[t]<1),
    #                                palette = "Red-Green", mid = 0.5, na.value = "grey",
    #                                labels = scales::percent_format(accuracy = 1),limits=c(0,1)) +
    scale_discrete_manual("fill", name = expression("Probability R"[t]<1),
                          values = c("#7b3294", "#c2a5cf", "#f7f7f7", "#a6dba0", "#008837"),
                          labels = c("x < 20%", expression(paste("20%"<=" x < 40%")),
                                     expression(paste("40%"<=" x < 60%")), expression(paste("60%"<=" x < 80%")),
                                     expression(paste("x">="80%")))) +
    theme_bw() +
    theme(panel.border = element_blank(),
          panel.grid = element_blank(),
          axis.title.x = element_blank(),
          axis.title.y = element_blank(),
          axis.ticks.x = element_blank(),
          axis.text.x = element_blank(),
          axis.ticks.y = element_blank(),
          axis.text.y = element_blank(),
          axis.line = element_blank())
  print(p1)
  ggsave(paste0("usa/figures/", JOBID, "_rt_map_chloropleth", ext), p1, width = 12)

  data <- data[which(data$code != "DC"),]
  more_fifty_percent <- length(which(data$less > 0.5))
  more_ninty_five_percent <- length(which(data$less > 0.95))
  saveRDS(c(sprintf("%s", more_fifty_percent), sprintf("%s", more_ninty_five_percent)),
          paste0("usa/results/", JOBID, "-chloropleth-percentage.RDS"), version = 2)
}


#' Extract images from DynamicFire NetLogo Model saved view
#'
#' The images were saved with the NetLogo extension CSV each 30 steps (ticks) after 7200 steps
#'
#' @param fname
#' @param plot
#'
#' @return
#' @export
#'
#' @examples
extract_patch_distr_nl <- function(fname,plot=FALSE){
  #
  # Extract parameters encoded in names
  #
  ss <- data.frame(str_split(tools::file_path_sans_ext(fname),"_",simplify=TRUE),stringsAsFactors = FALSE) %>% mutate_at(2:7,as.numeric)
  plan(multisession)
  p_df <- future_lapply( 2:length(fname), function(h){

  png <- read_csv(paste0("Data/",fname[h-1]),col_names = c("i","j","value"), col_types = cols()) %>% filter(value!=55 & value!=0) %>% mutate(value= value>0)
  png1 <- read_csv(paste0("Data/",fname[h]),col_names = c("i","j","value"),  col_types = cols()) %>% filter(value!=55 & value!=0) %>% mutate(value= value>0)
  dif <- anti_join(png1,png, by=c("i","j"))
  #ggplot(dif, aes(y=i,x=j,fill=value)) +geom_raster() + theme_void()
  #ggplot(png, aes(y=i,x=j,fill=value)) +geom_raster() + theme_void()
  #ggplot(png1, aes(y=i,x=j,fill=value)) +geom_raster() + theme_void()
  if( nrow(dif)>0) {
    sm <- sparseMatrix(i=dif$i+1,j=dif$j+1,x=dif$value)
    pl <- patchdistr_sews(as.matrix(sm))
    if(plot) print(plot_distr(pl,best_only = FALSE) + ggtitle(paste("Days",ss[h,5])))

    pl <- tibble::remove_rownames(data.frame(pl))
    patch_distr <- patchsizes(as.matrix(sm))
    pl <- pl %>% mutate(max_patch = max(patch_distr),size=as.numeric(ss[h,7])*as.numeric(ss[h,8]),tot_patch=sum(patch_distr),days = ss[h,6],
                        initial_forest_density= ss[h,2], fire_probability = ss[h,3], forest_dispersal_distance = ss[h, 4],
                        forest_growth= ss[h,5]
                        )
  }
  }, future.seed = TRUE)
  plan(sequential)
  patch <- bind_rows(p_df)
  return(patch)
}

#' Evaluate patch distribution in a raster brick
#'
#' @param br raster with distribution data >0 is TRUE
#' @param returnEWS if TRUE returns the early warnings, FALSE returns the patch distribution
#'
#' @return a data frame with results
#' @export
#'
#' @examples
evaluate_patch_distr <- function(br,returnEWS=TRUE){
  if( class(br)!="RasterLayer")
    stop("Paramter br has to be a RasteLayer")
  ## Convert to TRUE/FALSE matrix
  #
  brTF <- as.matrix(br)
  brTF <- brTF>0

  # Extract Date from name of the band
  #
  brName <- str_sub( str_replace_all(names(br), "\\.", "-"), 2)

  if( returnEWS ){
    patch_distr <- patchdistr_sews(brTF)

    patch_df <- tibble::remove_rownames(data.frame(patch_distr)) %>% mutate(date=brName)
  } else {
    patch_distr <- patchsizes(brTF)
    patch_df <- tibble(size=patch_distr) %>% mutate(date=brName)

  }
  return(patch_df)
}

convert_to_sparse <- function(fire_bricks,region_name){

  future::plan(multiprocess)
  on.exit(future::plan(sequential))

  require(Matrix)
  p_df <- lapply( seq_along(fire_bricks), function(ii){

    br <- brick(paste0("Data/",fire_bricks[ii]))
    df <- future_lapply(seq_len(nbands(br)), function(x){
      brName <- stringr::str_sub( stringr::str_replace_all(names(br[[x]]), "\\.", "-"), 2)
      mm <- as.matrix(br[[x]]>0)
      message(paste(x,"-", brName ,"Suma de fuegos", sum(mm)))
      sm <- as(mm,"sparseMatrix")

      summ <- as_tibble(summary(sm))
      names(summ) <- c("i","j","data")
      summ <- summ %>% mutate(t=x,date=brName) %>% dplyr::select(t,i,j,data,date)
    })
    #yy <- str_sub(names(br)[1],2,5)
    df <- do.call(rbind,df) %>% mutate(region=region_name)
  })
  p_df <- do.call(rbind,p_df)

}


windows(width=10,height=5)
par(mar=c(5,7,1,1))
filled.contour(xx1,yy1,zz1,xlab="GC1 (min)",ylab="GC2 (sec)",col=red_blue(cstep),levels=clevels )

for (graph.i in 1:nrow(prop_coef) ){
        graph.name <- paste(rownames(prop_coef),".contour",sep="")[graph.i]
        graph.variant <- eval(parse(text=paste(graph.name)))
        level.box <- replace(graph.variant, is.nan(graph.variant),0)
        level.range <- round(quantile(level.box,c(0.005,0.995)))
        level.step <- seq(level.range[1],level.range[2],1)
        level.step

        ####Log K
        par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1,mgp=c(3, 1, 0))
        contour(xx1,yy1,graph.variant, yaxs="i",axes=FALSE,col=rainbow(graph.i),lwd=1.2,levels=level.step,labcex = 1.1)
}


#######################################
###  2010, David Ellinghaus         ###
###  2019, Florian Uellendahl-Werth ###
#######################################

rm(list=ls())

file.genome = commandArgs()[4]
inc<-10000
library("stream")
genome<-DSD_ReadCSV(file.genome,sep="",skip=1,take=c(7,8))
wng<-T
lines_n<-0
png(file=paste(file.genome, ".IBD-plot.png", sep=""), width=960, height=960)
plot(get_points(genome,n=1,outofpoints = "warn"), xlim=c(0,1.0), ylim=c(0,1.0), xlab="ZO", ylab="Z1",  pch=20, axes=F)
while (wng) {
  points_tmp<-get_points(genome,n=inc,outofpoints = "ignore")
  points(points_tmp, xlim=c(0,1.0), ylim=c(0,1.0), pch=20)
  if(dim(points_tmp)[1]==0){wng<-F}
  lines_n<-lines_n+inc
  print(lines_n)
  flush.console()
}

axis(1, at=seq(0,1.0,0.2), tick=T)
axis(2, at=seq(0,1.0,0.2), tick=T)
dev.off()


#########################################
#Splinter et al. 2012 Methods
#Supplemental R script
#
#Within code is contained that can generate spider plots.

#dummy example
#> source("spider_plots.R")
#> x1 <- seq(0,110e6, by=10e6)
#> x2 <- seq(0,110e6, by=10e6)+2e6
#> makeSpiderGramSingle(dom=cbind(x1,x2), chrom.len=150e6, vp.loc=130e6, col=rgb(0,0,1))

#The genes you have to add your self since these are different for every species and chromosome.

#written by Elzo de Wit (2012)
#mail: e.wit@hubrecht.eu
#Hubrecht Institute
#Utrecht, the Netherlands
#########################################

#draw a tubular shaped chromosome
drawChrom <- function(chrom.len = 50e6, max.wid = 100e6, hei=10, chrom.wid=1, y.loc=5){
	r <- seq(0,2*pi, len=1000)
	chrom.wid = chrom.wid/2

	dim.val <- par("din")
	left  <- r[501:1000]
	right <- r[1:500]

	correction <- ((max.wid*chrom.wid)/(2*hei)) / (dim.val[1]/dim.val[2])

	x <- sin(left)*correction + correction
	y <- cos(left)*chrom.wid+y.loc

	x1 <- x
	y1 <- y

	x <- c(x, sin(right)*correction+chrom.len -correction)
	y <- c(y, cos(right)*chrom.wid+y.loc )

	x2 <- sin(right)*correction+chrom.len -correction
	y2 <- cos(right)*chrom.wid+y.loc
	polygon(x,y, col='white')

	col.seq <- seq(0.5,1,len=250)
	col.seq <- c(col.seq,rev(col.seq))
	cols <- rgb(col.seq,col.seq,col.seq)
	segments(x1,y1,x2,rev(y2), col = cols)
	polygon(x,y, lwd=2)

}

#function for drawing two chromosomes
drawLocalChrom <- function(labels=c("Xa","Xi"), yloc1 = 3, yloc2 = 5, wid = 2, num.chrom=1, chrom.len){
	plot(c(0,chrom.len), c(yloc1-wid,yloc2+wid), type='n', axes=F, xlab="chromosomal location", ylab="", cex.lab=1)

	mb <- floor(chrom.len/1e6)
	mb10 <- floor(mb/10)*10
	#draw an axis
	label <- c(seq(0,mb10, by=10),mb)
	segments(label*1e6, -1e9, label*1e6, 1e9, lwd=2, lty=2, col='grey90')
	mid.y <- (yloc1+yloc2)/2
	segments(label*1e6, mid.y-0.15, label*1e6, mid.y+0.15, lwd=2)
	segments(0, mid.y, mb*1e6, mid.y, lwd=2)

	#active X
	if(num.chrom==2){
		drawChrom(chrom.len=chrom.len, max.wid=chrom.len, y.loc=yloc1)
		text(-1e6,yloc1, labels[2],cex=1)
	}
	#inactive X
	drawChrom(chrom.len=chrom.len, max.wid=chrom.len, y.loc=yloc2)

	text(-1e6,yloc2, labels[1],cex=1)
	at <- 0:mb
	axis(1, at=at*1e6, labels=NA, cex.axis=1, lwd=1,las=1)
	axis(1, at=label*1e6, labels=label, cex.axis=1, lwd=2,las=1)
	axis(3, at=at*1e6, labels=NA, cex.axis=1, lwd=1,las=1)
	axis(3, at=label*1e6, labels=label, cex.axis=1, lwd=2)
}

#draw the splines showing the interactions
drawSplines.domain <- function( dom, vp.loc, y.base, y.arc, plot=F, col='black', chrom.size=166e6, relative=F){
	if(nrow(dom) == 0)
		return
	for(i in 1:nrow(dom)){
		#start <- min(dom[i,1], dom[i,2])
		#end <- max(dom[i,1], dom[i,2])
		start <- dom[i,1]
		end <- dom[i,2]
		xspline(c(vp.loc, (end + vp.loc)/2, end, start, (end + vp.loc)/2, vp.loc), c(y.base,y.arc,y.base,y.base,y.arc,y.base), open=F, shape=c(0,1,0,0,1,0), col=col, border=col)
	}
}

#dom:       matrix or data.frame with two columns, start and end position of the interactions
#vp.loc:    the position of the viewpoint
#color:     color of the interaction splines
#gene:      data.frame containing the columns for the start, end and strand of gene
#labels:    what should be put on the left side of the plot
#chrom.len: the length of the chromosome

makeSpiderGramSingle <- function( dom, vp.loc, color='black', gene="", labels=c(""), chrom.len ){

	#draw two chromosomes
	drawLocalChrom( labels = labels, num.chrom=1, chrom.len = chrom.len )

	#and the splines
	drawSplines.domain(dom, vp.loc=vp.loc, plot=F, relative=F, y.arc=8, y.base=5.5, col=color)

	#draw the genes
	if(! is.null(nrow(gene))){
		gene <- gene[gene[,2]-gene[,1] < 2e5,]
		rect(gene[,1],5, gene[,2], ifelse(gene[,3]=='+',5.5,4.5), col='black')
	}

}


guess.with.cheat <- function(n = 1000, cheat = 0.01){
  # Guess game: guess a number between 1 and n

  # generate random number between 1 and n
  num <- as.integer(runif(1, 1, n))
  # save guess history
  guess.log <- c()
  # input the number
  guess.input <- function(){
    guess.num <- suppressWarnings(
      as.integer(readline("guess an integer: "))
      )
    # check the input
    while (is.na(guess.num) | guess.num < 1 | guess.num > n) {
      cat("Input Error\n",
          "Please input an integer between 1 to", n, "!\n\n")
      guess.num <- suppressWarnings(
        as.integer(readline("Guess an integer: "))
        )
    }
    return(guess.num)
  }

  # Start game information
  cat("Guess Game\n\n")
  cat("Guess an integer from 1 to", n, ".\n\n")

  # guessing...
  guess.num <- guess.input()
  # log the guess number
  guess.log <- c(guess.log, guess.num)

  while (guess.num != num) {
    # do not get the right number
    if (guess.num < num) {
      cat("Too Small !")
    } else {
      cat("Too large !")
    }
    guess.num <- guess.input()
    guess.log <- c(guess.log, guess.num)
  }

  # get the right number !
  cat("Bingo ! You got the number", num, "in", length(guess.log), "time(s) !")
  # plot the guess log
  plot(guess.log, main = "Guess log", type = "b",
       ylim = c(1, n), ylab = "guess number")
}