#author: Thomas Coleman
# Difference in Differences Regressions - Error Analysis and Graphs for data from Snow 1855

# See "Causality in the Time of Cholera" working paper at https://papers.ssrn.com/abstract=3262234
# and my John Snow project website, http://www.hilerun.org/econ/papers/snow

# This code is licensed under the BSD 2-Clause License, https://opensource.org/licenses/BSD-2-Clause

# This collect together some simple functions that produce a standard format graph, and are 'source'd
# into various notebooks

# **preperrdata** Before graphing, to prepare the data

#  * Takes in *fittedmodel* - a regression that has been already run. From this it extracts the necessary
#  parameters. Also *single*, a string which for "single" says that there is a single treatment effect.
#  * Calculates the 1849 and 1854 predicted counts and rates
#  * Calculates *approximate* 95% error bars around the predicted rates, based on whether the fitted model
#  is Poisson or Negative Binomial
#  * Produces an adjusted 1854 predicted rate, adjusting for the 1854 time effect and treatment effect, so
#  that it is comparable to the 1849 predicted rate (for purposes of plotting with error bars)

#  This function changes global data (the x1849 & x1854 dataframes) using the "<<-" instead of "<-"
#  assignment. This is poor programming style but I could not find another easy way of doing what I wanted.

# **plot2_worker** Plots actual vs predicted, with error bars around the predicted

#  * Actually does the plotting, given all the data as input arguments (sequence no. for sub-districts;
#  the actual mean or rate; predicted; the 2.5% and 97.5% points; title)
#  * btw, the hack for plotting error bars is from
#  https://stackoverflow.com/questions/13032777/scatter-plot-with-error-bars

# **plot2_worker** Is a cover function which unpacks the actual versus predicted mean from the appropriate dataframe

# **plot3** Plots actual 1849, 1854 (adjusted for time & treatment effects), predicted, with error bars

# **plotcomp** Plots actual 1849 versus 1854, with error bars around actual 1849

# **ploterrbars** is NOT a function you should use - I use it to print out .pdf versions of the graphs I want to use

preperrdata <- function(fittedmodel,single = "single") {       # This is not a good way to do this because I am
	                                                  # changing globals from within the function (using <<-
	                                                  # instead of <-)
# Function to prepare the data (error bars) for graphing
# The 2.5% and 97.5% confidence bands are calculated assuming either Poisson or Negative Binomial
# The rates are calculated by generating the counts up and down from the "expected" (from the fitted model)

	expected <- exp(predict(fittedmodel))       # expected values
	theta <- fittedmodel$theta
	x1849$predcount <<- expected[1:28]
	x1854$predcount <<- expected[29:56]
	x1849$predrate <<- 10000 * expected[1:28] / x1849$pop1851
	x1854$predrate <<- 10000 * expected[29:56] / x1854$pop1851
	xfamily <- family(fittedmodel)$family
	if (xfamily == "poisson") {         # Get 95% confidence bands depending on model used (Poiss vs Neg Binom)
		x1849$limdn <<- 10000 * qpois(.025,lambda=x1849$predcount) / x1849$pop1851
		x1849$limup <<- 10000 * qpois(.975,lambda=x1849$predcount) / x1849$pop1851
	} else {
		x1849$limdn <<- 10000 * qnbinom(.025,size=theta,mu=x1849$predcount) / x1849$pop1851
		x1849$limup <<- 10000 * qnbinom(.975,size=theta,mu=x1849$predcount) / x1849$pop1851
		x1854$limdn <<- 10000 * qnbinom(.025,size=theta,mu=x1854$predcount) / x1849$pop1851
		x1854$limup <<- 10000 * qnbinom(.975,size=theta,mu=x1854$predcount) / x1849$pop1851
		x1849$limdnact <<- 10000 * qnbinom(.025,size=theta,mu=x1849$deaths) / x1849$pop1851
		x1849$limupact <<- 10000 * qnbinom(.975,size=theta,mu=x1849$deaths) / x1849$pop1851
	}

	# Now adjust the 1854 predicted counts (and rates) for the time and treatment fixed effects -
	# effectively netting out the 1854 effect and making it 1849-equivalent
	xyr1854 <- (coef(fittedmodel)["year1854"])
	x3 <- exp(-xyr1854)
	# Adjust for the year effect only - this should make 1849 & 1854 comparable net of time effect
	x1854$rateadjyr <<- 10000 * (x1854$deaths*x3) / x1854$pop1851
	# Adjust the 1854 actual for the estimated Treatment Effect and the estimate Year Effect
	if (single == "single")  {   # model with single treatment effect
		xdegless <- (coef(fittedmodel)["supplierSouthwarkVauxhall_Lambeth:year1854"])
		xdegmore <- xdegless               # Make both treatment effects the same
		x3 <- x3 * exp(-(x1854$lambethdegree == "less_Lambeth")*xdegless)
		x3 <- x3 * exp(-(x1854$lambethdegree == "more_Lambeth")*xdegmore)
	} else if (single == "two") {      # model with two treatment effects
		xdegless <- coef(fittedmodel)["lambethdegreeless_Lambeth:year1854"]
		xdegmore <- coef(fittedmodel)["lambethdegreemore_Lambeth:year1854"]
		x3 <- x3 * exp(-(x1854$lambethdegree == "less_Lambeth")*xdegless)
		x3 <- x3 * exp(-(x1854$lambethdegree == "more_Lambeth")*xdegmore)
	} else { # model with continuous treatment (population proportions)
		xlambethperc54 <- coef(fittedmodel)["lambethperc54"]
		x3 <- x3 * exp(-(x1854$lambethperc54 * xlambethperc54))
	}

	# Adjust for year & treatment effect - so that we can compare the actuals against each other
	x1854$rateadj <<- 10000 * (x1854$deaths*x3) / x1854$pop1851

	return(xfamily)
}

# "Worker" function to plot mean, predicted, and error bars
plot2_worker <- function(yseq, xmean,xlimdn,xpred,xlimup,title) {
	xplot <- plot(xmean, yseq,
	    xlim=range(c(xmean, xpred,xlimdn,xlimup)),
	    ylim=rev(range(yseq)), col="red",
	    main=title,xlab="Mortality rate actual (red filled) vs predicted (empty circle)",ylab="sub-district",
	    pch=19)
	lines(xpred, yseq, type="p",
	    xlim=range(c(xmean, xpred,xlimdn,xlimup)),
	    ylim=rev(range(yseq)),
	    pch=1)
	# horizontal error bars
	xplot <- arrows(xlimdn, yseq, xlimup, yseq, length=0.05, angle=90, code=3,lty=3)
	xplot
}
# "Cover" function that takes in the dataframe and unpacks
plot2 <- function(confidata,xsupplier,title) {
	xmean <- subset(confidata,supplier==xsupplier)[,"rate"]
	xlimdn <- subset(confidata,supplier==xsupplier)[,"limdn"]
	xlimup <- subset(confidata,supplier==xsupplier)[,"limup"]
	xpred <- subset(confidata,supplier==xsupplier)[,"predrate"]
	yseq <- subset(confidata,supplier==xsupplier)[,"seq"]
#	xtitle <- paste(xsupplier,title)
	xplot <- plot2_worker(yseq,xmean,xlimdn,xpred,xlimup,title)
}

plot3 <- function(confidata1849,confidata1854,xsupplier,title) {
	xmean <- subset(confidata1849,supplier==xsupplier)[,"rate"]
	xlimdn <- subset(confidata1849,supplier==xsupplier)[,"limdn"]
	xlimup <- subset(confidata1849,supplier==xsupplier)[,"limup"]
	xpred <- subset(confidata1849,supplier==xsupplier)[,"predrate"]
	y <- subset(confidata1849,supplier==xsupplier)[,"seq"]
	x1854adj <- subset(confidata1854,supplier==xsupplier)[,"rateadj"]
	xplot <- plot(xmean, y,
	    xlim=range(c(xmean, xpred,xlimdn,xlimup,x1854adj)),
	    ylim=rev(range(y)), col="red",
	    main=title,xlab="Mortality: 1849 red circle, 1854 blue diamond vs predicted (circle)",ylab="sub-district",
	    pch=19)
	lines(xpred, y, type="p",
	    xlim=range(c(xmean, xpred,xlimdn,xlimup)),
	    ylim=rev(range(y)),
	    pch=1)
	lines(x1854adj, y, type="p",
	    xlim=range(c(xmean, xpred,xlimdn,xlimup)),
	    ylim=rev(range(y)), col="blue",
	    pch=17)

	# horizontal error bars
	xplot <- arrows(xlimdn, y, xlimup, y, length=0.05, angle=90, code=3,lty=3)
}

# Plotting joint region for 1849 & 1854 with error bars for each
plotcomp <- function(confidata1849,confidata1854,xsupplier,title) {
	xmean <- subset(confidata1849,supplier==xsupplier)[,"rate"]
	xlimdn <- subset(confidata1849,supplier==xsupplier)[,"limdnact"]
	xlimup <- subset(confidata1849,supplier==xsupplier)[,"limupact"]
	xpred <- subset(confidata1849,supplier==xsupplier)[,"predrate"]
	y <- subset(confidata1849,supplier==xsupplier)[,"seq"]
	xmean1854 <- subset(confidata1854,supplier==xsupplier)[,"rateadjyr"]
#	xlimdn1854 <- subset(confidata1854,supplier==xsupplier)[,"limdn"]
#	xlimup1854 <- subset(confidata1854,supplier==xsupplier)[,"limup"]
	xplot <- plot(xmean, y,
	    xlim=range(c(xmean, xmean1854,xlimdn,xlimup)),
	    ylim=rev(range(y)), col="red",
	    main=title,xlab="Mortality: 1849 red circle, 1854 blue diamond",ylab="sub-district",
	    pch=19)
	lines(xmean1854, y, type="p",
	    xlim=range(c(xmean, xmean1854,xlimdn,xlimup)),
	    ylim=rev(range(y)), col="blue",
	    pch=17)

	# horizontal error bars
	xplot <- arrows(xlimdn, y, xlimup, y, length=0.05, angle=90, code=3,,lty=3)
#	xplot <- arrows(xlimdn1854, y, xlimup1854, y, length=0.05, angle=90, code=3)
}

