rm(list = ls())

wd.main <- 'C:/Users/gbal/Desktop/r.training'
setwd(wd.main)

salmon <- read.table('2.data/2.salmon/salmon.data.raw.2.txt',
                     header = TRUE,
                     sep = ';',
                     dec = ',')

head(salmon)

salmon$weight[which(salmon$weight > 50)] <-
  salmon$weight[which(salmon$weight > 50)] / 1000

salmon$length[which(salmon$length < 44)] <-
  salmon$length[which(salmon$length < 44)] * 2.54

# 5.1.1 ============================================================

# Plot length Vs weight of sea.age = 1 fish from Moy river

#salmon$sea.age == 1 & salmon$river == 'moy'
plot(x = salmon$weight[salmon$sea.age == 1 & salmon$river == 'moy'],
     y = salmon$length[salmon$sea.age == 1 & salmon$river == 'moy'])

# option 2
idx.a1.moy <- salmon$sea.age == 1 & salmon$river == 'moy'
plot(x = salmon$weight[idx.a1.moy],
     y = salmon$length[idx.a1.moy])

#option 3
salmon.subset <- salmon[idx.a1.moy, ]
plot(salmon.subset$weight,
     salmon.subset$length)

#Histogram weight of fish from Ireland
hist(salmon$weight[salmon$country == 'ie'])
hist(salmon$weight[salmon$river %in% c('moy', 'corrib')],
     xlab = 'Weight (kg)',
     main = 'Weight Ireland',
     col = 'pink',
     breaks = seq(from = 0, to = 20, by = .1))

#Boxplot of weight with a box per year
boxplot(salmon$weight ~ salmon$river.age * salmon$year, outline = FALSE)

#Save some of your graphics
pdf(file = 'my.first.pdf.pdf',
    useDingbats = FALSE)
#jpeg(file = 'graph.2.jpg') # here save only last one
boxplot(salmon$weight ~ salmon$river.age * salmon$year, outline = FALSE)
plot(salmon$weight)
dev.off()

#Barplot number of fish per year (contengency table)
barplot(table(salmon$year))

#Matplot number fish per river per year (if time)

# 5.2.1 =======================================================

ixd <- salmon$river == 'corrib' #&
plot(salmon$weight[ixd],
     salmon$length[ixd],
    # ylim = c(60, 90),
    # xlim = c(2, 5),
     pch = 16,
     cex = .5,
    col = salmon$sea.age[ixd])

legend(
  'topleft',
  legend = sort(unique(salmon$sea.age[!is.na(salmon$sea.age)])),
  col = sort(unique(salmon$sea.age[!is.na(salmon$sea.age)])),
  pch = 16
  )

# 5.3.1 ===========================================================

#use x11() to create new graph windows
#x11()

pdf('multi.plot.pdf', useDingbats = FALSE)

#Use argument mfrow of par() to allow for 3 graphics
par(mfrow = c(1, 3))

#Use argument oma of par() to make really small outer margins
#Add 3 graphics on the figure panel (your choice)
par(oma = c(1, 1, 1, 18), mar = c(1, 1, 1, 1))
barplot(table(salmon$year))
barplot(table(salmon$river))
par(mar = c(4, 4, 4, 4))
barplot(table(salmon$sea.age))

#Save that panel as a .pdf file
dev.off()


#!/usr/bin/Rscript

# process fimo.txt from fimo output

## assumptions: 1) the motifs are string and not a pwm which gives same score for every match. 2) the motifs can overlap then weighted score is reported.

options(warn=1)

args <- commandArgs(trailingOnly=T)

data = read.table(args[1], header = F)

pos = read.table(args[2], header= F)

colnames(pos) = c("chrom", "start", "end")

pos[,"id"] = paste0(pos$chrom, ":", pos$start, "-", pos$end )

colnames(data) = c("pattern_name", "sequence_name", "start", "stop", "strand", "score", "p-value", "q-value", "matched_sequence")

motifs = as.character(unique(data[,"pattern_name"]))

output = data.frame()  # make an N by 3 dataframe, where N is the number of cases in the dataset fed to fimo.

output = data.frame(matrix(vector(), nrow(pos), 0), stringsAsFactors=F)

rownames(output) = pos$id  # maybe convert to list

names = list()

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

	names = c(names, paste0(motifs[i], "_presence"), paste0(motifs[i], "_count"), paste0(motifs[i], "_score_weighted"))
}

#colnames(output) = names

for (col in names){

	output[,col] = 0

}

for (mot in motifs){

	instances = as.character(unique(data[which(data$pattern_name == mot),"sequence_name"]))

	for (ins in instances){

		insDf = data[which(data$sequence_name == ins & data$pattern_name == mot),]

		insDf = insDf[order(insDf$start),]  ## sort by start

		output[ins, paste0(mot, "_presence")] = 1

		count= 1 # number of non-overlapping motifs

		insDf_idx =c(1)  # non-ov motif start location per instance.

		if (nrow(insDf) > 1){

			for (i in 1:(nrow(insDf)-1)){

				# non-overlap
				if (insDf[i, "stop"] < insDf[(i+1), "start"]){

					count = count +1

					insDf_idx = c(insDf_idx, i+1)

				}
			}
		}

		ov_size = 0

		for (m in 1:length(insDf_idx)){ # for each non-ov motif

			first_loc = insDf[insDf_idx[m], "start"]

			if (m == length(insDf_idx)){

				last_loc = insDf[nrow(insDf), "stop"]

			} else {

				last_loc = insDf[(insDf_idx[m+1]-1), "stop"]

			}

			ov_size = ov_size + (last_loc - first_loc +1) # total size where motifs covered.

			motif_score = insDf[1,"score"]

			motif_size = length(mot)

			unit_score = motif_score / motif_size

			weighted_score = unit_score * ov_size

			# assume all the scores are same due to stricht motif search (i.e. not the pwm but search the string)

	  	}

		output[ins, paste0(mot, "_count")] = count

		output[ins, paste0(mot, "_score_weighted")] = weighted_score

	}

}

write.table(output, args[3], sep="\t", quote=F, row.names=T, col.names=T)


#  James Rekow

subgroupVecMatcher = function(subgroupVec1, subgroupVec2){

  #  ARGS: subgroupVec1 - a numeric vector whose ith element is the subgroup to which sample i belongs,
  #                       where sample i is an element of a set A
  #        subgroupVec2 - another vector of the same form as subgroupVec1, corresponding to the same set A
  #
  #  RETURNS: subgroupVec2Ordered  - subgroupVec2 with the values permuted so as to minimize the number of
  #                                  differences between subgroupVec1 and subgroupVec2

  #  TODO: add a method argument with two options, Jaccard index, and misallocated elements

  library(gtools)

  #  number of subgroups in subgroupVec2
  numSubgroups2 = max(subgroupVec2)

  #  list which indices correspond to each subgroup
  subgroupIxList = lapply(as.list(1:numSubgroups2), function(ii) as.numeric(subgroupVec2 == ii))

  #  create a matrix whose rows are the permutations of 1:numSubgroups 2
  permutationMat = permutations(n = numSubgroups2, r = numSubgroups2)

  createSubgroupVec = function(perm){

    #  ARGS: perm - numeric vector that is a permutation of 1:numSubgroups2
    #
    #  RETURNS: permSubgroupVec2 - subgroup created by permuting the values of subgroupVec2 according to
    #                              perm

    #  compute the elements of the permutation in each subgroup
    permSubgroupVec2List = lapply(as.list(1:numSubgroups2), function(ii) perm[ii] * subgroupIxList[[ii]])

    #  combine values to create the permuted subgroup vector
    permSubgroupVec2 = Reduce("+", permSubgroupVec2List)

    return(permSubgroupVec2)

  } #  end createSubgroupVec function

  computeSubgroupDiff = function(perm){

    #  ARGS: perm - numeric vector that is a permutation of 1:numSubgroups2
    #
    #  RETURNS: subgroupDiff - number of differences between subgroupVec1 and the given permutation
    #                          of the values of subgroupVec2. All of the values of i in subgroupVec2
    #                          are replaced by perm[i]

    #  create subgroup corresponding to input permutation of values of subgroupVec2
    permSubgroupVec2 = createSubgroupVec(perm)

    #  compute number of differences between the given permutation of values of subgroupVec2 and
    #  subgroupVec1
    subgroupDiff = sum(subgroupVec1 != permSubgroupVec2)

    return(subgroupDiff)

  } #  end computeSubgroupDiff function

  #  compute the number of differences between subgroupVec1 and each permutation of values of subgroupVec2
  subgroupDiffs = apply(permutationMat, 1, computeSubgroupDiff)

  #  find the row number of the permutation that gives the minimum number of subgroup differences
  minDiffIx = which.min(subgroupDiffs)

  #  identify optimal permutation of values of subgroupVec2
  optimalPerm = permutationMat[minDiffIx, ]

  #  create optimal permutation of values of subgroupVec2
  subgroupVec2Ordered = createSubgroupVec(optimalPerm)

  return(subgroupVec2Ordered)

} #  end subgroupVecMatcher function


library(datasets)
library(shiny)
library(dygraphs)
library(xts)
library(shinythemes)

Node_383 <- read.csv(file="Node383.csv", header = TRUE)# read csv file
Node_384 <- read.csv(file="Node384.csv", header = TRUE, skip =15)# read csv file
Node_573 <- read.csv(file="Node573.csv", header = TRUE, skip =15)# read csv file
Node_574 <- read.csv(file="Node574.csv", header = TRUE, skip =15)# read csv file

shinyUI(fluidPage(theme = shinytheme("cerulean"),

  ## Application title
  titlePanel(title = h2("Data Analysis and Visualisation", align = "center")),

  ## Sidebar with a slider input for number of observations

  sidebarPanel (

    radioButtons(
      inputId="radio",
      label="Selection a Node:",
      choices=list(
        "Node_383" = "Node_383",
        "Node_384" = "Node_384",
        "Node_573" = "Node_573",
        "Node_574" = "Node_574"),
      selected="Node_383"),
    fileInput("file","upload a file"),
    helpText("Max. file size is 5MB"),

    uiOutput("datasize"),

    dateInput('date_start',label = 'Start Date',"2015-03-27",format = "yyyy-mm-dd"),#start = Sys.Date() - 2, end = Sys.Date() + 2),
    dateInput('date_end',label = 'End Date',"2015-03-27",format = "yyyy-mm-dd"),
    textInput("time_start","Start Time", "13:16:01"),
    textInput("time_end","End Time", "13:17:01"),
    helpText("Please enter in the format 'HH:MM:SS' for start and end time"),

    width=2

  ),

  ## Show a plot of the generated distribution

  mainPanel(
    tabsetPanel(type="tab",
                #tabPanel("test",uiOutput("button"), textOutput("button_text")),
                tabPanel("Summary", h4(textOutput("dataname")),uiOutput("choose_plot"), plotOutput("plot_raw")),
                tabPanel("Data",downloadButton("data_down","Download Data (.csv file)"), tableOutput("data")),
                tabPanel("Statistics",h4(textOutput("samplesize")), verbatimTextOutput("stats"), uiOutput("raw_data"), h3(textOutput("st_text")), h5(textOutput("st_test")), plotOutput("plot_temp")),
                tabPanel("Similarity Measures",
                         helpText("Identify the model of the simulated data using the correlograms, the",
                                  strong("Autocorrelation Function"), "(ACF), ",
                                  strong("Crosscorrelation Function"), "(CCF) and the",
                                  strong("Partial Autocorrelation Function"), "(PACF).",
                                  br(),br()),
                         tabsetPanel(type = "tab",
                                     tabPanel("ACF",
                                              fluidRow (style= "padding-bottom: 20px",
                                                        column(3, uiOutput("acf_data")),
                                                        column(3, numericInput("acf_lag","TimeLag", 4 , min=2, max =50)),
                                                        column(3, radioButtons(
                                                          inputId="acf_options",label="Operations",
                                                          choices=c("Auto Covariance" = "covariance",
                                                                    "Auto Correlation"= "correlation",
                                                                    "partial Auto Correlation" ="partial"),
                                                          selected="covariance"))),
                                              fluidRow(plotOutput("plot_acf"))),
                                     tabPanel("CCF",
                                              fluidRow (style= "padding-bottom: 20px",
                                                        column(3, uiOutput("ccf_data1")),
                                                        column(3, uiOutput("ccf_data2")),
                                                        column(3, numericInput("ccf_lag","TimeLag", 4 , min=2, max =50)),
                                                        width=2),
                                              fluidRow(plotOutput("plot_ccf")))
                                          )),
                tabPanel("Regression analysis",
                         fluidRow(style= "padding-bottom: 20px",
#                                   column(3,actionButton(inputId="coef_test", label="Coefficient testing"),tableOutput("coef_table")),
                                  column(3,uiOutput("reg")),
                                  column(3,uiOutput("reg_data")),
                                  column(3, uiOutput("reg_options"))),
fluidRow(actionButton(inputId="coef_test", label="Coefficient testing"),tableOutput("coef_table")),

                         fluidRow(plotOutput("plot_reg"), downloadButton(outputId="down",label="Download Plot"))),
                tabPanel("Filters", fluidRow (style= "padding-bottom: 20px",
                                              column(3, uiOutput("filter_data")),
                                              column(3, uiOutput("filter_args")),
                                              column(3, radioButtons(
                                                inputId="filter_options",label="Operations",
                                                choices=c("Moving Average" = "MA",
                                                          "Spline"= "SP"#," Kalman" ="Kalman"
                                                          ),
                                                selected="MA"))),
                         fluidRow(plotOutput("plot_filter"))),
                tabPanel("Information",
                         #---function definition---#
                         h2("Function Definitions", align="center"),
                         h3("Correlation coefficient"),
                         p("Input:   timestamp (t), data (y)"),
                         code("Formula: r=(1/n)*(sum((t-t_mean).*(y-y_mean)))/(st*sy)"),
                         p("Output: -> 1 value: correlation coefficient r",br(),"-> 5 values: Correlation coefficient r, mean_x, mean_y, sx, sy"),
                         h3("Stationarity test"),
                         p("Input:   	-> Only data of a time series",br(),
                           "-> Desired number of intervals"),
                         code("Formula: interval=round(length(data)/i)"),
                         p("Output: 2 String-values- Hypothesis test result for T-Test and F-Test (Null-hypothesis failed to reject - Time series is stationary or Null-hypothesis rejected - Time series is not stationary)"),
                         h3("Auto Covariance and Corelation"),
                         p("Input:  	Time Series with timestamp (t) and data (y)"),
                         code("Formula: acf=zeros(round(n/4)+1,2)"),
                         p("Output: -> A shorter time series with time intervals (not time stamps) in t and auto covariance values in y"),
                         h3("Cross Corelation"),
                         p("Input:    2 Time Series with timestamp (t)(must be of same length) and data (y)"),
                         code("Formula: tau=round(length(t)/4)"),
                         p("Output: -> Cross correlation function with Lags-column and XCF-column",br(),"-> Time shifted version of second time series with data column y and corrected time-value column t_shift"),
                         h3("Regressions"),
                         p("Input:    Time Series with timestamp (t) and data (y)"),
                         h3("Moving Average"),
                         h3("Event Detection"),
                         a("http://shiny.rstudio.com/tutorial/lesson2/"))
                         ),width=9
  )
)

)


