# 3. faza: Vizualizacija podatkov

source("lib/uvozi.zemljevid.r", encoding = "UTF-8")
source("lib/libraries.r", encoding = "UTF-8")
source("uvoz/uvoz.r", encoding = "UTF-8")
library(RColorBrewer)

#Primerjava cene in zivljenski standard v nekoliko drzavah
countries <- filter(cene, Country %in% c("Bulgaria", "Romania", "Finland", "Spain", "United Kingdom", "Switzerland"))
nb.cols <- 6
mycolours <- colorRampPalette(brewer.pal(7, "Paired"))(nb.cols)

graf_cene <- ggplot(mapping = aes(x=Year, y=Value, colour=Country)) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, size = 8), plot.title = element_text(size = 20)) +
  geom_line(linetype="solid", data=countries) +
  geom_line(linetype="dashed", data=gdp_per_capita, show.legend = TRUE) +
  labs(x="Leto", y="Cen in BDP - indeksi cen (referenca EU28=100)", title="Sprememba cen in BDP prebivalca\npo letih 2008-2018 capita", colour="Države") +
  scale_x_discrete(limits=c(2008:2018))+
  scale_colour_manual(values = mycolours)

#Proizvodnja alkohola v EU
vrednosti <- sort(unique(production$`Type of alcohol`))
graf_proizvodnja <- ggplot(data=production, aes(x=Year, y=Production, fill=`Type of alcohol`)) +
  labs(x="Leto", y="Litrov alkohola", title = "Proizvodnja alkohola v EU po kategorijah") +
  theme_minimal() +
  geom_bar(stat = "identity", position=position_dodge(), size=.3) +
  scale_x_discrete(limits=c(2008:2018))+
  scale_y_continuous(labels=comma_format(big.mark=" ", scale = 0.00001)) +
  scale_fill_manual(labels = c("Pivo", "Gin", "Rum", "Vodka", "Viski"), values= mycolours, breaks=vrednosti) +
  theme(axis.text.x = element_text(angle = 90, size = 8), legend.text = element_text(size=8),
        legend.position = "bottom",  plot.title = element_text(size = 20)) +
  labs(fill="Tip alkohol") +
  coord_flip()

#Zemljevid

zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",

                              "ne_50m_admin_0_countries",mapa="./zemljevidi") %>% fortify()

#Zemljevid: kolicina alkohola per capita
zemljevid_kolicina_alkohola <- ggplot() +
  geom_polygon(data=left_join(zemljevid, kolicina_pc %>% group_by(Countries) %>% summarise(`Total alcohol`), by=c("SOVEREIGNT"="Countries")),
               aes(x=long, y=lat, group=group, fill=`Total alcohol`), size=0.1) +
  labs(x="", y="", fill="Litrov alkohola na prebivalca", title = "Konzumacija alkohola") +
  theme_map(base_size = 20) +
  theme(legend.position = "bottom")

#Zemljevid: kolicina spirits, pivo, vino per capita
s1 <- left_join(zemljevid, kolicina_pc %>% group_by(Countries) %>% summarise(`Spirits(%)`), by=c("SOVEREIGNT"="Countries"))
s1 <- mutate(s1, type = c("Spirits"))
s2 <- left_join(zemljevid, kolicina_pc %>% group_by(Countries) %>% summarise(`Wine(%)`), by=c("SOVEREIGNT"="Countries"))
s2 <- mutate(s2, type = c("Wine"))
s3 <- left_join(zemljevid, kolicina_pc %>% group_by(Countries) %>% summarise(`Beer(%)`), by=c("SOVEREIGNT"="Countries"))
s3 <- mutate(s3, type = c("Beer"))

zemljevid_kolicina <- ggplot() +
  geom_polygon(data=s1,
               aes(x=long, y=lat, group=group, fill=`Spirits(%)`), size=0.1) +
  geom_polygon(data=s2,
               aes(x=long, y=lat, group=group, fill=`Wine(%)`), size=0.1) +
  geom_polygon(data=s3,
               aes(x=long, y=lat, group=group, fill=`Beer(%)`), size=0.1) +
  facet_grid(type~., labeller = as_labeller(c("Beer"="Pivo", "Spirits" = "Zganje", "Wine"="Vino"))) +
  labs(x="", y="", fill="Litrov na prebivalca") +
  ggtitle("Konzumacija različnih pijačah na prebivalca") +
  theme_map(base_size = 20)

#Zemljevid: kolicina alkohola na mladi ljudi
alcohol_young_people <- kolicina %>% filter(Sex=="Total") %>% filter(Frequency=="Every month") %>% group_by(Country) %>% summarise(Total)

zemljevid_kolicina_alkohola_mlade <- ggplot() +
  geom_polygon(data=left_join(zemljevid %>% filter(CONTINENT=="Europe"), alcohol_young_people, by=c("SOVEREIGNT"="Country")),
               aes(x=long, y=lat, group=group, fill=Total), size=0.1) +
  labs(x="", y="", fill="Kolicina alkohola\nna osebo (15-24) let") +
  ggtitle("Konzumacija alkohola v Evropi s strani mladih (15-24 let)") +
  coord_cartesian(xlim=c(-27, 50), ylim=c(25, 80), expand = TRUE)  +
  theme_map(base_size = 20)


library(shiny)

# Define UI for application that draws a histogram
ui <- fluidPage(

   # Application title
   titlePanel("Toy App"),

   # Sidebar with a slider input for number of bins
   sidebarLayout(
      sidebarPanel(
         sliderInput("bins",
                     "Number of bins:",
                     min = 1,
                     max = 50,
                     value = 30)
      ),

      # Show a plot of the generated distribution
      mainPanel(
         plotOutput("distPlot")
      )
   )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

   output$distPlot <- renderPlot({
      # generate bins based on input$bins from ui.R
      x    <- faithful[, 2]
      bins <- seq(min(x), max(x), length.out = input$bins + 1)

      # draw the histogram with the specified number of bins
      hist(x, breaks = bins, col = 'darkgray', border = 'white')
   })
}

# Run the application
shinyApp(ui = ui, server = server)


m <- 10
n <- 10
mat <- matrix(sample(1:20L, m*n, replace=TRUE), nrow=m); mat
done <- FALSE
for(i in seq_len(m))
{
   for(j in seq_len(n))
   {
      cat(mat[i,j])
      if(mat[i,j] == 20)
      {
         done <- TRUE
         break
      }
      cat(", ")
   }
   if(done)
   {
      cat("\n")
      break
   }
}


cat(seq(1, 99, 2), sep="\n")


###############################################################################
#
# plottestspeedup.r - plot speedup graph from timetests.sh output
#
# File:    plottestspeedup.r
# Author:  Alex Stivala
# Created: May 2009
#
# Plot speedup graph from timetests.sh output
#
# Usage:
#       R --vanilla --slave -f plottestspeedup.r --args rtabfile
#
#    rtabfile is name of 3-colmn (threads, iteration, ms) .rtab
#      file created by timetests.sh
#    output is PostScript file named foo.eps where foo.rtab was the input file
#
#
# Requires the gplots package from CRAN to draw error bars.
#
# $Id: plottestspeedup.r 2492 2009-06-07 06:30:53Z astivala $
#
###############################################################################

library(gplots)

rtabfile <- commandArgs(trailingOnly=TRUE)
timetab <- read.table(rtabfile,header=TRUE)

maxthreads = max(timetab$threads)

# time for "0 threads", the baseline
# in this plot the baseline is just the same program still with pthreads
# but running with 1 thread
# (speedup is relative to this )
basetime = mean(subset(timetab, threads==1)$ms)

# EPS suitable for inserting into LaTeX
postscript(sub('[.]rtab$','.eps',rtabfile),
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)

x <- subset(subset(timetab, threads > 0), iteration==1)$threads
means <- c()
stdev <- c()
ciw <- c()
for (i in x) {
  # FIXME this code is ugly and inefficient, should use sapply or something
  means <-  c(means, mean(basetime/subset(timetab, threads==i)$ms))
  thisstdev <-  sqrt(var(basetime/subset(timetab, threads==i)$ms))
  stdev <-  c(stdev, thisstdev)
  n <- length(subset(timetab, threads==i)$ms)
  ciw <- c(ciw, qt(0.975, n) * thisstdev / sqrt(n))
}

means
stdev
ciw

plotCI(x, y=means, uiw=ciw, xlab="threads", ylab="speedup" )
#     main=paste('httslftest',rtabfile) )
lines(x,means)
dev.off()
warnings()


rm(list = objects())

library(dplyr)
library(data.table)

# introducir la ubicacion donde se encuentren los archivos
home_folder <- 'ubicacion'
# introducir el nobre del archivo con el dataset
dataset_file <- file.path(home_folder, 'nombre_archivo_dataset')
# introducir el nombre del archivo del modelo
model_file <- file.path(home_folder, 'nombre_archivo_modelo')
# introducir el nombre del archivo de las variables
features_file <- file.path(home_folder, 'nombre_archivo_variables')

# cargamos las generic utilities que contienen la funcion DrawROCCurve
# este script esta en GitHub
source('generic_utilities.R')

dt <- data.table::fread(dataset_file)

model <-  readRDS(model_file)
features <-  readRDS(features_file)

dt <- datasets$dev

# tests train test and dev obtenidos de la documentacion
dt[, set := dplyr::case_when(
  YEAR_MONTH_DAY <= 20171130 ~ 'train',
  YEAR_MONTH_DAY >= 20171201 & YEAR_MONTH_DAY <= 20180131 ~ 'dev',
  YEAR_MONTH_DAY >= 20180201 ~ 'test'
)]

# hay que añadir la columna train porque se guardo en los nobmres de variables pero no tiene incidencia sobre la performance
dt[, train := 1]

# nos aseguramos de que las variables a usar estén en formato numerico
dt[, (features) := lapply(.SD, as.numeric), .SDcols = features]

mtx <- as.matrix(dt[, features, with = FALSE])
target <- dt[, TARGET_BINARY_TARG]

xgb_matrix <- xgboost::xgb.DMatrix(mtx, label = target)

predictions <- predict(model, xgb_matrix) %T>%
  testthat::expect_length(nrow(dt))

output <- data.table::data.table(
  set = dt[, set],
  target = dt[, TARGET_BINARY_TARG],
  score = predictions
)

DrawROCCurve(validationSet = output[set == 'train'], target = 'target', scores = 'score', title = 'Train Set')
DrawROCCurve(validationSet = output[set == 'dev'], target = 'target', scores = 'score', title = 'Dev Set')
DrawROCCurve(validationSet = output[set == 'test'], target = 'target', scores = 'score', title = 'Test Set')


#' Centroid Band Extraction
#'
#' @param data A list of matrices of XYZ point clouds
#' @param pc Align along principal components before extracting
#' @param threshold Metric for band thickness relative to the point cloud scale
#'
#' @keywords CentroidBand
#' @export
#' @examples
#' CentroidBand(data = pointclouds, pc = TRUE, threshold = 4)

CentroidBand <- function(data = NULL, pc = TRUE, threshold = 4) {
	pointcloud_list <- list()
	for(i in 1:length(data)) {
		#align along principal components
		if(pc) {
			pointcloud <- CentroidBanding::pca_align(data[[i]])
		}
		else {
			pointcloud <- data[[i]]
		}

		#calculate centroid
		centroid <- apply(pointcloud, 2, mean)

		#first band
		t1 <- pointcloud[pointcloud[,1] <= centroid[1]+threshold, ]
		band_1 <- t1[t1[,1] >= centroid[1]-threshold, ]

		#second band
		t2 <- pointcloud[pointcloud[,2] <= centroid[2]+threshold, ]
		band_2 <- t2[t2[,2] >= centroid[2]-threshold, ]

		#third band
		t3 <- pointcloud[pointcloud[,3] <= centroid[3]+threshold, ]
		band_3 <- t3[t3[,3] >= centroid[3]-threshold, ]

		#row binds into a single matrix
		pointcloud_list[[i]] <- unique(rbind(band_1, band_2, band_3))
	}
	return(pointcloud_list)
}


#clearing the workspace
rm(list=ls())
graphics.off()
options(show.error.locations = TRUE)
require("ggplot2")

# If we are in a stand alone ubiquity distribution we run
# from there otherwise we try to load the package
if(file.exists(file.path('library', 'r_general', 'ubiquity.R'))){
  source(file.path('library', 'r_general', 'ubiquity.R'))
} else {
  library(ubiquity) }

# Creating the mAb system file
system_new(file_name="system.txt", system_file="mab_pk", overwrite = TRUE)

# For documentation explaining how to modify the commands below
# See the "R Workflow" section at the link below:
# http://presentation.ubiquity.grok.tv

# Rebuilding the system (R scripts and compiling C code)
cfg = build_system(output_directory     = file.path(".", "output"),
                   temporary_directory  = file.path(".", "transient"))

# set name                  | Description
# -------------------------------------------------------
# default                   | TMDD: Membrane bound target

cfg = system_select_set(cfg, "default")

# fetching the parameter values
parameters = system_fetch_parameters(cfg)

# The following applies to both individual and stochastic simulations:
# Define the solver to use
cfg=system_set_option(cfg,group = "simulation", option = "solver", value = "lsoda")
# Specify the output times
cfg=system_set_option(cfg, group  = "simulation",
                           option = "output_times",
                           seq(0,10*7,1))

# -------------------------------------------------------------------------
# Enabling titration
cfg=system_set_option(cfg,
                      group       = "titration",
                      option      = "titrate",
                      value       = TRUE)

# IV bolus dosing every two weeks:
cfg=system_new_tt_rule(cfg,
                       name       = "ivdose",
                       times      = c(0, 2, 4, 6, 8),
                       timescale  = "weeks")

cfg=system_set_tt_cond(cfg,
                       name       = "ivdose",
                       cond       = 'TRUE',
                       action     = "SI_TT_BOLUS[state='Cc', values=500, times=0]",
                       value      = "5")

# At week 3 we remove 1/2 of the drug from the system by
# Setting Cc and Cp to zero
cfg=system_new_tt_rule(cfg,
                       name       = "state_reset",
                       times      = c(3),
                       timescale  = "weeks")
cfg=system_set_tt_cond(cfg,
                       name       = "state_reset",
                       cond       = 'TRUE',
                       action     = "SI_TT_STATE[Cc][0.5*Cc]",
                       value      = "0")