ploterrbars <- function(fittedmodel,plotname,single = "single") {       # This is not a good way to do this because I am
	                                                  # changing globals from within the function (using <<-
	                                                  # instead of <-)
	xfamily <- preperrdata(fittedmodel,single)  # this function modifies global data

	pdf(paste("../paper/figures/errbar_",plotname,"a.pdf",sep=""))
		plot2(x1849,"SouthwarkVauxhall",paste("First-12 Southwark-only ",xfamily," 1849 "))
	dev.off()
	pdf(paste("../paper/figures/errbar_",plotname,"b.pdf",sep=""))
		plot2(x1849,"SouthwarkVauxhall_Lambeth",paste("Next-16 Jointly-Supplied ",xfamily," 1849 "))
	dev.off()
	pdf(paste("../paper/figures/errbar_",plotname,"c.pdf",sep=""))
		plot3(x1849,x1854,"SouthwarkVauxhall",paste("First-12 Southwark-only ",xfamily," 1849vs1854 "))
	dev.off()
	pdf(paste("../paper/figures/errbar_",plotname,"d.pdf",sep=""))
		plot3(x1849,x1854,"SouthwarkVauxhall_Lambeth",paste("Next-16 Jointly-Supplied ",xfamily," 1849vs1854 "))
	dev.off()
	if (xfamily != "poisson") {         # Plot comparison for joint region only for Negative Binomial
		pdf(paste("../paper/figures/errbar_",plotname,"e.pdf",sep=""))
			plotcomp(x1849,x1854,"SouthwarkVauxhall",paste("First-12 Southwark-only ",xfamily," 1849vs1854 "))
		dev.off()
		pdf(paste("../paper/figures/errbar_",plotname,"f.pdf",sep=""))
			plotcomp(x1849,x1854,"SouthwarkVauxhall_Lambeth",paste("Next-16 Jointly-Supplied ",xfamily," 1849vs1854 "))
		dev.off()
	}

}


if (latitude < 0):
    if (sowingDay > sDsa_sh):
        fixPhyll = p * (1 - rp * min(sowingDay - sDsa_sh, sDws))
    else: fixPhyll = p
else:
    if (sowingDay < sDsa_nh):
        fixPhyll = p * (1 - rp * min(sowingDay, sDws))
    else: fixPhyll = p


library(shiny)
library(shinyjs)
load("table.Rdata")
library(qvalue, lib.loc= .libPaths()[1])

shinyServer(function(input, output) {

  output$subTabs <- renderUI({
    tabsetPanel(id = "subTabPanel1",
                tabPanel("Plot",plotOutput("qvaluePlot", height="1200px", width="1200px")%>% withSpinner(color="#c10b26") , downloadButton('downloadData.plot', 'Download Plot' )), tabPanel("Histogram", plotOutput("qvalueHist", height="1200px", width="1200px")%>% withSpinner(color="#c10b26"), downloadButton('downloadData.histogram', 'Download Histogram')), tabPanel("Summary", verbatimTextOutput("summary")%>% withSpinner(color="#c10b26"))    )
  })
  # Return the requested dataset

  # input$file1 will be NULL initially. After the user selects and uploads a
  # file, it will be a data frame with 'name', 'size', 'type', and 'datapath'
  # columns. The 'datapath' column will contain the local filenames where the
  # data can be found.
  pi0Input <- reactive({
    switch(input$pi0method,
           "smoother" = "smoother",
           "bootstrap" = "bootstrap")
  })
  datasetInput <- reactive({
    inFile <- input$file
    if (is.null(inFile)) return()
    dataset <- read.csv(file.path("data", inFile), header=input$header, sep=input$sep)
    # generate an rnorm distribution and plot it
    dataset <-unlist(dataset,use.names=FALSE)
    qval <- qvalue(data.matrix(dataset),
                   pi0.method=pi0Input(),
                   fdr.level=input$fdr,
                   lambda=seq(from=input$lambda[1],
                              to=input$lambda[2],
                              by=input$step),
                   smooth.df=input$sdf,
                   smooth.log.pi0=input$pi0log,
                   trunc=input$trunc,
                   monotone=input$mono,
                   transf=input$transf,
                   adj=input$adj,
                   eps=input$eps,
                   pfdr=input$pfdr)
  })
  output$qvaluePlot <- renderPlot({
    out <- datasetInput()
    if (is.null(out)) return()
    plot(out)
  })
  output$qvalueHist <- renderPlot({
    out <- datasetInput()
    if (is.null(out)) return()
    hist(out)
  })
  # Generate a summary of the dataset
  output$summary <- renderPrint({
    out <- datasetInput()
    if (is.null(out)) return()
    summary(out)
  })
  output$summary2 <- renderPrint({
    paste0(help(qvalue))
  })
  output$downloadData <- downloadHandler(
    filename =c('qvalue_output.txt'),
    content = function(file) {
      qwrite(datasetInput(), file)
    }
  )
  output$help <- renderTable({
    if (is.null(table)) {return()}
    print(table)
  }, 'include.rownames' = FALSE
  , 'include.colnames' = TRUE
  , 'sanitize.text.function' = function(x){x}
  )
  # output$help <- renderUI({
  #addResourcePath("library", "usr/lib64/R/library")
  #  getHelpURL=function() {
  #file=as.character(help(qvalue))
  #if (length(file) == 0) stop("No help file found")
  #path <- dirname(file)
  #dirpath <- dirname(path)
  #pkgname <- basename(dirpath)
  #"http://www.bioconductor.org/packages/release/bioc/manuals/qvalue/man/qvalue.pdf"
  #   "http://www.princeton.edu/~ajbass/qvalue_helpFiles/qvalue.html"
  # }
  # tags$iframe(#style="width: 100%; height: 100%; position: absolute; left: 0px; top: 0px; right: 0px; bottom: 0px; ",
  #   style="width: 100%; height: 600px;", # should be sized to contents but no idea how.
  #   seamless="TRUE",
  #   src=getHelpURL())
  # })
  output$about <- renderUI({
    wellPanel(
      p("This is a Shiny implementation of the qvalue R package, adapted from the app created by Andrew Bass. This tool allows to explore the FDR of the ExG associations that can be studied in CLIMGeno and GenoCLIM. The qvalue R package is by John Storey et al. and can be found at Bioconductor's repository:", a("qvalue package",     href="http://www.bioconductor.org/packages/release/bioc/html/qvalue.html")),
      p("In order to use this application:"),
      p("1. Choose the ExG association  of interest"),
      p("2. It is then possible to modify the settings that are used to estimate q-values with the various options on the side panel. See the 'Help' tab in the application or see the", a("user manual", href="http://www.bioconductor.org/packages/release/bioc/vignettes/qvalue/inst/doc/qvalue.pdf"), "for the qvalue package by John D. Storey and Andrew J. Bassfor explanations of these options."),
      p("3. To view useful visualizations of the results refer to the 'Figures' tab for plots produced by qvalue package. Allow enough time for calculations and plot redering. When you are finished with your analysis, you may click the 'Download Output' button to save your results.")
    )
  })
  output$ref <- renderUI({
    wellPanel(
      p("-", tags$b("Estimation Methodology:"), "Storey JD. (2002) A direct approach to false discovery rates. Journal of the Royal Statistical Society, Series B, 64: 479-498.", a("[PDF]", href="http://genomics.princeton.edu/storeylab//papers/directfdr.pdf")),
      p("-", tags$b("Genomics:"), "Storey JD and Tibshirani R. (2003) Statistical significance for genome-wide studies. Proceedings of the National Academy of Sciences, 100: 9440-9445.", a("[PDF]", href="http://genomics.princeton.edu/storeylab//papers/Storey_Tibs_PNAS_2003.pdf"), a("[Supplementary Information]", href="http://genomics.princeton.edu/storeylab/qvalue/results.html")),
      p("-", tags$b("Bayesian Connections:"), "Storey JD. (2003) The positive false discovery rate: A Bayesian interpretation and the q-value. Annals of Statistics, 31: 2013-2035.", a("[PDF]", href="http://genomics.princeton.edu/storeylab//papers/Storey_Annals_2003.pdf")),
      p("-", tags$b("Theory:"), "Storey JD, Taylor JE, and Siegmund D. (2004) Strong control, conservative point estimation, and simultaneous conservative consistency of false discovery rates: A unified approach. Journal of the Royal Statistical Society, Series B, 66: 187-205.", a("[PDF]", href="http://genomics.princeton.edu/storeylab//papers/623.pdf")),

      div(tags$a(img(src='shiny.png',  height="100px"),href="https://shiny.rstudio.com/"),
          tags$a(img(src='rstudio.png',  height="100px"),href="https://www.rstudio.com/"),
          tags$a(img(src='bioconductor.png',  height="100px"),href="https://www.bioconductor.org/"),
          tags$a(img(src='1001.png',  height="100px"),href="http://1001genomes.org/"),  align="middle", style="text-align: center;"),

      h3(''),
      h3(''),

      tags$a(div(img(src='climtools.png',  align="middle"), style="text-align: center;"), href="http://www.personal.psu.edu/sma3/CLIMtools.html"),

      tags$a(div(img(src='climtools logo.png',  align="middle"), style="text-align: center;"), href="http://www.personal.psu.edu/sma3/CLIMtools.html"),
      tags$a(div(img(src='github.png'), style="text-align: center;"), href="https://github.com/CLIMtools/FDRCLIM"),

      h3(''),
      tags$a(div(img(src='assmann_lab.png'), style="text-align: center;"), href="http://www.personal.psu.edu/sma3/index.html")

      )
  })
  output$downloadData.plot <- downloadHandler(
    filename <- function() {
      paste('plot', Sys.Date(),'.pdf',sep='') },
    content <- function(file) {
      pdf(file, width=10, height=10)
      top6.plot <- plot(datasetInput())
      print(top6.plot)
      dev.off()},
    contentType = 'image/pdf'
  )
  output$downloadData.histogram <- downloadHandler(
    filename <- function() {
      paste('histogram', Sys.Date(),'.pdf',sep='') },
    content <- function(file) {
      pdf(file, width=10, height=10)
      top6.hist <- hist(datasetInput())
      print(top6.hist)
      dev.off()},
    contentType = 'image/pdf')

})


library(base)
library(caret)
library(e1071)
library(graphics)
library(modules)
library(neuralnet)
library(rsample)
library(rstudioapi)
library(stats)
library(tidyverse)
library(utils)

base::setwd(base::dirname(rstudioapi::getActiveDocumentContext()$path))
start <- base::Sys.time()

base::set.seed(0xACDC)

data <- modules::use('data')$get_data$get_data()

target_column <- 47
target_column_name <- base::colnames(data)[target_column]
train_test_prop <- 0.75

formula <- stats::as.formula(base::paste(target_column_name, ' ~ .'))

data$url <- NULL
data[, target_column_name] <-
  base::ifelse(data[, target_column_name] == 'legitimate', 1, 2)

data_split <- rsample::initial_split(data, prop = train_test_prop)
data_train <- rsample::training(data_split)
data_test <- rsample::testing(data_split)

target_data <- data[, target_column_name]
target_train <- data_train[, target_column_name]
target_test <- data_test[, target_column_name]

maxs <- base::apply(data, 2, max)
mins <- base::apply(data, 2, min)

scaled <-
  base::as.data.frame(base::scale(data, center = mins, scale = maxs - mins))

data_train_scaled <- scaled[data_split$in_id, ]
data_test_scaled <- scaled[-data_split$in_id, ]

nn <- neuralnet::neuralnet(
  formula,
  data = data_train_scaled,
  hidden = base::c(6, 3),
  linear.output = TRUE
)

base::plot(nn, rep = 'best')

best_rep <- base::which.min(nn$result.matrix[1, ])