# Source: https://blogs.rstudio.com/tensorflow/posts/2017-12-14-image-classification-on-small-datasets/
# Source: Chollet & Allaire, 2017 - https://github.com/fchollet & https://github.com/jjallaire
# Data: https://www.kaggle.com/c/dogs-vs-cats/data

library(keras)

# Set dirs
base_dir <- "~/data/cats_and_dogs_small"
train_dir <- file.path(base_dir, "train")
validation_dir <- file.path(base_dir, "validation")
test_dir <- file.path(base_dir, "test")
train_cats_dir <- file.path(train_dir, "cats")
train_dogs_dir <- file.path(train_dir, "dogs")
validation_cats_dir <- file.path(validation_dir, "cats")
validation_dogs_dir <- file.path(validation_dir, "dogs")
test_cats_dir <- file.path(test_dir, "cats")
test_dogs_dir <- file.path(test_dir, "dogs")

# Load VGG16 model

conv_base <- application_vgg16(
  weights = "imagenet",
  include_top = FALSE,
  input_shape = c(150, 150, 3)
)
summary(conv_base)

model <- keras_model_sequential() %>%
  conv_base %>%
  layer_flatten() %>%
  layer_dense(units = 256, activation = "relu") %>%
  layer_dense(units = 1, activation = "sigmoid")

summary(model)
length(model$trainable_weights)

freeze_weights(conv_base)
length(model$trainable_weights)

####################################################################
# Train model

train_datagen = image_data_generator(
  rescale = 1/255,
  rotation_range = 40,
  width_shift_range = 0.2,
  height_shift_range = 0.2,
  shear_range = 0.2,
  zoom_range = 0.2,
  horizontal_flip = TRUE,
  fill_mode = "nearest"
)

# Note that the validation data shouldn't be augmented!
test_datagen <- image_data_generator(rescale = 1/255)

train_generator <- flow_images_from_directory(
  train_dir,                  # Target directory
  train_datagen,              # Data generator
  target_size = c(150, 150),  # Resizes all images to 150 × 150
  batch_size = 20,
  class_mode = "binary"       # binary_crossentropy loss for binary labels
)

validation_generator <- flow_images_from_directory(
  validation_dir,
  test_datagen,
  target_size = c(150, 150),
  batch_size = 20,
  class_mode = "binary"
)

model %>% compile(
  loss = "binary_crossentropy",
  optimizer = optimizer_rmsprop(lr = 2e-5),
  metrics = c("accuracy")
)

history <- model %>% fit_generator(
  train_generator,
  steps_per_epoch = 100,
  epochs = 30,
  validation_data = validation_generator,
  validation_steps = 50
)

summary(conv_base)

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

# Fine tune model
unfreeze_weights(conv_base, from = "block3_conv1")

model %>% compile(
  loss = "binary_crossentropy",
  optimizer = optimizer_rmsprop(lr = 1e-5),
  metrics = c("accuracy")
)

history <- model %>% fit_generator(
  train_generator,
  steps_per_epoch = 100,
  epochs = 100,
  validation_data = validation_generator,
  validation_steps = 50
)

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

test_generator <- flow_images_from_directory(
  test_dir,
  test_datagen,
  target_size = c(150, 150),
  batch_size = 20,
  class_mode = "binary"
)

model %>% evaluate_generator(test_generator, steps = 50)


#------- Time windows creation.

# 1. get data and group variables- calculate MAXTIME

Mins <- MIN_data
Mins$animal_ID = as.character(Mins$animal_ID)

source ("Rcode/grouping_variables.r")

# calculate maxtime where all mice have data (time relative to light off), rounded
temp =Mins %>% group_by(ID)%>% summarise(max(bintodark))
MAXTIME=trunc(min (temp$`max(bintodark)`)/6)/10

#2 create table of time window in minutes

#2.1 calculate lenght of the day from the metadata:
LIGHT_ON = (as.numeric(strsplit(format(metadata$light_on,"%H:%M:%S"),split = ':')[[1]][1])*60)+
  as.numeric(strsplit(format(metadata$light_on,"%H:%M:%S"),split = ':')[[1]][2])
LIGHT_OFF = (as.numeric(strsplit(format(metadata$light_off,"%H:%M:%S"),split = ':')[[1]][1])*60)+
  as.numeric(strsplit(format(metadata$light_off,"%H:%M:%S"),split = ':')[[1]][2])
daylenght =(LIGHT_OFF-LIGHT_ON)/60
nightlenght = 24-daylenght

#2.2 create table: single elements:
T1 = c("Bin", 0,2,"first 2 hours of recording") # 2 first hours of recording
T2= c("Bintodark", -2,0, "last 2h before night") # last 2h before light off
T3 = c("Bintodark", 0,3, "first 3h of night") # early night
T35 =c("Bintodark", 3,nightlenght-3, "middle night") #middle night
T4 = c("Bintodark", nightlenght-3,min ((nightlenght),MAXTIME), "late night (3h)") # late night
#T5 = c("Bintodark", 12,15) # early day 2
T5 = c("Bintodark", nightlenght,min ((nightlenght+3),MAXTIME),"early day(3h)") # early day 2: 3h or maximal time with all mice included

T6= c("Bintodark", -2,min ((nightlenght+3),MAXTIME), "full recording")
T7 = c("lightcondition", "DAY",NA, "daytime")
T8 = c("lightcondition", "NIGHT", NA, "nighttime")

#2.3 put the table together

#create table with numeric values, values being in minutes
#Timewindows = data.frame(rbind(T1,T2,T3,T4,T5)) #original split
Timewindows = data.frame(rbind(T1,T2,T3,T35,T4,T5,T6))
#if (MAXTIME<daylenght) Timewindows = data.frame(rbind(T1,T2,T3,T35,T4))
colnames (Timewindows) = c("time_reference", "windowstart", "windowend", "windowname")
Timewindows$time_reference = as.character(Timewindows$time_reference)
Timewindows =Timewindows %>%
  mutate (windowstart = 60*as.numeric (as.character(windowstart)))%>%
  mutate (windowend = 60*as.numeric (as.character(windowend)))
Timewindows = data.frame(rbind(Timewindows,T7,T8))

# erase non-existing time windows (example nightlenght < 6, no middle night)
Timewindows = Timewindows %>% filter ( is.na(windowend) | windowstart < windowend )


# R script.
# has one main function

cat("SOURCING PERFREPORT SCRIPT\n")

require(xts)
require(quantmod)
require(fBasics)
require(PerformanceAnalytics)

p <- function(fileName, folder="./", prefix="", cw = 800, ch = 600){
	png(paste(folder, prefix, fileName, ".png", sep=""), width=cw, height=ch)
}

# target resolution must be any of:
# RAW, 1m, 1h, 1d, 1w, 1M
analysis <- function(seriesCsvFile="/home/ustaudinger/work/activequant/trunk/reports2/pnl.csv", fileType="PNL", targetResolution="EOD", targetFolder="./", chartWidth=800, chartHeight=600){
	browser()
	pnlData = read.csv(seriesCsvFile)
	# convert pnl data to xts
	if(length(pnlData)==0){
		cat("No PNL data \n");
		return;
	}
	nCols = length(pnlData[1,])
	pnlData = xts(pnlData[,3:nCols],as.POSIXct(pnlData[,1] / 1000000000, origin="1970-01-01"))

	# as we have made an XTS object out of it, we have now one column less.
	nCols = length(pnlData[1,])
	# create a colour palette
	colors = rainbow(nCols)

	# read transaction numbers
	transactionCount = read.csv(paste(targetFolder, "transactionCount.properties", sep=""), sep="=")
	cat("Loaded transaction count\n")
	#
	config = read.csv(paste(targetFolder, "/report.config", sep=""), sep="=")
	rownames(config) = config[,1]
	cat("Loaded config\n")
	#
	characteristics = data.frame();

	# rs closes ..
	rsCloses = xts()

	# resample pnlData to the specified resolution
	for(i in 1:nCols){
		columnName = colnames(pnlData)[i]
		cat("Processing ", columnName, "\n")

		# raw requires no action
		rsPnl = pnlData[,i]
		formerPeriod = -1;
		formerValue = pnlData[1,i];
		#
		if(targetResolution=="MINUTES_1"){
			rsPnl = to.minutes(pnlData[,i], 1)
			formerPeriod = as.POSIXlt(index(rsPnl)[1], origin="1970-01-01")
			formerPeriod$min = formerPeriod$min - 1
		} else if(targetResolution=="HOURS_1"){
			rsPnl = to.hourly(pnlData[,i])
			formerPeriod = as.POSIXlt(index(rsPnl)[1], origin="1970-01-01")
			formerPeriod$hour = formerPeriod$hour - 1
		} else if(targetResolution=="EOD"){
			rsPnl = to.daily(pnlData[,i], drop.time=TRUE)
			formerPeriod = as.POSIXlt(index(rsPnl)[1], origin="1970-01-01")
			formerPeriod$yday = formerPeriod$yday - 1
		}
		colnames(rsPnl) <- c("Open","High","Low", "Close")
		#if(formerPeriod!=-1){
			## append it.
		#	newRow = xts(cbind(formerValue,formerValue,formerValue,formerValue), formerPeriod, tzone="")
		#	colnames(newRow) <- c("Open","High","Low", "Close")
		#	rsPnl = rbind(newRow, rsPnl)
		#}

		# merge the rs close value into the outer rs values object.
		rsCloses = merge(rsCloses, rsPnl[,4])
		colnames(rsCloses)[length(rsCloses[1,])] = columnName

		# generate candle chart
		p(columnName, folder=targetFolder, prefix=paste(fileType,"_CANDLE_", sep=""), cw=chartWidth, ch=chartHeight)
		#browser()
		candleChart(rsPnl, name=columnName, theme="white", TA="addEMA()")
		dev.off()
		# generate a plain line chart.
		p(columnName, folder=targetFolder, prefix=paste(fileType, "_LINE_", sep=""), cw=chartWidth, ch=chartHeight)
		lineChart(rsPnl[,4], name=columnName, theme="white", TA="addEMA()")
		dev.off()

		# generate return statistics

		absReturns = diff(rsPnl[,4])
		# replace NAs.
		absReturns[is.na(absReturns)] = 0

		p(columnName, folder=targetFolder, prefix=paste(fileType, "_HIST_", sep=""), cw=chartWidth, ch=chartHeight)
		hist(absReturns, col="gray", main=paste("Histogram of ",fileType," (", columnName, ")", sep=""))
		dev.off();

		p(columnName, folder=targetFolder, prefix=paste(fileType, "_QQ_", sep=""), cw=chartWidth, ch=chartHeight)
		z.norm <- (absReturns - mean(absReturns))/sd(absReturns)
		qqnorm(z.norm, main=paste("Normal QQ Plot of ", fileType, " (", columnName, ")", sep=""))
		abline(0,1)
		dev.off()

		# calculate some curve specific parameters
		characteristics["skewness", columnName] = skewness(absReturns)
		characteristics["kurtosis", columnName] = kurtosis(absReturns)

		characteristics["startCash", columnName] = as.double(first(rsPnl)[,1])
		finPnl = as.double(last(rsPnl)[,4])
		characteristics["finalValue", columnName] = finPnl
		characteristics["transactions", columnName] = transactionCount[columnName,1]
		characteristics["pnl per transaction", columnName] = transactionCount[columnName,1]/finPnl
		characteristics["maxValue", columnName] = max(rsPnl)
		characteristics["minValue", columnName] = min(rsPnl)
		characteristics["meanAbsRetPerPeriod", columnName] = mean(absReturns)

		if(!is.na(config[paste(columnName, ".START", sep=""),2])){
			startCap = config[paste(columnName, ".STARTCAP", sep=""),2]
			startCap = as.double(as.matrix(startCap))
			characteristics["startCap", columnName] = startCap
			# calculate the performance
			absGainOverStartCap = diff(pnlData[,columnName])/startCap
			monthlyGains = table.CalendarReturns(absGainOverStartCap)
			write.csv(monthlyGains, paste(targetFolder, "/", fileType, "_", columnName, "_TABULARRETS.csv", sep=""))

		}

		#browser()
	}
	# generate an aggregated chart with all rs closes on it.
	p("AGGREGATION", folder=targetFolder, prefix=paste(fileType, "_", sep=""), cw=chartWidth, ch = chartHeight)
	for(i in 1:nCols){
		columnName = colnames(rsCloses)[i]
		cat("Processing rs close for ", columnName, "\n")
		if(i==1){
			plot(rsCloses[,i], type="l", main="Comparison of value series", ylim=c(min(rsCloses),max(rsCloses)))
			par(xpd=TRUE)
			legend("topleft", legend=colnames(rsCloses), fill = colors)

		}
		else{
			lines(rsCloses[,i],col=colors[i])
		}
	}
	dev.off()
	# write the characteristics
	write.csv(characteristics, paste(targetFolder, "/", fileType, "_characteristics.csv", sep=""))
}