cfg=system_set_tt_cond(cfg,
                       name       = "state_reset",
                       cond       = 'TRUE',
                       action     = "SI_TT_STATE[Cp][0.5*Cp]",
                       value      = "0")

# Simulating the system
som_tt = run_simulation_titrate(parameters, cfg)

myfig = ggplot() +
        geom_line(data=som_tt$simout, aes(x=ts.weeks,   y=Cc), color="red")
myfig = prepare_figure('present', myfig)

print(myfig)

ggsave(sprintf('output%sstate_reset.png', .Platform$file.sep), width=8, height=3.4, plot=myfig)


locus_colocalization_hyprcoloc <- function(workDir, select_dist, select_ref, gwasfile, qtlfile, ldfile, request, bucket) {
  source('services/query_scripts/QTLs/ezQTL_ztw.R')
  setwd(workDir)
  .libPaths(c(.libPaths(), "~/R"))
  library(hyprcoloc)
  library(tidyverse)
  library(jsonlite)
  library(ggrepel)
  library(aws.s3)

  ##  args = commandArgs(trailingOnly=TRUE)
  ##  gwasfile <- args[1]
  ##  qtlfile <- args[2]
  ##  ldfile <- args[3]
  ##  prefix <- args[4]

  gwasfile <- paste0('tmp/', request, '/ezQTL_input_gwas.txt')
  qtlfile <- paste0('tmp/', request, '/ezQTL_input_qtl.txt')
  ld.matrix <- read_delim(paste0('tmp/', request, '/', ldfile), delim = '\t', col_names = F, col_types = cols('X1' = 'c')) %>% rename(chr = X1, pos = X2, rsnum = X3, ref = X4, alt = X5)

  ## for jiyeon ##

  trait1 <- read_delim(gwasfile, delim = '\t', col_names = T, col_types = cols('chr' = 'c', 'ref' = 'c', 'alt' = 'c'))
  cedistance <- strtoi(select_dist, base = 0L)
  index1 <- which(trait1$rsnum == select_ref)[1]
  if (is.na(index1)) return(toJSON(list(error = paste0(select_ref, ' not found in GWAS data'))))
  minpos1 <- trait1$pos[index1] - cedistance
  if (minpos1 < 0) {
    minpos1 = 0
  }
  maxpos1 <- trait1$pos[index1] + cedistance

  trait1 <- subset(trait1, pos > minpos1 & pos < maxpos1)
  trait2 <- read_delim(qtlfile, delim = '\t', col_names = T, col_types = cols('chr' = 'c', 'variant_id' = 'c', 'ref' = 'c', 'alt' = 'c'))
  index2 <- which(trait2$rsnum == select_ref)[1]
  minpos2 <- trait2$pos[index2] - cedistance
  if (minpos2 < 0) {
    minpos2 = 0
  }
  maxpos2 <- trait2$pos[index2] + cedistance

  trait2 <- subset(trait2, pos > minpos2 & pos < maxpos2)

  gene2symbol <- trait2 %>% select(gene_id, gene_symbol) %>% unique()

  # ld.matrix <- read_delim(ldfile, delim = '\t', col_names = F, col_types = cols('X1' = 'c')) %>% rename(chr = X1, pos = X2, rsnum = X3, ref = X4, alt = X5)
  ld.info <- ld.matrix %>% select(chr, pos, rsnum, ref, alt) %>% mutate(Seq = seq_along(chr))

  ld.matrix <- ld.matrix %>% select(-c(chr, pos, rsnum, ref, alt)) %>% as.matrix
  ## ld =

  result_hyprcoloc <- tibble(iteration = integer(), traits = character(), posterior_prob = double(), regional_prob = double(), candidate_snp = character(), posterior_explained_by_snp = double(), dropped_trait = character())
  result_snpscore <- tibble(rsnum = character(), snpscore = double())

  ### keep the gene id with at least 5 snps ###
  nminal <- 5
  gene_id_filtered <- trait2 %>% count(gene_id, sort = T) %>% arrange(desc(n)) %>% filter(n > nminal) %>% pull(gene_id)
  if (length(gene_id_filtered) < 1) {
    errinfo <- paste0("\nERROR: the number of SNPs is less than 5 for all traits. ezQTL will not perform colocalizaiton analysis using HyPrColoc.")
    cat(errinfo, file = logfile, sep = "\n", append = T)
    stop("ezQTL QC failed for HyPrColoc analysis")
  }
  trait2 <- trait2 %>% filter(gene_id %in% gene_id_filtered)
  ###

  for (i in unique(trait2$gene_id)) {
    geneid <- i

    tdata <- trait1 %>%
      left_join(
        trait2 %>% filter(gene_id == geneid), by = c('chr' = 'chr', 'pos' = 'pos', 'ref' = 'ref', 'alt' = 'alt')
      ) %>%
      mutate(rsnum = if_else(rsnum.x != rsnum.y, paste(chr, pos, ref, alt, sep = ':'), rsnum.x)) %>%
      filter(!is.na(slope), !is.na(effect), !is.na(se), !is.na(slope_se)) %>%
      filter(slope != 0, effect != 0, se != 0, slope_se != 0) %>%
      filter(str_detect(rsnum, "rs")) %>%
      as.data.frame()
    rownames(tdata) <- tdata$rsnum
    betas <- tdata[, c("effect", "slope")] %>% rename(GWAS = effect, QTL = slope) %>% as.matrix()
    ses <- tdata[, c("se", "slope_se")] %>% rename(GWAS = se, QTL = slope_se) %>% as.matrix()
    traits <- c('GWAS', 'QTL')
    # rsid=rownames(tdata)

    rsindex = tdata %>% select(chr, pos, rsnum) %>% left_join(ld.info) %>% select(Seq, rsnum) %>% filter(!is.na(Seq)) ##
    ld.matrix.seq <- ld.matrix[rsindex$Seq, rsindex$Seq]
    rownames(ld.matrix.seq) <- rsindex$rsnum
    colnames(ld.matrix.seq) <- rsindex$rsnum
    betas <- betas[rsindex$rsnum,] ##
    ses <- ses[rsindex$rsnum,] ##

    binary.traits <- c(1, 0)
    res <- hyprcoloc(betas, ses, trait.names = traits, snp.id = rsindex$rsnum, binary.outcomes = binary.traits, snpscores = TRUE, ld.matrix = ld.matrix.seq);

    result_hyprcoloc <- bind_rows(result_hyprcoloc, res[[1]] %>% mutate(gene_id = geneid))
    if (length(res) > 1) {
      # tmpres <- res[[2]][[1]] %>% as.data.frame() %>% rownames_to_column() %>% mutate(gene_id = geneid)
      tmpres <- tibble(rsnum = names(res[[2]][[1]]), snpscore = res[[2]][[1]]) %>% mutate(gene_id = geneid)
      colnames(tmpres) <- c("rsnum", "snpscore", "gene_id")
      result_snpscore <- bind_rows(result_snpscore, tmpres)
    }
  }

  result_hyprcoloc <- result_hyprcoloc %>% left_join(gene2symbol)

  if (dim(result_snpscore)[1] > 0) {
    result_snpscore <- result_snpscore %>% left_join(gene2symbol)
  }

  result_hyprcoloc <- result_hyprcoloc %>% arrange(desc(posterior_explained_by_snp))
  ## parse result_hyprcoloc dataframe to JSON
  result_hyprcoloc_colnames <- colnames(result_hyprcoloc)
  hyprcoloc_data <- setNames(as.data.frame(result_hyprcoloc), result_hyprcoloc_colnames)
  hycoloc_barplot(hyprcoloc_data, output_plot = paste0('tmp/', request, '/', 'hyprcoloc_table.svg'))
  result_hyprcoloc_data = list(hyprcoloc_data)

  result_snpscore <- result_snpscore %>% arrange(desc(snpscore))
  ## parse result_snpscore dataframe to JSON
  result_snpscore_colnames <- colnames(result_snpscore)
  snpscore_data <- setNames(as.data.frame(result_snpscore), result_snpscore_colnames)
  hycoloc_boxplot(snpscore_data, output_plot = paste0('tmp/', request, '/', 'hyprcoloc_snpscore_table.svg'))
  result_snpscore_data = list(snpscore_data)

  result_hyprcoloc_filename <- paste0(request, ".hyprcoloc.txt")
  result_snpscore_filename <- paste0(request, ".hyprcoloc_snpscore.txt")
  result_hyprcoloc %>% write_delim(paste0('tmp/', request, '/', result_hyprcoloc_filename), delim = '\t', col_names = T)
  result_snpscore %>% write_delim(paste0('tmp/', request, '/', result_snpscore_filename), delim = '\t', col_names = T)

  #save.image(file=paste0(prefix,".hyprcoloc.RData"))
  dataSourceJSON <- c(toJSON(list(hyprcoloc = list(request = request, result_hyprcoloc = list(data = result_hyprcoloc_data), result_snpscore = list(data = result_snpscore_data))), na = 'string'))
  return(dataSourceJSON)
}
### LEAVE EMPTY LINE BELOW ###


#' @export
#' @title pie.add
#' @description couldn't accurately describe
#' @param \code{z}
#' @param \code{x} defaults to 0
#' @param \code{y} defaults to 0
#' @param \code{labels} defaults to names(z)
#' @param \code{radius} defaults to 1
#' @param \code{edges} defaults to 200
#' @param \code{clockwise} defaults to TRUE
#' @param \code{init.angle} defaults to 90
#' @param \code{density} defaults to NULL
#' @param \code{angle} defaults to 45
#' @param \code{col} defaults to NULL
#' @param \code{border} defaults to NULL
#' @param \code{lty} defaults to NULL
#' @param \code{label.dist} defaults to 1.1
#' @family  plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
pie.add <- function (z, x = 0, y = 0, labels = names(z), radius = 1, edges = 200,
                     clockwise = TRUE, init.angle = 90, density = NULL, angle = 45,
                     col = NULL, border = NULL, lty = NULL, label.dist = 1.1,
                     ...) {
  if (!is.numeric(z) || any(is.na(z) | z < 0))
    stop("'z' values must be positive.")
  if (is.null(labels))
    labels <- as.character(seq_along(z))
  else labels <- as.graphicsAnnot(labels)
  z <- c(0, cumsum(z)/sum(z))
  dz <- diff(z)
  nz <- length(dz)
  asp <- get.asp()
  if (is.null(col))
    col <- if (is.null(density))
      c(rainbow(8,alpha=0.5))
  else par("fg")
  if (!is.null(col))
    col <- rep_len(col, nz)
  if (!is.null(border))
    border <- rep_len(border, nz)
  if (!is.null(lty))
    lty <- rep_len(lty, nz)
  angle <- rep(angle, nz)
  if (!is.null(density))
    density <- rep_len(density, nz)
  twopi <- if (clockwise)
    -2 * pi
  else 2 * pi
  t2xy <- function(t) {
    t2p <- twopi * t + init.angle * pi/180
    list(x = asp * radius * cos(t2p) + x, y = radius * sin(t2p) +
           y)
  }
  for (i in 1L:nz) {
    n1 <- max(2, floor(edges * dz[i]))
    P <- t2xy(seq.int(z[i], z[i + 1], length.out = n1))

    polygon(c(P$x, 0 + x), c(P$y, 0 + y), density = density[i],
            angle = angle[i], border = border[i], col = col[i],
            lty = lty[i])
    P <- t2xy(mean(z[i + 0:1]))
    lab <- as.character(labels[i])
    if (!is.na(lab) && nzchar(lab)) {
      text(label.dist * (P$x - x) + x, label.dist * (P$y -
                                                       y) + y, labels[i], xpd = TRUE, adj = ifelse(P$x -
                                                                                x < 0, 1, 0), ...)
    }
  }
}


#devtools::test("asremlPlus")
context("predictions_alldiffs")

cat("#### Test for predictions.frame on Oats with asreml4\n")
test_that("PredictionsFrame_asreml4", {
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  ## Use asreml to get predictions and associated statistics

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  current.asrt <- as.asrtests(m1.asr)
  Var.pred <- asreml::predict.asreml(m1.asr, classify="Nitrogen:Variety",
                                     sed=TRUE)
  if (getASRemlVersionLoaded(nchar = 1) == "3")
    Var.pred <- Var.pred$predictions
  Var.preds <- as.predictions.frame(Var.pred$pvals, se = "std.error",
                                    est.status = "status")

  ## Check the class and validity of the predictions.frame
  testthat::expect_true(is.predictions.frame(Var.preds))
  testthat::expect_true(validPredictionsFrame(Var.preds))
})


# This code creates the weekly naive
# and adjusted seroprevalence charts for
# Seroprevalence of SARS-CoV-2 antibodies in Saint
# Petersburg, Russia paper (https://doi.org/10.1038/s41598-021-92206-y)
library(data.table)
library(ggplot2)
library(ggthemes)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load the per-group prevalence computed by estimate_prevalence_by_variable.r
load("estimates/wave1/prevalence_by_variable_level.rdata")

# Rename tests
prevalence_by_variable_level[serotest == "IgA_or_G_or_M_testC", serotest := "ELISA"]
prevalence_by_variable_level[serotest == "IgG_testB", serotest := "CMIA"]

# Keep only adjusted univariate prevalence for interview week
prevalence_by_interview_week <- prevalence_by_variable_level[ prevalence_type == "univariate" & variable == "interview_week" & surveyweight == "no" & sensitivity != 1]
setnames(prevalence_by_interview_week, "variable_level", "week")

prevalence_by_interview_week[, week := as.numeric(week)]
prevalence_by_interview_week[week == 21, week_label := "May 18-24"]
prevalence_by_interview_week[week == 22, week_label := "May 25-31"]
prevalence_by_interview_week[week == 23, week_label := "June 1-7"]
prevalence_by_interview_week[week == 24, week_label := "June 8-14"]
prevalence_by_interview_week[week == 25, week_label := "June 15-21"]
prevalence_by_interview_week[week == 26, week_label := "June 22-28"]

# Keep only naive prevalence for draw sample week
prevalence_by_draw_sample_week <- prevalence_by_variable_level[ prevalence_type == "naive" & variable == "draw_week" & surveyweight == "no" & sensitivity != 1]
setnames(prevalence_by_draw_sample_week, "variable_level", "week")