plot_results <- function(target, ds_pr.nn, title) {
  graphics::plot(
    target,
    type = 'p',
    col = 'red',
    xlab = 'Sample',
    ylab = 'Status',
    main = base::paste(title, ': Real (red) - Predicted (blue)')
  )
  graphics::lines(ds_pr.nn, type = 'p', col = 'blue')
}

do_mlp <- function(fdata, target, ds_pr.nn) {
  error <- target - ds_pr.nn

  R2 <-
    1 - base::sum(error ^ 2) /
    base::sum((target - base::mean(target_data)) ^ 2)
  R2_adjust <-
    (1 - (1 - R2) * (base::nrow(fdata) - 1) /
       (base::nrow(fdata) - base::ncol(fdata) - 1))

  target <- base::ifelse(target == 1, 'legitimate', 'phishing')

  predicted <-
    base::ifelse(base::round(ds_pr.nn) == 1, 'legitimate', 'phishing')

  cm <-
    caret::confusionMatrix(base::as.factor(predicted), base::as.factor(target))

  base::print(base::paste('R2:', R2))
  base::print(base::paste('R2 adjust:', R2_adjust))
  base::print(cm$table)
  base::print(cm$overall['Accuracy'])
}

pr.nn_training <-
  stats::predict(nn, data_train_scaled, rep = best_rep, all.units = FALSE)

ds_pr.nn_train <-
  pr.nn_training *
  (maxs[target_column_name] - mins[target_column_name]) +
  mins[target_column_name]

pr.nn_test <-
  stats::predict(nn, data_test_scaled, rep = best_rep, all.units = FALSE)

ds_pr.nn_test <-
  pr.nn_test *
  (maxs[target_column_name] - mins[target_column_name]) +
  mins[target_column_name]

base::print('Train:')
do_mlp(data_train, target_train, ds_pr.nn_train)

base::print('Test:')
plot_results(target_test, ds_pr.nn_test, 'Test')
do_mlp(data_test, target_test, ds_pr.nn_test)

base::print(base::Sys.time() - start)
base::rm(start)

predict_using_mlp <- function(file = 'scripts/output.csv') {
  output <- utils::read.csv(
    file,
    header = TRUE,
    sep = ',',
    stringsAsFactors = FALSE,
    strip.white = TRUE
  )

  urls <- output$url
  output$url <- NULL

  results <-
    base::ifelse(base::round(
      stats::predict(nn, output, rep = best_rep, all.units = FALSE) *
        (maxs[target_column_name] - mins[target_column_name]) +
        mins[target_column_name]
    ) == 1,
    'legitimate',
    'phishing')

  base::print(base::data.frame(url = urls, status = results))
}


geo <- read.csv("geo.dat", header=TRUE)
head(geo)

library(ggmap)
library(plyr)
map <- get_map(location = 'United States of America', zoom = 4)

info <- ddply(geo, c("state"), summarise, quant = length(state), lat = mean(lat), lon = mean(lon))
head(info)

mapPoints <- ggmap(map) + geom_point(aes(x = lon, y = lat, size = quant), data = info, alpha = .5)
mapPoints

mapPoints <- ggmap(map) + geom_point(aes(x = lon, y = lat, size =(quant), color=state), data = info, alpha = 1)
mapPointsLegend <- mapPoints + scale_size_area(name = "Cidades com mais tweets")
mapPointsLegend


###############################################################################
##                                                                           ##
##  Exploratory Data Analysis                                                ##
##  Project 01                                                               ##
##  Plot 03                                                                  ##
##                                                                           ##
###############################################################################

#
# Read in all data
# Note: if you ran my code for an earlier plot you can skip to below
#

data <- read.csv(file = "./data/household_power_consumption.txt",
                 header = TRUE,
                 sep = ";",
                 na.strings = "?")

#
# Add in new column DateC that converts data$Date from factor to date
#

data$DateC <- as.Date(data$Date, format="%d/%m/%Y")

#
# Subset for our dates of interest
#

data <- subset(data, subset=(DateC >= "2007-02-01" & DateC <= "2007-02-02"))

#
# Consider time...
#

data$DateC <- as.POSIXct(paste(data$DateC, data$Time))

#
# OK, DateC now has date and time data, let's make plots and save them to png
# NOTE: If you ran my code for another plot then you can start here
#

png(filename = "./data/plot3.png",
    width = 480,
    height = 480)

plot(x = data$DateC,
     y = data$Sub_metering_1,
     type = "l",
     xlab="",
     ylab="Energy sub metering")
lines(x = data$DateC,
      y = data$Sub_metering_2,
      type = "l",
      col = "red")
lines(x = data$DateC,
      y = data$Sub_metering_3,
      type = "l",
      col = "blue")
legend(x = "topright",
       legend = c("Sub_metering_1", "Sub_metering_2", "Sub_metering_3"),
       col = c("black", "red", "blue"),
       lty = 1,
       lwd = 2)

dev.off()


##CTE534_EDA=group
##Imagen=raster
##Vector=vector
##Campo=field Vector
##Puntos=number 50
##Salida= output table
##Media_Usos= output table
##Tipo=selection Regular;Aleatorio
##showplots
library(sp)
if (Tipo == 0) {
ptsamp<-spsample(Vector,Puntos,type="regular")
class <- over(ptsamp, Vector)
ptsamp$class <- class[[Campo]]
Salida<-extract(Imagen, ptsamp)

ms <- aggregate(Salida,list(ptsamp$class),mean)
#Usar row names en lugar de la primera columna
rownames(ms) <- ms[,1]
Media_Usos <- ms[,-1]
Media_Usos

#transformar ms de data frame a matrix
ms <-as.matrix(Media_Usos)
# Crear espacio de gráfico vacio
plot(0, ylim=c(0,max(Media_Usos)), xlim =c(0,dim(Media_Usos)[2]), type='n', xlab="Bandas", ylab = "Reflectividad")#
# Agregar las diferentes clases
for(i in 1:nrow(ms)){
  lines(ms[i,], type = "l", lwd = 3, lty = 1, col=i)
  }
# Título
title(main="Perfil Espectral", font.main = 2)
# Leyenda
legend("topleft",rownames(ms),cex=0.8, col=c(1:nrow(ms)), lty = 1, lwd =3, bty = "n")

} else if (Tipo == 1) {
ptsamp<-spsample(Vector,Puntos,type="random")
class <- over(ptsamp, Vector)
ptsamp$class <- class[[Campo]]
Salida<-extract(Imagen, ptsamp)

ms <- aggregate(Salida,list(ptsamp$class),mean)
# Usar row names en lugar de la primera columna
rownames(ms) <- ms[,1]
Media_Usos <- ms[,-1]
Media_Usos

#transformar ms de data frame a matrix
ms <-as.matrix(Media_Usos)
# Crear espacio de gráfico vacio
plot(0, ylim=c(0,max(Media_Usos)), xlim =c(0,dim(Media_Usos)[2]), type='n', xlab="Bandas", ylab = "Reflectividad")#
# Agregar las diferentes clases
for(i in 1:nrow(ms)){
  lines(ms[i,], type = "l", lwd = 3, lty = 1, col=i)
  }
# Título
title(main="Perfil Espectral", font.main = 2)
# Leyenda
legend("topleft",rownames(ms),cex=0.8, col=c(1:nrow(ms)), lty = 1, lwd =3, bty = "n")
}


iEat_to_foodWeb <- function(iEatResult) {
    library(stringr)
    foodWeb <- matrix(nrow = nrow(iEatResult), ncol = nrow(iEatResult), data = 0, dimnames = list(rownames(iEatResult), rownames(iEatResult)))

    for(i in 1:nrow(iEatResult)) {
        resources <- unique(c(unlist(str_split(iEatResult[i, 'target_catalogue'], ' \\| ')), unlist(str_split(iEatResult[i, 'target_predictive'], ' \\| '))))
        foodWeb[which(rownames(foodWeb) %in% resources), i] <- 1
    }

    return(foodWeb)
}


library(assertthat)

is.wholenumber <- function(x){
  assert_that(is.numeric(x)&&length(x)==1)
  x%%1==0
}

assert_integer<-function(x){
  assert_that(is.wholenumber(x),msg = paste(x, "is not an integer"))
}

are_elements_equal<- function(x,tol=sqrt(.Machine$double.eps)){
  assert_that(is.numeric(x))
  if (length(x) == 1) return(TRUE)
  abs(max(x) - min(x)) < tol
}


library(ggplot2)
library(odbc)
library(DBI)

rm(list=ls())

myinf1 <- "/projects/varnf/GLASS-III/GLASS-III/results/kallisto/kallisto/final/gene_tpm_matrix_all_samples.tsv"
myinf2 <- "/projects/varnf/SofWar/kallisto/Ensembl_v96_homo_sapiens/homo_sapiens/rRNA_annotation_table.txt"

data <- data.matrix(read.delim(myinf1,row.names=1))
colnames(data) <- gsub("\\.","-",colnames(data))
#data <- log10(data+1)

annotation <- read.delim(myinf2,stringsAsFactor=FALSE)
mygene <- unique(annotation[,"GeneSymbol"])

#Load clinical data
con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

q <- "SELECT al.aliquot_barcode, sa.sample_type, su.*, aliquot_batch
FROM biospecimen.aliquots al
LEFT JOIN clinical.surgeries su ON su.sample_barcode = al.sample_barcode
LEFT JOIN biospecimen.samples sa ON al.sample_barcode = sa.sample_barcode
WHERE aliquot_analyte_type = 'R'"

clin <- dbGetQuery(con,q)

mybatch <- unique(clin[,"aliquot_batch"])

res <- matrix(0,nrow=length(mygene),ncol=length(mybatch))
pval <- matrix(0,nrow=length(mygene),ncol=length(mybatch))
rownames(res) <- rownames(pval) <- mygene
colnames(res) <- colnames(pval) <- mybatch
for(i in 1:length(mybatch))
{
	myaliquots <- clin[which(clin[,"aliquot_batch"]==mybatch[i]),"aliquot_barcode"]
	sub_gene <- data[mygene,myaliquots]
	out_gene <- data[mygene,-which(colnames(data)%in%myaliquots)]
	for(j in 1:nrow(sub_gene))
	{
		pval[j,i] <- wilcox.test(sub_gene[j,],out_gene[j,])$p.value
	}
	res[,i] <- apply(sub_gene,1,mean)

}

apply(res,2,mean)

rrna_meta <- apply(data[mygene,],2,mean)
aliquot_batch <- gsub("-RNA","",clin[match(names(rrna_meta),clin[,"aliquot_barcode"]),"aliquot_batch"])
plot_res <- data.frame(rrna_meta,aliquot_batch)

pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/rrna_by_batch.pdf",width=7,height=4)
p1 <- ggplot(plot_res,aes(y = rrna_meta, x = aliquot_batch)) +
	geom_boxplot() +
	labs(x = "Aliquot batch", y = "rRNA TPM") +
	theme_bw() +
	theme(axis.text.x=element_text(size=7),axis.text.y = element_text(size=7),
	axis.title.x = element_text(size=7),axis.title.y = element_text(size=7),
	panel.grid.major=element_blank(),panel.grid.minor=element_blank(),
	legend.position="none") +
	coord_cartesian(ylim=c(0,200))