# see http://stackoverflow.com/questions/2151212/how-can-i-read-command-line-parameters-from-an-r-script
args <- commandArgs(trailingOnly = TRUE)
print(args)

currentwd = getwd()
setwd(args[3])

analysis(seriesCsvFile=args[1], targetFolder=args[3],targetResolution=args[4], fileType="PNL")
analysis(seriesCsvFile=args[2], targetFolder=args[3],targetResolution=args[4], fileType="CASH");

pnl = read.csv("pnl.csv")
fees = read.csv("fees_resampled_to_timeframe.csv")
interest = read.csv("interest.csv")
refrates = read.csv("refrates.csv")

nCols1 = length(pnl[1,])
nCols2 = length(fees[1,])
nCols3 = length(interest[1,])
nCols4 = length(refrates[1,])

xpnl = xts(pnl[,3:nCols1],as.POSIXct(pnl[,1] / 1000000000, origin="1970-01-01"))
xfees = xts(fees[,3:nCols2],as.POSIXct(fees[,1] / 1000000000, origin="1970-01-01"))
colnames(xfees)=colnames(fees)[3:ncol(fees)]

xinterest = xts(interest[,3:nCols3],as.POSIXct(interest[,1] / 1000000000, origin="1970-01-01"))
colnames(xinterest)=colnames(interest)[3:ncol(interest)]

xrefrates = xts(refrates[,3:nCols4],as.POSIXct(refrates[,1] / 1000000000, origin="1970-01-01"))
colnames(xrefrates)=colnames(refrates)[3:ncol(refrates)]

pnlCols = colnames(pnl)
refratesCols= colnames(xrefrates)
processPnlCol <- function (i) {
  inverted1 = FALSE
  inverted2 = FALSE
  columnToBeUsed = -1
  #
  colname = substring(pnlCols[i], 4)
  # have to find the target ref rate to convert to USD
  quotee = substring(colname, 4)
  if (quotee == "USD") {
    conversionRate = 1.0;
    columnToBeUsed = -2
    cat("Not converting a USD rate. \n")
  }
  else {
    # check all the xrefrate columns if we can use one.
    for(j in 1:ncol(xrefrates)){
      refratecol = refratesCols[j]
      refratecol = substring(refratecol, 4)
      cat("- Checking ", refratecol, "\n")
      base_ = substring(refratecol, 1,3)
      quotee_ = substring(refratecol, 4)
      if (base_== "USD") {
        # ok, possible target ...
        if (quotee_ == quotee) {
          inverted1 = TRUE
          columnToBeUsed = j
          cat("Have to invert first, ", columnToBeUsed, "\n")
          break
        }
      } else if (quotee_ == "USD") {
        # ok, possible target ...
        if (base_ == quotee) {
          columnToBeUsed = j
          cat("Have to invert none, ", columnToBeUsed, "\n")
          break
        }
      }
    }
  }
  return(c(columnToBeUsed, inverted1, inverted2))
}

nCols5 = ncol(xpnl)
pnlCols = colnames(xpnl)

convertedPnl = xts()
for(i in 1:nCols5){
  columnToBeUsed = -1
  inverted1 = FALSE
  inverted2 = FALSE
  columnName = pnlCols[i]
  cat("I: ", i, "--> " , columnName, "\n")
  if(pnlCols[i]=="TOTAL"){
    cat("Not converting a total. \n")
  }
  else{
    x1 = processPnlCol(i)
    columnToBeUsed = x1[1]
    inverted1 = x1[2]
    inverted2 = x1[3]
    pnlColumn = xpnl[,i]
    print(x1)
    if(columnToBeUsed==-1){
      cat("Can't convert.\n")
    }
    else if(columnToBeUsed==-2){
      convertedPnlInUsd = pnlColumn
      colnames(convertedPnlInUsd) = c(columnName)
      print(colnames(convertedPnlInUsd))
      convertedPnl = merge(convertedPnl, convertedPnlInUsd)
      #print(pnlColumn)
    }
    else {
      pnlColumn = xpnl[,i]
      refratecol = xrefrates[,columnToBeUsed]
      if(inverted1==1)
        refratecol = 1/refratecol
      convertedPnlInUsd = pnlColumn * refratecol
      colnames(convertedPnlInUsd) = c(columnName)
      print(colnames(convertedPnlInUsd))
      # browser()
      convertedPnl = merge(convertedPnl, convertedPnlInUsd)
      #print(convertedPnl)
    }
  }
}

#
x1 = rowsum(convertedPnl,group=index(convertedPnl))
print(x1)
convertedPnl = cbind(x1, convertedPnl)

#

# add all fees, etc.
write.csv(convertedPnl, "pnl_in_usd.csv")

png("pnl_in_usd.png", width=800, height=600)
plot(convertedPnl[,1], ylim=c(min(convertedPnl), max(convertedPnl)), main="PNL IN USD")
par(xpd=TRUE)
legend("topleft", legend=colnames(rsCloses), fill = colors)
colors = rainbow(ncol(convertedPnl))
for(i in 1:ncol(convertedPnl)){
  lines(convertedPnl[,i],col=colors[i])
}

dev.off()

setwd(currentwd)


library(MASS)
library(dplyr)
library(tidyr)
library(ggplot2)
library(ascii)
library(lubridate)
library(splines)
library(mgcv)

## Import datasets needed for chapter 4
PSDS_PATH <- file.path('~', 'statistics-for-data-scientists')

lung <- read.csv(file.path(PSDS_PATH, 'data', 'LungDisease.csv'))

zhvi <- read.csv(file.path(PSDS_PATH, 'data', 'County_Zhvi_AllHomes.csv'))
zhvi <- unlist(zhvi[13,-(1:5)])
dates <- parse_date_time(paste(substr(names(zhvi), start=2, stop=8), "01", sep="."), "Ymd")
zhvi <- data.frame(ym=dates, zhvi_px=zhvi, row.names = NULL) %>%
  mutate(zhvi_idx=zhvi/last(zhvi))

house <- read.csv(file.path(PSDS_PATH, 'data', 'house_sales.csv'), sep='\t')
# house <- house[house$ZipCode > 0, ]
# write.table(house, file.path(PSDS_PATH, 'data', 'house_sales.csv'), sep='\t')
## Code for Figure 1
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0401.png'),  width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
plot(lung$Exposure, lung$PEFR, xlab="Exposure", ylab="PEFR")
dev.off()

## Code snippet 4.1
model <- lm(PEFR ~ Exposure, data=lung)
model

## Code for figure 2
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0402.png'), width = 350, height = 350)
par(mar=c(4,4,0,0)+.1)

plot(lung$Exposure, lung$PEFR, xlab="Exposure", ylab="PEFR", ylim=c(300,450), type="n", xaxs="i")
abline(a=model$coefficients[1], b=model$coefficients[2], col="blue", lwd=2)
text(x=.3, y=model$coefficients[1], labels=expression("b"[0]),  adj=0, cex=1.5)
x <- c(7.5, 17.5)
y <- predict(model, newdata=data.frame(Exposure=x))
segments(x[1], y[2], x[2], y[2] , col="red", lwd=2, lty=2)
segments(x[1], y[1], x[1], y[2] , col="red", lwd=2, lty=2)
text(x[1], mean(y), labels=expression(Delta~Y), pos=2, cex=1.5)
text(mean(x), y[2], labels=expression(Delta~X), pos=1, cex=1.5)
text(mean(x), 400, labels=expression(b[1] == frac(Delta ~ Y, Delta ~ X)), cex=1.5)
dev.off()

## Code snippet 4.2
fitted <- predict(model)
resid <- residuals(model)

## Code for figure 3
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0403.png'),  width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)

lung1 <- lung %>%
  mutate(Fitted=fitted,
         positive = PEFR>Fitted) %>%
  group_by(Exposure, positive) %>%
  summarize(PEFR_max = max(PEFR),
            PEFR_min = min(PEFR),
            Fitted = first(Fitted)) %>%
  ungroup() %>%
  mutate(PEFR = ifelse(positive, PEFR_max, PEFR_min)) %>%
  arrange(Exposure)

plot(lung$Exposure, lung$PEFR, xlab="Exposure", ylab="PEFR")
abline(a=model$coefficients[1], b=model$coefficients[2], col="blue", lwd=2)
segments(lung1$Exposure, lung1$PEFR, lung1$Exposure, lung1$Fitted, col="red", lty=3)
dev.off()

## Code snippet 4.3
head(house[, c("AdjSalePrice", "SqFtTotLiving", "SqFtLot", "Bathrooms",
               "Bedrooms", "BldgGrade")])

## Code snippet 4.4
house_lm <- lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot + Bathrooms +
                 Bedrooms + BldgGrade,
               data=house, na.action=na.omit)

## Code snippet 4.5
house_lm

## Code snippet 4.6
summary(house_lm)

## Code snippet 4.7
house_full <- lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot + Bathrooms +
                   Bedrooms + BldgGrade + PropertyType + NbrLivingUnits +
                   SqFtFinBasement + YrBuilt + YrRenovated + NewConstruction,
                 data=house, na.action=na.omit)

## Code snippet 4.8
step_lm <- stepAIC(house_full, direction="both")
step_lm

lm(AdjSalePrice ~  Bedrooms, data=house)

# WeightedRegression
## Code snippet 4.9
house$Year = year(house$DocumentDate)
house$Weight = house$Year - 2005

## Code snippet 4.10
house_wt <- lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot + Bathrooms +
                 Bedrooms + BldgGrade,
               data=house, weight=Weight, na.action=na.omit)
round(cbind(house_lm=house_lm$coefficients,
            house_wt=house_wt$coefficients), digits=3)

# Factor Variables
## Code snippet 4.11
head(house[, 'PropertyType'])

## Code snippet 4.12
prop_type_dummies <- model.matrix(~PropertyType -1, data=house)
head(prop_type_dummies)

## Code snippet 4.13
lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot + Bathrooms +
     Bedrooms +  BldgGrade + PropertyType, data=house)

## Code snippet 4.14
table(house$ZipCode)

## Code snippet 4.15
zip_groups <- house %>%
  mutate(resid = residuals(house_lm)) %>%
  group_by(ZipCode) %>%
  summarize(med_resid = median(resid),
            cnt = n()) %>%
  # sort the zip codes by the median residual
  arrange(med_resid) %>%
  mutate(cum_cnt = cumsum(cnt),
         ZipGroup = factor(ntile(cum_cnt, 5)))
house <- house %>%
  left_join(select(zip_groups, ZipCode, ZipGroup), by='ZipCode')

# correlated variables
# Code snippet 4.15
step_lm$coefficients

# Code snippet 4.16
update(step_lm, . ~ . -SqFtTotLiving - SqFtFinBasement - Bathrooms)

#  ConfoundingVariables
## Code snippet 4.17
lm(AdjSalePrice ~  SqFtTotLiving + SqFtLot +
     Bathrooms + Bedrooms +
     BldgGrade + PropertyType + ZipGroup,
   data=house, na.action=na.omit)

#  Interactions
## Code snippet 4.18
lm(AdjSalePrice ~  SqFtTotLiving*ZipGroup + SqFtLot +
     Bathrooms + Bedrooms +
     BldgGrade + PropertyType,
   data=house, na.action=na.omit)

head(model.matrix(~C(PropertyType, sum) , data=house))

# outlier anaysis
## Code snippet 4.19
house_98105 <- house[house$ZipCode == 98105,]
lm_98105 <- lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot + Bathrooms +
                 Bedrooms + BldgGrade, data=house_98105)

## Code snippet 4.20
sresid <- rstandard(lm_98105)
idx <- order(sresid, decreasing=FALSE)
sresid[idx[1]]
resid(lm_98105)[idx[1]]

## Code snippet 4.21
house_98105[idx[1], c('AdjSalePrice', 'SqFtTotLiving', 'SqFtLot',
                      'Bathrooms', 'Bedrooms', 'BldgGrade')]

# Figure 4-5: Influential data point in regression
seed <- 11
set.seed(seed)
x <- rnorm(25)
y <- -x/5 + rnorm(25)
x[1] <- 8
y[1] <- 8

png(filename=file.path(PSDS_PATH, 'figures', 'psds_0405.png'),  width = 4, height=4, units='in', res=300)
par(mar=c(3,3,0,0)+.1)
plot(x, y, xlab='', ylab='', pch=16)
model <- lm(y~x)
abline(a=model$coefficients[1], b=model$coefficients[2], col="blue", lwd=3)
model <- lm(y[-1]~x[-1])
abline(a=model$coefficients[1], b=model$coefficients[2], col="red", lwd=3, lty=2)
dev.off()

# influential observations
## Code snippet 4.22
std_resid <- rstandard(lm_98105)
cooks_D <- cooks.distance(lm_98105)
hat_values <- hatvalues(lm_98105)
plot(hat_values, std_resid, cex=10*sqrt(cooks_D))
abline(h=c(-2.5, 2.5), lty=2)