prevalence_by_draw_sample_week[, week := as.numeric(week)]
prevalence_by_draw_sample_week[week == 21, week_label := "May 18-24"]
prevalence_by_draw_sample_week[week == 22, week_label := "May 25-31"]
prevalence_by_draw_sample_week[week == 23, week_label := "June 1-7"]
prevalence_by_draw_sample_week[week == 24, week_label := "June 8-14"]
prevalence_by_draw_sample_week[week == 25, week_label := "June 15-21"]
prevalence_by_draw_sample_week[week == 26, week_label := "June 22-28"]

## Plot by interview week
prevalence_by_interview_week_plot <- ggplot(prevalence_by_interview_week, aes(x = week, y = pointest, color = serotest)) +
											geom_point(size = 2, position = position_dodge(width=0.5)) +
											geom_errorbar(aes(ymin = lowerbound, ymax = upperbound), width = 0.2, position = position_dodge(width=0.5)) +
											geom_text(aes(label = paste0(pointest, "%")), hjust = 1.2, vjust = 0.2, size = 6, position = position_dodge(width=0.5)) +
											scale_y_continuous(name = "Prevalence (single imputation model), %") +
											scale_x_continuous(	name = "Week of phone call inviting to participate in the study",
																breaks = unique(prevalence_by_interview_week$week), labels = unique(prevalence_by_interview_week$week_label),
																expand = c(0.1, 0)) +
											labs(color = "Test") +
											theme_minimal() +
											theme(panel.grid.minor = element_blank(), axis.text.y = element_text(size = 12), text = element_text(size = 15), legend.position = "bottom")

#ggsave(prevalence_by_interview_week_plot, file = "media/wave1/prevalence_by_interview_week_plot.pdf")

## Plot by draw sample week
prevalence_by_draw_sample_date_plot <- ggplot(prevalence_by_draw_sample_week, aes(x = week, y = pointest, color = serotest)) +
											geom_point(size = 2, position = position_dodge(width=0.5)) +
											geom_errorbar(aes(ymin = lowerbound, ymax = upperbound), width = 0.2, position = position_dodge(width=0.5)) +
											geom_text(aes(label = paste0(pointest, "%")), hjust = 1.2, vjust = 0.2, size = 6, position = position_dodge(width=0.5)) +
											scale_y_continuous(name = "Prevalence (naïve), %") +
											scale_x_continuous(	name = "Week of blood sample draw",
																breaks = unique(prevalence_by_draw_sample_week$week), labels = unique(prevalence_by_draw_sample_week$week_label),
																expand = c(0.1, 0)) +
											labs(color = "Test") +
											theme_minimal() +
											theme(panel.grid.minor = element_blank(), axis.text.y = element_text(size = 12), text = element_text(size = 15), legend.position = "bottom")

#ggsave(prevalence_by_draw_sample_date_plot, file = "media/wave1/prevalence_by_draw_sample_date_plot.pdf")


suppressPackageStartupMessages(library(kazaam))
comm.set.seed(1234)

tester = function(x, dx)
{
  norm = "O"
  test = rcond(dx, norm)
  comm.print(all.equal(rcond(x, norm), test))

  norm = "I"
  test = rcond(dx, norm)
  comm.print(all.equal(rcond(x, norm), test))

  norm = "1"
  test = rcond(dx, norm)
  comm.print(all.equal(rcond(x, norm), test))
}

dx = ranshaq(runif, 10, 3)
x = collapse(dx)
tester(x, dx)

dx = expand(matrix(1:30, 10))
x = collapse(dx)
tester(x, dx)

finalize()


#### ossc-libraries_and_functions.r: Part of `oss_community-langauge_dynamics.Rmd` ####
#
# This script loads libraries and creates a number of
# additional functions to facilitate data prep and analysis.
#
# Written by: A. Paxton (University of Connecticut) & Nelle Varoquaux (University of California, Berkeley)
# Date last modified: 30 May 2019
#####################################################################################

#### Load necessary packages ####

# list of required packages
required_packages = c(
  'dplyr',
  'data.table',
  'lme4',
  'ggplot2',
  'pander',
  'gridExtra',
  'plotrix',
  'gtable',
  'viridis',
  'jsonlite',
  'tidyr',
  'tibble',
  'RCurl',
  'splines',
  'magrittr',
  'jtools',
  'splines',
  'lmerTest'
  )

# load required packages using pacman
pacman::p_load(required_packages, character.only=TRUE)

#### Prevent scientific notation ####
options(scipen=999)

#### Read in external functions ####

# read in pander_lme
pander_lme_url = "https://raw.githubusercontent.com/a-paxton/stats-tools/2a1bf715097bbcc966ab612af3a9e0b14408d4ff/pander_lme.R"
pander_lme_file = getURL(pander_lme_url, ssl.verifypeer = FALSE)
eval(parse(text = pander_lme_file))

#### Create new functions ####

# compute p-values from t-statistics (typical in psychology)
compute_p_value_from_t_stats = function(t_stats){
  p_values = 2*(1-pnorm(abs(t_stats)))
}

# Because we need splines that span independently from one another the dates
# of projects, we need to create a function that takes two variable vectors
# from the dataframe: (1) the dates; (2) the groups. We also need to provide
# to the function the value corresponding to the group of interest. The rest
# is just a normal spline.
group_date_ns = function(date, group, value, knots=NULL, degrees_of_freedom=NULL){

  # Estimate the number of degrees of freedom we're assigning to this spline
  range = max(sentiment_frame$date[group == value]) - min(sentiment_frame$date[group == value])
  degrees_of_freedom = floor(range / 365)

  # Create the basis of the right size, but with 0 everywhere
  basis = 0 * splines::ns(date, df=degrees_of_freedom)

  # Now, for the correct group, create the splines that span across the
  # dates of the group. This means the basis should have 0 everywhere except
  # on the dates spanning this group.
  basis[group == value,] = splines::ns(date[group == value],
                                       knots=knots,
				       intercept=TRUE,
                                       df=degrees_of_freedom)
  return(basis)
}

# display cleaned ANOVA output
pander_clean_anova = function(model, rename_columns=TRUE,
                              pval_correction_method="BH",
			      display_only_significant=FALSE){
  # First, rename the functions into something sane.
  if(rename_columns){
    colnames(model) = c("sum_sq", "mean_sq", "num_df", "den_df",
                        "f_value", "p_value")
  }

  # Adjust p-values
  model$p_adj = stats::p.adjust(model$p_value, method=pval_correction_method)

  # Now, apply the same rounding on the p_value than on the rest
  model$p_value[model$p_value < .0001] = .0001
  model$p_value[model$p_value >= .0001] = round(model$p_value[model$p_value >= .0001],4)
  model$p_value[model$p_value >= .0005] = round(model$p_value[model$p_value >= .0005],3)
  model$p_value[model$p_value >= .25] = round(model$p_value[model$p_value >= .25],2)

  model$p_adj[model$p_adj < .0001] = .0001
  model$p_adj[model$p_adj >= .0001] = round(model$p_adj[model$p_adj >= .0001],4)
  model$p_adj[model$p_adj >= .0005] = round(model$p_adj[model$p_adj >= .0005],3)
  model$p_adj[model$p_adj >= .25] = round(model$p_adj[model$p_adj >= .25],2)

  model$sig = ' '
  model$sig[model$p_adj < .1] = '.'
  model$sig[model$p_adj < .05] = '*'
  model$sig[model$p_adj < .01] = '**'
  model$sig[model$p_adj < .001] = '***'
  if(display_only_significant){
    pander(model[model$p_adj < 0.05, ], , split.table=Inf, style="rmarkdown")
  }else{
    pander(model, , split.table = Inf, style = 'rmarkdown')
  }
}

#' Welch t-test
compute_t_statistics = function(means, standard_error,
                                contrasts){
  all_tests = data.frame()
  for(contrast in contrasts){
    splits = unlist(strsplit(contrast, "-"))
    if(length(splits) != 2){
      error("Dunno how to deal with this just yet")
    }

    group1 = splits[1]
    group2 = splits[2]

    t = ((means[group1] - means[group2]) /
           (standard_error[group1]**2 +
              standard_error[group2]**2)**.5)
    all_tests[contrast, "t_stats"] = t
  }
  return(all_tests)
}


# taken from here: http://stackoverflow.com/questions/16396090/r-topic-modeling-lda-model-labeling-fuction
library(topicmodels)
data(AssociatedPress)
train <- AssociatedPress[1:100]
test <- AssociatedPress[101:150]

train.lda <- LDA(train,2)
test.topics <- posterior(train.lda,test)$topics
head(test.topics)

colnames(test.topics) <- apply(terms(train.lda,5),2,paste,collapse=",")
head(test.topics)
test.topics <- apply(test.topics,1,function(x) colnames(test.topics)[which.max(x)])
head(test.topics)


spatiotemporal.pca <- function(correlation=TRUE){

# load required libraries
require(caTools)
require(pixmap)
require(graphics)
require(ReadImages)
require(fpc)

# get files and file info out of the directory
f <- system("ls *.jpg | sort -n",intern=T)
doy <- system("ls *.jpg | sort -n | cut -d'-' -f1",intern=T)
year <- system("ls *.jpg | sort -n | cut -d'-' -f2",intern=T)

# get the number of files in the directory
l <- length(f)

# get file dimensions
x <- dim(read.jpeg(f[1]))[2]
y <- dim(read.jpeg(f[1]))[1]

# calculate matrix size parameter
nrrows <- x*y

# create an output array a based upon the dimensions of the image
# and 365 days in a year. The array will be filled with data
# when data is available for that given day.
a <- array(NA,dim=c(x,y,l))

# for every file in the directory do.
for (i in f){
  loc <- which(i == f)

  # find the corresponding doy in the doy matrix
  #currentdoy <- doy[loc]

	# procesing which file?
	print(i)

	# read in jpeg images
	img <- read.jpeg(i)

	# extract RGB channel data
	red <-img[,,1]*255
	green <-img[,,2]*255
	blue <-img[,,3]*255

  # reshape every matrix into a 1 column vector
  red <- matrix(red,nrrows,1)
  green <- matrix(green,nrrows,1)
  blue <- matrix(blue,nrrows,1)

  # merge channels into a 3 column feature vector
  RGB <- cbind(red,green,blue)

  # calcute PCA on the RGB channels
  pca.results <- princomp(RGB,cor=correlation)

  # extract scores and get the first PCA component
  pca.1 <- pca.results$scores[,1]

  # convert the first pca component back into a matrix
  pca.matrix <- matrix(pca.1,480,640)
  pca.matrix <- t(pca.matrix[nrow(pca.matrix):1,])

  pca.matrix <- mean(pca.matrix[200:350,,],na.rm=T)

	a[,,loc] <- pca.matrix

}

# reshape the 3d array into a 2d matrix
a <- matrix(a,nrrows,l)

# write output to txt files

# write classification input data to file
write.table(a,paste('spatio-temporal-data-matrix-',unique(year),'.txt',sep=''),quote=F,row.names=F,col.names=F)

# write dates file
dates <- strptime(paste(year,doy,sep='-'),'%Y-%j')
write.table(dates,paste('dates-',unique(year),'.txt',sep=''),quote=F,row.names=F,col.names=F)

}
spatiotemporal.pca()


#!/usr/bin/env Rscript
#5a_NbClust.r
#
#Author: Abelardo Aguilar Camara
#
#Task performed:
#    This script takes the CPFSCC 28 dimensional vectors of a family,
#    performs 13 different clustering indices, and returns a family
#    membership data frame with consensus clustering
#
#
#NOTE:"CPFSCC" stands for central moments and covariance vectors of cumulative fourier transform power and phase spectra
#
#INPUT: CPFSCC vectors of anytaxon from  ../results/CPFSCC_vectors/anytaxon_CPFSCC_vectors.txt
#
#OUTPUT: Membership vectors        in    ../results/NbClust_membership_vectors/
#        Distance matrix           in    ../results/Distance_Matrices/
#        Point plot of distances   in    ../results/Clustering_graphics
#        Clusters PCA              in    ../results/Clustering_graphics
#
#################################################
#
#5a_NbClust.r
#
#################################################
# Load needed packages
suppressPackageStartupMessages(library("NbClust"))
suppressPackageStartupMessages(library("factoextra"))
suppressPackageStartupMessages(library("ggplot2"))
#################################################
# Reading input
setwd("../results/CPFSCC_vectors") #Location of CPFSCC vectors files
PosArgs <- as.character(commandArgs(trailingOnly = TRUE))
family = PosArgs[1]  #Reads positional arguments to define family (e.g. family = "Geminiviridae")
mincluster = as.numeric(PosArgs[2]) # defines minimum number of clusters
maxcluster = as.numeric(PosArgs[3]) # defines maximum number of clusters
file_suffix <- ("CPFSCC_vectors.txt") #Suffix to build input filename
family_CPFSCC_file <- paste(family,file_suffix, sep = "_") #Read filename
tmp <- as.matrix(read.csv(family_CPFSCC_file, header = TRUE, sep = ",", dec = ".")) #Transform to matrix
tmp2 <- t(tmp)
colnames(tmp2) <- sprintf("D%d", 1:28) #Name columns dimensions
datos <- as.data.frame(tmp2) # Object datos is the final input for the upcoming computations
#################################################
#indices to estimate
indexes <- c("kl",
             "ch",
             "hartigan",
             "cindex",
             "db",
             "silhouette",
             "ratkowsky",
             "ball",
             "ptbiserial",
             "mcclain",
             "dunn",
             "sdindex",
             "sdbw")