p1
dev.off()


library("bnlearn")
data(asia)

data_asia <- data.frame(asia)

# Definindo o cabeçalho com os nomes das variáveis normais, originalmente abreviados
headers <- c('Visitou_Asia','Fumante','Tuberculose','Cancer_Pulmao','Bronquite','Tuberculose_ou_Cancer','RaioX','Dispneia')

colnames(data_asia) <- headers

#Primeira rede, com a biblioteca bnlearn
baeysian_network <- hc(data_asia)


#' Francis effective sample size plots by index
#'
#' Compares input ESS with Francis (2011) estimates. Based on Francis 2011 CJFAS 68: 1124-1138.
#' @param asap name of the variable that read in the asap.rdat file
#' @param index.names names of indices
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotFrancisIndex <- function(asap,index.names,save.plots,od,plotf){

  par(mfrow=c(2,1), mar=c(4,4,2,4) )

  years <- seq(asap$parms$styr, asap$parms$endyr)
  ages <- seq(1,asap$parms$nages)
  cum.age.comp.flag<-0
  index.acomp.flags <- asap$control.parms$index.age.comp.flag
  ind.use <- asap$initial.guesses$index.use.flag  # NOTE: this would make more sense in the control.parm list

  if( sum(index.acomp.flags)>0) {

    i.seq.obs<-seq(1,2*asap$parms$nindices, by=2)
    i.seq.obs<-i.seq.obs[which(index.acomp.flags>0)]
    i.seq.pred<-seq(2,2*asap$parms$nindices, by=2)
    i.seq.pred<-i.seq.pred[which(index.acomp.flags>0)]
    i.neff.seq.obs<-seq(1,sum(index.acomp.flags))

    for (i in 1:asap$parms$nindices) {

      #if (index.acomp.flags[i]==1)  {
      if (index.acomp.flags[i]==1 & sum(asap$index.Neff.init[i,])>1)  {

        cum.age.comp.flag <- sum(index.acomp.flags[1:i])

        t.obs<-   as.data.frame(asap$index.comp.mats [i.seq.obs[cum.age.comp.flag] ] )
        t.pred<-   as.data.frame(asap$index.comp.mats [i.seq.pred[cum.age.comp.flag] ] )

        t.res <- matrix(NA, nrow=0, ncol=6)

        #ESS1 <- asap$index.Neff.init [i.neff.seq.obs[cum.age.comp.flag], ]
        ESS1 <- asap$index.Neff.init [i, ]
        ESS <- ESS1[ESS1>0]
        scale.Neff= max(ESS, na.rm=T)/10

        iyrs <- as.matrix(as.data.frame(asap$index.year [i]) )
        num.ind.yrs <- length(iyrs)  # total number of years in model
        acyrs1 <-  which(years %in% iyrs)  # position of iyrs in vector of years
        acyrs2 <- acyrs1[iyrs %in% years[ESS1>0] ] # position of iyrs in years where age comp exists

        num.acyrs2 <- length(acyrs2)  # number of age comp years

        for (j in 1:num.acyrs2 ){
          #for (j in 1:num.ind.yrs ){
          jj <- acyrs2[j]
          obsf <- CalcFreqMeanSE(ages,ESS[j],as.matrix(t.obs[jj,]) )
          prdf <- CalcFreqMeanSE(ages,ESS[j],t.pred[jj,])
          t.res <- rbind(t.res,c(obsf[1],obsf[1]-1.96*obsf[2],obsf[1]+1.96*obsf[2],
                                 prdf[1],prdf[1]-1.96*prdf[2],prdf[1]+1.96*prdf[2]))
        } # end j loop

        ess.uniques <- unique(ESS)
        len.uniques<- length(ess.uniques)
        Neff.bars <-  ESS/scale.Neff

        #-- First plot
        par(mfrow=c(2,1), mar=c(4,4,2,4) )
        plot(years[acyrs2],t.res[,4],lty=1,lwd=2,col="blue", ylim=c(0,10), ylab="Mean Age",
             type='l', xlab="Year")
        if (len.uniques>1) {
          segments(x0=years[acyrs2], y0=rep(0,num.acyrs2), x1=years[acyrs2], y1=Neff.bars, lwd=5, col='#66BB77aa')
          axis(side=4, at=seq(0,10,2), lab=scale.Neff*seq(0,10,2), las=2 )
          mtext(side = 4, "Eff. Sample Size", line = 3, col='#66BB77')
          lines(years[acyrs2],t.res[,4],lty=1,lwd=2,col="blue")
        } #end test for >1 unique ESS

        Hmisc::errbar(years[acyrs2], t.res[,1],t.res[,3],t.res[,2],ylim=c(0,10),ylab="Mean Age",
               xlab="Year", add=T)

        if(len.uniques==1) title(main=paste0("Index ",i, " (",index.names[i],")", " ESS = ",ESS[i]), outer=F)
        if(len.uniques>1) title(main=paste0("Index ",i, " (",index.names[i],")"), outer=F)

        sdres <- (t.res[,4]-t.res[,1])/((t.res[,1]-t.res[,2])/1.96)
        sdres[sdres==Inf]  <- NA
        sdres[sdres==-Inf]  <- NA
        sdnr <- sd(sdres, na.rm=T)
        rmse <- sqrt(mean(sdres^2, na.rm=T))
        plotrix::barp(sdres,names.arg=years[acyrs2],col="grey50",ylab="Std Resids",xlab="Year")
        legend('topleft',legend=c(paste0("SDNR=",round(sdnr,2)),paste0("RMSE=",round(rmse,2))),cex=0.7,h=T)

        if (save.plots) savePlot(paste0(od,"Francis_Mean_Age_Orig_Ind_",i,".",plotf), type=plotf)

        #-- Second plot
        par(mfrow=c(1,1), mar=rep(4,4) )
        aa <- sort(sdres)
        bb <- qqnorm(aa, plot.it=F)
        qqplot(bb$x,bb$y,xlab="Theoretical Quantile",ylab="Sample Quantiles")
        qqline(aa,col="red")
        abline(a=0,b=1,col="blue",lty=2)
        legend('topleft',legend=c("y=x","1st-3rd quartiles"),lty=c(2,1),col=c("blue","red"))

        if(len.uniques==1) title(main=paste0("Index ",i, " (",index.names[i],")", " ESS = ",ESS[i]), outer=F)
        if(len.uniques>1) title(main=paste0("Index ",i, " (",index.names[i],")"), outer=F)
        if (save.plots) savePlot(paste0(od,"Francis_QQ_Orig_Ind_",i,".",plotf), type=plotf)

      }  #end test for presence/absence of age-comp
    } # end loop on nindices
  }  #end test for index age comp

  return()
} # end function


library(ncdf4, quietly=TRUE)
library(fields, quietly=TRUE)