## Code for Figure 4-6
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0406.png'), width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
plot(hat_values, std_resid, cex=10*sqrt(cooks_D))
abline(h=c(-2.5, 2.5), lty=2)
dev.off()

## Table 4-2

lm_98105_inf <- lm(AdjSalePrice ~ SqFtTotLiving + SqFtLot +
                     Bathrooms +  Bedrooms + BldgGrade,
                   subset=cooks_D<.08, data=house_98105)

df <- data.frame(lm_98105$coefficients,
                 lm_98105_inf$coefficients)
names(df) <- c('Original', 'Influential Removed')
ascii((df),
      include.rownames=TRUE, include.colnames=TRUE, header=TRUE,
      digits=rep(0, 3), align=c("l", "r", "r") ,
      caption="Comparison of regression coefficients with the full data and with influential data removed")

## heteroskedasticity
## Code snippet 4.23
df <- data.frame(
  resid = residuals(lm_98105),
  pred = predict(lm_98105))
ggplot(df, aes(pred, abs(resid))) +
  geom_point() +
  geom_smooth()

## Code for figure 4-7
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0407.png'), width = 4, height=4, units='in', res=300)

ggplot(df, aes(pred, abs(resid))) +
  geom_point() +
  geom_smooth() +
  theme_bw()

dev.off()

## Code for figure 4-8
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0408.png'), width = 4, height=4, units='in', res=300)
par(mar=c(4,4,0,0)+.1)
hist(std_resid, main='')
dev.off()

## partial residuals plot
## Code snippet 4.24
terms <- predict(lm_98105, type='terms')
partial_resid <- resid(lm_98105) + terms

## Code snippet 4.25
df <- data.frame(SqFtTotLiving = house_98105[, 'SqFtTotLiving'],
                 Terms = terms[, 'SqFtTotLiving'],
                 PartialResid = partial_resid[, 'SqFtTotLiving'])
ggplot(df, aes(SqFtTotLiving, PartialResid)) +
  geom_point(shape=1) + scale_shape(solid = FALSE) +
  geom_smooth(linetype=2) +
  geom_line(aes(SqFtTotLiving, Terms))

## Code for figure 4-9
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0409.png'),  width = 4, height=4, units='in', res=300)

df <- data.frame(SqFtTotLiving = house_98105[, 'SqFtTotLiving'],
                 Terms = terms[, 'SqFtTotLiving'],
                 PartialResid = partial_resid[, 'SqFtTotLiving'])
ggplot(df, aes(SqFtTotLiving, PartialResid)) +
  geom_point(shape=1) + scale_shape(solid = FALSE) +
  geom_smooth(linetype=2) +
  theme_bw() +
  geom_line(aes(SqFtTotLiving, Terms))

dev.off()

## Code snippet 4.26

lm(AdjSalePrice ~ poly(SqFtTotLiving, 2) + SqFtLot +
   BldgGrade + Bathrooms +  Bedrooms,
   data=house_98105)

lm_poly <- lm(AdjSalePrice ~  poly(SqFtTotLiving, 2) + SqFtLot +
                BldgGrade +  Bathrooms +  Bedrooms,
              data=house_98105)
terms <- predict(lm_poly, type='terms')
partial_resid <- resid(lm_poly) + terms

## Code for Figure 4-10
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0410.png'), width = 4, height=4, units='in', res=300)

df <- data.frame(SqFtTotLiving = house_98105[, 'SqFtTotLiving'],
                 Terms = terms[, 1],
                 PartialResid = partial_resid[, 1])
ggplot(df, aes(SqFtTotLiving, PartialResid)) +
  geom_point(shape=1) + scale_shape(solid = FALSE) +
  geom_smooth(linetype=2) +
  geom_line(aes(SqFtTotLiving, Terms))+
  theme_bw()

dev.off()

## Code snippet 4.27
knots <- quantile(house_98105$SqFtTotLiving, p=c(.25, .5, .75))
lm_spline <- lm(AdjSalePrice ~ bs(SqFtTotLiving, knots=knots, degree=3) +  SqFtLot +
                  Bathrooms + Bedrooms + BldgGrade,  data=house_98105)

terms1 <- predict(lm_spline, type='terms')
partial_resid1 <- resid(lm_spline) + terms

## Code for Figure 4-12
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0412.png'), width = 4, height=4, units='in', res=300)

df1 <- data.frame(SqFtTotLiving = house_98105[, 'SqFtTotLiving'],
                 Terms = terms1[, 1],
                 PartialResid = partial_resid1[, 1])
ggplot(df1, aes(SqFtTotLiving, PartialResid)) +
  geom_point(shape=1) + scale_shape(solid = FALSE) +
  geom_smooth(linetype=2) +
  geom_line(aes(SqFtTotLiving, Terms))+
  theme_bw()

dev.off()

## Code snippet 4.27
lm_gam <- gam(AdjSalePrice ~ s(SqFtTotLiving) + SqFtLot +
                Bathrooms +  Bedrooms + BldgGrade,
              data=house_98105)
terms <- predict.gam(lm_gam, type='terms')
partial_resid <- resid(lm_gam) + terms

## Code for Figure 4-13
png(filename=file.path(PSDS_PATH, 'figures', 'psds_0413.png'), width = 4, height=4, units='in', res=300)
df <- data.frame(SqFtTotLiving = house_98105[, 'SqFtTotLiving'],
                 Terms = terms[, 5],
                 PartialResid = partial_resid[, 5])
ggplot(df, aes(SqFtTotLiving, PartialResid)) +
  geom_point(shape=1) + scale_shape(solid = FALSE) +
  geom_smooth(linetype=2) +
  geom_line(aes(SqFtTotLiving, Terms))  +
  theme_bw()
dev.off()


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     16.10.2019
#modificado: 05.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")

## 1. Outliers

#table
?diamonds
print(diamonds)

#summary
diamonds %>%
  summary()

#plots
fnam <- "../results/exploration/outliers1.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=x),binwidth=0.5)
dev.off()

fnam <- "../results/exploration/outliers2.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=y),binwidth=0.5)
dev.off()

fnam <- "../results/exploration/outliers3.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=z),binwidth=0.5)
dev.off()

fnam <- "../results/exploration/outliers4.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=x),binwidth=0.5) +
    coord_cartesian(ylim=c(0,50))
dev.off()

fnam <- "../results/exploration/outliers5.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=y),binwidth=0.5) +
    coord_cartesian(ylim=c(0,50))
dev.off()

fnam <- "../results/exploration/outliers6.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_histogram(mapping=aes(x=z),binwidth=0.5) +
    coord_cartesian(ylim=c(0,50))
dev.off()

#table
unusual <- diamonds %>%
  filter((x < 1) | (y < 1 | y > 20) | (z < 1 | z > 10)) %>%
  arrange(x)
print(unusual,n=23)

#plots
fnam <- "../results/exploration/outliers7.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_point(mapping=aes(x=price,y=x)) +
    geom_point(data=unusual,mapping=aes(x=price,y=x),color="red")
dev.off()

fnam <- "../results/exploration/outliers8.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_point(mapping=aes(x=price,y=y)) +
    geom_point(data=unusual,mapping=aes(x=price,y=y),color="red")
dev.off()

fnam <- "../results/exploration/outliers9.tiff"
tiff(file=fnam,units="in",width=3,height=3,res=300,compression="lzw")
diamonds %>%
  ggplot() +
    geom_point(mapping=aes(x=price,y=z)) +
    geom_point(data=unusual,mapping=aes(x=price,y=z),color="red")
dev.off()

#summary
diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10)) %>%
  summary()

## 2. Missing values

#table
?diamonds
diamonds_NA <- diamonds %>%
  mutate(x = ifelse(x < 1,NA,x)) %>%
  mutate(y = ifelse(y < 1 | y > 20,NA,y)) %>%
  mutate(z = ifelse(z < 1 | z > 10,NA,z))
print(diamonds_NA)

#summary
diamonds_NA %>%
  group_by(cut) %>%
  summarize(mean_x = mean(x),
            mean_y = mean(y),
            mean_z = mean(z),
            n = n(),
            x_NA = sum(is.na(x)),
            y_NA = sum(is.na(y)),
            z_NA = sum(is.na(z)))

diamonds_NA %>%
  group_by(cut) %>%
  summarize(mean_x = mean(x,na.rm=TRUE),
            mean_y = mean(y,na.rm=TRUE),
            mean_z = mean(z,na.rm=TRUE),
            n = n(),
            x_NA = sum(is.na(x)),
            y_NA = sum(is.na(y)),
            z_NA = sum(is.na(z)))

#plots
diamonds_NA %>%
  ggplot() +
    geom_point(mapping=aes(x=price,y=x))

diamonds_NA %>%
  ggplot() +
    geom_point(mapping=aes(x=price,y=x),na.rm=TRUE)

## 3. Distribution (1D)
library("moments")

#table
?diamonds
diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10))
print(diamonds2)

#distribution 1
fnam <- "../results/exploration/distribution1D_1.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_histogram(mapping=aes(x=price),binwidth=50)
dev.off()

#distribution 2
ldiamonds2 <- diamonds2 %>%
  mutate(price = log(price))
fnam <- "../results/exploration/distribution1D_2.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
ldiamonds2 %>%
  ggplot() +
    geom_histogram(mapping=aes(x=price),binwidth=0.01)
dev.off()

#distribution 1 vs distribution 2
param <- diamonds2 %>%
  summarize(n = n(),
            mean = mean(price),
            sd = sd(price),
            median = median(price),
            IQR = IQR(price))
lparam <- ldiamonds2 %>%
  summarize(n = n(),
            mean = mean(price),
            sd = sd(price),
            median = median(price),
            IQR = IQR(price))
tab1 <- round(cbind(t(param),t(lparam)),digits=2)
colnames(tab1) <- c("original","log()")
fnam = "../results/exploration/distribution1D_1.txt"
write.table(tab1,fnam,sep=",",row.names=TRUE,col.names=NA)

#distribution 3
ldiamonds2_scale <- ldiamonds2 %>%
  mutate(price = (price - mean(price))/sd(price))
fnam <- "../results/exploration/distribution1D_3.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
ldiamonds2_scale %>%
  ggplot() +
    geom_histogram(mapping=aes(x=price,y=..density..),binwidth=0.2) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))
dev.off()

#distribution 4
price_mean <- mean(ldiamonds2$price)
price_sd <- sd(ldiamonds2$price)
fnam <- "../results/exploration/distribution1D_4.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
ldiamonds2 %>%
  ggplot() +
    geom_histogram(mapping=aes(x=price,y=..density..),binwidth=0.2) +
    stat_function(fun=dnorm,color="red",args=list(mean=price_mean,sd=price_sd))
dev.off()

#distribution 3 vs Gaussian
param <- ldiamonds2_scale %>%
  summarize(n= n(),
            mean = mean(price),
            sd = sd(price),
            skewness = skewness(price),
            kurtosis = kurtosis(price))
tab2 <- round(cbind(t(param),c(1/0,0,1,0,3)),digits=3)
colnames(tab2) <- c("original","Gaussian")
fnam = "../results/exploration/distribution1D_2.txt"
write.table(tab2,fnam,sep=",",row.names=TRUE,col.names=NA)

## 4. Distribution (2D)

#table
?diamonds
diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10))
print(diamonds2)

#### 4.1. Continuous vs categorical

#plots
fnam <- "../results/exploration/distribution2D_1.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  filter(cut=="Ideal") %>%
  ggplot() +
    geom_boxplot(mapping=aes(x=clarity,y=price))
dev.off()

#summary
diamonds2 %>%
  filter(cut=="Ideal") %>%
  group_by(clarity) %>%
  summarize(mean_price = mean(price))

#plots
fnam <- "../results/exploration/distribution2D_2.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  filter(cut=="Ideal") %>%
  group_by(clarity) %>%
  mutate(mean_price = mean(price)) %>%
  ggplot() +
    geom_point(mapping=aes(x=mean_price,y=price),size=2,alpha=0.01) +
    geom_point(mapping=aes(x=mean_price,y=mean_price),size=2,color="red")
dev.off()

#correlation metric (correlation between observed and predicted values)
diamonds2 %>%
  filter(cut=="Ideal") %>%
  group_by(clarity) %>%
  mutate(mean_price = mean(price)) %>%
  ungroup() %>%
  summarize(cor(mean_price,price))

#### 4.2. Two categorical

#plots
fnam <- "../results/exploration/distribution2D_3.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_count(mapping=aes(x=clarity,y=cut))
dev.off()

fnam <- "../results/exploration/distribution2D_4.tiff"
tiff(file=fnam,units="in",width=4.5,height=3.5,res=300,compression="lzw")
diamonds2 %>%
  group_by(clarity,cut) %>%
  summarize(n = n()) %>%
  ggplot() +
    geom_count(mapping=aes(x=clarity,y=cut,color=n,size=n))
dev.off()

fnam <- "../results/exploration/distribution2D_5.tiff"
tiff(file=fnam,units="in",width=4.5,height=3.5,res=300,compression="lzw")
diamonds2 %>%
  group_by(clarity,cut) %>%
  summarize(n = n()) %>%
  ggplot() +
    geom_tile(mapping=aes(x=clarity,y=cut,fill=n))
dev.off()

#correlation metric (Cramer's V)

#Calculate Cramer's V from contingency table
calc_Cramers_V <- function(x){
    chi_stat <- chisq.test(x)$statistic #chi-sqrt
    n <- sum(x)                         #sample size
    min_dim <- min(dim(x)) - 1          #minimum number of dimensions - 1
    res <- sqrt(chi_stat/n/min_dim)     #Cramer's V
    names(res) = "Cramers.V"
    return(res)
}
cont_table <- table(diamonds2$clarity,diamonds2$cut) #contingency table
print(cont_table)
round(calc_Cramers_V(cont_table),digits=3)