diss_matrix<- dist(datos, method = "euclidean", diag=FALSE) #Pairwise distance matrix
#################################################
#Estimating the best number of clusters
res <- c() # Vector to contain results
Best_num_clust <- c() #Vector to contain best number of cluster proposed by each index
#Loop over indices to compute
for (i in indexes){
  res <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D", index = i)
  Best_num_clust[i] <- res$Best.nc[1]
}
Bestnc <- as.data.frame(Best_num_clust) #to dataframe
nc <- names(sort(summary(as.factor(Bestnc$Best_num_clust)), decreasing = TRUE)[1]) #Saves the most observed number of clusters
ncsubset <- subset(Bestnc, Best_num_clust==nc) #Defines a subset of those indexes indicating matching nc
first_index <- rownames(ncsubset)[1] #Selects index to operate partitions
#################################################
#Computing partitions
#Can be changed to for loop but I prefer this way to easily find when a partition method aborts
Partition_wardD <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D", index = first_index)
Partition_wardD2 <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "ward.D2", index = first_index)
Partition_single <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "single", index = first_index)
Partition_complete <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "complete", index = first_index)
Partition_average <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "average", index = first_index)
Partition_mcquitty <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "mcquitty", index = first_index)
Partition_median <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "median", index = first_index)
Partition_centroid <- NbClust(datos, diss=diss_matrix, distance = NULL, min.nc=mincluster, max.nc=maxcluster, method = "centroid", index = first_index)
#Save partitions to data frame
taxids <- rownames(datos)
Pertenencia.df <- data.frame(Partition_wardD$Best.partition,
                             Partition_wardD2$Best.partition,
                             Partition_single$Best.partition,
                             Partition_complete$Best.partition,
                             Partition_average$Best.partition,
                             Partition_mcquitty$Best.partition,
                             Partition_median$Best.partition,
                             Partition_centroid$Best.partition)
#################################################
#Define a function "moda" to recover the most popular clusters membership proposition for each genome
function.moda<-function(n)
{
  names(sort(summary(as.factor(n)), decreasing = TRUE)[1])
}
#################################################
#Use function.moda to estimate consensus membership vector
Pertenencia.df$Consenso <- apply(Pertenencia.df, 1, function.moda)
#################################################
#################################################
#Save outputs
#Membership vectors
setwd("..")
outdir <- ("mkdir -p NbClust_membership_vectors") #Make membership vectors outdir
system(outdir) #Make outdir
setwd("NbClust_membership_vectors")
outfile <- paste(family,"membership_vectors.csv", sep="_")
write.csv(Pertenencia.df, outfile, row.names = TRUE) #Write membership vectors file
#################################################
#Distance matrix
outdir2 <- ("mkdir -p ../Distance_Matrices/")
system(outdir2) #Make distance matrices outdir
setwd("../Distance_Matrices/")
Distancias <- dist(datos, method = "euclidean", diag=TRUE) #Estimate pairwise distances
Distancias.matrix <- as.matrix(Distancias) #Transform to matrix
outfile2 <- paste(family,"distance_matrix.csv", sep="_")
write.csv(Distancias.matrix, outfile2, row.names = TRUE) #Write distance matrix as csv
#################################################
#Point plot of ordered distances (pplot)
ene <- nrow(Distancias.matrix) #number of genomes
SumDist <- (rowSums(Distancias.matrix)) #get sum of distances by genome
SumDist.df <- as.data.frame(SumDist) #transform to data frame
mean_Distance <- (SumDist.df$SumDist)/ene #get average sum of distances per genome
SumDist.df$MeanDif <- mean_Distance #save average sum to data frame
SumDist.df <- cbind(SumDist.df, Pertenencia.df)
colnames(SumDist.df) <- c("SumDist",
                          "MeanDif",
                          "ward.D_method",
                          "ward.D2_method",
                          "single_method",
                          "complete_method",
                          "average_method",
                          "mcquitty_method",
                          "median_method",
                          "centroid_method",
                          "consensus_method")
methd <- c(3:11)
SumDist.df[,methd] <- lapply(SumDist.df[,methd] , factor)
OrderedDist.df <- SumDist.df[order(SumDist.df$MeanDif),] #sort sum of distances
IndexByDistSum <- seq(from = 1, to = ene)
OrderedDist.df$IndexByDistSum <- IndexByDistSum
setwd("..")
outdir3 <- ("mkdir -p Clustering_graphics") #make clustering graphics outdir
system(outdir3)
setwd("Clustering_graphics")
GraphMethods <- list(OrderedDist.df$ward.D_method,
                  OrderedDist.df$ward.D2_method,
                  OrderedDist.df$single_method,
                  OrderedDist.df$complete_method,
                  OrderedDist.df$average_method,
                  OrderedDist.df$mcquitty_method,
                  OrderedDist.df$median_method,
                  OrderedDist.df$centroid_method,
                  OrderedDist.df$consensus_method)
for (i in 1:length(GraphMethods)){
  outfilename <- paste(family, "_", colnames(OrderedDist.df)[2+i],"_distances_pplot.tiff", sep = "")
  legendtitle <- paste(family, paste("(", colnames(OrderedDist.df)[2+i], ")", sep = ""),"ordered distances by cluster")
  tiff(outfilename, units="in", width=7, height=5, res=600)
  print(ggplot(data=OrderedDist.df, aes(IndexByDistSum, MeanDif)) +
    geom_point(aes(colour = GraphMethods[[i]]), size = 2, alpha = 0.2) +
    theme(legend.position="top") +
    labs(color= legendtitle ))
  dev.off()
}
#################################################
#Clusters PCA
res.pca <- prcomp(datos, scale = TRUE) #make PCA
groups <- as.factor(Pertenencia.df$Consenso) #recover clusters
outfile4 <- paste(family,"_PCA_clusters.tiff", sep = "")
#Draw PCA to tiff file
#Clusters PCA
res.pca <- prcomp(datos, scale = TRUE) #make PCA
grupos <- list(as.factor(Pertenencia.df$Partition_wardD.Best.partition),
               as.factor(Pertenencia.df$Partition_wardD2.Best.partition),
               as.factor(Pertenencia.df$Partition_single.Best.partition),
               as.factor(Pertenencia.df$Partition_complete.Best.partition),
               as.factor(Pertenencia.df$Partition_average.Best.partition),
               as.factor(Pertenencia.df$Partition_mcquitty.Best.partition),
               as.factor(Pertenencia.df$Partition_median.Best.partition),
               as.factor(Pertenencia.df$Partition_centroid.Best.partition),
               as.factor(Pertenencia.df$Consenso))
for (i in 1:length(grupos)){
  outfilename <- paste(family, "_", colnames(OrderedDist.df)[2+i],"_PCA_clusters.tiff", sep = "")
  PCA_title <- as.character(paste(family, "PCA", paste("(", colnames(OrderedDist.df)[2+i], ")", sep = "")))
  tiff(outfilename, units="in", width=7, height=5, res=600) #tiff resolution parameters
  current_pca <- fviz_pca_ind(res.pca,
               col.ind = grupos[[i]], # color by groups
               palette = c("#00AFBB",
                           "#FC4E07",
                           "#50f0d0",
                           "#f05070",
                           "#d050f0",
                           "#70f050",
                           "#f0d050",
                           "#ffd88d",
                           "#5086a7",
                           "#dd9082",
                           "#093d3a",
                           "#196f69",
                           "#786045",
                           "#d59c2c",
                           "#336936",
                           "#d050f0",
                           "#70f050",
                           "#f0d050",
                           "#50f0d0",
                           "#f05070"),
               addEllipses = TRUE,
               ellipse.level=0.95,
               legend.title = "cluster",
               label = "none",
               title = PCA_title)
  print(current_pca)
  dev.off()
}


#script to further analyse comparison of modelled vs observed land cover
#reads a file created by CRAFTYsummary_5LCs.r

rm(list=ls())

#set for the run in CRAFTY (althrough runID difficult to control)
scenario <- "Testing_2019-02-21"
runID <- "0-0"

#script assumes there are three calibration years (2005, 2010, 2015); edit next line if that is not correct
calib_yrs <- c(2005, 2010, 2015)

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

library(tidyverse)
library(caret)   #for confusionMatrix
library(diffeR)  #for map comparison
library(gridExtra)  #for printing tables to pdf
library(grid)

#output variables)
output_name <- paste0("Data/",scenario,"/",runID,"/",scenario,"_LCcomparisonAnalysis.pdf")

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

cDat <- readr::read_csv(paste0("Data/",scenario,"/",runID,"/",scenario,"_CRAFTYmunisLC.csv"),
  col_types = cols(Year = col_integer(), diffcProp3 = col_double()))  #needed to ensure correct import (many zeros in diffcProp3 at top of file)

## Mode analysis

#1. count munis with different modes
#2. contingency table of performance
#3. maps of modes (observed, modelled, diffc)

#total number of munis that have different modes
cDat %>%
  group_by(Year) %>%
  dplyr::summarise(count = sum(diffcMode)) -> CDiffc

#proportional difference (of all municipalities)
cDat %>%
  group_by(Year) %>%
  dplyr::summarise(prop = round(sum(diffcMode)/length(diffcMode),3)) -> PDiffc

diffc <- inner_join(CDiffc, PDiffc)

print(diffc)

if(pdfprint) {
  grid.arrange(tableGrob(as.data.frame(diffc)), top=" Municipality Error")
}

#confusionMatrix needs factors
cDat <- cDat %>%
  mutate(ModMode = factor(ModMode, c(1,2,3,4,5))) %>%
  mutate(ObsMode = factor(ObsMode, c(1,2,3,4,5)))

#could create a table subset here of munis that do not match?

summary(cDat)
LCnames <- c("Nat", "OtherAgri", "Agri", "Other", "Pasture")  #used to label error matrix in loop below

#yr <- 2005
#loop through years, priting error matrices
for(yr in calib_yrs){

  #yr<-2005  #for testing
  cfm <- confusionMatrix(filter(cDat, Year == yr)$ModMode,filter(cDat, Year == yr)$ObsMode)

  xmat <- as.matrix(cfm, what = "xtabs")
  xtab <- as.table(cfm, what = "xtabs")

  colnames(xtab) <- LCnames
  rownames(xtab) <- LCnames

  print(cfm$overall)

  #From Pontius and Santacruz 2014 http://dx.doi.org/10.1080/2150704X.2014.969814
  #"Quantity difference is the amount of difference between the two maps that
  #derives from a less than perfect match in the amount of the categories."p.7543

  #"Quantity difference is zero if and only if the right column of marginal totals at time t
  #matches the bottom row of marginal totals at time t + 1." p.7544

  #"Exchange exists for a pair of pixels when one pixel is classified as category A in the
  #first map and as category B in the second map, while simultaneously the paired pixel is
  #classified as category B in the first map and as category A in the second map." (abstract)

  #"If there are more than two categories, then it is possible to have a component called shift,
  #which is allocation difference that is not exchange."(abstract)

  #Also see Ponitus Millones 2011 https://doi.org/10.1080/01431161.2011.552923
  #Sum of Exchange and Shift is equal to Exchange in this earlier paper

  print(diffTablej(xtab))
  print(exchangeDij(xtab))     #disaggregates Overall exchange (value from diffTablej or overallExchangeD)
  print(overallDiffCatj(xtab))  #sum of rows in diffTablej

  if(pdfprint) {
    g = list(tableGrob(xtab),
      tableGrob(round(as.data.frame(cfm$overall),3)) )
    grid.arrange(grobs=g, top=paste0(yr," Cross Tab and Error Metrics"))

    g = list( tableGrob(diffTablej(xtab)),
      tableGrob(exchangeDij(xtab)))
    grid.arrange(grobs=g, top=paste0(yr," Pontius diffTablej and its disaggregration"))
  }

}

## Proportions

#Plots are modelled proportions vs observed proportions by municiapilty. Municipality IDs of five largest outliers are shown. Red lines is a linear regression (coefficients shown in upper left).
#linear models used in plots below

#dummy to df to expand
ddf <- data_frame(
  Year = rep(calib_yrs,length.out=5),
  LC = c(1,2,3,4,5)
)

#get all combos of years and LCs (long, tidy format)
mods <- ddf %>% expand(Year, LC)

#add empty variables for coeffs of regression models
mods <- mods %>%
  mutate(a = -99) %>%
  mutate(b = -99) %>%
  mutate(r2 = -99)

#loop through years, fit models for each LC and populate mods table
for(yr in calib_yrs){

  #fit models for this year
  LC1_mod <- lm(Mod1 ~ Obs1, data = filter(cDat, Year == yr))
  LC2_mod <- lm(Mod2 ~ Obs2, data = filter(cDat, Year == yr))
  LC3_mod <- lm(Mod3 ~ Obs3, data = filter(cDat, Year == yr))
  LC4_mod <- lm(Mod4 ~ Obs4, data = filter(cDat, Year == yr))
  LC5_mod <- lm(Mod5 ~ Obs5, data = filter(cDat, Year == yr))

  #populate table with coeffs
  mods <-
    mods %>%
    mutate(a = ifelse(Year == yr & LC == 1, round(as.numeric(LC1_mod$coefficients[2]),3), a)) %>%
    mutate(b = ifelse(Year == yr & LC == 1, round(as.numeric(LC1_mod$coefficients[1]),3), b)) %>%
    mutate(r2 = ifelse(Year == yr & LC == 1, round(summary(LC1_mod)$r.squared,3), r2)) %>%
    mutate(a = ifelse(Year == yr & LC == 2, round(as.numeric(LC2_mod$coefficients[2]),3), a)) %>%
    mutate(b = ifelse(Year == yr & LC == 2, round(as.numeric(LC2_mod$coefficients[1]),3), b)) %>%
    mutate(r2 = ifelse(Year == yr & LC == 2, round(summary(LC2_mod)$r.squared,3), r2)) %>%
    mutate(a = ifelse(Year == yr & LC == 3, round(as.numeric(LC3_mod$coefficients[2]),3), a)) %>%
    mutate(b = ifelse(Year == yr & LC == 3, round(as.numeric(LC3_mod$coefficients[1]),3), b)) %>%
    mutate(r2 = ifelse(Year == yr & LC == 3, round(summary(LC3_mod)$r.squared,3), r2)) %>%
    mutate(a = ifelse(Year == yr & LC == 4, round(as.numeric(LC4_mod$coefficients[2]),3), a)) %>%
    mutate(b = ifelse(Year == yr & LC == 4, round(as.numeric(LC4_mod$coefficients[1]),3), b)) %>%
    mutate(r2 = ifelse(Year == yr & LC == 4, round(summary(LC4_mod)$r.squared,3), r2)) %>%
    mutate(a = ifelse(Year == yr & LC == 5, round(as.numeric(LC5_mod$coefficients[2]),3), a)) %>%
    mutate(b = ifelse(Year == yr & LC == 5, round(as.numeric(LC5_mod$coefficients[1]),3), b)) %>%
    mutate(r2 = ifelse(Year == yr & LC == 5, round(summary(LC5_mod)$r.squared,3), r2))
}