tpsRegridNetCDF <- function(infile, varname, outfile, gridfile,
                            maskfile="", mask.var="mask", radius=2.5,
                            verbose=FALSE, diagnostics=FALSE,
                            recalc.tps=FALSE, load.tps=FALSE,
                            save.tps=FALSE, tpsfile="",
                            log=FALSE, trace=NULL, fix.lon=TRUE ) {

  ## Regrids netcdf data using the thin-plate-spline algorithm
  ##
  ## Args:
  ##   infile:   name of input netcdf file (string)
  ##   varname:  name of data variable in infile (string)
  ##   outfile:  name of output netcdf file (string)
  ##   gridfile: name of netcdf file w/ lat/lon to project to (string)
  ##   maskfile: name of netcdf file with location mask (string)
  ##   radius:   radius for TPS fit.

  ##   verbose:          print progress messages? (bool)
  ##   diagnostics:      interactive sanity-check as we go? (bool)

  ##   recalc.tps:       recalculate fit object each timestep? (bool)
  ##   load.tps:         load fit object from file? (bool)
  ##   save.tps:         save fit object to file?   (bool)
  ##   tpsfile:  name of file to load/save fit object from/to (string)

  ##   log:      perform log transformation (bool)

  ##   trace:    values below this threshold set to zero (numeric)

  ##   fix.lon:  normalize longitudes to 0:360

  ## Returns: nothing

  ## Infile and gridfile are presumed to have horizontal coordinate
  ## dimensions xc & yc with accompanying 2D auxiliary coordinate
  ## variables lat & lon.

  ## Note that gridfile MUST contain a data variable of some kind; the
  ## ncdf4 library can't handle netcdf files that contain only
  ## coordinate variables.

  ## Maskfile should have exactly the same coordinates as gridfile; set
  ## maskfile to "" for no masking.

  ## A radius value of 2.5 (degrees) is a good default for half-degree /
  ## 50-km data.

  ## Non-essential auxiliary information like map projection, time
  ## bounds, and scalar level coordinate does not get copied into
  ## outfile, so outfile will not be cf-compliant.

  ## If outfile already exists, it will be clobbered with no warning.

  ## The TPS fit depends only on the geometry of the gridpoints, so if
  ## the input coordinates are identical, it can be reused instead of
  ## recalculated, which saves a lot of time.  The only time you
  ## wouldn't want to do this is if there are missing values in the
  ## input data that change from timestep to timestep.

  ## If you want to take it one step further, you can reuse a saved fit
  ## object with different input files, as long as they all have
  ## exactly the same grid locations.  Note that we only load/save a
  ## single fit object to file, so this is incompatible with the
  ## recalc.tps option.

  ## A log transform can be used to ensure that the interpolated values
  ## are always positive (e.g., for precipitation).  The interpolation
  ## is performed on ln(data) and exp(result) is returned.

  ## Trace is the threshold of negligibility.  Values below this
  ## threshold are set to trace/10 before interpolation, and to 0 after
  ## interpolation.  Used in conjunction with the log option, it means
  ## you don't have to worry about zero or negative values.  A good
  ## trace value for precipitation is 0.01.  Whether mm or inches, over
  ## a period of days or longer, a trace threshold of 0.01 will be
  ## negligible.  Meteorological data will often have precip floored to
  ## zero below 0.01 inches.

  if (recalc.tps && (load.tps || save.tps)) {
    print("tpsRegridNetCDF error: recalc.tps option incompatible with load.tps and save.tps.  Aborting.")
    return()
  }

  if (verbose) print("Reading input data...")

  if (diagnostics) par(ask=TRUE)

  vname <- list()

  ## Get coordinates from input data file

  fin <- nc_open(infile)

  for (v in fin$dim){
    va <- ncatt_get(fin, v$name)
    if (identical(va$standard_name, "time")) {
      time <- ncvar_get(fin,v$name)
      vname[["time"]] <- v$name
    }
    if (identical(va$standard_name, "latitude")) {
      iy <- ncvar_get(fin,v$name)
      vname[["iy"]] <- v$name
    }
    if (identical(va$standard_name, "longitude")) {
      ix <- ncvar_get(fin,v$name)
      vname[["ix"]] <- v$name
    }
  }

  static <- is.null(vname[["time"]])
  if (static) {
    nt <- 1
  } else {
    nt <- length(time)
  }

  if(is.null(vname[["ix"]]) || is.null(vname[["iy"]])) {
    for (v in fin$var){
      va <- ncatt_get(fin,v$name)
      if (identical(va$standard_name, "latitude")) {
        ilat <- ncvar_get(fin,v$name)
        ix <- v$dim[1][[1]]$vals
        iy <- v$dim[2][[1]]$vals
        vname[["ilat"]] <- v$name
        vname[["ix"]] <- v$dim[[1]]$name
        vname[["iy"]] <- v$dim[[2]]$name
      }
      if (identical(va$standard_name, "longitude")) {
        ilon <- ncvar_get(fin,v$name)
        vname[["ilon"]] <- v$name
      }
    }
  } else {
    ilat <- t(matrix(iy,length(iy),length(ix)))
    ilon <-   matrix(ix,length(ix),length(iy))
  }

  ## Read in data
  ## this slight convolution avoids dropping of degenerate dimensions
  var <-  fin$var[[varname]]
  data <- ncvar_get(fin,var)

  dim(data) <- var$varsize

  if(static){
    dim(data) <- c(dim(data),1)
  }

  ## Get target coordinates from grid file

  gin <- nc_open(gridfile)

  for (v in gin$dim){
    va <- ncatt_get(gin, v$name)
    if (identical(va$standard_name, "latitude")) {
      yc <- ncvar_get(gin,v$name)
      vname[["yc"]] <- v$name
    }
    if (identical(va$standard_name, "longitude")) {
      xc <- ncvar_get(gin,v$name)
      vname[["xc"]] <- v$name
    }
  }

  twod <- is.null(vname[["xc"]]) || is.null(vname[["yc"]])

  if(twod){
    for (v in gin$var){
      va <- ncatt_get(gin,v$name)
      if (identical(va$standard_name, "latitude")) {
        olat <- ncvar_get(gin,v$name)
        xc <- v$dim[1][[1]]$vals
        yc <- v$dim[2][[1]]$vals
        vname[["olat"]] <- v$name
        vname[["xc"]] <- v$dim[[1]]$name
        vname[["yc"]] <- v$dim[[2]]$name
      }
      if (identical(va$standard_name, "longitude")) {
        olon <- ncvar_get(gin,v$name)
        vname[["olon"]] <- v$name
      }
    }
  } else {
    olat <- t(matrix(yc,length(yc),length(xc)))
    olon <-   matrix(xc,length(xc),length(yc))
  }

  if(fix.lon){
    ilon = ilon %% 360
    olon = olon %% 360
  }

  ## If you wanted to dump the data to R format, do something like this:
  ##  precip <- list( x=lon2d, y=lat2d, z=data, t=time)
  ##  save(precip, file="precip.rda")

  if (diagnostics) {
    ## check that data looks sane
    image.plot(ilon,ilat,data[,,1])
    title("raw data check")
  }

  ## reform the 2-D lat/lon values into N-by-2 arrays
  iloc <- cbind( c(ilon), c(ilat))
  oloc <- cbind( c(olon), c(olat))

  ## mask output locations
  if (maskfile != ""){
    min <- nc_open(maskfile)
    mask <- ncvar_get(min, mask.var)
    mask <- ifelse(mask == 1, TRUE, FALSE)
    oloc <- oloc[c(mask),]
  } else {
    mask <- rep(TRUE,length(olat))
  }

  ## create output array
  nt <- length(time)
  nx <- length(xc)
  ny <- length(yc)
  result <- array(dim=c(nx,ny,nt))

  ## load fit object
  if(load.tps) {
    if(verbose) print(paste("loading fit object from file ",tpsfile))
    load(tpsfile)
  }

  ## data transforms
  if(!is.null(trace)){
    data[which(data < trace)] = trace/10.0
  }

  if(log) data <- log(data)

  ## main interpolation loop
  if(verbose) print("Calculating...")

  for (t in 1:nt){

    ## missing values make tps unhappy, so subset inputs to non-missing
    ind <- c(!is.na(data[,,t]))
    x <- iloc[ind,]
    y <- c(data[,,t])[ind]
    ## Note: works b/c loc & data unroll in same order when flattened w/ c().

    if(verbose) print(paste("time = ",t,": ",(length(ind)-sum(ind))," missing",sep=""))

    ## visual double-check:
    if(diagnostics){
      quilt.plot(iloc, c(data[,,t]))
      title("iloc vs data slice")
      quilt.plot(x,y)
      title("x vs y")
    }

    if(recalc.tps || !exists("fit")) {

      if(diagnostics){
        ## check radius.  Ideally you want at least 20 neighbors per point
        look <- nearest.dist(x,x, delta=radius)
        NN <- diff(look@rowpointers) ## nonzero distances each row = num neighbors
        stats(NN)
        hist(NN)

        lookdim <- dim(data)
        look <- matrix(NA, lookdim[1], lookdim[2])
        look[ind] <- NN
        look[look > 20] <- 20
        image.plot(ilon, ilat, look, zlim=c(1,20))
        title("neighbors")
      }
      if(verbose) print("calculating fit")
      fit <- fastTps(x, y, theta=radius)
    }

      ## interpolate fitted data to new locs.
      if(verbose) print("interpolating data")
      field <- array(dim=c(nx,ny))
      field[mask] <- predict(fit, xnew=oloc, ynew=y)
      result[,,t] <- field
  }

  if(log) result <- exp(result)

  if(!is.null(trace)){
    result[which(result < trace)] = 0
  }

  if(verbose) print("Finished interpolating; writing output...")

  ####################################
  ## And now we do all the output

  #####

  if (save.tps){
    if(verbose) print(paste("saving fit object to file ",tpsfile))
    save(fit,file=tpsfile)
  }

  #####

  if(verbose) print("creating netcdf output")

  ## convenience function
  copy.attributes <- function(fromfile, fromvar, tofile, tovar, skip=''){
    attlist <- ncatt_get(fromfile, fromvar)
    for (attname in names(attlist)) {
      if(!any(attname == skip)){
        ncatt_put(tofile, tovar, attname, attlist[[attname]])
      }
    }
  }

  ## define dimensions
  ndim <- list()

  ndim[[vname[["xc"]]]] <- ncdim_def(vname[["xc"]], "dummy", xc)
  ndim[[vname[["yc"]]]] <- ncdim_def(vname[["yc"]], "dummy", yc)
  if(!static) {
    ndim[[vname[["time"]]]] <- ncdim_def(vname[["time"]], "dummy", time, unlim=TRUE)
  }
  ndim[[varname]] <- ndim
  if(twod){
    ndim[["lat"]] <- ndim[["lon"]] <- ndim[c(1,2)]
  }

  ## define variables
  nvar <- list()
  #!# Note: get missval from file...
  if(twod){
    nvar[["lat"]] <- ncvar_def(name=vname[["olat"]], units="dummy", dim=ndim[["lat"]], missval=1e20)
    nvar[["lon"]] <- ncvar_def(name=vname[["olon"]], units="dummy", dim=ndim[["lon"]], missval=1e20)
  }
  nvar[[varname]] <- ncvar_def(name=varname, units="dummy", dim=ndim[[varname]], missval=1e20)

  if(verbose) print(paste("writing netcdf file ",outfile))

  ## create file
  fout <- nc_create(outfile, nvar)

  ## write variables to file

  if(twod){
    ncvar_put(fout,vname[["olat"]],olat)
    ncvar_put(fout,vname[["olon"]],olon)
  }
  if(static){
    ncvar_put(fout,varname,result[,,1])
  } else {
    ncvar_put(fout,varname,result)
  }

  ## copy attributes

  copy.attributes(fin,varname,fout,varname,skip="grid_mapping")
  copy.attributes(gin,vname[["xc"]],fout,vname[["xc"]])
  copy.attributes(gin,vname[["yc"]],fout,vname[["yc"]])
  if(!static){
    copy.attributes(fin,vname[["time"]],fout,vname[["time"]])
  }
  if(twod){
    copy.attributes(gin,vname[["olat"]],fout,vname[["olat"]])
    copy.attributes(gin,vname[["olon"]],fout,vname[["olon"]])
  }

  copy.attributes(fin,0,fout,0)

  ## add history entry

  history <- ncatt_get(fin, 0, attname="history")$value
  history <- paste(history, "\n",date(),":", sep="")
  history <- paste(history, " regridded data from ",basename(infile), sep="")
  history <- paste(history, " to grid from ",basename(gridfile), sep="")
  history <- paste(history, " using R function fastTps() in library 'fields'", sep="")
  if(load.tps){
    history <- paste(history," using fit from file ",basename(tpsfile), sep="")
  }else{
    history <- paste(history," with theta=",radius, sep="")
  }

  ncatt_put(fout, 0, "history", history)

  ## done
  nc_close(fout)
  if(verbose) print("done!")

  return()
}

# Copyright 2010-2012 Univ. Corp. for Atmos. Research
# Author: Seth McGinnis, mcginnis@ucar.edu


# ==============================================================================
#   DEWHA EV project hull-fouling samples analysis
#   Andrew Robinson, Enamul Kabir, and Keith Hayes
# ==============================================================================
## Clean up workspace
rm(list=ls())

## Load libraries
library(nlme)
library(lattice)
library(ggplot2)
library(lme4)
library(mgcv)

require(ggplot2)
require(GGally)
require(reshape2)
require(lme4)
require(compiler)
require(boot)
library(Amelia)

require(Hmisc)

source("functions.r")

# ========================================================================
#                           CODE
# ========================================================================
#
#
# ========================================================================
#                           Read in data
# ========================================================================

samplesdata <- read.csv("../data-raw/samples.csv")
propzerodata <- read.csv("../data-raw/aa.csv")
covars <- read.csv("../data-raw/covars.csv")

## Identify non-zero samples and exclude two outliers boat 24 and 51
nonzerosamples <- samplesdata[samplesdata$wetWeight>.5, ]
nonzerosamples1 <- subset(nonzerosamples, boatID!=24 & boatID!=51)

## Identify broad and specific sample locations
## KRH: but note that the sample units in the testLoc list are very different
## The only samples based on the same sampling unit (quadrats) are:
## Hull quadrats (HA), Rudder surface (PJ), Keel fixed (HP)
Loc <- c("Anchor", "Deck", "Dry Hull", "Fishing gear", "Internal spaces",
       "Propeller", "Rudder", "Wet Hull")
testLoc <- c("IB", "HA", "PJ", "PB", "HD", "HAH", "HP", "HH", "HK")
testLoc1 <- c("HA", "PJ", "HP")

## Identify non-zero samples from wet hull
samplesdata_WH <- samplesdata[samplesdata$Location==Loc[8], ]
nonzerosamples_WH <- samplesdata_WH[samplesdata_WH$wetWeight>.5, ]
nonzerosamples1_WH <- subset(nonzerosamples_WH, boatID!=24 & boatID!=51)