#### 4.3. Two continuous
library("hexbin")

#plots
fnam <- "../results/exploration/distribution2D_5.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_point(mapping=aes(x=carat,y=price))
dev.off()

fnam <- "../results/exploration/distribution2D_6.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_point(mapping=aes(x=carat,y=price),alpha=0.01)
dev.off()

fnam <- "../results/exploration/distribution2D_7.tiff"
tiff(file=fnam,units="in",width=4,height=3,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_bin2d(mapping=aes(x=carat,y=price),bins=100)
dev.off()

fnam <- "../results/exploration/distribution2D_8.tiff"
tiff(file=fnam,units="in",width=4,height=3,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_hex(mapping=aes(x=carat,y=price),bins=100)
dev.off()

fnam <- "../results/exploration/distribution2D_9.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_boxplot(mapping=aes(x=carat,y=price,group=cut_width(carat,0.1)))
dev.off()

fnam <- "../results/exploration/distribution2D_10.tiff"
tiff(file=fnam,units="in",width=4,height=4,res=300,compression="lzw")
diamonds2 %>%
  ggplot() +
    geom_boxplot(mapping=aes(x=carat,y=price,group=cut_number(carat,20)))
dev.off()

#correlation metric
diamonds2 %>%
  summarize(cor(carat,price))


# Best ARIMA model for barometer data

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Filter
  df <- df[PRESSURE_VALUE < 1100,]
  df <- df[PRESSURE_VALUE > 975,]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  # Normalize barometer so the mu is the same for every barometer
  # df[, 'PRESSURE_VALUE' := PRESSURE_VALUE - median(PRESSURE_VALUE)]

  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'logger.name' = logger.name)
}

df.list <- lapply(logger.names, read.baro)
df <- data.table::rbindlist(df.list, use.names = TRUE, fill = TRUE)
data.table::setkey(df, FILE, TIMESTAMP_UTC)
df
ggplot2::ggplot(data = df, ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, color = FILE)) +
  ggplot2::geom_line(show.legend = FALSE)

# Unit root test seems to fail and 1st order diff are taken.
# But assuming stationary one ends up with a slightly better likelihood and
# a much more parsimonious model.
forecast::auto.arima(df$PRESSURE_VALUE, trace = TRUE) # ARIMA(0,1,5): log likelihood=-1259788
forecast::auto.arima(df$PRESSURE_VALUE, trace = TRUE, stationary = TRUE) # ARIMA(2,0,0) with non-zero mean: log likelihood=-1256646

# The effect of the constant seems large:
# ARIMA(0,0,0) with zero mean     : 7033251
# ARIMA(0,0,0) with non-zero mean : 3221075
# Then the effect of the first AR(1) component also:
# ARIMA(1,0,0) with non-zero mean : 2523871
# The second AR component has hardly any effect:
# ARIMA(2,0,0) with non-zero mean : 2513298
# Note further that just taking differences has a huge impact:
# ARIMA(0,1,0)                    : 2545514
# which is much better than a white noise model: ARIMA(0,0,0)
# with non-zero mean, but slightly worse than ARIMA(1,0,0)
# with non-zero mean

# Gaussian noise model: too dense
fit.arima <- arima(df$PRESSURE_VALUE, order = c(0, 0, 0))
plot(forecast:::simulate.Arima(fit.arima, 10000))

# AR(1) model: looks quite like a real air pressure series
# Coefficient is 0.90 with sigma2 = 23.62
fit.arima <- arima(df$PRESSURE_VALUE, order = c(1, 0, 0))
plot(forecast:::simulate.Arima(fit.arima, 10000))

# Distribution of AR(1) model (coef = 0.90)
# Seems to be normal given a timestamp.
# So according to this approximation, a height-compensated barometer should be
# within a normal distribution with mu = 1033 and sd = 11.137
# Note that assumption is that the barometers are height-compensated.
# With coef = 0.82 the sd = 9.9
df.sim <- data.table::rbindlist(lapply(1:1000, function(x) data.frame(t = 1:1000, x = forecast:::simulate.Arima(fit.arima, 1000))))
data.table::setkey(df.sim, t, verbose = TRUE)
# plot(x = df.sim$t, y = df.sim$x, pch = '.')
df.sim.stats <- df.sim[, .(sd = sd(x)), by = t]
plot(x = df.sim.stats$t, y = df.sim.stats$sd, type = 'l')
hist(df.sim[t == 500, x], breaks = 100)
qqnorm(df.sim[t == 500, x])
qqline(df.sim[t == 500, x])

# Random walk model: fits well on data, but is completely wrong
fit.arima <- arima(df$PRESSURE_VALUE, order = c(0, 1, 0))
plot(forecast:::simulate.Arima(fit.arima, 10000))

# See also analysis v18 for a similar study on KNMI data.
# In that case, and if we go down o 1h intervals, then
# there are more AR components needed to simulate it correctly.
# Concretely: there are 2-3 components needed for 1h intervals.
# AR(1) model is too close to a random walk.

# Verified barometers
dfv <- data.table::copy(gwloggeR:::airpressure)
dfv <- dfv[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC), FILE)]
data.table::setkey(dfv, FILE, TIMESTAMP_UTC)
ggplot2::ggplot(data = dfv, ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, color = FILE)) +
  ggplot2::geom_line(show.legend = FALSE)
arima(dfv$PRESSURE_VALUE, order = c(1, 0, 0))
# Here also the most impact has the AR(1) model, after that the impact is not large
# The AR(1) coefficient is here 0.82 at 12h intervals with sigma2 = 31.85

# 65% non-drinfting barometers
analysis_10 <- data.table::fread(file = './drifts/analysis_10/baro_median_errors.csv')
analysis_10 <- analysis_10[order(WISK, decreasing = TRUE),]
dfw <- data.table::rbindlist(lapply(analysis_10[WISK <= quantile(WISK, probs = 0.65), FILE], read.baro), use.names = TRUE, fill = TRUE)
data.table::setkey(dfw, FILE, TIMESTAMP_UTC)
dfw
ggplot2::ggplot(data = dfw, ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, color = FILE)) +
  ggplot2::geom_line(show.legend = FALSE)
arima(dfw$PRESSURE_VALUE, order = c(1, 0, 0))
# Here the most impact has the AR(1) model, after that the impact is not large
# The AR(1) coefficient is here 0.89 at 12h intervals with sigma2 = 21.3!

# Normalizing the series around the median has little effect on AR(1) coef:
# it remains around 0.88, and sigma2 also remains around 21-23.
# This was tested on both df and dfw.
# So we can conclude that for modeling air pressure AR(1) is a good model.


#' Automatic DDM Parameter Extraction
#'
#' Automatically extracts parameter estimates from a stanfit object.
#' @param stanfit_object Output of a previous stanfit.
#' @param num_subjects Amount of fitted subjects. Required for automatic extraction.
#' @param names Subject names (Vector of strings) for correct plotting. Is not required, but recommended.
#' @export
#' @return Returns a CSV file with all parameter estimates.
parameter_extraction <- function(fit, numsub, names=NULL){
    suj_params <- rstan::extract(fit, permuted = TRUE)
    suj_params %<>% map(., function(x) colMeans(as.matrix(x), dims = 1)) %>% map(unname)
    suj_params <- suj_params[as.vector(map(suj_params, length)==numsub)];
    suj_params %<>% as.data.frame %>% dplyr::select(-contains("_pr"), -contains("_lik"))
    row.names(suj_params) <- names
    suj_params
}


# Predict a full tile using neural networks

library(neuralnet)
library(raster)
source("utils/set-temp-path.r")
source("utils/load-data.r")

OutputDir = "../../userdata/predictions/"

AllData = LoadClassificationData()
TrainingData = LoadTrainingData()
TrainingRasters = LoadTrainingRasters(exclude=c("osavi", "amplitude1", "aspect", "blue", "is.water", "amplitude2", "tpi"))
TrainingNames = GetTrainingNames(exclude=c("osavi", "amplitude1", "aspect", "blue", "is.water", "amplitude2", "tpi"))

# The rasters need to be scaled to 0-1, which will take forever, but what can you do
#mins = maxs = c()
#for (i in 1:nlayers(TrainingRasters))
#{
#    mins = c(mins, TrainingRasters[[i]]@data@min)
#    names(mins)[i] = names(TrainingRasters)[i]
#    maxs = c(maxs, TrainingRasters[[i]]@data@max)
#    names(maxs)[i] = names(TrainingRasters)[i]
#}

Formula = paste0(paste0(GetValidationNames(), collapse="+"),"~",paste0(TrainingNames, collapse="+"))

ScaleDataUntransf = AllData@data
ScaleDataUntransf$dominant = NULL
maxs = apply(ScaleDataUntransf, 2, max)
mins = apply(ScaleDataUntransf, 2, min)
ScaleDataUntransf = as.data.frame(scale(ScaleDataUntransf, center = mins, scale = maxs - mins))

rasterOptions(chunksize=1e+08, maxmemory=1e+09)
ScaledRasters = scale(TrainingRasters, center = mins[TrainingNames], scale = maxs[TrainingNames] - mins[TrainingNames])

pures=which(as.logical(ScaleDataUntransf$pure))
set.seed(0xfedbeef)
ModelUntransf = neuralnet(Formula, ScaleDataUntransf[pures,], 9, lifesign="full", rep=10, threshold=0.05)

ScaleNNPrediction = function(prediction, global=FALSE)
{
    PredMinScale = prediction
    Min = min(prediction)
    for (i in 1:nrow(prediction))
    {
        if (!global)
            Min = min(prediction[i,])
        PredMinScale[i,] = (prediction[i,]+abs(Min)) / sum(prediction[i,]+abs(Min))*100
    }
    PredMinScale = data.frame(PredMinScale)
    #names(PredMinScale) = names(prediction)
    return(PredMinScale)
}

NNP = function(ModelUntransf, ...)
{
    PredictionUntransf = compute(ModelUntransf, ..., rep=which.min(ModelUntransf$result.matrix[1,]))
    return(ScaleNNPrediction(PredictionUntransf$net.result))
}

print(system.time(predicted <- predict(ScaledRasters, ModelUntransf, fun=NNP, index=1:9, progress="text")))