#convert year and LCs to factors
mods <- mods %>%
  mutate(Year = as.factor(Year)) %>%
  mutate(LC = factor(LC, labels = c("Nature", "OtherAgri", "Agri", "Other","Pasture")))

print(mods)
grid.arrange(tableGrob(mods), top="Model Parameters")

#create colours for plot
myCols <- c("forestgreen","darkcyan","wheat3","black","orange2")
names(myCols) <- c('Nature',"OtherAgri","Agri","Other","Pasture")

#barplot of r2 by year and LC
p <- ggplot(mods, aes(x = Year, y = r2, fill = LC)) +
  scale_fill_manual(name = "LC",values = myCols) +
  geom_bar(stat="identity", position='dodge') +
  ggtitle("Model Comparison")
print(p)

#add state ID
cDat <- cDat %>%
  mutate(state = (muniID %/% 100000)) %>%
  mutate(state = if_else(state == 17, "TO",
      if_else(state == 29, "BA",
      if_else(state == 31, "MG",
      if_else(state == 35, "SP",
      if_else(state == 41, "PR",
      if_else(state == 42, "SC",
      if_else(state == 43, "RS",
      if_else(state == 50, "MS",
      if_else(state == 51, "MT",
      if_else(state == 52, "GO", "NA"
      ))))))))))
    )

#timeseries plots
cDat <- cDat %>%
      mutate(Nat.Mod = round(Mod1 * cellCount,0)) %>%
      mutate(OAgri.Mod = round(Mod2 * cellCount,0)) %>%
      mutate(Agri.Mod = round(Mod3 * cellCount,0)) %>%
      mutate(Other.Mod = round(Mod4 * cellCount,0)) %>%
      mutate(Pas.Mod = round(Mod5 * cellCount,0)) %>%
      mutate(Nat.Obs = round(Obs1 * cellCount,0)) %>%
      mutate(OAgri.Obs = round(Obs2 * cellCount,0)) %>%
      mutate(Agri.Obs = round(Obs3 * cellCount,0)) %>%
      mutate(Other.Obs = round(Obs4 * cellCount,0)) %>%
      mutate(Pas.Obs = round(Obs5 * cellCount,0))

#long version
cDat_long_mod <- cDat %>%
  dplyr::select(Year, state:Pas.Mod) %>%
  gather(key = LC, value = cells, -Year, -state) %>%
  group_by(Year,LC) %>%
  summarise_at(vars(matches("cells")),sum) %>%
  mutate(source = "Mod")

cDat_long_obs<- cDat %>%
  dplyr::select(Year, state, Nat.Obs:Pas.Obs) %>%
  gather(key = LC, value = cells, -Year, -state) %>%
  group_by(Year,LC) %>%
  summarise_at(vars(matches("cells")),sum) %>%
  mutate(source = "Obs")

cDat_long <- bind_rows(cDat_long_mod, cDat_long_obs)

cDat_long <- cDat_long %>%
  mutate(LC =
    if_else(LC == "Nat.Mod" | LC == "Nat.Obs", "Nature",
    if_else(LC == "OAgri.Mod" | LC == "OAgri.Obs", "OtherAgri",
    if_else(LC == "Agri.Mod" | LC == "Agri.Obs", "Agri",
    if_else(LC == "Other.Mod" | LC == "Other.Obs", "Other",
      "Pasture")))))

#mutate(LC = as.factor(LC), source = as.factor(source))

c <- cDat_long %>%
  ggplot(aes(x = Year, y = cells, color = LC, linetype = source)) +
  geom_line(size = 1) +
  scale_colour_manual(name = "LC",values = myCols) +
  scale_y_continuous(name = "Cells", labels = scales::comma) +
  ggtitle("CRAFTY Output")
print(c)

#scatter plots of observed vs 'modelled' proportion of muni LC
theme_set(theme_gray(base_size = 18))

##filter cDat by calib_yrs
cDat <- filter(cDat, Year %in% calib_yrs)

#facet plot by year for LC1
p <- ggplot(cDat, aes(x=Obs1, y=Mod1)) +
  geom_point() +
  xlab("Observed") +
  ylab("Modelled") +
  ggtitle("Nature")  +
  geom_abline(intercept = 0, slope = 1, color = "red") +   #add 45 degree line (perfect prediction)
  facet_grid(.~ Year)
print(p)

#facet plot by year for LC2
p <- ggplot(cDat, aes(x=Obs2, y=Mod2)) +
  geom_point() +
  xlab("Observed") +
  ylab("Modelled") +
  ggtitle("OtherAgri")  +
  geom_abline(intercept = 0, slope = 1, color = "red") +  #add 45 degree line (perfect prediction)
  facet_grid(.~ Year)
print(p)

#facet plot by year for LC3
p <- ggplot(cDat, aes(x=Obs3, y=Mod3)) +
  geom_point() +
  xlab("Observed") +
  ylab("Modelled") +
  ggtitle("Agriculture")  +
  geom_abline(intercept = 0, slope = 1, color = "red")+   #add 45 degree line (perfect prediction)
  facet_grid(.~ Year)
print(p)

#facet plot by year for LC4
p <- ggplot(cDat, aes(x=Obs4, y=Mod4)) +
  geom_point() +
  xlab("Observed") +
  ylab("Modelled") +
  ggtitle("Other")  +
  geom_abline(intercept = 0, slope = 1, color = "red") +   #add 45 degree line (perfect prediction)
  facet_grid(.~ Year)
print(p)

#facet plot by year for LC5
p <- ggplot(cDat, aes(x=Obs5, y=Mod5)) +
  geom_point() +
  xlab("Observed") +
  ylab("Modelled") +
  ggtitle("Pasture")  +
  geom_abline(intercept = 0, slope = 1, color = "red") +   #add 45 degree line (perfect prediction)
  facet_grid(.~ Year)
print(p)

if(pdfprint) {
  dev.off()
}


install.packages("readr")
install.packages("dplyr")
install.packages("gmodels")
install.packages("MASS")
install.packages("graphics")
install.packages("ggplot2")
install.packages("psych")
install.packages("ppcor")
install.packages("moonbook")
install.packages("reshape")
install.packages("lsmeans")
library(readr)
library(dplyr)
library(gmodels)
library(MASS)
require(graphics)
require(car)
library(ggplot2)
library(psych)
library(ppcor)
require(moonBook)
library(reshape)
library(lsmeans)
##데이터 불러오기
kosisdata <- read.csv("mean_kosis.csv")
head(kosisdata)
farmer <- read.csv("farmer_av.csv")
data<- merge(kosisdata,farmer,by="loc")
nrow(data)
head(data)
##컬럼 선택 (loc,mean_고령인구비율,mean_순이동인,mean_인구증가율,mean_전입인구,mean_전출인구,mean_합계출산율 제외)
sel.data<-data[,-1]
sel.data<-sel.data[,-3]
colnames(sel.data)
sel.data<-sel.data[,-8]
head(sel.data)
sel.data<-sel.data[,-16]
sel.data<-sel.data[,-c(17:18)]
colnames(sel.data)
sel.data<-sel.data[,-20]
colnames(sel.data)
sel.data<-sel.data[,-c(20:24)]## 년도별 귀농인구수 제외
sel.data<-sel.data[,-8]
sel.data<-sel.data[,-17]
colnames(sel.data)

sel.data <- sel.data%>%
  mutate(value4 = (0.75*mean_X119안전센터.1개센터당.담당주민수 ) + (0.59*mean_EQ.5D지표)+(0.5*mean_소방공무원.1인당.담당주민수))
colnames(sel.data)
sel.data <- sel.data%>%
  mutate(value3 = (0.58*mean_도로포장률 ) + (0.58*mean_상수도보급률)+(0.71*mean_하수도보급률))
sel.data <- sel.data%>%
  mutate(value2 = (0.81*mean_인구.천명당.의료기관병상수 ) + (0.96*mean_인구.천명당.의료기관종사의사수))
sel.data <- sel.data%>%
  mutate(value1 = (0.48*mean_구조.구급대원.1인당.담당주민수 ) - (0.43*mean_노인.천명당.노인여가복지시설수)+(0.44*mean_유아.천명당.보육시설수)+(0.91*mean_유치원수)-(0.52*mean_인구.십만명당.문화기반시설수)+(0.61*mean_인구.천명당.사설학원수)+(0.97*mean_초등학교수))
sel.data1 <- sel.data[,18:22]

fit.red1 <-  lm(value1 ~mean_구조.구급대원.1인당.담당주민수+mean_유아.천명당.보육시설수+mean_유치원수+mean_인구.천명당.사설학원수+mean_초등학교수-mean_노인.천명당.노인여가복지시설수-mean_인구.십만명당.문화기반시설수, data = sel.data)
summary(fit.red1)
fit.red2 <-  lm(value2 ~mean_인구.천명당.의료기관병상수+mean_인구.천명당.의료기관종사의사수, data = sel.data)
summary(fit.red2)
fit.red3 <-  lm(value3 ~mean_도로포장률+mean_상수도보급률+mean_하수도보급률, data = sel.data)
summary(fit.red3)
fit.red4 <-  lm(value4 ~mean_X119안전센터.1개센터당.담당주민수+mean_EQ.5D지표+mean_소방공무원.1인당.담당주민수, data = sel.data)
summary(fit.red4)

##omit으로 NA값 삭제
head(sel.data1)
omit.data<- na.omit(sel.data1)
##전체 다중회귀
fit.red1 <-  lm(avReFarmer ~., data = omit.data)
summary(fit.red1)

##후진제거법
reduced.model=step(fit.red1,direction ="backward" )

summary(reduced.model)

par(mfrow=c(2,2))
plot(fit.red1)

#회귀가정 확인
#install.packages("gvlma")
library(gvlma)
gvmodel <- gvlma(reduced.model)
summary(gvmodel)
##다중공선성 확인
#install.packages("car")
library(car)
vif(reduced.model)
sqrt(vif(reduced.model))>2

##후진제거법 후에 나온 변수 전체 회귀
fit.red1 <-  lm(avReFarmer ~mean_도로포장률+mean_상수도보급률+mean_하수도보급률+mean_구조.구급대원.1인당.담당주민수+mean_유아.천명당.보육시설수+mean_유치원수+mean_인구.천명당.사설학원수+mean_초등학교수-mean_노인.천명당.노인여가복지시설수-mean_인구.십만명당.문화기반시설수, data = sel.data)
summary(fit.red1)

##후진제거법 후에 유의미한 변수 회귀
fit.red2 <-  lm(avReFarmer~mean_상수도보급률+mean_유치원수+mean_인구.천명당.사설학원수, data = sel.data)
summary(fit.red2)

#install.packages("leaps")
require(leaps)
leaps <- regsubsets(avReFarmer ~mean_상수도보급률+mean_소방공무원.1인당.담당주민수 +mean_유치원수+mean_인구.천명당.사설학원수, data = sel.data ,nbest = 8)
plot(leaps,scale="adjr2")

##두 모델의 차이 없음
anova(fit.red1,fit.red2)

##최종모델
fit.red2 <-  lm(avReFarmer~mean_상수도보급률+mean_유치원수+mean_인구.천명당.사설학원수, data = sel.data)
summary(fit.red2)

city.data <- kosisdata%>%
  mutate(value3 = (0.58*mean_도로포장률 ) + (0.58*mean_상수도보급률)+(0.71*mean_하수도보급률))
city.data <- city.data%>%
  mutate(value1 = (0.48*mean_구조.구급대원.1인당.담당주민수 ) - (0.43*mean_노인.천명당.노인여가복지시설수)+(0.44*mean_유아.천명당.보육시설수)+(0.91*mean_유치원수)-(0.52*mean_인구.십만명당.문화기반시설수)+(0.61*mean_인구.천명당.사설학원수)+(0.97*mean_초등학교수))

#상위 5개 도시
top.data <- city.data %>%
  filter(loc == "양평군" | loc == "밀양시" | loc == "창녕군" | loc == "고흥군" |loc == "영천시" )
top <- top.data[,2:28]

top <- colMeans(top,na.rm = TRUE)
top <- data.frame(top)
top <- t(top)

#하위 5개 도시

bot.data <- city.data %>%
  filter(loc == "고령군" |loc == "철원군" |loc == "울진군" |loc == "삼척시" |loc == "증평군")
bot <- bot.data[,2:28]

bot <- colMeans(bot,na.rm = TRUE)
bot <- data.frame(bot)
bot <- t(bot)

#합천
hap.data <- city.data %>%
  filter(loc == "합천군" )

hap <- hap.data[,2:28]

hap <- colMeans(hap,na.rm = TRUE)

hap <- data.frame(hap)
hap <- t(hap)

total <- rbind(top,bot)

total <- rbind(total,hap)


# admin-polys-simplify.r
# andy south 2/3/2019

# script to create faster admin polygons file for malaria atlas project shiny viewer

# create one polygons object that has both admin0 and admin1 boundaries in it.
# make district lookups simpler with consistent codes
# save as an R object rather than a shapefile for faster loading
# move to using package sf the modern replacement for sp that makes looking at polygon attributes easier.
# simplify polygons so object is smaller and display is faster, country maps look cleaner (polygon detail not needed)

# get iso country ids for africa from existing shapefile (then it may not be needed further)
# this could be replaced by a different method
library(raster)
admin_1 <- raster::shapefile('data/districts/admin_1.shp')
country_ids <- unique(admin_1$COUNTRY_ID)

# get polygons for admin0 and admin1 from as a spatialpolygonsdataframe
admin_0 <- raster::shapefile('data/countries/admin2013_0.shp')
admin_0 <- admin_0[admin_0$COUNTRY_ID %in% country_ids, ]

# convert to sf
library(sf)
admin_1 <- admin_1[c(2:5, 1)]
names(admin_1) <- c("COUNTRY_ID",
                    "GAUL_CODE",
                    "ADMN_LEVEL",
                    "PARENT_ID",
                    "name")
combined <- rbind(admin_1, admin_0)
sf_africa <- sf::st_as_sf(combined)

# get rid of dodgy countrycodes
sf_africa <- sf_africa[sf_africa$country_id != 'XXX',]
# save as an R object that we can then read into the shiny app
# save(sf_africa, file='test.rda')
# then to plot the countries or districts just subset by admn_level
# ad0ago <- sf_africa[sf_africa$admn_level==0 & sf_africa$country_id=='AGO',]
# st_geometry needed to plot just the polygons
# plot(sf::st_geometry(ad0ago))