## Identify non-zero samples from HA (Hull quadrats)
samplesdata_HA <- samplesdata[samplesdata$LocID=="HA", ]
nonzerosamples_HA <- samplesdata_HA[samplesdata_HA$wetWeight>.5, ]
nonzerosamples1_HA <- subset(nonzerosamples_HA, boatID!=24 & boatID!=51)

## Identify non-zero samples in test locations
samplesdata_testLoc <- subset(samplesdata,LocID %in% testLoc[1:9])
nonzerosamples_testLoc <- subset(nonzerosamples,LocID %in% testLoc[1:9])

## Proportion of zero data in each of the test locations
propzerodata_testLoc <- subset(propzerodata, LocID %in% testLoc[1:9])

## KRH: same data sets based on standard sample units
samplesdata_testLoc1 <- subset(samplesdata,LocID %in% testLoc1[1:3])
nonzerosamples_testLoc1 <- subset(nonzerosamples,LocID %in% testLoc1[1:3])

# EK: non-zero samples based on standard sampling units and removing outliers
nonzerosamples1_testLoc1 <- subset(nonzerosamples1,LocID %in% testLoc1[1:3])

propzerodata_testLoc1 <- subset(propzerodata, LocID %in% testLoc1[1:3])

# ===========================================================================================
#              Graphical summary and data exploration
# ===========================================================================================

## Three Histograms summarizing the number of days since the vessel's last trip,
## the number of days since it was last cleaned or antifouled, and the median
## number of trips per annum.
# par(mfrow=c(2,2))
# hist(covars$days1, prob=F, xlab="Days since last trip", ylab="Frequency", main="")
# 	text(0,36,"a")
# hist(covars$days2, prob=F, xlab="Days since last cleaned or antifouled", ylab="Frequency", main="")
# 	text(0,24,"b")
# hist(covars$midTrips, prob=F, xlab="Median number of trips per annum", ylab="Frequency", main="")
#	text(0,37,"c")

####### FIGURE 1 ################
## The scatter plot matrix contains all the pairwise scatter plots of the variables on a single page
## in a matrix format. Here, there are 4 variables (days1, days2, midTrips and paintType), the scatter
## plot matrix will have 4 rows and 4 columns and the 2nd row and 3rd column of this matrix is a plot
## of days2 and midTrips.

## The scatter plot matrix shows that there seems to be some outliers in the data. However, it does
## not seem any pairwise correlation between the variables. Thus for further analysis, we will keep all
## four variables.

## KRH: I have added to the scatter plot the histograms on the diagonal and the correlation coefficients
## in the upper triangle, this combines all the information from the previous histograms into a
## single figure

## APR: Beautiful!

boat<-unique(samplesdata[, c("days1", "days2", "midTrips", "paintType")])

pairs(x=unique(boat[, c("days1", "days2", "midTrips", "paintType")]), diag.panel = panel.hist,
      upper.panel = panel.cor, lower.panel=points, pch = 20, ps = 8, cex.labels = 1.3)

######### FIGURE 2 ###############
## Histograms of sample wet weight (grams) for the whole sample, and the log of sample
## wet weight (grams) for the whole sample. Histogram of wet weight shows that samples are
## zero-inflated. However, histogram of log transformed data shows that samples are approximately
## normally distributed.
par(mfrow=c(2,2))
hist(samplesdata$wetWeight, prob=F, xlab="Wet-weight of fouling biomass (grams)", ylab="Frequency", main="")
	text(9000,1490,"a")
hist(log(samplesdata$wetWeight), prob=F, xlab="Log wet-weight of fouling biomass", ylab="Frequency", main="")
	text(9,330,"b")

## Histograms of sample wet weight (grams) for the non-zero (biomass) sample, and the log of
## sample wet weight (grams) for the non-zero (biomass) samples. The wet weight fouling biomass of
## non-zero samples is approximately log normally distributed but the log of these non-zero biomasses
## is normally distributed.
hist(nonzerosamples$wetWeight, prob=F, xlab="Wet-weight of non-zero samples (grams)",
     ylab="Frequency", main="" )
text(9000,740, "c")
hist(log(nonzerosamples$wetWeight), prob=F, xlab="Log wet-weight of non-zero samples",
     ylab="Frequency", main="" )
text(9,200, "d")

###### FIGURES 3-5 #############
## Smooth plots showing the log of the wet weight (grams) of biomass among
## the levels of paint type against days1, days2 and midTrips.

## These smooth plots show that there is a variation of log of the wet-weight
## among the levels of paint-type factor. The smooth plots also show there is a variation
## of log of the wet-weight among different testLoc.

## KRH: the variation between the testLoc is not surprising - they are very different sample
## Have added a figure using only those samples based on quadrats.

# EK: Make sense. But we do not need to consider qplot for nonzerosamples_HA.

# qplot(x=days2, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"), data=nonzerosamples)
# qplot(x=days2, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"), data=nonzerosamples)
# qplot(x=days1, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"), data=nonzerosamples)
# qplot(x=midTrips, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"), data=nonzerosamples)
# qplot(x=days2, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"), data=nonzerosamples_testLoc)
# qplot(x=days1, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"), data=nonzerosamples_testLoc)
# qplot(x=midTrips, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"), data=nonzerosamples_testLoc)

qplot(x=days2, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

#qplot(x=days2, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      #data=nonzerosamples_HA)

qplot(x=days1, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

#qplot(x=days1, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      #data=nonzerosamples_HA)

qplot(x=midTrips, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

#qplot(x=midTrips, y=log(wetWeight), group=paintType, colour=paintType, geom=c("point", "smooth"),
      #data=nonzerosamples_HA)

qplot(x=days2, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

qplot(x=days1, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

qplot(x=midTrips, y=log(wetWeight), group=LocID, colour=factor(LocID), geom=c("point", "smooth"),
      data=nonzerosamples_testLoc1)

## KRH: Box plot to see how the mean and variance of the wetweight varies between locations
## (so do we need a random effect at the location level?). Seems to suggest that we don't.
# qplot(factor(LocID), log(wetWeight), geom=c("boxplot", "jitter"), data = nonzerosamples_testLoc1)
qplot(factor(LocID), log(wetWeight), geom=c("boxplot"), data = nonzerosamples_testLoc1)

## EK: Excellent!

# ===============================================================================================================================
#                                   GLMM for fouled/not fouled response (data: samplesdata_testLoc)
# ===============================================================================================================================
## For GLMM, we consider data from LocID "IB"  "HA"  "PJ"  "PB"  "HD"  "HAH" "HP"  "HH"  "HK".
## Thus, here the dataset is samplesdata_testLoc.

####### Selecting a correct model ###################
## Generalized linear mixed-effect model (GLMM) considering all predictors (and their interactions)
## and boatID as a random effect.
## The summary of samples.logit_all2wayglmer1 suggests dropping days2:midTrips.
## KRH: OK here the use of all the locations for a logistic regression of fouled or not fouled
## (wetWeight1) makes sense

## APR Scale continuous parameters

samplesdata_testLoc.s <- droplevels(samplesdata_testLoc)

#for (columns in c("days1","days2","midTrips"))
 # samplesdata_testLoc.s[,columns] <- scale(samplesdata_testLoc.s[,columns])

#samples.logit_all2wayglmer1<-glmer(wetWeight1~days1+days2+midTrips+paintType+factor(LocID)+days1:days2+
#	days1:midTrips+ days1:paintType+days2:midTrips+days2:paintType+
#		midTrips:paintType+(1|boatID),family=binomial,
#			data=samplesdata_testLoc, na.action=na.exclude)

#summary(samples.logit_all2wayglmer1)

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

par(mfrow = c(3,2))
for (columns in c("days1","days2","midTrips")) {
  plot(density(na.omit(samplesdata_testLoc.s[,columns])))
  samplesdata_testLoc.s[,columns] <-
    scale(log(samplesdata_testLoc.s[,columns] + 0.1))
  plot(density(na.omit(samplesdata_testLoc.s[,columns])))
}

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

# Address missingness - test

lapply(samplesdata_testLoc.s,
       function(x) sum(is.na(x)))

naplot(naclus(samplesdata_testLoc.s))

# Substantial

samplesdata_testLoc.s$LocID <- factor(samplesdata_testLoc.s$LocID)

set.seed(300)

bf.out <-
    amelia(samplesdata_testLoc.s[,c("wetWeight1","days1","days2","midTrips","paintType",
                                    "LocID","boatID")],
           m = 500,   ### 100 is just a guess
           cs = "boatID",
           noms = c("paintType","LocID"))

# http://stackoverflow.com/questions/16571580/multi-level-regression-model-on-multiply-imputed-data-set-in-r-amelia-zelig-l

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

#samples.logit_all2wayglmer1.s<-glmer(wetWeight1~days1+days2+midTrips+paintType+factor(LocID)+days1:days2+
	#days1:midTrips+ days1:paintType+days2:midTrips+days2:paintType+
		#midTrips:paintType+(1|boatID),family=binomial,
			#data=samplesdata_testLoc, na.action=na.exclude)

### bobyqa optimizar --- BASE MODEL

samples.logit_all2wayglmer1.s <-
  glmer(wetWeight1 ~ days1 + days2 + midTrips + paintType + factor(LocID) +
        days1:days2 + days1:midTrips + days1:paintType +
        days2:midTrips + days2:paintType +
        midTrips:paintType + (1|boatID),
        family = binomial,
        data = samplesdata_testLoc.s,
        nAGQ = 10,
        control = glmerControl(optimizer="bobyqa"),
        na.action = na.exclude)

####### Residual Plot ####################
## Full Model (samples.logit_all2wayglmer1.s)
par(mfrow = c(1,2))
scatter.smooth(fitted(samples.logit_all2wayglmer1.s),
               residuals(samples.logit_all2wayglmer1.s, type="pearson"),
               xlab="Fitted Values", ylab="Residuals", main="Residuals Plot GLMER1")
abline(h=0, col="red")

## Reduced Model (samples.logit_all2wayglmer2.s)
scatter.smooth(fitted(samples.logit_all2wayglmer2.s),
               residuals(samples.logit_all2wayglmer2.s, type="pearson"),
               xlab="Fitted Values", ylab="Residuals", main="Residuals Plot GLMER2")
abline(h=0, col="red")

## The residual shows that there are some outliers.
## There is a curved pattern that indicates the residuals are non-linear.

######## Q-Q plot for Residuals #################
## Full Model (samples.logit_all2wayglmer1.s)
par(mfrow = c(1,2))
qqnorm(residuals(samples.logit_all2wayglmer1.s, type="pearson"),
       main="Q-Q Normal-Residuals GLMER1")
qqline(residuals(samples.logit_all2wayglmer1.s, type="pearson"), col="red")

## Reduced Model (samples.logit_all2wayglmer2.s)
qqnorm(residuals(samples.logit_all2wayglmer2.s, type="pearson"),
       main="Q-Q Normal-Residuals GLMER2")
qqline(residuals(samples.logit_all2wayglmer2.s, type="pearson"), col="red")

## Q-Q plot for residual shows a problem with the Gaussian assumption for both models.

raf <- ranef(samples.logit_all2wayglmer1.s)
rand.samples.logit_all2wayglmer1.s <- raf[[1]][, "(Intercept)"]
qqnorm(rand.samples.logit_all2wayglmer1.s,
       main="Q-Q plot, random intercept GLMER1", cex.main = 0.75)
qqline(rand.samples.logit_all2wayglmer1.s)

## Now start model selection.  Only get these diagnostics for the final model.

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

## Re-run the analysis but drop days1:paintType

samples.logit_all2wayglmer2.s <- update(samples.logit_all2wayglmer1.s,.~.-days1:paintType)

## The reduced model can be tested against the full model by using following anova
anova(samples.logit_all2wayglmer1.s, samples.logit_all2wayglmer2.s, test="F")

## Which suggests to accept the reduced model (p-value 0.00249). In the reduced model
## AIC is less than the full model. Thus in terms of
## AIC reduced model (samples.logit_all2wayglmer2.s) is the better model.
## However, we perform a parametric bootstrap test to take a final decision.

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

## Now introduce imputation test instead of PB, which chokes because
## of the missingness.

imputeLRT.c(samples.logit_all2wayglmer2.s,  #### SMALLER MODEL FIRST
            samples.logit_all2wayglmer1.s,
            bf.out)

# This says p = 0.308.  Not a significant difference.

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

## Parametric bootstrap-based test (PB) for comparison --- using reduced data

red.1 <- update(samples.logit_all2wayglmer1.s,
                data = na.omit(samplesdata_testLoc.s[,c("wetWeight1","days1","days2",
                    "midTrips","paintType","LocID","boatID")]))
red.2 <- update(samples.logit_all2wayglmer2.s,
                data = na.omit(samplesdata_testLoc.s[,c("wetWeight1","days1","days2",
                    "midTrips","paintType","LocID","boatID")]))

samples.logit_all2wayglmer.PB1.2.s <- replicate(200, pboot(red.2, red.1))

(samples.logit_all2wayglmer.obsdev1.2.s <- 2*(logLik(red.1)-logLik(red.2)))

mean(samples.logit_all2wayglmer.PB1.2.s > samples.logit_all2wayglmer.obsdev1.2.s)

## This mean is the p-value

## Classical test: chisq(samples.logit_all2wayglmer.obsdev1.2, df=63, lower.tail=FALSE)

## PB shows a p-value 0.838, indicating reduced model (samples.logit_all2wayglmer2.s)
## is better model.


#=============================================================================
#	Test suite for running ranger.
#=============================================================================
library(testthat)
library(cv.models)
library(ranger)

set.seed(123)

#-----------------------------------------------------------------------------
#	Tests for regression by ranger.
#-----------------------------------------------------------------------------

# ranger regression.
run.ranger.regression <- function() {
	cv <- cv.models(ranger(Petal.Length ~ ., data = iris, num.trees = 10))
}

# ranger regression without cluster.
run.ranger.regression.no.cluster <- function() {
	cv <- cv.models(
		ranger(Petal.Length ~ ., data = iris, num.trees = 10), n.cores = 1
	)
}

# ranger regression with "join".
run.ranger.regression.join <- function() {
	cv <- cv.models(
		ranger(Petal.Length ~ ., data = iris, num.trees = 10),
		aggregate.method = "join"
	)
}

# ranger classification with grid.
run.ranger.regression.with.grid <- function() {
	cv <- cv.models(
		ranger(Petal.Length ~ ., data = iris, num.trees = 10),
		grid = list(max.depth = c(1, 5), min.node.size = c(1, 10))
	)
}

# ranger classification with grid without cluster.
run.ranger.regression.with.grid.no.cluster <- function() {
	cv <- cv.models(
		ranger(Petal.Length ~ ., data = iris, num.trees = 10), n.cores = 1,
		grid = list(max.depth = c(1, 5), min.node.size = c(1, 10))
	)
}

# ranger regression with "join" without cluster.
run.ranger.regression.join.no.cluster <- function() {
	cv <- cv.models(
		ranger(Petal.Length ~ ., data = iris, num.trees = 10),
		aggregate.method = "join", n.cores = 1
	)
}

# ranger regressin with external formula.
run.ranger.regression.external.formula <- function() {
	f <- Petal.Length ~ .
	cv <- cv.models(ranger(f, data = iris, num.trees = 10))
}

# ranger regressin with external formula without cluster.
run.ranger.regression.external.formula.no.cluster <- function() {
	f <- Petal.Length ~ .
	cv <- cv.models(ranger(f, data = iris, num.trees = 10), n.cores = 1)
}

#-----------------------------------------------------------------------------
#	Tests for classification by ranger.
#-----------------------------------------------------------------------------

# ranger classification.
run.ranger.classification <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		positive.class = "virginica", n.cores = 2
	)
}

# ranger classification without cluster.
run.ranger.classification.no.cluster <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		positive.class = "virginica", n.cores = 1
	)
}

# ranger classification with grid.
run.ranger.classification.with.grid <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		grid = list(max.depth = c(2, 5), min.node.size = c(2, 10)),
		positive.class = "virginica"
	)
}