writeRaster(predicted, filename = paste0(OutputDir, "neuralnetwork-pure.tif"), progress="text",
    datatype="INT1U", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"), overwrite=TRUE)


  interpolate.missing.xyz = function( xyz, method="default",  nmax=30, maxdist=50, idp=0.5 ) {

    out = NULL
    names( xyz) =  c("x", "y", "z")

    missing = which( !is.finite( xyz$z ) )
    if (any( (!is.finite( xyz$x)) | (!is.finite( xyz$y)) )) {
      print( "Missing values in coords not allowed" )
      return (NULL)
    }

    if ( length( missing ) ==0 ) {
      print( "Nothing to interpolate" )
      return (NULL)
    }

    if ( (nrow( xyz ) - length(missing)) < 30 ) {
      print ("Not enough data to interpolate")
      return ( NULL  )
    }

    data.range = range( xyz$z, na.rm =T )

    if ( method %in% c("default", "linear.akima" ) ) { # interpolation is simple linear
      require( akima)
      gs = try( interp( x=xyz$x[-missing], y=xyz$y[-missing], z=xyz$z[-missing], xo=xyz$x[missing], yo=xyz$y[missing], linear=T, duplicate="mean" ) )
      if (class(gs) =="try-error" )  return (NULL )
      k =  as.matrix(gs[[3]])
      dimnames(k) = list( gs[[1]], gs[[2]] )
      pred = as.data.frame.table(k)
      names( pred ) =  names( xyz)
      pred = pred [ which(is.finite( pred$z ) ), ]
      xyz$order = c( 1:nrow(xyz) )
      out = merge( xyz, pred, by=c( "x", "y" ), all.x=T, all.y=F, sort=F, suffixes=c("",".new") )
      if (nrow(xyz) != nrow(out) ) {
        print( "Merge failure at interpolation" )
        stop()  # error
      }
      out$z[missing] = out$z.new[missing]
      out = out[ order( out$order) , c("x", "y", "z" ) ]
      out = range.cap( out, data.range )
      return (out )
    }

    if ( method =="bicubic.spline.akima" ) {
      require( akima)
      gs = try( interp( x=xyz$x[-missing], y=xyz$y[-missing], z=xyz$z[-missing], xo=xyz$x[missing], yo=xyz$y[missing], linear=F, extrap=T, duplicate="mean" ) )
      if (class(gs) =="try-error" )  return (NULL )
      k =  as.matrix(gs[[3]])
      dimnames(k) = list( gs[[1]], gs[[2]] )
      pred = as.data.frame.table(k)
      names( pred ) =  names( xyz)
      pred = pred [ which(is.finite( pred$z ) ), ]
      xyz$order = c( 1:nrow(xyz) )
      xyz = merge( xyz, pred, by=c( "x", "y" ), all.x=T, all.y=F, sort=F, suffixes=c("",".new") )
      xyz$z[missing] = xyz$z.new[missing]
      xyz = xyz[ order( xyz$order) , c("x", "y", "z" ) ]
      out = range.cap( xyz, data.range )
      return (out )
    }

    if ( method =="inverse.distance.gstat" ) {
      require( gstat )
      m = gstat( id="interpolation", formula=z~1, locations=~x+y, data=xyz[-missing,], nmax=nmax, maxdist=maxdist, set=list(idp=idp))
      pred = predict( object=m, newdata=xyz[missing,] ) [,3]
      if (class(pred) =="try-error" )  return (NULL )
      pred = range.cap( pred, data.range )
      xyz$z[missing] = pred
      return (xyz$z )
    }

    return ( "Method not found" )

  }


list.fullrank <- list()
MODE <- '30days'
load(paste('./results/aucs_FEB2018_', MODE,'_data.RData', sep=''))
library(xgboost)
for(f in 1:5) {
  list.fullrank[[f]] <- xgb.importance(feature_names=list.featurenames[[f]], model=list.xgb[[f]])
}

vars <- list.featurenames[[1]]
rankmat <- matrix(NA, nrow=length(vars), ncol=5)

for(v in 1:length(vars)) {
  rankvec <- vector()
  for(f in 1:5) {
    temp <- which(vars[v] == list.fullrank[[f]]$Feature)
    if(length(temp) == 0) {
      rankvec[f] <- NA
    } else {
      rankvec[f] <- temp[1]
    }

  }
  rankmat[v,] <- rankvec
}

rankdf <- data.frame(rankmat)
fullmean <- rowMeans(rankdf, na.rm=FALSE)
NAMean <- rowMeans(rankdf, na.rm=TRUE)
fullsd <- apply(rankdf, 1, sd, na.rm=FALSE)
NAsd <- apply(rankdf, 1, sd, na.rm=TRUE)

rankdf$fullmean <- fullmean
rankdf$fullsd <- fullsd
rankdf$NAMean <- NAMean
rankdf$NAsd <- NAsd

colnames(rankdf) <- c('fold1', 'fold2', 'fold3', 'fold4', 'fold5', 'Fullmean', 'Fullstd', 'NAMean', 'NAstd')
rownames(rankdf) <- vars
write.csv(rankdf, file=paste('./results/variables_MODE_', MODE, '_6FEB2018.csv',sep=''))


library("dplyr")
library("sf")
library("cartogram")
library("tmap")
library("viridis")

dir.create("docs/visualisations", showWarnings = FALSE, recursive = TRUE)

boundaries = sf::read_sf("data/processed/boundaries.gpkg")
boundaries_cartogram = cartogram::cartogram_cont(boundaries, "num_burglaries")

map =
    tm_basemap(NULL) +
    tm_shape(boundaries_cartogram) +
    tm_polygons(
        col = "num_burglaries", palette = "viridis",
        popup.vars = c("Constabulary: " = "name", "Burglaries: " = "num_burglaries")
    ) +
    tm_layout(legend.show = FALSE, frame = FALSE)

tmap_save(
    map, "docs/visualisations/burglaries.html",
    height = 1070, units = "px", selfcontained = TRUE
)

write_sf(boundaries_cartogram, "data/processed/boundaries_cartogram.gpkg")


#' Variogram plots for spatial models.
#'
#' Produces variogram plots for checking spatial trends.
#'
#' @param model.obj An `asreml` model object.
#' @param palette A string specifying the colour scheme to use for plotting. The default value (`"default"`) is equivalent to `"rainbow"`. Colour blind friendly palettes can also be provided via options `"colour blind"` (or `"color blind"`, both equivalent to `"viridis"`), `"magma"`, `"inferno"`, `"plasma"` or `"cividis"`. The `"Spectral"` palette from [scales::brewer_pal()] is also possible.
#'
#' @return A ggplot2 object.
#'
#' @importFrom interp interp
#' @importFrom grDevices rainbow
#' @importFrom lattice wireframe
#' @importFrom cowplot plot_grid
#' @importFrom ggplot2 ggplot geom_tile coord_equal geom_contour scale_fill_gradientn theme_bw scale_x_continuous scale_y_continuous theme labs
#'
#' @references S. P. Kaluzny, S. C. Vega, T. P. Cardoso, A. A. Shelly, "S+SpatialStats: User’s Manual for Windows® and UNIX®" _Springer New York_, 2013, p. 68, https://books.google.com.au/books?id=iADkBwAAQBAJ.
#' @references A. R. Gilmour, B. R. Cullis, A. P. Verbyla, "Accounting for Natural and Extraneous Variation in the Analysis of Field Experiments." _Journal of Agricultural, Biological, and Environmental Statistics 2, no. 3_, 1997, pp. 269–93, https://doi.org/10.2307/1400446.
#'
#' @examples
#' \dontrun{
#' library(asreml)
#' oats <- asreml::oats
#' oats <- oats[order(oats$Row, oats$Column),]
#' model.asr <- asreml(yield ~ Nitrogen + Variety + Nitrogen:Variety,
#'                     random = ~ Blocks + Blocks:Wplots,
#'                     residual = ~ ar1(Row):ar1(Column),
#'                     data = oats)
#' variogram(model.asr)
#' }
#' @export

variogram <- function(model.obj, palette = "default") {

    if(!(inherits(model.obj, "asreml"))) {
        stop("model.obj must be an asreml model object")
    }

    aa <- vario_df(model.obj)
    xnam <- names(aa)[2]
    ynam <- names(aa)[1]
    fld <- interp::interp(y = aa[,1], x = aa[,2], z = aa$gamma)
    gdat <- cbind(expand.grid(x = fld$x, y = fld$y), z = as.vector(fld$z))

    a <- ggplot2::ggplot(gdat, ggplot2::aes(x = y, y = x, z = z, fill = z)) +
        ggplot2::geom_tile(alpha = 0.6) +
        ggplot2::coord_equal() +
        ggplot2::geom_contour(color = "white", alpha = 0.5) +
        ggplot2::theme_bw(base_size = 8) +
        ggplot2::scale_y_continuous(expand = c(0, 0), breaks = seq(1, max(gdat$x), 2)) +
        ggplot2::scale_x_continuous(expand = c(0, 0), breaks = seq(1, max(gdat$y), 2)) +
        ggplot2::theme(legend.position = "none", aspect.ratio = 0.3) +
        ggplot2::labs(y = paste(xnam, "Lag", sep = " "), x = paste(ynam, "Lag", sep = " "))

    if(tolower(palette) == "rainbow" | tolower(palette) == "default") {
        a <- a + ggplot2::scale_fill_gradientn(colours = grDevices::rainbow(100))

        b <- lattice::wireframe(z ~ y * x, data = gdat, aspect = c(61/87, 0.4),
                                scales = list(cex = 0.5, arrows = FALSE),
                                shade = TRUE, colorkey = FALSE,
                                par.settings = list(axis.line = list(col = 'transparent')),
                                xlab = list(label = paste(ynam, "Lag", sep = " "), cex = .8, rot = 20),
                                ylab = list(label = paste(xnam, "Lag", sep = " "), cex = .8, rot = -18),
                                zlab = list(label = NULL, cex.axis = 0.5))
    }
    else if(any(grepl("(colou?r([[:punct:]]|[[:space:]]?)blind)|cb|viridis", palette, ignore.case = T))) {
        a <- a + ggplot2::scale_fill_gradientn(colours = scales::viridis_pal(option = "viridis")(50))

        # Create the lattice plot
        b <- lattice::wireframe(z ~ y * x, data = gdat, aspect = c(61/87, 0.4),
                                scales = list(cex = 0.5, arrows = FALSE),
                                drape = TRUE, colorkey = FALSE,
                                par.settings = list(axis.line = list(col = 'transparent')),
                                xlab = list(label = paste(ynam, "Lag", sep = " "), cex = .8, rot = 20),
                                ylab = list(label = paste(xnam, "Lag", sep = " "), cex = .8, rot = -18),
                                zlab = list(label = NULL, cex.axis = 0.5),
                                col.regions = scales::viridis_pal(option = "viridis")(100))
    }
    else if(tolower(palette) %in% c("magma", "inferno", "cividis", "plasma")) {
        a <- a + ggplot2::scale_fill_gradientn(colours = scales::viridis_pal(option = palette)(50))

        # Create the lattice plot
        b <- lattice::wireframe(z ~ y * x, data = gdat, aspect = c(61/87, 0.4),
                                scales = list(cex = 0.5, arrows = FALSE),
                                drape = TRUE, colorkey = FALSE,
                                par.settings = list(axis.line = list(col = 'transparent')),
                                xlab = list(label = paste(ynam, "Lag", sep = " "), cex = .8, rot = 20),
                                ylab = list(label = paste(xnam, "Lag", sep = " "), cex = .8, rot = -18),
                                zlab = list(label = NULL, cex.axis = 0.5),
                                col.regions = scales::viridis_pal(option = palette)(100))
    }

    else if(palette %in% c("Spectral")) {
        a <- a + ggplot2::scale_fill_gradientn(colours = scales::brewer_pal(palette = palette)(11))

        # Create the lattice plot
        b <- lattice::wireframe(z ~ y * x, data = gdat, aspect = c(61/87, 0.4),
                                scales = list(cex = 0.5, arrows = FALSE),
                                drape = TRUE, colorkey = FALSE,
                                par.settings = list(axis.line = list(col = 'transparent')),
                                xlab = list(label = paste(ynam, "Lag", sep = " "), cex = .8, rot = 20),
                                ylab = list(label = paste(xnam, "Lag", sep = " "), cex = .8, rot = -18),
                                zlab = list(label = NULL, cex.axis = 0.5),
                                col.regions = scales::brewer_pal(palette = palette)(11))
    }
    else {
        stop("Invalid value for palette.")
    }

    # if(isTRUE(horizontal)) {
        output <- cowplot::plot_grid(b, a, nrow = 2, scale = c(2, 1))
    # }
    # else if(isFALSE(horizontal)) {
    #     output <- cowplot::plot_grid(b, a, ncol = 2, nrow = 1, scale = c(1, 1))
    # }
    # else {
    #     stop("horizontal must be either TRUE or FALSE")
    # }

    return(output)
}

#' Calculate the variogram data frame for a model
#'
#' @param model.obj An asreml model
#'
#' @return A data frame with the variogram for a model. The data frame contains the spatial coordinates (typically row and column), the $gamma$ for that position and the number of points with the separation.
#' @keywords internal
vario_df <- function(model.obj) {
    # The 'z' value for the variogram is the residuals
    # Need to be able to pull out the x/y from the model object

    dims <- unlist(strsplit(names(model.obj$R.param[1]), ":"))
    Row <- as.numeric(model.obj$mf[[dims[1]]])
    Column <- as.numeric(model.obj$mf[[dims[2]]])
    Resid <- residuals(model.obj)

    nrows <- max(Row)
    ncols <- max(Column)

    vario <- expand.grid(Row = 0:(nrows-1), Column = 0:(ncols-1))

    # Ignore the 0, 0 case (gamma=0, counted row*cols times)
    gammas <- rep(0, nrows*ncols)
    nps <- rep(nrows*ncols, nrows*ncols)

    for (index in 2:nrow(vario)) {
        i <- vario[index, 'Row']
        j <- vario[index, 'Column']

        gamma <- 0
        np <- 0
        for (val_index in 1:nrows) {
            # val <- vals[val_index, ]

            # Deliberate double-counting so that offset handling is easy
            # (so e.g. we compute distance from (1,1)->(2,3), and then again
            # later from (2,3)->(1,1)).
            for (offset in unique(list(c(i, j), c(-i, j), c(i, -j), c(-i, -j)))) {
                row <- Row[val_index] + offset[1]
                col <- Column[val_index] + offset[2]

                if (0 < row && row <= nrows && 0 < col && col <= ncols) {
                    other <- which(Row == row & Column == col)
                    gamma <- gamma + (Resid[val_index]-Resid[other])^2
                    np <- np + 1
                }
            }
        }
        # Since we double-counted precisely, halve to get the correct answer.
        np <- np / 2
        gamma <- gamma / 2

        if (np > 0) {
            gamma <- gamma / (2*np)
        }

        gammas[index] <- gamma
        nps[index] <- np
    }
    vario <- cbind(vario, data.frame(gamma = gammas, np = nps))
    colnames(vario) <- c(dims, "gamma", "np")
    class(vario) <- c("variogram", "data.frame")
    return(vario)
}


#' Compute arithmetic mean with confidence interval.
.get_mean_with_ci <- function (data, key, metric_name) {
    # Key not used but supplied by group map calls.

    # We work on run means for speed.
    runs <- get_run_means (data, metric_name)

    # Do not even try with one run.
    if (length (runs) > 1) {

        # Standard bootstrap computation.
        mean_boot <- boot (runs, function (d, i) mean (d [i]), R = REPLICATES)

        # The computations can fail so fall back to something if they do.
        mean_ci <- tryCatch (boot.ci (mean_boot, type = 'bca', conf = CONFIDENCE), error = function (e) NA)
        if (!is.null (mean_ci) && !any (is.na (mean_ci))) return (tibble (avg = mean_boot $ t0, lo = mean_ci $ bca [1,4], hi = mean_ci $ bca [1,5]))
        mean_ci <- tryCatch (boot.ci (mean_boot, type = 'basic', conf = CONFIDENCE), error = function (e) NA)
        if (!is.null (mean_ci) && !any (is.na (mean_ci))) return (tibble (avg = mean_boot $ t0, lo = mean_ci $ basic [1,4], hi = mean_ci $ basic [1,5]))
    }

    return (tibble (avg = mean (runs), lo = NA, hi = NA))
}

#' Compute arithmetic means with confidence intervals per given group.
comp_mean_with_ci <- function (data, metric_name) {
    return (data %>% group_modify (.get_mean_with_ci, metric_name))
}


##############################################################
# Description:   Create pseudo-data for the VIVED app.
# Usage: R -f CreatePseudoDataGithub.r --args <output_prefix> <start> <end> <frac_missing>
# Author: Haley Hunter-Zinck
# Date: April 28, 2017
# Dependencies:
# Input: optional: .params
# Output: .edis.csv
##############################################################

# user input
args=commandArgs(trailingOnly=TRUE)
if(length(args)!=4)
{
	print("Usage: R -f CreatePseudoDataGithub.r --args <output_prefix> <start> <end> <frac_missing>")
	q(save="no")
}
# args=c("example_dataset", "3001-01-01", "3003-12-31","0.05")

# get start time
t1Total=as.double(format(Sys.time(),"%s"))

# packages

# parameters
outprefix=args[1]
start=as.POSIXct(args[2])
end=as.POSIXct(args[3])
fmiss=as.double(args[4])

# files
pfile=paste(outprefix,".params", sep="")
eOutfile=paste(outprefix,".edis.csv", sep="")

# constants
ADMIT=c("Admit", "Telemetry", "ICU", "Psych")
ADMIT_PROB=c(0.7,0.1,0.1,0.1)
DISCHARGE=c("Home", "Eloped", "AMA")
DISCHARGE_PROB=c(0.98,0.01,0.01)
ACUITY=c(1:5)
ACUITY_PROB=c(0.01,0.1,0.69,0.1,0.1)
PROVIDERS=c("Provider1", "Provider2", "Provider3", "Provider4")
PSIDS=c(1:10000)
WARD=paste("Ward",c(1:50),sep="")
LOC=sort(rep(paste("Location",c(1:5),sep=""),5))
STATION=3

# set parameters to default or given a parameter file
setParam=function(file)
{
	# initialize
	params=list()

	if(!file.exists(file))
	{
		# default parameters for edis
		params$intervalMean=30
		params$fracAdmit=0.3
		params$ttMean=5
		params$tsMean=15
		params$tdMean=60
		params$maxProb=1
		params$ageMean=65
		params$ageSd=15

		# default parameters for inpat
		params$inpatIntervalMean=20
		params$itoMean=2*24*60

	} else
	{
		params=readRDS(file)
	}
	return(params)
}

# probability that visit should be removed
probRemove=function(x,maxProb=1)
{
	scaled=maxProb/720^2
	return(scaled*(x-1440/2)^2)
}

# read params
params=setParam(pfile)

################### EDIS #######################

# create time in for all visits
totalMin=(as.double(end+24*3600-1)-as.double(start))/60
intervals=rexp(ceiling(totalMin/params$intervalMean), rate=1/params$intervalMean)
ti=as.POSIXct(start+cumsum(intervals)*60)

# remove ti if beyond data range
indeces=which(ti>=end+24*3600)
if(length(indeces)>0)
{
	ti=ti[-indeces]
}

# remove ti with probability a function of time of day
tiMin=as.double(format(ti,"%H"))*60+as.double(format(ti,"%M"))
rIndeces=which(runif(length(ti))<probRemove(tiMin%%1440,maxProb=params$maxProb))
ti=ti[-rIndeces]

# get dispositions
disp=rep(NA,length(ti))
iAdmit=sample(c(1:length(ti)),round(params$fracAdmit*length(ti)))
disp[iAdmit]=sample(ADMIT,length(iAdmit),replace=TRUE,prob=ADMIT_PROB)
disp[-iAdmit]=sample(DISCHARGE,length(disp)-length(iAdmit),replace=TRUE, prob=DISCHARGE_PROB)

# get providers
md=sample(PROVIDERS,length(ti),replace=TRUE)

# get acuity
acuity=sample(ACUITY,length(ti), replace=TRUE, prob=ACUITY_PROB)

# get age
ageAtVisit=round(rnorm(length(ti),mean=params$ageMean, sd=params$ageSd))

# create time triage
intervals=rexp(length(ti), rate=1/params$ttMean)
tt=as.POSIXct(ti+intervals*60)

# create time seen
intervals=rexp(length(ti), rate=1/params$tsMean)
ts=as.POSIXct(tt+intervals*60)

# create time disposition
intervals=rexp(length(ti), rate=1/params$tdMean)
td=as.POSIXct(ts+intervals*60)

# create time out (time betwen disp and to should be longer)
intervals=rexp(length(ti), rate=1/params$tdMean)
to=as.POSIXct(td+intervals*60)
to[iAdmit]=as.POSIXct(to[iAdmit]+intervals[iAdmit]*60)

# setup for writing
header=c("VisitId","Station","PatientID","TimeIn","TimeOut",
	"TimeDisposition","MdAssigned","Acuity","Disposition",
	"AgeAtVisit","TimeAcuity","TimeSeen")
towrite=cbind(c(1:length(ti)),rep(STATION,length(ti)),sample(PSIDS,length(ti), replace=TRUE),format(ti), format(to),
	format(td), md, acuity,disp,
	ageAtVisit, format(tt), format(ts))

# incorporate missingness if required
if(fmiss>0)
{
	indeces=sample(c(1:length(towrite)),length(towrite)*fmiss)
	towrite[indeces]=NA
}

# write to file
towrite=rbind(header,towrite)
write(t(towrite),sep=",", file=eOutfile, ncolumns=ncol(towrite))

# get end time
t2Total=as.double(format(Sys.time(),"%s"))

# debug
printSumm=function()
{
    cat("#############################################\n")
	cat("Outfile: ",eOutfile,"\n",sep="")
    cat("Runtime: ",t2Total-t1Total," s\n",sep="")
    cat("#############################################\n")
}
printSumm()


# Calculo de Promedio de Grupos para salida de RNA
# retorna una vector con los promedio de los grupos de 100 iteraciones
prom_clases<-function(y,target)
{
yc<-y-matrix(rep(colMeans(y),nrow(y)),ncol=ncol(y),byrow=TRUE)
salida<-as.matrix(yc)%*%carga
return(salida)
}

src/AppBundle/R/calculo promedio grupos kmeans.r


s = 0

i = 1
repeat

{

  s = s + i
  i = i + 1

  if(i==9)
    break
}
cat("sum is", s)


library(MASS)

vecOfFiles=character()
args= commandArgs(trailingOnly = T)
myargs =args[length(args)]
if(length(args)==0){
	vecOfFiles=append(vecOfFiles,"peaksForR.txt")
	print("no args passed to R")
	quit()
}else{
	for(i in 1:length(args)){
		vecOfFiles=append(vecOfFiles,args[i])
		print(args[i])
	}
}

sink("r.out")
vOfPvalues = numeric()
testFunc <- function(x) {
	v = strsplit(x, '\t')
	y =as.integer(strsplit(as.character(v[3]), ',', fixed=TRUE)[[1]])
	results = tryCatch({
		ff = fitdistr(y, "Negative Binomial")
		est_size = ff$estimate[1]
		est_mu = ff$estimate[2]
		#v[2] is height
		cat(
		sprintf("%s\t%s\t%s\t%e\n", v[1], v[2], v[3], 1-pnbinom(q=(as.integer(v[2])-1), size=est_size, mu=est_mu, log.p=F) )
		)
	}, error = function(e) {
		cat(
		sprintf("%s\t%s\t%s\t%e\n", v[1], v[2], v[3], 0 )
		)
	})
}

for (i in 1:length(vecOfFiles)) {
	t = read.table(file=vecOfFiles[i], sep="\t")
 	tmp = apply(t, 1, testFunc )
}
sink()

#warnings()


print(0);
print(1);
a <- c(0,1);
while(a[[1]] + a[[2]] != Inf)
{
	c <- a[[1]] + a[[2]];
	a <- c(a[[2]], c);
	print(c);
}


require(raster)
require(rgdal)

#dataDir <- "~/Dropbox1T/GlobalCriticalForest/centralamerica/"
#dataDir <- "~/Dropbox/Projects/CriticalGlobalForest/Results/centralamerica/"
dataDir <- "~/Academicos/oceania"
rasterOptions(tmpdir="~/Academicos/tmp")

fil <- list.files(dataDir,pattern="\\.tif$")
fil
setwd(dataDir)

# mod_oc <- raster(fil[3]) # MODIS VCF
# mod_oc[mod_oc==253|mod_oc==200]<-NA
# mod_oc1 <- reclassify(mod_oc,matrix(c(253,NA,200,NA),ncol=2,byrow=T))
# plot(mod_oc,col=grey(1:200/200))

# mod_oc_t10_1<- raster(fil[4]) # Top 10 patches
# plot(mod_oc_t10_1)
# mod_oc_t10_1 <- reclassify(mod_oc_t10_1,cbind(0,NA))
mod_oc_fp_1<-raster(fil[1])   # Forest patches
mod_oc_fp_1

coa_oc1_fp<-aggregate(mod_oc_fp_1,5,fun=max)
coa_oc1_fp
plot(coa_oc1_fp)

require(rworldmap)
data(countriesLow)
crs.gh <- CRS("+proj=wag4 +lon_0=0")
country.gh <- spTransform(countriesLow, crs.gh)
plot(country.gh)
coa_oc1_fpr<-projectRaster(coa_oc1_fp,crs=crs.gh)

plot(coa_oc1_fpr,xlim=c(9e+06,1.7e+07))
plot(country.gh,add=T)
crs(countriesLow)
#
require(dismo)
oc_g<- gmap("Australia",ext=3,type="terrain")
plot(oc_g)
crs(oc_g)

###

r1<-raster(ncol=100,nrow=100)
#values(r1) <- round(runif(ncell(r1)))
r1[,1:20]<- 1
r1[,21:100]<-0
as.matrix(r1)[1,]
r1 <-aggregate(r1,fact=10,fun=max)
as.matrix(r1)[1,]
r1 <- subs(r1,data.frame(1,1))
as.matrix(r1)[1,]
plot(r1,legend=F)

r2<-raster(ncol=100,nrow=100)
#values(r2) <- round(runif(ncell(r2)))
r2[,40:60]<- 2
r2 <- subs(r2,data.frame(2,2))
plot(r2,add=T,col=terrain.colors(4),legend=F)
legend("bottomleft", legend = c("ocean", "category 2", "category 3", "category 4"), fill = rev(terrain.colors(4)))

r3<-raster(ncol=100,nrow=100)
#values(r2) <- round(runif(ncell(r2)))
r3[,80:100]<- 3
r3 <- subs(r3,data.frame(3,3))

r4 <-do.call(cover, list(r1,r2,r3))
as.matrix(r4)[1,]
require(RColorBrewer)
colvec <- brewer.pal(4,"BrBG")
plot(r4,col=colvec,legend=F)
legend("bottomleft", legend = c("category 1", "category 2","Cat 3"), fill = colvec)

require(rasterVis)
levelplot(r4)


library(dmrff)
library(parallel)

options(mc.cores=4)

source("functions.r")

## construct a random dataset
set.seed(20180220)
n.sites <- 1000
n.samples <- 100
manifest <- generate.manifest(n.sites)
dataset <- generate.dataset(n.samples, manifest)

## show methylation correlation structure
r <- sapply(2:nrow(dataset$methylation), function(i)
            cor(dataset$methylation[i,], dataset$methylation[i-1,]))
distance <- tail(manifest$pos,-1) - head(manifest$pos,-1)
distance <- 1/exp(distance/200)
coef(summary(lm(r~distance)))["distance",]
 ##     Estimate    Std. Error       t value      Pr(>|t|)
 ## 9.471601e-01  2.174437e-02  4.355887e+01 5.733639e-233

## run EWAS
ewas.stats <- ewas(dataset$methylation, dataset$data, "variable")

## identify DMRs (there should be none)
ret <- dmrff(ewas.stats$estimate, ewas.stats$se, ewas.stats$p.value,
             dataset$methylation,
             manifest$chr, manifest$pos)
stopifnot(sum(ret$p.adjust < 0.05) == 0)

## generate a variable that has a dmr in the data
var <- generate.true.dmr.var(dataset$methylation, manifest$chr, manifest$pos,
                             cluster.sites=20, dmr.sites=10, cluster.position=0.5,
                             r=0.5, maxgap=500)
dataset$data$variable <- var$var

## run EWAS
ewas.stats <- ewas(dataset$methylation, dataset$data, "variable")

## look at the stats for the DMR CpG sites
ewas.stats[var$dmr.idx,]
##          estimate           se          t     p.value p.adjust
## 316 -0.0005470468 0.0013763417 -0.3974644 0.691926174        1
## 317  0.0040301904 0.0027890924  1.4449828 0.151788140        1
## 318  0.0085432014 0.0032910487  2.5958903 0.010947997        1
## 319  0.0091552368 0.0031276493  2.9271942 0.004289582        1
## 320  0.0074271524 0.0022735968  3.2666972 0.001519592        1
## 321  0.0074153650 0.0023855728  3.1084212 0.002488674        1
## 322  0.0084965433 0.0026289360  3.2319324 0.001695868        1
## 323  0.0032488870 0.0014932333  2.1757397 0.032082156        1
## 324  0.0017993648 0.0008530498  2.1093316 0.037573678        1
## 325  0.0065404556 0.0019777913  3.3069492 0.001336953        1

## identify DMRs (there should be one)
ret <- dmrff(ewas.stats$estimate, ewas.stats$se, ewas.stats$p.value,
             dataset$methylation,
             manifest$chr, manifest$pos)
stopifnot(sum(ret$p.adjust < 0.05) == 1)

ret[which(ret$p.adjust < 0.05),]
##   chr start   end n start.idx end.idx start.orig end.orig   z.orig     p.orig
## 1   1 63431 64019 5       318     322        318      325 2.322495 0.02020632
##          z      p.value    p.adjust
## 1 4.568012 4.923719e-06 0.005307769


source("R/EpiProgInf.r")
source("R/makebetas.R")

 n.sims <- 500
 n.epis <- 25

 fs <- matrix(nrow=n.epis, ncol=n.sims)
 pcts <- matrix(nrow=n.epis, ncol=n.sims)

 K.VC_linear <- fs
 K.VC_rpart <- fs
 K.VC_super <- fs
 K.norm_linear <-fs
 K.norm_rpart <-fs
 K.norm_super <- fs
 K.VC_alone <- fs
 K.norm_alone <- fs
 K.linear_alone <- fs
 K.rpart_alone <- fs
 K.super_alone <- fs

 for (i in 1:n.sims) {

   cat("iteration ", i, "\n")

   many.cov.betas <- gen_betas_many_cov2(n.epis, 5,5)

  N <- nrow(many.cov.betas)
  pcts[,i] <- runif(N, .05,1)
  #pcts <- seq(5,25,length.out = 25)/25

  gamma <- 1/3
  beta <- many.cov.betas$beta2/3

  pop_sz <- rep(10000, N)

  ecs <- gen.epidemic.curves.SIR(pcts[,i], beta,pop_sz, gamma)

  ## Need to decompose ecs into ecs and true final sizes
  fs[,i] <- ecs$fs
  ecs <- ecs$ecs

  ##########RUN THE EM ALGORITHM
  dat <-subset(many.cov.betas, select=-beta2)
  #dat$K <- epi.mdl.normcurve.init(ecs)$K
  dat$K <- 2*sapply(ecs, sum)

  K.VC_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.linear.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.VC_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.rpart.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

   K.VC_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.sl.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.norm_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.linear.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

  K.norm_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.rpart.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.norm_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.sl.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.VC_alone[,i] <- epi.mdl.ViboudChowell.init2(ecs)$K

   K.norm_alone[,i] <- epi.mdl.normcurve.init(ecs)$K

   tmp.dat <- dat
   tmp.dat$K <- sapply(ecs, sum)

   print("RPART STAT")
   K.rpart_alone[,i] <- stat.mdl.rpart.pred(stat.mdl.rpart.fit(tmp.dat))

   print("RPART LIN")
   K.linear_alone[,i] <- stat.mdl.linear.pred(stat.mdl.linear.fit(tmp.dat))

   print("RPART SUPER")
   K.super_alone[,i] <- stat.mdl.sl.pred(stat.mdl.sl.fit(tmp.dat))
 }

save(pcts, fs, K.VC_linear, K.VC_rpart, K.VC_super, K.norm_linear, K.norm_rpart, K.norm_super,
     K.VC_alone, K.norm_alone, K.rpart_alone, K.linear_alone, K.super_alone, file="SIRMulitVar.RData")


# uses the CTFS R formated Tables

# From x,y,species,dbh data Generates a lattice (sed file) with species for dbh>=dbhmin
# and calculates the clusters size distribution
#
# bcidata       = dataframe with x,y data
# biomassXYname = name base for output files
# dbhmin        = min dbh for processing
#
# Result:       A list with H (Shannon Diversity) and S (SPecies richnes) before Hin,Sin
#               and after the discretization Hout,Sout
#               ad_p: the pvalue of Anderson-Darling test to check if SADs are different
#               a data.frame with cluster sizes and species. the firs record signals if an spannig cluster exists.
#
genSpSed_hk<- function(bcidata, biomassXYname, sizex,sizey,lc=1,dbhmin=0)
{
  require(kSamples)
  bci <-with(bcidata, subset(bcidata, status=='A' & !is.na(gx) & dbh>=dbhmin,select=c('gx','gy','sp','dbh')))
  bcin <- as.data.frame(table(bci$sp))
  bcin <-cbind(bcin[rev(order(bcin$Freq)),], seq(nrow(bcin)))
  names(bcin)[3]<-"SpNum"
  names(bcin)[1]<-"sp"
  bci$SpNum <- bcin$SpNum[match(bci$sp,bcin$sp)]
  bci$Freq <- bcin$Freq[match(bci$sp,bcin$sp)]

  require(vegan)
  answer <- list(Hin=diversity(bcin$Freq),Sin=nrow(bcin))

  fname.txt <- paste(biomassXYname ,".txt",sep="")
  fname.sed <- paste(biomassXYname ,".sed",sep="")
  fname.bin <- paste(biomassXYname ,".pat",sep="")
  system(paste0("rm ", fname.sed))
  system(paste0("rm ", fname.bin))

  write.table(bci[,c(1,2,5,6)],fname.txt,col.names=F,row.names=F)

  s <- system("uname -a",intern=T)
  if(!grepl("i686",s)) {
    ClusterizeBin <-paste0(ClusterizeBin,"64")
    hkBin <-paste0(hkBin,"64")
  }
  # Ejecuta XY2sed para generar archivo sed
  syst.txt <- paste(ClusterizeBin, fname.txt, fname.sed, sizex,lc,sizey,lc,"2")
  #syst.txt <- paste("./XY2sed", biomassXYname.txt, biomassXYname.sed, "1000 1 500 1 2")
  system(syst.txt)
  bci <- read_sed(fname.sed)

  bci1 <-as.data.frame(table(bci[bci>0]))

  ks <-ad.test(list(bcin$Freq,bci1$Freq),method="simulated",nsim=1000)

  answer <- c(answer,Hout=diversity(bci1$Freq),Sout=nrow(bci1),ad_p=ks$ad[[7]])
  # Runs hk to calculate clusters
  #

  syst.txt <- paste(hkBin,fname.sed,fname.bin, "SP")
  system(syst.txt)

  clu <-readClusterHk(fname.bin)

  return( c(answer,Clusters=clu) )

  # Leer archivo
}

# Read cluster sizes from hk program output
#
#
readClusterHk <- function(fname){
  den <- read.delim(fname,stringsAsFactors = F)
  return(den)
}

# Genera archivo sed con especie + abundante y calcula espectro MF
#
genSpAbundSed_mfSBA <- function(bcidata, biomassXYname, dbhmin=0)
{
  attach(bcidata)
  # dbh >100 mm
  bci <- subset(bci.full1, status=='A' & !is.na(gx) & dbh>=dbhmin,select=c('gx','gy','sp','agb'))
  detach(bcidata)
  attach(bci)
  bcin <- as.data.frame(table(sp))
  bcin <-cbind(bcin[rev(order(bcin$Freq)),], seq(nrow(bcin)))
  names(bcin)[3]="SpNum"
  bci$SpNum <- bcin$SpNum[match(bci$sp,bcin$sp)]

  library(vegan)
  answer <- list(diversity(bcin$Freq),nrow(bcin))
  names(answer)[[1]]<-"Shannon H"
  names(answer)[[2]]<-"Number of species S"

  biomassXYname.txt <- paste(biomassXYname ,".txt",sep="")
  biomassXYname.sed <- paste(biomassXYname ,".sed",sep="")

  write.table(bci[bci$SpNum==1,c(1,2,5,4)],biomassXYname.txt,col.names=F,row.names=F)
  detach(bci)

  # Ejecuta XY2sed para generar archivo sed
  syst.txt <- paste("./XY2sed", biomassXYname.txt, biomassXYname.sed, "1000 1 500 1 2")
  system(syst.txt)

  # Ejecuta mfSBA para espectro multifractal
  syst.txt <- paste("./mfSBA", biomassXYname.sed, "q21.sed 2  512 20 S")
  system(syst.txt)
  return(answer)
}

#
# Fit 3 models using ML for patch sizes, exponential, power, and power with exponential cutoff
# and calculates DeltaAICc
#

#
# return a data.frame with a field type:
#  1=Spanning
#  2=Most Abundant
#  3=Other not most Abundant
#  4=Other not Spanning
#
BCIFit_Clusters <- function(clu)
{

  require(plyr)
  require(dplyr)

  # Spanning species
  clu1 <-clu %>% slice(1:1) %>% rename(Spanning=ClusterSize)

  clu <- clu %>% slice(2:n()) %>% arrange(desc(ClusterSize))

  clu <- left_join(clu,clu1) %>% mutate(Spanning=ifelse(is.na(Spanning),0,1))

  # Select most abundant or spanning species !!!!!!!
  #
  clu1 <-clu %>% slice(1:1) %>% select(Species,Spanning)

  #if(clu1$Spanning[1]==0)
  #  clu1 <- clu %>%  group_by(Species) %>% summarize(totClu=sum(ClusterSize),Spanning=mean(Spanning)) %>% filter( totClu==max(totClu)) %>% select(Species,Spanning)

  clu2 <- inner_join(clu,clu1)

  # Fits only 1 species patches, most abundant or spanning
  #
  mdl <- fitNeutral_Clusters(clu2,TRUE)
  mdl$Species <- clu$Species[1]
  mdl$ClusterSize <- clu$ClusterSize[1]

  #clu2 <- anti_join(clu,clu1) # eliminates most abundant or spanning sp

  # if there is no spanning sp change Spanning =3, else Spanning =4
  #
  # clu2 <- clu2 %>% mutate(Spanning=ifelse(clu1$Spanning[1]==0,3,4))
  # mdl1 <- fitNeutral_Clusters(clu2)
  # mdl1$Species <- 0
  # mdl1$ClusterSize <- 0

  #mdl <- bind_rows(mdl,mdl1)

  # Calculates DeltaAIC
  #

  mdl <- group_by(mdl,type) %>% mutate( DeltaAIC= AICc -min(AICc)) %>% arrange(DeltaAIC)
  return(mdl)
}

# Plot of cluster sizes
# clu: CLusters
# mdl: fitted models
#
BCIplot_Clusters <- function(clu,mdl,year)
{
  options("scipen"=0, "digits"=4)

  require(plyr)
  require(dplyr)

  # Spanning species
  clu1 <-clu %>% slice(1:1) %>% rename(Spanning=ClusterSize)

  clu <- clu %>% slice(2:n()) %>% arrange(desc(ClusterSize))

  clu <- left_join(clu,clu1) %>% mutate(Spanning=ifelse(is.na(Spanning),0,1))

  # Select most abundant or spanning species !!!!!!!
  #
  clu1 <-clu %>% slice(1:1) %>% select(Species,Spanning)

  tpe<-1
  if(clu1$Spanning[1]==0)
  {
    tdes <- "Max Patch"
    tpe <- 2
  }
  else
    tdes <- "Spanning"

  clu2 <- inner_join(clu,clu1)

  # Plots only 1 species patches, most abundant or spanning
  #
  mPow<-displ$new(clu2$ClusterSize)

  # select power law
  m0 <- filter(mdl,model=="Pow",Year==year,type==tpe)
  xmin <- m0$xmin
  mPow$setXmin(xmin)
  mPow$setPars(m0$alfa)

  mExp<-disexp$new(clu2$ClusterSize)
  m1 <- filter(mdl,model=="Exp",Year==year,type==tpe)
  mExp$setXmin(xmin)
  mExp$setPars(m1$alfa)
  tit <- paste("BCI",year,tdes)

  m2 <- filter(mdl,model=="PowExp",Year==year,type==tpe)
  freq_plot_displ_exp(clu2$ClusterSize,m0$alfa,m1$alfa,m2$alfa,m2$rate,xmin,tit)
  #cdfplot_displ_exp(clu2$ClusterSize,m0$alfa,m1$alfa,m2$alfa,m2$rate,xmin,tit)

  # Selects not spanning or not most abundant

  # clu2 <- anti_join(clu,clu1) # eliminates most abundant or spanning sp
  #
  # # if there is no spanning sp change Spanning =3, else Spanning =4
  # #
  # clu2 <- clu2 %>% mutate(Spanning=ifelse(clu1$Spanning[1]==0,3,4))
  # tdes <- ifelse(clu1$Spanning[1]==0,"Other Max Patch","Other Spanning")
  # tpe <- ifelse(clu1$Spanning[1]==0,3,4)
  # # Plots multi species patches, not most abundant or not spanning
  # #
  # mPow<-displ$new(clu2$ClusterSize)
  #
  # # select power law
  # m0 <- filter(mdl,model=="Pow",Year==year,type==tpe)
  # xmin <- m0$xmin
  # mPow$setXmin(xmin)
  # mPow$setPars(m0$alfa)
  #
  # mExp<-disexp$new(clu2$ClusterSize)
  # m1 <- filter(mdl,model=="Exp",Year==year,type==tpe)
  # mExp$setXmin(xmin)
  # mExp$setPars(m1$alfa)
  # tit <- paste("BCI",year,tdes)
  #
  # m2 <- filter(mdl,model=="PowExp",Year==year,type==tpe)
  # freq_plot_displ_exp(clu2$ClusterSize,m0$alfa,m1$alfa,m2$alfa,m2$rate,xmin,tit)
  #cdfplot_displ_exp(clu2$ClusterSize,m0$alfa,m1$alfa,m2$alfa,m2$rate,xmin,tit)

}

BCI_fit_plot <-function(rdat,dat,spdat,year,x=1000,y=500,lc=1)
{

  setwd(BCIwd)

  load(rdat)
  dat <- get(dat)
  sa <- genSpSed_hk(dat,spdat,x,y,lc)

  BCIClus <- data.frame(Species=sa$Clusters.Species,ClusterSize=sa$Clusters.ClusterSize)
  maxClus <-top_n(BCIClus,1)
  sumClus <-filter(BCIClus,Species==maxClus$Species) %>% summarise(totSmax=sum(ClusterSize))

    hs <- data.frame(Year=year,Hin=sa$Hin,Hout=sa$Hout,Sin=sa$Sin,Sout=sa$Sout,SpanSp=sa$Clusters.Species[1],
                   SpanClus=sa$Clusters.ClusterSize[1], SmaxSpecies=maxClus$Species, Smax=maxClus$ClusterSize,SmaxTotal=sumClus$totSmax,AD_p=sa$ad_p)

  dl <- BCIFit_Clusters(BCIClus)
  dl$Year <- year

  setwd(oldcd)

  setwd("figs")
  BCIplot_Clusters(BCIClus,dl,year)

  setwd(oldcd)
  return(list(BCIhsize=hs,BCIMdl=dl))
}