# sf_africa has spain in too !
# plot(sf::st_geometry(sf_africa))

#library(mapview)
#mapview(sf_africa)

#and has much more detail than we need e.g. fiddly islands.

#remove spain
sf_africa <- sf_africa[sf_africa$COUNTRY_ID!='ESP',]

# simplify
library(rmapshaper)
#default keeps 0.05 of points keep=0.05
#keep all polygons keep_shapes=TRUE
sf_afr_simp <- rmapshaper::ms_simplify(sf_africa, keep_shapes=TRUE)

save(sf_afr_simp, file='data/sf_afr_simp_fao.rda')

# to load
load('data/sf_afr_simp_fao.rda')

library(mapview)
mapview(sf_afr_simp, zcol='COUNTRY_ID', legend=FALSE)

ggplot(sf_afr_simp) +
geom_sf(aes(fill=COUNTRY_ID))

# subset by country and then plot coloured named districts

#shorter name
sfafsi <- sf_afr_simp

#subset districts for one country
sfago <- sfafsi[sfafsi$admn_level==1 & sfafsi$country_id=='AGO',]

#datum=na needed to remove gridlines now, may not be in future

ggplot(sfago) +
geom_sf(aes(fill=name)) +
coord_sf(datum = NA) +
theme_void()

# if I wanted to add district labels
ggplot(sfafsi) +
geom_sf() +
geom_text_repel(aes(x=X, y=Y, label=name))


setwd("/home/eric/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/")

file <- "tab2018ayca.csv"
d <- read.csv(file = file, stringsAsFactors = FALSE, fileEncoding="utf-8")

d[1,]
str(d)
colnames(d)

# make numeric
sel <- grep("v[.]*|nr|nul", colnames(d))
sel <- c(17:33,36)
v <- d[,sel]
v[1,]
for (i in 1:ncol(v)){
    v[,i] <- as.numeric(v[,i])
}
v[is.na(v)] <- 0
d[,sel] <- v

head(d)
str(d)
colnames(d)

# consolidate mun votes
for (i in sel){
    d[,i] <- ave(d[,i], as.factor(d$MUNICIPIO), FUN=sum, na.rm=TRUE)
}

head(d)

# drop redundant obs
d <- d[duplicated(d$ID_MUNICIPIO)==FALSE,]

colnames(d)
sel <- c(5:6,17:33,36)
d <- d[,sel]

data.frame(d$mun)

d$seccion <- NULL
d$casilla <- NULL
d$tipo <- NULL
d$ext <- NULL

colnames(d)
head(d)

file2 <- "tab2018aymu.csv"
write.csv(d, file = file2, row.names = FALSE)

# re-read after hand cleaning
d <- read.csv(file = file2, stringsAsFactors = FALSE)

head(d)
colnames(d)

# pick cols with coalitions
v <- d[,c(18:28)]

sel <- which(v$pri.pvem.panal.pd>0)
v[sel,][1,]

v[sel,1] <- rowSums(v[sel,])
v[sel,2:ncol(v)] <- 0

sel <- which(v$pri.pvem.panal.pd==0)
v[sel,]

d[sel, c(18:28)] <- v[sel,]

d <- d[,-c(19:28)]

head(d)
colnames(d)

l <- colnames(d)[5:19]
l2 <- data.frame(matrix(rep(l, nrow(d)), ncol = length(l), nrow = nrow(d), byrow = TRUE))
for (i in 1:ncol(l2)){
    l2[,i] <- gsub("[.]", "-", l2[,i])
}

n <- c(paste("l0", 1:9, sep = ""), paste("l", 10:15, sep = ""))

colnames(l2) <- n

l2

d <- cbind(d, l2)

colnames(d)

n <- c(paste("v0", 1:9, sep = ""), paste("v", 10:15, sep = ""))

colnames(d)[5:19] <- n

d <- d[, c("Municipio", "disn", "lisnom", "v01","l01", "v02","l02", "v03","l03", "v04","l04", "v05","l05", "v06","l06", "v07","l07", "v08","l08", "v09","l09", "v10","l10", "v11","l11", "v12","l12", "v13","l13", "v14","l14", "v15","l15", "nul","Total")]

write.csv(d, file = file2, row.names = FALSE)


library(ROCR)
data=read.table(file="Human_train.dat",header=T,sep="\t")
attach(data)
names(data)

#total 20000
d1 =seq(1,2000)
d2 =seq(2001,4000)
d3 = seq(4001,6000)
d4 = seq(6001,8000)
d5 = seq(8001,10000)
d6 = seq(10001,12000)
d7 = seq(12001,14000)
d8 = seq(14001,16000)
d9 = seq(16001,18000)
d10 = seq(18001,20000)

#d1
vlabel = Label[-d1]
vmrna = mRNA[-d1]
vorf = ORF[-d1]
vfickett = Fickett[-d1]
vhexamer = Hexamer[-d1]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d1], vorf = ORF[d1],vfickett = Fickett[d1], vhexamer = Hexamer[d1], vlabel=Label[d1])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test1.xls",quote=F,sep="\t",row.names=ID[d1])

#d2
vlabel = Label[-d2]
vmrna = mRNA[-d2]
vorf = ORF[-d2]
vfickett = Fickett[-d2]
vhexamer = Hexamer[-d2]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d2], vorf = ORF[d2],vfickett = Fickett[d2], vhexamer = Hexamer[d2], vlabel=Label[d2])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test2.xls",quote=F,sep="\t",row.names=ID[d2])

#d3
vlabel = Label[-d3]
vmrna = mRNA[-d3]
vorf = ORF[-d3]
vfickett = Fickett[-d3]
vhexamer = Hexamer[-d3]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d3], vorf = ORF[d3],vfickett = Fickett[d3], vhexamer = Hexamer[d3], vlabel=Label[d3])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test3.xls",quote=F,sep="\t",row.names=ID[d3])

#d4
vlabel = Label[-d4]
vmrna = mRNA[-d4]
vorf = ORF[-d4]
vfickett = Fickett[-d4]
vhexamer = Hexamer[-d4]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d4], vorf = ORF[d4],vfickett = Fickett[d4], vhexamer = Hexamer[d4], vlabel=Label[d4])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test4.xls",quote=F,sep="\t",row.names=ID[d4])

#d5
vlabel = Label[-d5]
vmrna = mRNA[-d5]
vorf = ORF[-d5]
vfickett = Fickett[-d5]
vhexamer = Hexamer[-d5]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d5], vorf = ORF[d5],vfickett = Fickett[d5], vhexamer = Hexamer[d5], vlabel=Label[d5])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test5.xls",quote=F,sep="\t",row.names=ID[d5])

#d6
vlabel = Label[-d6]
vmrna = mRNA[-d6]
vorf = ORF[-d6]
vfickett = Fickett[-d6]
vhexamer = Hexamer[-d6]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d6], vorf = ORF[d6],vfickett = Fickett[d6], vhexamer = Hexamer[d6], vlabel=Label[d6])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test6.xls",quote=F,sep="\t",row.names=ID[d6])

#d7
vlabel = Label[-d7]
vmrna = mRNA[-d7]
vorf = ORF[-d7]
vfickett = Fickett[-d7]
vhexamer = Hexamer[-d7]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d7], vorf = ORF[d7],vfickett = Fickett[d7], vhexamer = Hexamer[d7], vlabel=Label[d7])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test7.xls",quote=F,sep="\t",row.names=ID[d7])

#d8
vlabel = Label[-d8]
vmrna = mRNA[-d8]
vorf = ORF[-d8]
vfickett = Fickett[-d8]
vhexamer = Hexamer[-d8]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d8], vorf = ORF[d8],vfickett = Fickett[d8], vhexamer = Hexamer[d8], vlabel=Label[d8])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test8.xls",quote=F,sep="\t",row.names=ID[d8])

#d9
vlabel = Label[-d9]
vmrna = mRNA[-d9]
vorf = ORF[-d9]
vfickett = Fickett[-d9]
vhexamer = Hexamer[-d9]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d9], vorf = ORF[d9],vfickett = Fickett[d9], vhexamer = Hexamer[d9], vlabel=Label[d9])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test9.xls",quote=F,sep="\t",row.names=ID[d9])

#d10
vlabel = Label[-d10]
vmrna = mRNA[-d10]
vorf = ORF[-d10]
vfickett = Fickett[-d10]
vhexamer = Hexamer[-d10]

mylogit <- glm(vlabel ~ vmrna + vorf + vfickett + vhexamer, family=binomial(link="logit"), na.action=na.pass)
test <- data.frame(vmrna = mRNA[d10], vorf = ORF[d10],vfickett = Fickett[d10], vhexamer = Hexamer[d10], vlabel=Label[d10])
test$prob <- predict(mylogit,newdata=test,type="response")
output = cbind("mRNA"=test$vmrna, "ORF"=test$vorf, "Fickett"=test$vfickett, "Hexamer" = test$vhexamer, "Label"=test$vlabel,"Prob"=test$prob)
write.table(output,file="test10.xls",quote=F,sep="\t",row.names=ID[d10])

#ROC
test1=read.table(file="test1.xls",header=T,sep="\t")
test2=read.table(file="test2.xls",header=T,sep="\t")
test3=read.table(file="test3.xls",header=T,sep="\t")
test4=read.table(file="test4.xls",header=T,sep="\t")
test5=read.table(file="test5.xls",header=T,sep="\t")
test6=read.table(file="test6.xls",header=T,sep="\t")
test7=read.table(file="test7.xls",header=T,sep="\t")
test8=read.table(file="test8.xls",header=T,sep="\t")
test9=read.table(file="test9.xls",header=T,sep="\t")
test10=read.table(file="test10.xls",header=T,sep="\t")

Response = list(test1$Prob,test2$Prob,test3$Prob,test4$Prob,test5$Prob,test6$Prob,test7$Prob,test8$Prob,test9$Prob,test10$Prob)
Labls = list(test1$Label,test2$Label,test3$Label,test4$Label,test5$Label,test6$Label,test7$Label,test8$Label,test9$Label,test10$Label)
ROCR_data = list(predictions=Response,Labels=Labls)
pred <- prediction(ROCR_data$predictions, ROCR_data$Labels)
#perf <- performance(pred,"auc")
#avergae AUC = 0.9927

pdf("Figure_3.pdf")
par(mfrow=c(2,2),mar=c(5,4,2,2),cex.axis=1.2, cex.lab=1.2)
#ROC curve
#pdf("Human_10fold.ROC.pdf")
perf <- performance(pred,"tpr","fpr")
plot(perf,col="blue",lty=3,xlab="1-Specificity",ylab="Sensitivity",ylim=c(0.7,1),xlim=c(0,0.3),main="",cex.axis=1.5,cex.label=1.5)	#AUC = 0.9927
plot(perf,lwd=2,avg="vertical",add=TRUE,col="red",xlab="1-specificity",ylab="sensitivity",main="",cex.axis=1.2,cex.label=1.2)
abline(v=0,lty="dashed",lwd=0.5)
abline(h=1.0,lty="dashed",lwd=0.5)
abline(v=0.05,lty="dashed",lwd=0.5)
abline(h=0.95,lty="dashed",lwd=0.5)
#dev.off()

#precision
#pdf("Human_10fold.precision_vs_recall.pdf")
d=performance(pred,measure="prec", x.measure="rec")
plot(d,col="blue",lty=3,xlab="Recall (TPR)",ylab="Precision (PPV)",xlim=c(0.7,1),ylim=c(0.7,1),cex.axis=1.2,cex.label=1.2)
plot(d,lwd=2,avg="vertical",col="red",xlab="Recall (TPR)",ylab="Precision (PPV)",add=T,cex.axis=1.2,cex.label=1.2)
abline(v=1.0,lty="dashed",lwd=0.5)
abline(h=1.0,lty="dashed",lwd=0.5)
abline(v=0.95,lty="dashed",lwd=0.5)
abline(h=0.95,lty="dashed",lwd=0.5)
#dev.off()

#Accuracy
#pdf("Human_10fold.Accuracy.pdf")
perf <- performance(pred,"acc")
plot(perf,col="blue",lty=3,xlab="Coding probability cutoff",ylab="Accuracy",ylim=c(0.7,1),cex.axis=1.2,cex.label=1.2)
plot(perf,lwd=2,avg="vertical",add=TRUE,col="red",cex.axis=1.2,cex.label=1.2)
abline(h=1,lty="dashed",lwd=0.5)
abline(h=0.95,lty="dashed",lwd=0.5)
#dev.off()

#sensitivity vs specificity
pred <- prediction(ROCR_data$predictions, ROCR_data$Labels)
S <- performance(pred,measure="sens")
P <- performance(pred,measure="spec")
#pdf("Human_10fold_sens_vs_spec.pdf")
plot(S,col="blue",lty=3,ylab="Performance",xlab="Coding Probability Cutoff",ylim=c(0.8,1),cex.axis=1.2,cex.label=1.2)
plot(S,lwd=2,avg="vertical",add=TRUE,col="blue")
plot(P,col="red",lty=3, add=TRUE,)
plot(P,lwd=2,avg="vertical",add=TRUE,col="red")
abline(h=0.966,lty="dashed",lwd=0.5)
abline(v=0.364,lty="dashed",lwd=0.5)
legend(0.4,0.85,col=c("blue","red"),lwd=2,legend=c("Sensitivity","Specificity"))
dev.off()


#' @title matrixBubbles
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export