# ranger classification with grid without cluster.
run.ranger.classification.with.grid.no.cluster <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		grid = list(max.depth = c(1, 5), min.node.size = c(1, 10)),
		positive.class = "virginica", n.cores = 1
	)
}

# ranger classification.
run.ranger.classification.join <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		positive.class = "virginica", aggregate.method = "join"
	)
}

# ranger classification without cluster.
run.ranger.classification.join.no.cluster <- function() {
	cv <- cv.models(
		ranger(
			Species ~ ., data = iris, case.weights = iris$Sepal.Width,
			num.trees = 10
		),
		positive.class = "virginica", aggregate.method = "join", n.cores = 1
	)
}

# ranger classification with external formula.
run.ranger.classification.external.formula <- function() {
	f <- Species ~ .
	cv <- cv.models(
		ranger(
			f, data = iris, case.weights = iris$Sepal.Width, num.trees = 10
		),
		positive.class = "virginica", n.cores = 2
	)
}

# ranger classification without cluster.
run.ranger.classification.external.formula.no.cluster <- function() {
	f <- Species ~ .
	cv <- cv.models(
		ranger(
			f, data = iris, case.weights = iris$Sepal.Width, num.trees = 10
		),
		positive.class = "virginica", n.cores = 1
	)
}

#-----------------------------------------------------------------------------
#	Run tests.
#-----------------------------------------------------------------------------
do.test.that <- function(fun) {
	msg <- deparse(substitute(fun))
	test_that(msg, fun())
}

do.test.that(run.ranger.regression)
do.test.that(run.ranger.regression.no.cluster)
do.test.that(run.ranger.regression.with.grid)
do.test.that(run.ranger.regression.with.grid.no.cluster)
do.test.that(run.ranger.regression.join)
do.test.that(run.ranger.regression.join.no.cluster)
do.test.that(run.ranger.regression.external.formula)
do.test.that(run.ranger.regression.external.formula.no.cluster)

do.test.that(run.ranger.classification)
do.test.that(run.ranger.classification.no.cluster)
do.test.that(run.ranger.classification.with.grid)
do.test.that(run.ranger.classification.with.grid.no.cluster)
do.test.that(run.ranger.classification.join)
do.test.that(run.ranger.classification.join.no.cluster)
do.test.that(run.ranger.classification.external.formula)
do.test.that(run.ranger.classification.external.formula.no.cluster)


library(stargazer)

library(xtable)
library(IRdisplay)
library(repr)