matrixBubbles <- function (dmat,xr,yr,ttl,xlab,ylab,maxinch,colors,zeroflag=T,yc.colors=F,ch.col = c("rainbow(nx,alpha=0.5)", "heat.colors(nx,alpha=0.5)","terrain.colors(nx,alpha=0.5)",
 "topo.colors(nx,alpha=0.5)","cm.colors(nx,alpha=0.5)"),xlabs = seq(1970,2015,by=5)){
	nx = length(xr)
	ny= length(yr)
	npts = nx * ny
	dmat <- as.matrix(dmat)
	io = which(dmat>quantile(dmat,0.99)) #prune the largest samples to a smaller size i.e. max bubbles are the lowest 99%

	dmat[io] <- quantile(dmat,0.99)
	if(length(dmat) != npts) return("length error")
	mat3 = matrix(0,nrow = npts,ncol = 4)
	sca = maxinch/max(abs(dmat))
	if(yc.colors) {
		v<-eval(parse(text=ch.col))
		mat<-matrix(v,nrow=ny,ncol=nx,T)
		for( i in 2:ny){
		mat[i,]<-c(mat[i-1,nx],mat[i-1,-nx])
		}
	col.vec=as.vector((mat))
	k = 0
	for(i in 1:nx){
		for(j in 1:ny){
			k = k + 1
			mat3[k,] = c(xr[i],yr[j],dmat[j,i]/sca,col.vec[k])
		}
	    plot(1,1,type='n',xlim=c(0.5,nx+0.5),ylim=c(0.5,ny+0.5),xlab = xlab,ylab = ylab,xaxt='n')
		    imask = mat3[,3] > 0
	symbols(mat3[imask,1],mat3[imask,2], circles = mat3[imask,3],xlab = xlab,ylab = ylab,add=T,main = ttl,inches = maxinch,bg=mat3[imask,4])
	negmask = !imask
	negz= abs(as.numeric(mat3[negmask,3]))
	symbols(mat3[negmask,1],mat3[negmask,2], circles = negz,add = TRUE,inches = maxinch,bg=mat3[negmask,4])
	if(zeroflag) {
		zmask = mat3[,3] == 0
		points(mat3[zmask,1],mat3[zmask,2], pch = 3,col=2,cex = 0.5,lwd = 1)
		}
		}
		mu = (xlabs[2]-xlabs[1])
	axis(side=1,labels=xlabs,at=seq(1,(length(xlabs)*mu),by=mu))
		}
		if(yc.colors==FALSE) {
	colors <- rgb(t(col2rgb(colors)),maxColorValue=255,alpha=125)
    imask = mat3[,3] > 0
    plot(1,1,type='n',xlim=c(1,(nx)),ylim=c(1,ny))
	symbols(mat3[imask,1],mat3[imask,2], circles = mat3[imask,3],xlab = xlab,ylab = ylab,main = ttl,inches = maxinch,bg=colors[1])
	negmask = !imask
	negz= abs(mat3[negmask,3])
	symbols(mat3[negmask,1],mat3[negmask,2], circles = negz,add = TRUE,inches = maxinch,bg=colors[2])
	if(zeroflag) {
		zmask = mat3[,3] == 0
		points(mat3[zmask,1],mat3[zmask,2], pch = 3,col=2,cex = 0.5,lwd = 1)
		}
		}
}

#xx = matrix(sample(100,48),nrow = 8)
#xy =  xx - 50
#xy[5:7,1:3] = 0
#myBubbles(dmat=xy,xr = 1:6,yr=1:8,ttl="ttl",xlab="XX",ylab="YY",maxinch = .4,yc.colors=F,colors = c("green","blue"),zeroflag = TRUE,ch.col="rainbow(nx)")


require(beanplot)
require('KernSmooth')
require('MASS')

# require(simecol)
# require(retimes)
# require(modeest)

RTbw = 25

# bhvdir = '/SCRATCH/BHV_files'
#
# bhvfl = 'I_34_change_release_2014_06_02.dat'
# bhvfl = 'I_34_chng_rel_2014_06_03.dat'
# bhvfl = 'I_34_chng_rel_2014_06_04.dat'
# bhvfl = 'I_34_dimming_2014_06_05.dat'
# bhvfl = 'I_34_dimming_2014_06_06.dat'

fname  = file.choose()
bhvfl  = basename(fname)
bhvdir =  dirname(fname)

setwd(bhvdir)

dt=read.table(bhvfl, header=TRUE)

chngtime =  dt$GoEff    - dt$NoGoEff
reltime  =  dt$TPullEff - dt$NoGoEff
sesstime = (dt$NoGoEff - dt$NoGoEff[1])/60000

relpos   = is.finite(reltime);
hitpos   = dt$Result == 0 & relpos   == 1;
earlypos = dt$Result == 5 & relpos   == 1;
latepos  = dt$Result == 2 & relpos   == 1;
resppos  = hitpos    == 1 | earlypos == 1 | latepos == 1

resnm = rep(NA, length(resppos))
resnm[hitpos]   = 'accept'
resnm[earlypos] = 'early'
resnm[latepos]  = 'late'

relall   = density(reltime[resppos],         bw=RTbw, from=0, cut=0, na.rm=TRUE)
relhit   = density(reltime[hitpos],          bw=RTbw, from=0, cut=0, na.rm=TRUE)
relearly = density(reltime[earlypos],        bw=RTbw, from=0, cut=0, na.rm=TRUE)
rellate  = density(reltime[latepos],         bw=RTbw, from=0, cut=0, na.rm=TRUE)
RThit    = density(dt$RT[hitpos],            bw=RTbw, from=0, cut=0, na.rm=TRUE)
RTlate   = density(dt$RelTime[latepos],      bw=RTbw, from=0, cut=0, na.rm=TRUE)
ChngTime = density(dt$ChangeIntent[resppos], bw=RTbw, from=0, cut=0, na.rm=TRUE)

relall$y   = relall$y   * sum(relpos)   * RTbw
relhit$y   = relhit$y   * sum(hitpos)   * RTbw
relearly$y = relearly$y * sum(earlypos) * RTbw
rellate$y  = rellate$y  * sum(latepos)  * RTbw
ChngTime$y = ChngTime$y * sum(resppos)  * RTbw

RThit$y  = RThit$y  * sum(hitpos)  * RTbw
RTlate$y = RTlate$y * sum(latepos) * RTbw

# create conditions according to dimming time
#dimmitv = seq(min(dt$ChangeIntent, na.rm=TRUE), max(dt$ChangeIntent, na.rm=TRUE), length=6)
dimmitv = quantile(dt$ChangeIntent[resppos], probs = seq(0, 1, 0.2))
DimmCnd = rep(1, length(dt$ChangeIntent))

for(i in seq(length(dimmitv)-1)){
 pos = dt$ChangeIntent > dimmitv[i]
 DimmCnd[pos] = i;
}

### start plots
x11(width=12, height=10, pointsize=16)

#layout(matrix(c(1, 3, 7, 9, 2, 4, 7, 10, 5, 5, 5, 11, 6, 6, 6, 12, 8, 8, 8, 13), 5, 4, byrow = TRUE))
layout(matrix(c(1, 3, 7,  2, 4, 7, 5, 5, 5, 6, 6, 6, 8, 8, 8), 5, 3, byrow = TRUE))
par(mar = c(2.5, 2.5, 1.5, 0.5))
par(mgp = c(1.5, 0.5, 0))
par(oma = c(0, 0, 3, 0))

### distribution of release times
maxY = max(c(relhit$y, rellate$y , RThit$y, relearly$y,ChngTime$y))
maxX = max(c(relhit$x, RThit$x, relearly$x, rellate$x,ChngTime$x ))
plot(relhit, xlim=c(0, maxX), ylim = c(0, maxY), col = 'red', main = 'Release Time', xlab='trial time [ms]', lwd=2.5, cex=1.5, xaxs='i', yaxs='i')
#lines(relhit, col='red', lwd=2.5)
lines(relearly, col='green', lwd=2.5)
lines(rellate, col='blue', lwd=2.5)
lines(ChngTime, col='black', lwd=1)

abline(v=dimmitv, lty=2, col='black')

legend("topright", c('hit','early','late','change'), pch = 15, col = c('red','green','blue','black'),ncol=1,bty='n',cex=1.2)

### RT distribution
max_X = max(c(tail(RThit$x, n=1), tail(RTlate$x, n=1)))
max_Y = max(c(max(RThit$y), max(RTlate$y)))

truehist(dt$RT, h=RTbw, col='darkgrey', main='Reaction Time', xlab='RT [ms]', ylab='count', prob=FALSE, xlim=c(0, max_X), xaxs='i', yaxs='i')
lines(RThit,  lwd=2.5, col='red')
lines(RTlate, lwd=2.5, col='blue')
abline(v=median(dt$RT, na.rm=TRUE), col='red', lwd=2.5)

text(max_X, max_Y/2,pos=2,adj=0,labels=paste('N(hit): ',sum(hitpos),'\n','N(early): ',sum(earlypos),'\n','N(late): ',sum(latepos),'\n',sep=''),cex=1.2)

## RT for dimming intervals
# beanplot(dt$RT[hitpos]~DimmCnd[hitpos], beanlines='median', overallline='median', b w=RTbw, col='darkgrey', main='Reaction Times', xlab='dimming interval', ylab='RT [ms]', yaxs='i')
boxplot(dt$RT[hitpos]~DimmCnd[hitpos], notch=TRUE, outline=FALSE, col='darkgrey', main='Reaction Times', xlab='dimming interval', ylab='RT [ms]', yaxs='i', ylim=range(dt$RT[hitpos], na.rm=TRUE))
stripchart(dt$RT[hitpos]~DimmCnd[hitpos], method = "jitter", jitter = 0.1, vertical =TRUE, add=TRUE, pch=20, cex=0.8)
abline(h=median(dt$RT[hitpos]), lty=2, lwd=2, col='red')

### performance for dimming intervals
barplot(100 * prop.table(table(resnm[resppos], DimmCnd[resppos]), margin=2), beside=T, space=c(0, 0.4), col=c('red', 'green', 'blue'), ylab='rate [%]', xlab='dimming interval', main='Performance', yaxs='i')

### session time course of release times
rngX = range(sesstime[resppos], na.rm=TRUE)
rngY = range(reltime[resppos],  na.rm=TRUE)

plot(sesstime[hitpos], reltime[hitpos], type='p', pch=20, ylab='release time [ms]', xlab='session time [min]', main='Release times', col='red', xaxs='i', yaxs='i', xlim=rngX, ylim=rngY)

points(sesstime[earlypos], reltime[earlypos], pch=20, col='green')
points(sesstime[latepos],  reltime[latepos],  pch=20, col='blue')

### session time course of reaction times
plot(sesstime[hitpos], dt$RT[hitpos], type='p', pch=20, ylab='RT [ms]', xlab='session time [min]', main='reaction times', xaxs='i', yaxs='i', xlim=rngX)
abline(h=median(dt$RT, na.rm=TRUE), col='red', lwd=2.,lty=2)

### release times dependent on dimming time
rngX = range(dt$ChangeIntent[resppos], na.rm=TRUE)
# rngY = range(reltime[resppos], na.rm=TRUE)

plot(dt$ChangeIntent[hitpos], reltime[hitpos], type='p', pch=20, ylab='release time [ms]', xlab='change time [ms]', main='Release times', col='red', xaxs='i', yaxs='i', xlim=rngX, ylim=rngY)
points(dt$ChangeIntent[earlypos], reltime[earlypos], pch=20, col='green')
points(dt$ChangeIntent[latepos], reltime[latepos], pch=20, col='blue')

abline(a=0, b=1, , lty=3, lwd=2)

# performance
rngX = range(sesstime[resppos], na.rm=TRUE)

tpos = hitpos + earlypos + latepos

winwd = 5;
avrgvec = seq(winwd/2,max(sesstime)-winwd/2,by=0.5)

lateperf = earlyperf = hitperf = rep(0,length(avrgvec))

for(i in 1:length(avrgvec)){
    ctm = avrgvec[i]
    cpos = sesstime > ctm-winwd/2 & sesstime < ctm+winwd/2

    tcnt = sum(tpos[cpos])
    if(tcnt>0){
        hitperf[i] = 100 * (sum(hitpos[cpos])/tcnt)
        lateperf[i] = 100 * (sum(latepos[cpos])/tcnt)
        earlyperf[i] = 100 * (sum(earlypos[cpos])/tcnt)
    }
}

plot(avrgvec,hitperf, col='red',xaxs='i', yaxs='i', xlim=rngX, ylim=c(0,100), type='l',lwd=2.5, ylab='performance [%]', xlab='session time [min]')
lines(avrgvec,earlyperf,col='green',lwd=1.5)
lines(avrgvec,lateperf,col='blue',lwd=1.5)
abline(h=50,lty=1)
abline(h=c(25,75),lty=2)

### figure title
mtext(paste(dt$Subject[1], " - Performance Summary from ", dt$Date[1], sep=''), outer = TRUE, side = 3, cex = 1.2, line = 1)

### save figure as image file
dev.copy(png,filename=paste(dt$Subject[1], '_',dt$Experiment[1],"_", dt$Date[1],'.png', sep=''),height=800, width=1200, bg="white")
dev.off()


pdf_file<-"pdf/maps_germany_cities_3d_90_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=13,height=11)

par(omi=c(0.5,0,0.25,0.25),mai=c(0,0,0,0),lend=2,family="Lato Light",las=1)
library(scatterplot3d)
library(mapdata)

# Import data

dt.map<-map("worldHires","Germany",plot=F)
dt.map2<-map("rivers",plot=F,add=T)
data(world.cities)
Germany<-subset(world.cities,country.etc=="Germany")
attach(Germany)

# Create chart and other elements

s3d<-scatterplot3d(long, lat, pop^0.42, box=F, axis=F, grid=F, scale.y=2.2, mar=c(0, 1.5, 2, 0), type="n", xlim=c(5, 15), ylim=c(47, 55), zlim=c(0, 2000), angle=90, color="grey", pch=20, cex.symbols=2, col.axis="grey", col.grid="grey")
s3d$points3d(dt.map$x,dt.map$y,rep(0,length(dt.map$x)),col="grey",type="l")
s3d$points3d(dt.map2$x,dt.map2$y,rep(0,length(dt.map2$x)),col=rgb(0,0,255,170,maxColorValue=255),type="l")
s3d$points3d(long, lat, pop^0.42, col=rgb(255, 0, 0, pop^0.36, maxColorValue=255), type="h", lwd=5, pch=" ")

# Titling

mtext("Where we live...",adj=0.0,cex=3.5,line=-5,family="Lato Black",outer=T)
mtext("Source: Richard A. Becker, Allan R. Wilks, worldHires/mapdata, CIA World Data Bank II",1,adj=0.9,cex=1.5,line=0,font=3,outer=T)
dev.off()


#' @title Print \code{BandMat} objects
#' @description Printing for \code{BandMat} objects.
#' @param x \code{BandMat} object
#' @param ... unused
#' @name print-BandMat
#' @rdname print-Bandmat
#' @method print BandMat
#' @export
print.BandMat <- function(x, ...)
{
  dim <- getdim(x)
  k <- kdim(x)

  .Call(R_matprinter, getData(x), dim[1L], dim[2L], k[1L], k[2L])
  invisible()
}


# context("igraph back and forth")
#
# test_that("viz attributes are kept", {

  set.seed(1)
  net <- igraph::barabasi.game(10)
  igraph::V(net)$color <- colors()[1:10]
  igraph::V(net)$size  <- runif(10, 10, 20)
  igraph::V(net)$att1  <- rnorm(10)
  igraph::graph_attr(net, "layout") <- igraph::layout_with_fr(net)

  net1 <- igraph.to.gexf(net, rescale.node.size=TRUE)
  net2 <- gexf.to.igraph(net1)

  # plot(net)
  # plot(net1)
  #

  # Structure is the same
  ne <- igraph::ecount(igraph::difference(net, net2, byname=FALSE))
  expect_equal(ne, 0L)

  # Attributes are the same
  expect_equal(igraph::V(net)$att1, igraph::V(net2)$att1)

  # Viz attributes are (somewhat) the same
  norml <- function(x) {
    for (i in 1:ncol(x)) {
      pran <- range(x[,i])
      if (pran[1] == pran[2])
        next

      x[,i] <- (x[,i] - pran[1])/(pran[2] - pran[1])
    }

    x
  }

  layout  <- norml(igraph::graph_attr(net, "layout"))
  layout2 <- norml(igraph::graph_attr(net2, "layout"))
  expect_equal(layout[, 1:2], layout2[, 1:2])

# })


#devtools::test("asremlPlus")
context("model_selection3")
asr3.lib <- "D:\\Analyses\\R oldpkg"

cat("#### Test variofaces using Atieno with asreml3\n")
test_that("Variofaces_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml, lib.loc = asr3.lib)
  library(asremlPlus)

  data(chkpeadat)
  testthat::expect_equal(nrow(chkpeadat), 1056)
  testthat::expect_equal(ncol(chkpeadat), 18)

  # Fit the final fitted asreml object
  current.asr <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                        random = ~Smarthouse:Zone + Smarthouse:spl(vLanes),
                        rcov = ~at(Smarthouse):ar1(Lane):ar1(Position),
                        data = chkpeadat, trace = FALSE)
  summary(current.asr)$varcomp
  current.asrt <- as.asrtests(current.asr, denDF = "numeric")
  current.asrt$wald.tab
  recalcWaldTab(current.asrt, denDF="numeric", dDF.na = "maximum")
  testthat::expect_equal(length(current.asrt), 3)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 7)
  testthat::expect_equal(nrow(current.asrt$test.summary), 0)

  # Fit initial model
  current.asr <- asreml(Biomass.plant ~ Smarthouse + Lines*TRT ,
                        random = ~ Smarthouse:(Lane + Position),
                        rcov = ~ at(Smarthouse):ar1(Lane):ar1(Position),
                        data=chkpeadat)
  summary(current.asr)$varcomp

  # Load current fit into an asrtests object
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  # Check for and remove any boundary terms
  current.asrt <- rmboundary(current.asrt)
  print(current.asrt)

  # Test Lanes autocorrelation
  current.asrt <- testresidual(current.asrt, "~ at(Smarthouse):Lane:ar1(Position)",
                               label="Lane autocorrelation", simpler=TRUE)

  # Test Pos autocorrelation (depends on whether Lane autocorrelation retained)
  k <- match("Lane autocorrelation", current.asrt$test.summary$terms)
  p <- current.asrt$test.summary$p
  {if (p[k] <= 0.05)
    current.asrt <- testresidual(current.asrt, "~ at(Smarthouse):ar1(Lane):Position",
                                 label="Pos autocorrelation", simpler=TRUE,
                                 update=FALSE)
    else
      current.asrt <- testresidual(current.asrt, "~ at(Smarthouse):Lane:Position",
                                   label="Pos autocorrelation", simpler=TRUE,
                                   update=FALSE)
  }
  testthat::expect_equal(length(current.asrt), 3)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 5)
  testthat::expect_equal(nrow(current.asrt$test.summary), 3)
  print(current.asrt)

  # Get current fitted asreml object
  current.asr <- current.asrt$asreml.obj
  current.asr <- update(current.asr, aom=TRUE)

  # Form variance matrix based on estimated variance parameters
  gamma.Lane <- current.asr$gammas[1]
  s2.SW <- current.asr$gammas[2]
  rho.lSW <- current.asr$gammas[3]
  rho.pSW <- current.asr$gammas[4]
  lane.ar1SW <- mat.ar1(order=24, rho=rho.lSW)
  pos.ar1SW <- mat.ar1(order=22, rho=rho.pSW)
  RSW <- s2.SW * mat.dirprod(lane.ar1SW, pos.ar1SW)
  s2.SE <- current.asr$gammas[5]
  rho.pSE <- current.asr$gammas[6]
  rho.lSE <- current.asr$gammas[7]
  lane.ar1SE <- mat.ar1(order=24, rho=rho.lSE)
  pos.ar1SE <- mat.ar1(order=22, rho=rho.pSE)
  RSE <- s2.SE * mat.dirprod(lane.ar1SE, pos.ar1SE)
  V <- mat.dirsum(list(RSW, RSE))
  #2 Smarthouses = 1056
  V <- gamma.Lane * with(chkpeadat, fac.sumop(fac.combine(list(Smarthouse,Lane)))) + V
  testthat::expect_equal(nrow(V), 1056)
  testthat::expect_equal(ncol(V), 1056)

  #Produce variogram faces plot (Stefanaova et al, 2009)
  faces <- variofaces(current.asr, V=V, nsim = 50, maxiter = 20, seed = 14522)
  testthat::expect_equal(nrow(faces$face1), 48)
  testthat::expect_equal(ncol(faces$face1), 6)
  testthat::expect_equal(nrow(faces$face2), 44)
  testthat::expect_equal(ncol(faces$face2), 6)

  #Get Variety predictions
  Var.pv <- predict(current.asr, classify="Lines")$predictions$pvals
  testthat::expect_equal(nrow(Var.pv), 247)
  testthat::expect_equal(ncol(Var.pv), 4)
})


##### ----- COMPUTE CORRELATION MATRIX ----- #####

args = commandArgs(trailingOnly = TRUE)     # input arguments in order: .raw file, gene set file, MAGMA output file, pheno name, working directory

# for testing purposes
# setwd('~/drugsets/')
# raw.file = '/Users/nyb/drugsets/DATA/MAGMA_ANNOT/dgsa_input/T2D-step2.genes.raw'
# set.file = '~/drugsets/DATA/GENESETS/entrez_cond_sets.txt'
# res.file = '~/drugsets/OUTPUT/T2D_SOLO.gsa.out'

# set working directory
setwd(args[5])

# set file names to load
raw.file = args[1]                          # "SCZ_SAMPLE.genes.raw"
set.file = args[2]                          # "entrez_cond_sets.txt"
res.file = args[3]                          # "cond.gsa.out"

prune.thresh = 0.1  #used for gene-set correlation matrix as well

raw.data = strsplit(scan(raw.file, what="", comment.char="#", sep="\n"), " ")
info.length = length(raw.data[[1]])

raw.info = data.frame(matrix(sapply(raw.data, head, info.length), ncol=info.length, byrow=T), stringsAsFactors=F)[,-(3:4)]
names(raw.info) = c("gene", "chr", "nsnps", "nparam", "nsamp", "mac", "zstat")
for (i in 3:ncol(raw.info)) raw.info[,i] = as.numeric(raw.info[,i])

raw.corrs = lapply(raw.data, tail, -info.length)
chr.names = unique(raw.info$chr)
projection = list(); proj.index = list(); no.proj = 0
for (chr in chr.names) {
	curr.raw = raw.corrs[raw.info$chr == chr]
	curr.size = length(curr.raw)
	curr.corr = matrix(0, ncol=curr.size, nrow=curr.size)
	for (i in 2:curr.size) {
		len = length(curr.raw[[i]])
		if (len > 0) curr.corr[i,1:len+(i-len-1)] = as.numeric(curr.raw[[i]])
	}
	curr.corr = curr.corr + t(curr.corr)
	diag(curr.corr) = 1

	eig = eigen(curr.corr)
	use = which(eig$values >= prune.thresh)
  projection[[chr]] = eig$vectors[,use] %*% diag(1/sqrt(eig$values[use]))
	proj.index[[chr]] = 1:length(use) + no.proj
	no.proj = no.proj + length(use)
}

project.data = function(data) {
	out = matrix(NA, nrow=no.proj, ncol=ncol(data))
	for (chr in chr.names) {
		out.index = proj.index[[chr]]
		out[out.index,] = t(projection[[chr]]) %*% data[raw.info$chr == chr,]
	}
	return(out)
}

residualize = cbind(data.matrix(raw.info[,c("nsnps", "nparam", "nsamp")]), 1/raw.info$mac)
residualize = residualize[,apply(residualize, 2, var) > 0]
residualize = cbind(1, scale(cbind(residualize, log(residualize))))
residualize = project.data(residualize)

outcome = project.data(matrix(raw.info$zstat, ncol=1))
outcome = lm(outcome ~ residualize - 1)$residuals

gsa.res = read.table(res.file, header=T, stringsAsFactors=F)
sets = strsplit(scan(set.file, what="", sep="\n"), "\t")
sets.use = c(gsa.res$FULL_NAME, "druggable")

set.names = sapply(sets, head, 1)
set.genes = lapply(sets[set.names %in% sets.use], tail, -1)
set.names = set.names[set.names %in% sets.use]

sets = matrix(0, nrow=nrow(raw.info), ncol=length(set.names))
for (i in 1:length(set.names)) sets[raw.info$gene %in% set.genes[[i]],i] = 1
sets = project.data(sets)

#assuming conditioning on 'druggable'
covar = cbind(residualize[,1], sets[,set.names == "druggable"])
sets = sets[,set.names != "druggable"]

ctc.inv = solve(t(covar) %*% covar)
cts = t(covar) %*% sets
det = apply(sets^2, 2, sum) - apply(cts * (ctc.inv %*% cts), 2, sum)
V = sweep(sets - covar %*% ctc.inv %*% cts, 2, det, FUN="/")

beta = t(V) %*% outcome
set.corrs = cov2cor(t(V) %*% V)

eig = eigen(set.corrs)
use = which(eig$values >= prune.thresh)
set.corrs.inv = eig$vectors[,use] %*% diag(1/eig$values[use]) %*% t(eig$vectors[,use])

set.info = data.frame(
	set.name = gsa.res$FULL_NAME,
	size = gsa.res$NGENES,
	stat = gsa.res$BETA / gsa.res$SE,
	stringsAsFactors=F
)

save(set.info, set.corrs, set.corrs.inv, file=sprintf("%s%s%s_setcorrs.rdata", args[5],'OUTPUT',args[4]))


#' @title which.noise
#' @description   similar to interpolate.xy.robust given a vector, or xy, identify errors or noise
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
which.noise = function( xy, method="",  probs=c(0.025, 0.975), lags=c(1,2,3,2,1)  ) {

  debug = FALSE
  # debug = TRUE
  if( debug ){
    method="sequential"
    probs=c(0.025, 0.975)
    lags=c(1,2,3,2,1)
    xy= 1:100
    nb = 10
    xy[sample( 1:length(xy), nb)] = runif( nb ) * 1000
  }

  if (ncol(xy) ==1 ) {
    nz = length(xy)
    z = data.frame( x=1:nz, y=xy )
  } else  if (ncol(xy) ==2 ) {
    nz = nrow(xy)
    z = data.frame( xy)
    names(z) = c("x", "y" )
  } else {
    stop( "Error: y or c(x,y) expected")
  }

  z$y0 = z$y  # a copy in case we need original data
  z$noise=FALSE

  if (method =="sequential") {
    # check adjacent values and reject if differences are greater than a given range of quantiles (95%)
    for ( lg in lags ) {
      finished = FALSE
      noise.n0 = 2
      noise.n = noise.n0-1  # staring with a dummy value
      while ( noise.n > 0 ) {
        zd = diff( z$y, lag=lg )
        z$ydiff = c( zd , rep(NA,lg ))  # padding with NA's
        yquants = quantile( z$ydiff, probs=probs, na.rm=T)
        i = which( z$ydiff < yquants[1] | z$ydiff > yquants[2])
        suspect.noise =  c(i, i+lg )
        noise = suspect.noise[ duplicated(suspect.noise, incomparables=c(1, nz, NA)) ] # exclude terminal points
        noise.n0 = noise.n
        noise.n = length( noise )
        if (noise.n0 == noise.n) break()  # converged upon a solution
        if (noise.n >0 ) {
          z$noise[noise] = TRUE
          allnoisydata = which(z$noise)
          z$y[allnoisydata ] = NA
          z$y[allnoisydata ] = approx( x=z$x, y=z$y, xout=allnoisydata, method="linear", rule=2 )$y
        }
      }
    }
  }

 if (method=="loess") {
    for( sp in seq( 0.34, 0.02, by=-0.02 ) ) {
      # ID a good span where loess solution ~ real data
      lmod = try( loess( y ~ x, data=z, span=sp, control=loess.control(surface="direct") ), silent=TRUE )
      if ( "try-error" %in% class(lmod) ) next()
      z$y.smoothed = NA
      z$y.smoothed = predict( lmod )
      lmtest = try( lm( y.smoothed ~ y, z ), silent=TRUE)
      if ( "try-error" %in% class(lmtest) ) next()
      lsumm = summary( lmtest )
      if (lsumm$r.squared > 0.95 ) {
        # only accept solutions if it produces predictions that are pretty close to original data
        z$y.diff = z$y - z$y.smoothed
        yquants = quantile( z$y.diff, probs=probs, na.rm=TRUE )
        i =  which( z$y.diff < yquants[1] | z$y.diff > yquants[2] )
        if (length(i) > 0) z$noise[i] = TRUE
        break()
      }
    }
  }

  return( which( z$noise) )

  if (debug) {
    plot ( y0 ~ index, z, pch=20, cex=0.3, col="orange" )
    points ( y ~ index, z, pch=20, cex=0.2, col="green" )
    points ( y0 ~ index, z[!z$noise,], pch=20, cex=0.2, col="blue" )
  }

}