display_markdown('[MD](http://commonmark.org) *formatted*')
display_html('
(http://commonmark.org) *formatted*
')
display_javascript('execute(this)')

display_html('

Statistic	N	Mean	St. Dev.	Min	Pctl(25)	Pctl(75)	Max

rating	30	64.633	12.173	40	58.8	71.8	85

complaints	30	66.600	13.315	37	58.5	77	90

privileges	30	53.133	12.235	30	45	62.5	83

learning	30	56.367	11.737	34	47	66.8	75

raises	30	64.633	10.397	43	58.2	71	88

critical	30	74.767	9.895	49	69.2	80	92

advance	30	42.933	10.289	25	35	47.8	72

')

ht <- stargazer( attitude, type='html' )
# lt <- stargazer( attitude, type='latex' )
length(ht)
o = paste(ht,sep='')
display_html(data=o)


pdf_file<-"pdf/timeseries_areas_below_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=8.26)

library(gdata)
par(cex.axis=1.1,mai=c(0.75,1.5,0.25,0.5),omi=c(0.5,0.5,1.1,0.5), mgp=c(6,1,0),family="Lato Light",las=1)

# Import data and prepare chart

colour<-rgb(68,90,111,150,maxColorValue=255)
myData<-read.xls("myData/chile.xlsx", encoding="latin1")
attach(myData)

# Define chart and other elements

plot(x,y,axes=F,type="n",xlab="",xlim=c(1800,2020),ylim=c(0,14000),xpd=T,ylab="million 1990 International Geary-Khamis dollars")
axis(1,at=pretty(x),col=colour)
axis(2,at=py<-pretty(y),col=colour,cex.lab=1.2,labels=format(py,big.mark=","))

y<-ts(y,start=1800,frequency=1)
points(window(y, end=1869))
lines(window(y, start=1870))

myShapeColour1<-rgb(0,128,128,50,maxColorValue=255)
myShapeColour2<-rgb(0,128,128,80,maxColorValue=255)
mySelection<-subset(myData,x >= 1879 & x <= 1884)
attach(mySelection)
polygon(c(min(mySelection$x),mySelection$x,max(mySelection$x)),c(-500,mySelection$y,-500),col=myShapeColour2,border=NA)
text(1860,2200,adj=0,col=colour,"Pacific War")
mySelection<-subset(myData,x >= 1940 & x <= 1973)
attach(mySelection)
polygon(c(min(mySelection$x),mySelection$x,max(mySelection$x)),c(-500,mySelection$y,-500),col=myShapeColour1,border=NA)
text(1930,5000,adj=0,col=colour,"Allende Regime")
mySelection<-subset(myData,x >= 1973 & x <= 1990)
attach(mySelection)
polygon(c(min(mySelection$x),mySelection$x,max(mySelection$x)),c(-500,mySelection$y,-500),col=myShapeColour2,border=NA)
text(1960,6800,adj=0,col=colour,"Military Regime")

# Titling

mtext("Gross national product of Chile",3,line=2,adj=0,cex=2.4,family="Lato Black", outer=T)
mtext("Annual figures",3,line=-0.5,adj=0,cex=1.8,font=3, outer=T)
mtext("Source: Rolf Lüders, The Comparative Economic Performance of Chile 1810-1995, www.ggdc.net/maddison",1,line=3,adj=1.0,cex=0.95,font=3)
dev.off()


library(pROC)

n_genes = 20

fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_genes.txt")
cc.rob = fread(fn.cd38.cor) %>%
  arrange(desc(cor.mean.sd.ratio)) %>%
  top_n(n_genes, cor.mean.sd.ratio) %>%
  mutate(gene = factor(gene, levels=gene[order(.$cor.mean.sd.ratio)]))

# df.auc.one = data.frame(gene=factor(gene.sig, levels=rev(gene.sig)), AUC=auc.one)
ggplot(cc.rob, aes(x=gene, y=auc.gene)) +
  geom_bar(stat = "identity") +
  geom_hline(yintercept=0.5, lty=2, size=1, col="red") +
  geom_vline(xintercept=10.5, lty=2, size=1, col="black") +
  ylab("AUC") +
  coord_flip() + theme_bw()

fn.fig = file.path(PROJECT_DIR, "figure_generation", "CHI_CD38.20gene_single.gene.AUC")
ggsave(paste0(fn.fig,".png"), w=4, h=4)
ggsave(paste0(fn.fig,".pdf"), w=4, h=4)

ggplot(cc.rob, aes(x=gene, y=cor.mean.sd.ratio)) +
  geom_bar(stat = "identity") +
  # geom_hline(yintercept=0.5, lty=2, size=1, col="red") +
  geom_vline(xintercept=10.5, lty=2, size=1, col="black") +
  ylab("Correlation coefficient, mean / SD") +
  coord_flip() + theme_bw()

fn.fig = file.path(PROJECT_DIR, "figure_generation", "CHI_CD38.20gene_single.gene.cor.mean.sd")
ggsave(paste0(fn.fig,".png"), w=4, h=4)
ggsave(paste0(fn.fig,".pdf"), w=4, h=4)

# plot all genes

cc.rob = fread(fn.cd38.cor) %>%
  arrange(desc(cor.mean.sd.ratio)) %>%
  # top_n(n_genes, cor.mean.sd.ratio) %>%
  mutate(gene = factor(gene, levels=gene[order(.$cor.mean.sd.ratio)]))
cc.rob$sig = 0
cc.rob$sig[1:10] = 1

ggplot(cc.rob, aes(x=gene, y=cor.mean.sd.ratio, fill=factor(sig))) +
  geom_col() +
  # geom_hline(yintercept=0.5, lty=2, size=1, col="red") +
  # geom_vline(xintercept=10.5, lty=2, size=1, col="black") +
  scale_fill_manual(values=c("black","red"), guide=F) +
  xlab("Genes ranked by correlation with CD20+CD38++ cell frequency") +
  ylab("") +
  # coord_flip() +
  theme_minimal() +
  theme(axis.text = element_blank(), axis.ticks = element_blank(),
        panel.grid = element_blank())

fn.fig = file.path(PROJECT_DIR, "figure_generation", "CHI_CD38.all.gene_single.gene.cor.mean.sd")
ggsave(paste0(fn.fig,".png"), w=5, h=1.5)
ggsave(paste0(fn.fig,".pdf"), w=5, h=1.5)


years <- 2008:2121
xmas <- as.POSIXlt(paste(years, '/12/25', sep=""))
years[xmas$wday==0]


#' Function which reads in a CHM TIFF file and produces a table of (x,y,z) of
#' local maxima based on methods from ITCsegment package
#'
#' @param chm_tiff the filename of the CHM as a TIFF file
#' @param scale The resolution of the raster CHM in meters
#' @param lut_csv An optional lookup table for H to R allometry based on quantile
#' quantile regression. Can be generated by rq_lut() method
#' @param window_size The fixed window size (in terms of pixels) to be used if
#' lut not supplied
#' @param min_h The minimum height for data to be included
#' @return A matrix of coordinates of local maxima (x,y,z)
#' @export
#' @author Jon Williams
#' @details
#'
#' Created 17-11-06
#
# NB: requires both utils.R and detect_maxima.r from the work of Tom Swinfield
#
gen_ITCSegmax_prior <- function(chm_tiff,scale,lut_csv=NULL,window_size=3,tau=90,min_h=0){

        # get package dependencies
        if(!require(raster)){
                install.packages('raster')
        }
        library(raster)

        # read in CHM and get cooridnates of [0,0] on grid
        chm <- raster(chm_tiff)
        xmin <- chm@extent@xmin
        ymax <- chm@extent@ymax
        chm_mat <- as.matrix(chm)

        # If supplying a look-up use it, otherwise used a fixed window size
        if(class(lut_csv) != 'NULL'){
                lut <- read.csv(lut_csv)
                chm_max <- detect_maxima(chm_mat,scale=scale,lut=lut,tau=tau,
                                         min_h=min_h)
        } else {
                chm_max <- detect_maxima(chm_mat,scale=scale,
                                         lm.searchwin = window_size,tau=tau,
                                         min_h=min_h)
        }

        # Convert pixels to coordinates- centre on middle of grid
        # Note: matrix indexed from top left, rows for y, cols for x

        if(is.character(chm_max)){
                # if no maxima found then link to a near ground point
                maxima = matrix(nrow=1,ncol=3, data=0)
                maxima[1,] = c(xmin,ymax,1)

        } else {
                # We have maxima from algorithm
                maxima <- matrix(nrow=nrow(chm_max),ncol=3, data=0)
                for (i in 1:nrow(chm_max)){
                        ths_x <- scale*(chm_max[i,2]-1 + 0.5) + xmin
                        ths_y <- ymax- scale*(chm_max[i,1]-1+0.5)
                        ths_z <- chm_max[i,3]
                        maxima[i,1:3] <- c(ths_x,ths_y,ths_z)
                }
        }

        return(maxima)
}


library(DBI)
library(ROracle)
ora <- dbDriver("Oracle")
con <- dbConnect(ora, "context/nSrXt8p@context.cs.helsinki.fi")
res <- dbSendQuery(con, "\
select \
	call.datetime,\
	case act.state when 'active' then 0\
	else 1440*(call.datetime - act.valid_from - 1/1440) end t,\
	call.direction, act.state, act.person\
from\
	activity act, call, profile prof\
where\
	act.person = call.person and\
	act.person = prof.person and\
	call.datetime - 1/1440 between act.valid_from and act.valid_until and\
	call.datetime - 1/1440 between prof.valid_from and prof.valid_until and\
	( call.direction = 'Incoming' or call.direction = 'Missed call' )\
	and not exists ( select call2.person from call call2 where\
		call.person = call2.person and\
		call.datetime between call2.datetime+1/(60*1440) and\
			call2.datetime+call2.duration/(60*1440) and\
		call2.duration>0\
	)\
	and not prof.id = 4\
")
chunk <- fetch(res, n=10000)
missed <- chunk[chunk[,3]=="Missed call",2]
incoming <- chunk[chunk[,3]=="Incoming",2]

plot(density(log(missed+1)), col="red")
lines(density(log(incoming+1)), col="blue")

h<-c(0.0, 1, 5, 10, 15, 30, 60, 120, 300, 1000, 5000, 10000, 30000)
x <- h
y <- h; yc <- h
counts <- h; countsc <- h
for (i in 1:length(h))
{
	if (i==1) {
		low <- -1
	} else {
		low <- h[i-1]
	}
	m <- sum( missed > low & missed <= h[i] )
	inc <- sum( incoming > low & incoming <= h[i] )
	counts[i] <- m+inc
	y[i] <- m/(m+inc)
	mc <- sum( missed <= h[i] )
	incc <- sum( incoming <= h[i] )
	countsc[i] <- mc+incc
	yc[i] <- mc/(mc+incc)
}
a <- matrix(nrow=length(h), ncol=3)
a[,1]=h; a[,2]=y; a[,3]=counts
ac <- matrix(nrow=length(h), ncol=3)
ac[,1]=h; ac[,2]=yc; ac[,3]=countsc
plot(x[x<1100], y[x<1100], "l", log="x")
lines(x[x<1100], yc[x<1100], "l", log="x", col="blue")
plot(x, y, "l")

min_t<-0
max_t<-max(max(missed), max(incoming))
c<-10
x<- 1:c
y<- 1:c
l<- 1:c
h<- 1:c
n<- 1:c
for (i in 1:c) {
	low <- exp( (i-1) * log(max_t)/c)-1
	l[i] <- low
	high <- exp( (i+1) * log(max_t)/c)
	h[i] <- high
	x[i] <- exp(i * log(max_t)/c)
	miss <- sum(missed >= low & missed <= high)
	inc <- sum(incoming >= low & incoming <= high)
	n[i] <- miss+inc
	y[i] <- miss/(miss+inc)
}
plot(x, y, "l", log="x")


# Load required libraries
library(httr)
library(dplyr)
library(jsonlite)

# Set the URL root to the address where BMDS server is currently running:
url_root <- Sys.getenv('BMDS_SERVER_URL', 'http://bmds-server.com')

# Create a data-frame that has two continuous dose-response datasets:
datasetsDf = data.frame(
     id=c(rep("run #1", 4), rep("run #2", 4)),
     doses=rep(c(0,1.96,5.69, 29.75), 2),
     ns=rep(c(75, 49, 50, 49), 2),
     means=c(479, 460, 462, 420, 2.61, 2.61, 2.96, 4.66),
     stdevs=c(43, 42, 39, 39, 0.36, 0.19, 0.17, 0.42)
)

# Group the data from a dataframe:
datasets <- datasetsDf %>%
    group_by(id) %>%
    summarize(doses=list(doses), ns=list(ns), means=list(means), stdevs=list(stdevs))

# Create a BMDS job. This example uses uses BMDS v2.6.0.1. with both datasets:
inputs <- list(
     id='My first BMDS-server run',
     dataset_type='C',
     bmds_version='BMDS2601',
     datasets=datasets
)

# Submit input data
inputs_json <- toJSON(inputs, auto_unbox=TRUE)
url <- sprintf('%s/api/job/', url_root)
response <- POST(url, body=list(inputs=inputs_json))

# If submission is successful, we'll get a HTTP 201 response (job created),
# along with a new unique identifier for this job:
if(response$status_code == 201){
    json <- content(response, 'parsed')
    job_id <- json$id
} else {
    # If submission fails, print response so we know why the job failed.
    print(content(response, 'text'))
}

# Each job is added to a queue on the server; when there are no other jobs
# running this job will be started. We can poll the results page (in this
# case waiting 15 seconds between requests) until the job is finished:
repeat{
    url <- sprintf('%s/api/job/%s/', url_root, job_id)
    response <- GET(url)
    json <- content(response, 'parsed')
    if(json$is_finished){
        outputs <- json$outputs
        break
    }
    Sys.sleep(15)
}

# After completion, the job returns model outputs. There's lots of
# information in the outputs, including the created dfile, output file,
# and results from the parsed output. If model-recommendations is enabled,
# then a model will also be recommended in the outputs. Here's a snapshot:
for (output in outputs$outputs){
    print('---')
    print(sprintf('Dataset: %s', toJSON(output$dataset)))
    print(sprintf('Number of models: %d', length(output$models)))
    for (model in output$models){
        print(sprintf('  %s: BMD -> %f', model$output$model_name, model$output$BMD))
    }
}