# Zelinsky search task - data analysis
# Usage: source("analysis.r")

require(ggplot2)

# Parameters (TODO: accept command-line arg)
drop_incorrect = TRUE  # drop trials with incorrect answer
plot_size = c(7, 4)  # c(4, 4) for single plots, c(7, 4) for side-by-side

## Input data: One combined file
data_file = "data/all_2014-04-09.csv"  # uncomment to read this single file

## Input data: Individual runs to combine
Q_5 = "data/Q_5_256_0_2014-04-09_12-49-03.csv"
Q_17 = "data/Q_17_256_0_2014-04-09_16-05-42.csv"
O_5 = "data/O_5_256_0_2014-04-09_17-56-49.csv"
O_17 = "data/O_17_256_0_2014-04-09_18-58-21.csv"
#data_file_list = c(Q_5, Q_17, O_5, O_17)  # uncomment to read all files in this list

# Utility functions
## Standard error of the mean (stdErr); for error bars: lower limit (errBarLow), upper limit (errBarHigh)
stdErr <- function(x) { sqrt(var(x, na.rm=TRUE) / length(na.omit(x))) }
errBarLow <- function(x) { return(mean(x) - stdErr(x)) }
errBarHigh <- function(x) { return(mean(x) + stdErr(x)) }

# TODO: Compute within subject variablility error bars as per Zelinksy paper

## Data reading
readData <- function(filename) {
	cat("Reading data file:", filename, "\n")
	dat_ = read.csv(filename, header=TRUE)
	dat_ = dat_[, (colnames(dat_) != 'X')]  # drop extra NA col that PsychoPy adds, if any
	return(dat_)
}

readDataAll <- function() {
	dat_all = NULL
	for (filename in data_file_list) {
		dat_ = readData(filename)
		if(is.null(dat_all)) {
			dat_all = dat_
		}
		else {
			dat = rbind(dat_all, dat_)
		}
	}
	return(dat_all)
}

# Read data
if(exists("data_file")) {
	dat = readData(data_file)
} else if(exists("data_file_list")) {
	dat = readDataAll(data_file_list)
}

# Convert appropriate columns to factors
if(!is.factor(dat$present)) {
	dat$present = factor(dat$present, levels=c(1, 0), labels=c('Positive', 'Negative'))  # convert
} else if(all(levels(dat$present) == c('Negative', 'Positive'))) {
	dat$present <- factor(dat$present, levels=c('Positive', 'Negative'), labels=c('Positive', 'Negative'))  # re-order
}

# Data cleaning
if (drop_incorrect) {
	dat = dat[dat$response.corr==1,]
}

# Data summary
#dat_sum <- summarySE(dat, measurevar="response.rt", groupvars=c("target", "num_stimuli"))

# Plot
rtPlot = ggplot(dat, aes(x=as.factor(num_stimuli), y=response.rt, colour=target, shape=target)) +
  stat_summary(aes(group=target), fun.y=mean, geom="line", size=0.75) +
  stat_summary(fun.y=mean, geom="point", size=1.25) +
  stat_summary(fun.ymin=errBarLow, fun.ymax=errBarHigh, geom="errorbar", width=0.125) +
  facet_grid(. ~ present) +
  scale_colour_discrete(name="Task", breaks=c('Q', 'O'), labels=c("Parallel", "Serial")) +
  scale_shape_discrete(name="Task", breaks=c('Q', 'O'), labels=c("Parallel", "Serial")) +
  guides(colour=guide_legend(title=NULL), shape=guide_legend(title=NULL)) +
  xlab("Display size") + ylab("Reaction Time (sec)") +
  ggtitle(sprintf("Zelinsky search task\ntarget: %s; display size: %s; #trials: %d",
            paste(unique(dat$target), collapse=", "),
            paste(unique(dat$num_stimuli), collapse=", "),
            nrow(dat))) +
  # To include target presence levels: paste(levels(dat$present), collapse=", ")
  theme(title=element_text(size=10),
  		axis.text=element_text(size=10),
        axis.title=element_text(size=10))

dev.new(width=plot_size[1], height=plot_size[2])
#X11()  # maybe useful for launching plots from command-line
print(rtPlot)  # actually show plot (if run from command-line, this saves the plot to Rplots.pdf)


# Function to plot color bar
# Modified from http://stackoverflow.com/questions/9314658/colorbar-from-custom-colorramppalette
colorBar <- function(colRamp, min, max=-min, mar = NULL, nticks=11, ticks=seq(min, max, len=nticks), title='', align = 'horizontal', new = FALSE, ...) {
    scale = (length(colRamp)-1)/(max-min)

    if(align == 'vertical') {
        if(new == TRUE) {
            dev.new(width=1.75, height=5)
        }
        if(is.null(mar)) mar <- c(0,0,0,4)
        par(mar = mar)
        plot(c(0,10), c(min,max), type='n', bty='n', xaxt='n', xlab='', yaxt='n', ylab='', main=title, ...)
        axis(4, ticks, las=1, ...)
        for (i in 1:(length(colRamp)-1)) {
            y = (i-1)/scale + min
            rect(0,y,10,y+1/scale, col=colRamp[i], border=NA)
        }
    }

    if(align == 'horizontal') {
        if(new == TRUE) {
            dev.new(width=5, height=1.75)
        }
        if(is.null(mar)) mar <- c(4,0,0,0)
        par(mar = mar)
        plot(c(min,max), c(0,1), type='n', bty='n', xaxt='n', xlab='', yaxt='n', ylab='', main=title, ...)
        axis(1, ticks, las=1, ...)
        for (i in 1:(length(colRamp)-1)) {
            y = (i-1)/scale + min
            rect(y,0,y+1/scale,10, col=colRamp[i], border=NA)
        }
    }
}


library(ggplot2)
library(tidyr)
library(dplyr)
library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(EnvStats)
library(matrixStats)
library(scales)
library(gridExtra)
library(bayesplot)
library(cowplot)

#---------------------------------------------------------------------------
format_data <- function(i, dates, countries, estimated_cases_raw, estimated_deaths_raw,
                        reported_cases, reported_deaths, out, forecast=0, SIM = FALSE){

  N <- length(dates[[i]])
  if(forecast > 0) {
    dates[[i]] = c(dates[[i]], max(dates[[i]]) + 1:forecast)
    N = N + forecast
    reported_cases[[i]] = c(reported_cases[[i]],rep(NA,forecast))
    reported_deaths[[i]] = c(reported_deaths[[i]],rep(NA,forecast))
  }

  country <- countries[[i]]

  estimated_cases <- colMeans(estimated_cases_raw[,1:N,i])
  estimated_cases_li <- colQuantiles(estimated_cases_raw[,1:N,i], probs=.025)
  estimated_cases_ui <- colQuantiles(estimated_cases_raw[,1:N,i], probs=.975)
  estimated_cases_li2 <- colQuantiles(estimated_cases_raw[,1:N,i], probs=.25)
  estimated_cases_ui2 <- colQuantiles(estimated_cases_raw[,1:N,i], probs=.75)

  estimated_deaths <- colMeans(estimated_deaths_raw[,1:N,i])
  estimated_deaths_li <- colQuantiles(estimated_deaths_raw[,1:N,i], probs=.025)
  estimated_deaths_ui <- colQuantiles(estimated_deaths_raw[,1:N,i], probs=.975)
  estimated_deaths_li2 <- colQuantiles(estimated_deaths_raw[,1:N,i], probs=.25)
  estimated_deaths_ui2 <- colQuantiles(estimated_deaths_raw[,1:N,i], probs=.75)

  rt <- colMeans(out$Rt_adj[,1:N,i])
  rt_li <- colQuantiles(out$Rt_adj[,1:N,i],probs=.025)
  rt_ui <- colQuantiles(out$Rt_adj[,1:N,i],probs=.975)
  rt_li2 <- colQuantiles(out$Rt_adj[,1:N,i],probs=.25)
  rt_ui2 <- colQuantiles(out$Rt_adj[,1:N,i],probs=.75)

  if (SIM == FALSE){
    mu <- mean(out$mu[,i])
    mu_li <- quantile(out$mu[,i], probs=.025)
    mu_ui <- quantile(out$mu[,i], probs=.975)
  }

  data_state_plotting <- data.frame("date" = dates[[i]],
                                    "country" = rep(country, length(dates[[i]])),
                                    "reported_cases" = reported_cases[[i]],
                                    "predicted_cases" = estimated_cases,
                                    "cases_min" = estimated_cases_li,
                                    "cases_max" = estimated_cases_ui,
                                    "cases_min2" = estimated_cases_li2,
                                    "cases_max2" = estimated_cases_ui2,
                                    "reported_deaths" = reported_deaths[[i]],
                                    "estimated_deaths" = estimated_deaths,
                                    "deaths_min" = estimated_deaths_li,
                                    "deaths_max"= estimated_deaths_ui,
                                    "deaths_min2" = estimated_deaths_li2,
                                    "deaths_max2"= estimated_deaths_ui2,
                                    "rt" = rt,
                                    "rt_min" = rt_li,
                                    "rt_max" = rt_ui,
                                    "rt_min2" = rt_li2,
                                    "rt_max2" = rt_ui2)

  if (SIM == FALSE){
    data_state_plotting$mu_rep = rep(mu, length(dates[[i]]))
    data_state_plotting$mu_li = rep(mu_li, length(dates[[i]]))
    data_state_plotting$mu_ui = rep(mu_ui, length(dates[[i]]))
  }

  return(data_state_plotting)

}


library(ggplot2)

x_value <- c()
y_value <- c()

for (i in 1:100) {
  x_value <- c(x_value, as.double(PARAM[[i]][1]))
  y_value <- c(y_value, as.double(PARAM[[i]][2]))
}

ggplot(mapping = aes(x = x_value, y = y_value)) + geom_point(shape = 18, color = "blue") +
  xlab("R (nm)") + ylab("H (nm)")

mean_value <- c()
for (i in 1:251) {
  mean_value <- c(mean_value, mean(DIFSLIKA[[i]]$V3))
}

ggplot(mapping = aes(x = x_value, y = y_value)) + geom_tile(aes(fill = mean_value)) +
  scale_fill_gradient(low = "white", high = "black") + geom_abline(slope = 2, intercept = 0)

write.table(x = mean_value, file = "Desktop/mean_value", row.names = FALSE)

x_unique <- unique(x_value)
y_unique <- unique(y_value)
z_matrix <- array(, dim = c(length(unique(x_value)), length(unique(y_value))))

for (i in 1:100) {
  i_ind <- which(x_value[i] == x_unique)
  j_ind <- which(y_value[i] == y_unique)

  z_matrix[i_ind, j_ind] <- mean(DIFSLIKA[[i]]$V3)
}

write.table(z_matrix, file = "mean_matrix.txt", row.names = FALSE, col.names = FALSE)
write.table(unique(x_value), file = "x_value.txt", row.names = FALSE, col.names = FALSE)
write.table(unique(y_value), file = "y_value.txt", row.names = FALSE, col.names = FALSE)

na_rows <- c()
na_cols <- c()
na_count <- 0
for (i in 1:nrow(z_matrix)) {
  for (j in 1:ncol(z_matrix)) {
    if (is.na(z_matrix[i, j])) {
      na_rows <- c(na_rows, i)
      na_cols <- c(na_cols, j)
      na_count <- na_count + 1
    }
  }
}

na_rows <- sort(unique(na_rows[1:100]))
na_cols <- sort(unique(na_cols[1:100]))

color_value <-  y_value / x_value

color_value <- sapply(color_value, function(x) ifelse(x >= 2, 1, 0))

ggplot(mapping = aes(x = x_value, y = y_value, color = color_value)) +
  geom_point() + geom_abline(slope = 99/40, intercept = -2375) + scale_x_continuous(limits = c(0, 5000))

for (i in 1:100)


library(ggplot2)
source("date.r")
source("explore-data.r")
theme_set(theme_bw())

source("finances.r")

# Control for inflation ------------------------------------------------------

geo$month <- month(geo$date)
geo$year <- year(geo$date)

geo <- merge(geo, cpi, by = c("month", "year"), sort = F)
geo$priceadj <- geo$price / geo$ratio

# Add interest rates
irates$date <- NULL
geo <- merge(geo, irates, by = c("month", "year"), sort = F)

# Basic summaries of data --------------------------------------

consistent <- subset(geo, !(county %in% c("Monterey County", "San Benito County", "San Joaquin County", "Santa Cruz County")))

daily <- ddply(consistent, .(date), function(df) {
  data.frame(
    n = nrow(df),
    avg_priceadj = mean(df$priceadj, na.rm = TRUE),
    avg_price = mean(df$price, na.rm = TRUE),
    cpi = df$cpi[1],
    mprime = df$mprime[1]
  )
}, .progress = "text")

qplot(date, n, data = daily, geom = "line", ylab = "Number of sales") + xlab(NULL)
ggsave(file = "beautiful-data/graphics/daily-sales.pdf", width = 8, height = 4)

qplot(date, avg_price / 1e6, data = daily, geom = "line", ylab = "Average price (millions)") + xlab(NULL)
ggsave(file = "beautiful-data/graphics/daily-price.pdf", width = 8, height = 4)

qplot(date, mprime, data = daily, geom = "line")
qplot(mprime, avg_price, data = daily)
qplot(mprime, n, data = daily)

ggplot(daily, aes(x = date)) +
  geom_line(aes(y = avg_price / 1e6), colour = "grey60") +
  geom_line(aes(y = avg_priceadj / 1e6)) +
  labs(x = NULL, y = "Average price (millions)")
ggsave(file = "beautiful-data/graphics/daily-price-adj.pdf", width = 8, height = 4)


# /////////////////////////////////////////////////////////////////////////
#
# Creates bipartite web plot.
# The final graph was further edited in Inkscape (https://inkscape.org/).
#
# /////////////////////////////////////////////////////////////////////////

# Load packages -----------------------------------------------------------

library(bipartite)

# Clean global environment
rm(list = ls(all.names = TRUE))

# Load customized web plotting function.
# It has some additional flexibility to adjust graphical parameters.
source("https://raw.githubusercontent.com/valentinitnelav/bipartite_webs/master/R/plot_grid.R")

# Read & prepare data -----------------------------------------------------

network <- read.csv("data/Supporting_Information_S5.csv")

# ...............................................

# Defensively check for duplicates in species names.

# Check for duplicates in Plants.
which(table(network$Plants) != 1)
# integer(0) indicates no duplicates

# Check for duplicates in column names (Pollinators)
# First, substitute dot/multiple dots with space. This is also useful further as
# labels in the network graph.
colnames(network) <- gsub(pattern = "\\.+", replacement = " ", x = colnames(network))
# which name appears more than once?
which(table(colnames(network)) != 1)
# integer(0) indicates no duplicates

# ...............................................

# Prepare matrix of interactions
network4graph <- network[, -1]
rownames(network4graph) <- network[, 1]

# visweb ------------------------------------------------------------------

# Open a PDF graphic device with desired parameters
pdf(file = paste0("Output/web_graph_", format(Sys.time(), "%Y-%m-%d-%Hh%Mm%Ss"), ".pdf"),
    width = 20/2.54,
    height = 10/2.54,
    pointsize = 8)

par(oma = c(bottom = 0, left = 0, top = 0, right = 0),
    mar = c(bottom = 0, left = 0, top = 0, right = 0),
    lwd = 0.1)

# Note that:
# pred - Pollinators
# prey - Plants
plot_grid(
  web = network4graph,
  type = "nested",
  labsize = 2.7,
  square = "black",
  xlabel = "Pollinators",
  ylabel = "Plants",
  # Adjust axis labels side
  pred.axis.side = 3,
  # Adjust position of axis labels:
  pred.axis.pos = -7.9,
  prey.axis.pos = -3.3,
  # Adjust position of axis titles:
  pred.axis.title.line = -2.5,
  prey.axis.title.line = -0.8,
  # increase axis title size if needed:
  axis.title.cex = 1,
  # Adjusts the matrix left-right:
  x.lim = c(-3, ncol(network4graph)-4.7)
)

# close the device
dev.off()


# RGL-demo: subdivision surfaces
# author: Daniel Adler
# $Id: subdivision.r 568 2007-03-11 18:15:27Z dmurdoch $

rgl.demo.subdivision <- function()
{
  # setup environment
  clear3d("all")
  view3d()
  bg3d(color="gray")
  light3d()

  # generate basic mesh
  obj <- oh3d()

  part <- function( level, tx, ... )
  {
    shade3d( translate3d( obj, tx, 0, 0 )
    , color="gray30", front="lines",alpha=0.5,back="lines", override=TRUE
    )
    shade3d( translate3d( subdivision3d( obj, depth=level ), tx, 0, 0 )
    , override=TRUE, ... )
  }

  common <- c(alpha=0.5)

  part(0, -5.50, color="blue"   , common )
  part(1, -1.75, color="yellow" , common )
  part(2,  1.75, color="red"    , common )
  part(3,  5.50, color="green"  , common )

}

open3d()
rgl.demo.subdivision()


#  James Rekow

countSubgroupVecDiff = function(subgroupVec1, subgroupVec2){

  #  ARGS: subgroupVec1 - numeric vector of subgroup indices corresponding to a base set A
  #        subgroupVec2 - numeric vector of subgroup indices corresponding to the same base set A
  #
  #  RETURNS: numDiff - minimum number of differences between the two subgroups for any permutation
  #                     of values of subgroupVec2

  source("subgroupVecMatcher.r")

  #  find the optimal permutation of the values of subgroupVec2
  subgroupVec2Ordered = subgroupVecMatcher(subgroupVec1 = subgroupVec1, subgroupVec2 = subgroupVec2)

  #  compute the minimum number of differences between the subgroup assignment in the two input vectors
  numDiff = sum(subgroupVec1 != subgroupVec2Ordered)

  return(numDiff)

} #  end countSubgroupVecDiff function


library(BGVAR)
library(reshape2)
library(panelvar)
library(dtw)
#library(pacman)
#p_load(tidyverse,panelvar)

#setwd('Projects/covid-analysis/')
df <- read.csv('../../data/tidy/cases_mobility_activity.csv')
df <- df[, c(2,4,8:186)] #36:95

# Infer missing Apple data
df[df$transportation_type=='driving','X5.11.2020'] = df[df$transportation_type=='driving','X5.10.2020']
df[df$transportation_type=='driving','X5.12.2020'] = df[df$transportation_type=='driving','X5.10.2020']
df[df$transportation_type=='walking','X5.11.2020'] = df[df$transportation_type=='walking','X5.10.2020']
df[df$transportation_type=='walking','X5.12.2020'] = df[df$transportation_type=='walking','X5.10.2020']
df[df$transportation_type=='transit','X5.11.2020'] = df[df$transportation_type=='transit','X5.10.2020']
df[df$transportation_type=='transit','X5.12.2020'] = df[df$transportation_type=='transit','X5.10.2020']

# Convert dataframe
melted.df <- melt(df, id.vars = c('region', 'transportation_type'))
m.data <- dcast(melted.df, region + variable~transportation_type)
colnames(m.data) = c('Country', 'Date', 'cov', 'car', 'groc', 'parks', 'home', 'reta', 'tran', 'tstop', 'walk', 'work' )

# Convert countries to factors
m.data$Country <- as.factor(m.data$Country)

# Convert numbers to numeric
for (i in seq(3, length(c('Country', 'Date', 'cov', 'car', 'groc', 'parks', 'home', 'reta', 'tran', 'tstop', 'walk', 'work' )  ) )) {
  m.data[,i] = as.numeric(m.data[,i], na.pass=TRUE)
}

# Correct Google (add 100 to baseline)
m.data[,c( 'groc', 'parks', 'home', 'reta',  'tstop', 'work' )] = m.data[,c( 'groc', 'parks', 'home', 'reta',  'tstop', 'work' )] + 100

# Remove Apple data
endovars <-  c('car', 'tran', 'walk', 'groc', 'parks', 'home', 'reta',  'tstop', 'work' )
m.data <- subset(m.data, select = c('Country', 'Date', endovars) )
m.data <- na.omit(m.data)
#m.data <- m.data[-1,]

#m.data <- m.data[m.data$cov >= 1,] # remove all zero covid cases
# m.data['day'] = 1 # initialize day column
# for (i in unique(m.data$Country)) {
#   for (j in seq(1,nrow(m.data[m.data$Country==i,]) ) ) {
#     m.data[m.data$Country==i,][j, 'day'] = j
#   }
# }
#m.data <- m.data[m.data$day <= 60,]

# Drop date column
m.data <- subset(m.data, select = -Date)

#Log and difference
#m.data[,endovars] = log(m.data[,endovars])
#diff(m.data[,endovars])

#ggplot(m.data, aes(x=Date,y=car,color=Country,group=Country)) + geom_point() + geom_line()
#ggplot(m.data, aes(x=Date,y=home,color=Country,group=Country)) + geom_point() + geom_line()

########################################
# DTW
########################################
dm <- matrix(NA, nrow=length(unique(m.data$Country)), ncol =length(unique(m.data$Country))  )
diag(dm) <- 0
dm
rownames(dm) <- unique(m.data$Country)
colnames(dm) <- unique(m.data$Country)

ii = 0
for (i in unique(m.data$Country)) {
  ii = ii + 1
  jj = 0
  for (j in unique(m.data$Country)) {
    jj = jj + 1
    if (jj > ii) {
      dm[i,j] <- dtw(dist(m.data[m.data$Country==i,], m.data[m.data$Country==j,]), distance.only = T)$normalizedDistance
    }
  }
}

write.csv(dm,file='disimilarity-matrix-mobility.csv')

# mod.pvar1 <- pvargmm(
#   dependent_vars = endovars,
#   lags = 1,
#   transformation = "fd",
#   data = m.data,
#   panel_identifier=c("Country", "day"),
#   steps = c("twostep"),
#   system_instruments = FALSE,
#   collapse = FALSE
# )

#m.data <- subset(m.data, select = c(Country, Data, cov, car, groc, parks, home, reta, reta))
#l.data <- vector(mode = "list", length = length(unique(m.data$Country)))
# for (i in unique(m.data$Country)) {
#   l.data[[i]] <- subset(m.data, Country==i)
#   l.data[[i]] <- l.data[[i]][,3:12]
#   l.data[[i]] <- data.matrix(l.data[[i]], rownames.force = NA)
# }

#w.data <- read.csv('963652501_T_T100I_MARKET_ALL_CARRIER_2019_YEAR.csv')
#acast(w.data, ORIGIN_COUNTRY~DEST_COUNTRY, sum, value.var="PASSENGERS")
#
# model.1<-bgvar(Data=df,
#                     W=W.trade0012,
#                     saves=100,
#                     burns=100,
#                     plag=2,
#                     prior="NG",
#                     SV=TRUE,
#                     thin=1,
#                     trend=TRUE,
#                     h=0,
#                     save.country.store=FALSE,
#                     multithread=TRUE,
#                     eigen=1.05
#                     )


context("bed_projection")

genome <- tibble::tribble(
  ~ chrom, ~ size,
  "chr1", 1000,
  "chr2", 1000
)

x <- tibble::tribble(
  ~ chrom, ~ start, ~ end,
  "chr1", 50, 75,
  "chr1", 250, 400,
  "chr1", 500, 600
)

y <- tibble::tribble(
  ~ chrom, ~ start, ~ end,
  "chr1", 100, 200,
  "chr1", 200, 800
)

bed_projection(x, y, genome)
bed_projection(x, y, genome, by_chrom = TRUE)

test_that("basic projection test works", {
  # compare output to pbinom( )function
  # 2 of 3 hits, 7 of 10 chance
  # 1- pbinom because pval > .5

  exp <- 1 - pbinom(2, 3, 7 / 10)
  res <- bed_projection(x, y, genome)
  expect_equal(res$p.value, exp)
})

test_that("projection per chromosome works (by_chrom = TRUE)", {
  genome <- tibble::tribble(
    ~ chrom, ~ size,
    "chr1", 2000,
    "chr2", 2000
  )

  x <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 100, 200,
    "chr1", 250, 400,
    "chr1", 500, 600,
    "chr1", 1000, 2000,
    "chr2", 100, 200
  )

  y <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 150, 175,
    "chr1", 525, 575,
    "chr1", 1100, 1200,
    "chr1", 1400, 1600,
    "chr2", 100, 1500
  )
  res <- bed_projection(x, y, genome, by_chrom = TRUE)
  expect_true(all(c("chr1", "chr2") %in% res$chrom))
})

test_that("report significant when intervals are underrepresented, .lower_tail = TRUE", {
  sig <- pbinom(0, 4, .7)

  genome <- tibble::tribble(
    ~ chrom, ~ size,
    "chr1", 1000,
    "chr2", 1000
  )

  x <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 10, 20,
    "chr1", 25, 40,
    "chr1", 50, 60,
    "chr1", 100, 150
  )

  y <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 200, 275,
    "chr1", 525, 575,
    "chr1", 200, 900
  )
  res <- bed_projection(x, y, genome)
  expect_true(res$lower_tail == TRUE)
  expect_true(res$p.value < .5)
  expect_true(res$p.value == sig)
})

test_that("report significant when intervals are overrepresented, .lower_tail = FALSE", {
  sig <- 1 - pbinom(4, 4, .7)
  genome <- tibble::tribble(
    ~ chrom, ~ size,
    "chr1", 1000,
    "chr2", 1000
  )

  x <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 200, 225,
    "chr1", 250, 400,
    "chr1", 500, 600,
    "chr1", 300, 350
  )

  y <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 200, 275,
    "chr1", 525, 575,
    "chr1", 200, 900
  )
  res <- bed_projection(x, y, genome)
  expect_true(res$lower_tail == FALSE)
  expect_true(res$p.value < .5)
  expect_true(res$p.value == sig)
})


# # LE ZA ZGLED KAKO DODAJAMO ČRTE POSTOPOMA
# ggplot(cbind(skupna17[c("round", "goals_scored", "own_goals")] %>% group_by(round) %>%
#                summarise(st_zadetkov_17 = sum(goals_scored + own_goals)),
#              skupna18[c("round", "goals_scored", "own_goals")] %>% group_by(round) %>%
#                summarise(st_zadetkov_18 = sum(goals_scored + own_goals)) %>% select(-round),
#              skupna19[c("round", "goals_scored", "own_goals")] %>% group_by(round) %>%
#                summarise(st_zadetkov_19 = sum(goals_scored + own_goals)) %>% select(-round))) +
#   aes(x=round) + aes(y = st_zadetkov_17, colour = "st_zadetkov_17") + geom_line() +
#   geom_line(aes(y = st_zadetkov_18, colour = "st_zadetkov_18")) +
#   geom_line(aes(y = st_zadetkov_19, colour = "st_zadetkov_19"))
#
#
#
#
# goli_po_sezonah <- cbind(skupna17[c("goals_scored", "own_goals","was_home")] %>%
#                            group_by(was_home) %>%
#                            summarise("2016/17"=sum(goals_scored + own_goals)) %>%
#                            rename(Teren=was_home),
#                          skupna18[c("goals_scored", "own_goals","was_home")] %>%
#                            group_by(was_home) %>%
#                            summarise("2017/18"=sum(goals_scored + own_goals)) %>% select(-was_home),
#                          skupna19[c("goals_scored", "own_goals","was_home")] %>%
#                            group_by(was_home) %>%
#                            summarise("2018/19"=sum(goals_scored + own_goals)) %>%
#                            select(-was_home)) %>%
#   pivot_longer(-Teren,names_to="sezona", values_to="stevilo_golov") %>%
#   mutate(Teren=sapply(Teren, function(x) {if (x == TRUE) {x="Doma"} else {x="V gosteh"}}))
#
# ggplot(goli_po_sezonah) + aes(x=sezona, y=stevilo_golov, fill=Teren) + geom_col(position="dodge") +
#   geom_text(aes(label = stevilo_golov), vjust=1.5, position=position_dodge(0.9)) +
#   ggtitle("Število zadetkov doma in v gosteh") + ylab("Število zadetkov") + xlab("Sezona")
#
#
# goli_pozicija <- cbind(kom17[c("goals_scored","element_type")] %>% filter(element_type < 5) %>%
#                          group_by(element_type) %>%
#                          summarise(odstotek_zadetkov17 = sum(goals_scored)/sum(kom17$goals_scored) * 100),
#                        kom18[c("goals_scored","element_type")] %>% filter(element_type < 5) %>%
#                          group_by(element_type) %>%
#                          summarise(odstotek_zadetkov18 = sum(goals_scored)/sum(kom17$goals_scored) * 100) %>%
#                          select(-element_type),
#                        kom19[c("goals_scored","element_type")] %>% filter(element_type < 5) %>%
#                          group_by(element_type) %>%
#                          summarise(odstotek_zadetkov19 = sum(goals_scored)/sum(kom17$goals_scored) * 100) %>%
#                          select(-element_type)) %>%
#   mutate(odstotek_zadetkov17=round(odstotek_zadetkov17,2),
#          odstotek_zadetkov18=round(odstotek_zadetkov18,2),
#          odstotek_zadetkov19=round(odstotek_zadetkov19,2)) %>% rename(Pozicija = element_type) %>%
#     mutate(Pozicija = c("Vratar", "Branilec", "Vezist", "Napadalec")[Pozicija]) %>%
#   filter(odstotek_zadetkov17 > 0, odstotek_zadetkov18 > 0, odstotek_zadetkov19 > 0) %>%
#   rename("2016/17" = odstotek_zadetkov17, "2017/18" = odstotek_zadetkov18,
#          "2018/19" = odstotek_zadetkov19) %>%
#   pivot_longer(-Pozicija, names_to = "sezona", values_to = "odstotek_zadetkov")
#
# ggplot(goli_pozicija) + aes(x=sezona, y=odstotek_zadetkov, fill=Pozicija) +
#   geom_col(position = "dodge") +
#   geom_text(aes(label = odstotek_zadetkov), vjust=1.5, position=position_dodge(0.9)) +
#   ggtitle("Odstotek vseh zadetkov razdeljen po igralnih položajih") + ylab("Odstotek zadetkov") + xlab("Sezona")

# SEDAJ NAS ZANIMAJO LE IGRALCI V POLJU Z VEC KOT SEDMIMI CELOTNIMI ODIGRANIMI TEKMAMI
igralci <- kom19 %>% filter(minutes >= 20*20, Pozicija=="Vezist" | Pozicija=="Napadalec" | Pozicija=="Branilec")

podaje_asistence <- igralci %>% filter(assists/minutes >= quantile(igralci$assists/igralci$minutes, 2/3, na.rm = TRUE) |
                               completed_passes/minutes >= quantile(igralci$completed_passes/igralci$minutes, 2/3, na.rm=TRUE)) %>%
  mutate(odstotek_uspesnih_podaj = round(completed_passes/attempted_passes * 100, 2), st_asistenc_90 = round(assists/minutes * 90, 2)) %>%
  select(Igralec, st_asistenc_90, odstotek_uspesnih_podaj, attempted_passes, completed_passes, assists, minutes, Uvrstitev)

graf_podaje_asistence <- ggplotly(ggplot(podaje_asistence) + aes(igralec = Igralec, ekipa = Ekipa, st_asistenc = assists, minute = minutes,
                                           x = st_asistenc_90, y = odstotek_uspesnih_podaj, colour = Pozicija, shape = Uvrstitev) + geom_point() +
           ggtitle("Najnatančnejši podajalci in najboljši asistenti") + ylab("Odstotek uspešnih podaj") +
           xlab("Število asistenc na 90 minut"))

priloznosti_driblingi <- igralci %>%  filter(dribbles/minutes >= quantile(igralci$dribbles/igralci$minutes, 2/3, na.rm = TRUE) |
                                                       big_chances_created/minutes >= quantile(
                                                         igralci$big_chances_created/igralci$minutes, 2/3, na.rm = TRUE)) %>%
  mutate(st_driblingov_90 = round(dribbles/minutes*90, 2), st_velikih_priloznosti_90 = round(big_chances_created/minutes*90, 2)) %>%
  select(Igralec, st_driblingov_90, st_velikih_priloznosti_90, dribbles, big_chances_created, minutes, Uvrstitev)

graf_priloznosti_driblingi <- ggplotly(ggplot(priloznosti_driblingi) + aes(igralec = Igralec, ekipa = Ekipa, st_driblingov = dribbles,
                                                                           priloznosti = big_chances_created, x = st_velikih_priloznosti_90, minute = minutes,
                                                                           y = st_driblingov_90, color = Pozicija, shape = Uvrstitev) +
                                         geom_point() + ggtitle("Primerjava driblerjev in kreativnih igralcev") +
                                         ylab("Število driblingov na 90 minut") + xlab("Število ustvarjenih velikih priložnosti na 90 minut"))

driblingi_odvzete_zoge <- igralci %>% filter(dribbles/minutes >= quantile(igralci$dribbles/igralci$minutes, 2/3, na.rm = TRUE) |
                                               tackled/minutes >= quantile(igralci$tackled/igralci$minutes, 2/3, na.rm = TRUE)) %>%
  mutate(odvzete_zoge_90 = round(tackled/minutes*90, 2), st_driblingov_90 = round(dribbles/minutes*90, 2)) %>%
  select(Igralec, odvzete_zoge_90, st_driblingov_90, dribbles, tackled, minutes, Uvrstitev)

graf_driblingi_odvzete_zoge <- ggplotly(ggplot(driblingi_odvzete_zoge) + aes(igralec = Igralec, ekipa = Ekipa, izguba_zoge = tackled,
                                                                           st_driblingov = dribbles, x = odvzete_zoge_90, minute = minutes,
                                                                           y = st_driblingov_90, color = Pozicija, shape = Uvrstitev) +
                                         geom_point() + ggtitle("Primerjava driblingov in izgubljenih žog") +
                                         ylab("Število driblingov na 90 minut") + xlab("Število izgubljenih žog na 90 minut"))

blokade_napake <- igralci %>% filter(errors_leading_to_goal_attempt/minutes >=
                                            quantile(igralci$errors_leading_to_goal_attempt/igralci$minutes, 2/3, na.rm = TRUE) |
                                            clearances_blocks_interceptions/minutes >= quantile(igralci$clearances_blocks_interceptions/
                                                                                igralci$minutes, 2/3, na.rm = TRUE)) %>%
  mutate(obrambne_akcije_90 = round(clearances_blocks_interceptions/minutes*90,2), napake_za_priloznost_90 =
           round(errors_leading_to_goal_attempt/minutes*90,2)) %>% select(Igralec, napake_za_priloznost_90, obrambne_akcije_90, minutes,
                                                                          errors_leading_to_goal_attempt, clearances_blocks_interceptions, Uvrstitev)

graf_blokade_napake <- ggplotly(ggplot(blokade_napake) + aes(igralec = Igralec, ekipa = Ekipa,
                                                             izbijanja_blokiranja_prestrezanja = clearances_blocks_interceptions,
                                                             st_napak_za_priloznost = errors_leading_to_goal_attempt,
                                                             x = napake_za_priloznost_90, minute = minutes, y = obrambne_akcije_90, color = Pozicija,
                                                             shape = Uvrstitev) + geom_point() +
                                  ggtitle("Primerjava obrambnih akcij in napak") + ylab("Število obrambnih posredovanj na 90 minut") +
                                  xlab("Napake za nasprotnikove priložnosti na 90 minut"))

odvzete_zoge_favli <- igralci %>% filter(tackles/minutes >= quantile(igralci$tackles/igralci$minutes, 2/3, na.rm = TRUE) |
                               fouls/minutes >= quantile(igralci$fouls/igralci$minutes, 2/3, na.rm = TRUE)) %>%
  mutate(odvzete_zoge_90 = round(tackles/minutes*90,2), prekrski_90 = round(fouls/minutes*90,2)) %>%
  select(Igralec, prekrski_90, odvzete_zoge_90, minutes, fouls, tackles, Uvrstitev)

graf_odvzete_zoge_favli <- ggplotly(ggplot(odvzete_zoge_favli) + aes(igralec = Igralec, ekipa = Ekipa, prekrski = fouls, odvzemanja_zoge = tackles,
                                                                     x = prekrski_90, minute = minutes, y = odvzete_zoge_90, color = Pozicija,
                                                                     shape = Uvrstitev) +
                                      geom_point() + ggtitle("Primerjava odvzetih žog in prekrškov") + ylab("Število odvzetih žog na 90 minut") +
                                  xlab("Število prekrškov na 90 minut"))

vratarji <- kom19 %>% filter(minutes >= 90*3, Pozicija == "Vratar")

obrambe_clean_sheeti <- vratarji %>% mutate(obrambe_90 = round(saves/minutes*90,2)) %>% select(Igralec, obrambe_90, clean_sheets, minutes, saves,
                                                                                Uvrstitev)

graf_obrambe_clean_sheeti <- ggplotly(ggplot(obrambe_clean_sheeti) + aes(igralec = Igralec, ekipa = Ekipa, obrambe = saves,
                                                                         tekma_brez_prejetega_zadetka = clean_sheets,
                                                                       x = clean_sheets, minute = minutes, y = obrambe_90, colour = Uvrstitev) +
                                        geom_point() + ggtitle("Tekme brez prejetega zadetka in obrambe") + ylab("Število obranjenih strelov na 90 minut") +
                                        xlab("Število tekem brez prejetega gola"))

# # OGLED VSEH GRAFOV
# print(graf_podaje_asistence)
# print(graf_priloznosti_driblingi)
# print(graf_driblingi_odvzete_zoge)
# print(graf_blokade_napake)
# print(graf_odvzete_zoge_favli)
# print(graf_obrambe_clean_sheeti)

#DODANO ŠE FILTRIRANJE PO ODSTOTKU NATANCNOSTI
# & completed_passes/attempted_passes >= quantile(tabela_vezistov$completed_passes/tabela_vezistov$attempted_passes, 0.75, na.rm = TRUE))


#  James Rekow

#  this doesn't seem to work

randomizeAbdList  = function(abdList){

  #  ARGS:
  #
  #  RETURNS: randomizedAbdList - abundance list randomized according to the procedure used to create Null
  #           Model 1 in Section 1.3 of Bashan et al.

  #  extract number of samples in cohort and number of species in each sample
  M = length(abdList)
  N = length(abdList[[1]])

  abdMat = Reduce(rbind, abdList, init = NULL)

  randomizeSpeciesAbd = function(inputCol){

    nonzeroIx = inputCol > 0
    nonzeroAbdVals = inputCol[nonzeroIx]

    newNonzeroAbdVals = sample(nonzeroAbdVals, replace = TRUE)

    randomizedCol = inputCol
    randomizedCol[nonzeroIx] = newNonzeroAbdVals

    return(randomizedCol)

  } #  end randomizeSpeciesAbd function

  randomizedAbdMat = apply(abdMat, 2, randomizeSpeciesAbd)

  randomizedAbdMat = randomizedAbdMat / max(randomizedAbdMat)

  randomizedAbdList = lapply(as.list(1:M), function(n) randomizedAbdMat[n, ])

  #
  #
  # randomizedList = lapply(as.list(1:M), function(n) sample(abdMat[n, ], replace))
  #
  # nonzeroIx = abdMat > 0
  #
  # selectRandomizedSample = function(n){
  #
  #
  #
  # } #  end selectRandomizedSample function

  return(randomizedAbdList)

} #  end  randomizedAbdList  function


# code for propensity matched model.
# propensity matching 1:1 for OPCAB and ONCAB.
# use code from the lita/bita paper for ease.

# get the libraries needed.

library(pacman)
p_load(
    tidyverse, survival, rms, Hmisc, survminer,
    survRM2, relsurv
)

library(easypackages)
libraries(c(
    "tidyverse", "haven", "readxl",
    "survival", "lubridate", "WeightIt",
    "cobalt", "rms", "Hmisc", "survminer",
    "cmprsk", "splines"))

library(cobalt)
library(Matching)
library(MatchIt)
library(WeightIt)
library(twang)
library(MatchThem)
library(naniar)
library("MatchIt")
library("lmtest")
library("sandwich")
library("boot")
library("survival")

# get the dataset here.

df <- read_csv("D:/opcab/opcab_paper/long_term_results/dataset_latest.csv")

glimpse(df)

#THE ORIGINAL PAPER WAS SENT WITHOUT ADDING THE SURGEON VOLUME DATA.
#DF2 <- DF WILL GET THE ORIGINAL RESULTS.
#REMOVE TYPE FROM THE PROPENSITY MODEL.
# to add surgeon volume here...

dfs <- read_excel("D:/opcab/opcab_paper/propensity_model/raw_data.xlsx",sheet = 1)

dfs2 <- dfs %>% dplyr::select(Pat_ID, Surgeon_name)

dfs2 <- dfs2[!duplicated(dfs2$Pat_ID), ]

s_count <- dfs2 %>% group_by(Surgeon_name) %>% summarise(total = n())

# list of low:-

s_l <- s_count %>% filter(total <= 30)

s_m <- s_count %>% filter(total > 30 & total <= 60)

s_h <- s_count %>% filter(total > 60)

# now add the surgeon_names to the main dataset.

names(dfs2) <- tolower(names(dfs2))

dfs2$pat_id = as.numeric(dfs2$pat_id)

df2 <- left_join(df, dfs2, by = "pat_id")

df2$type <- with(df2, ifelse(surgeon_name %in% s_l$Surgeon_name, 1,
                             ifelse(surgeon_name %in% s_m$Surgeon_name, 2, 3)))

df2 %>% count(type)

# now to see missing information for the variables to be used for the propensity score model.

vars <- c("age_at_surgery",
    "gender", "bmi",
    "diabetes", "dialysis_dependence", "systemic_hypertension", "smoker",
    "hyperlipidemia", "copd", "peripheral_vascular_disease", "preop_lvef",
    "elective", "urgent", "emergency", "left_main_disease", "preop_mi",
    "preop_cva", "prior_cardiac_surgery", "logistic_euroscore", "opcab", "type")

miss_var_summary(df2[, c(vars)])

summary(df2[, c(vars)])

# while none missing, preop_mi has -9 and bmi needs to change.

df2$preop_mi[df2$preop_mi == -9] <- 001

df2$bmi[df2$bmi == 94] <- 49

df2%>% count(coronary_disease_detail)

# now to use all these variables and create a model for propensity score.

formula <- opcab ~ age_at_surgery + gender + bmi + diabetes +
    dialysis_dependence + systemic_hypertension + smoker + hyperlipidemia +
    copd + peripheral_vascular_disease + preop_lvef + elective + type +
  urgent + emergency + left_main_disease + preop_mi + preop_cva + prior_cardiac_surgery + logistic_euroscore +
    coronary_disease_detail

psmodel <- glm(formula, data = df2, family = "binomial"(link = "logit"))

df2$ps <- fitted.values(psmodel)

# using the MatchIt package to do the matching and then use the cobalt library
# to do the balance checks.

library(mosaic)

favstats(ps ~ opcab, data = df2)

# opcab        min        Q1    median        Q3       max      mean         sd   n
# 1     0 0.08759807 0.2982455 0.3508001 0.4266387 0.7205048 0.3640819 0.09584981 719
# 2     1 0.17017071 0.3334291 0.3963809 0.4743310 0.7580399 0.4077491 0.10461494 442

results = broom::tidy(psmodel)

write_csv(results,
    "D:/opcab/opcab_paper/propensity_model/table_model.csv")

gm <- matchit(data = df2, formula = formula,
    method = "nearest", caliper = 0.2,
    replace = F, ratio = 1)

love.plot(gm)

cobalt::bal.tab(gm, un = T)

lp <- cobalt::bal.tab(gm, un = T)

data = lp$Balance %>% tbl_df()

Variable = c("Distance","PS", "Sex","BMI","DM","ESRD",
             "HTN","Smoking","Hyperlipidemia","COPD",
             "PAD","LVEF","Elective","Urgent","Emergent",
             "LMCA stenosis","Prior MI","Prior Stroke",
             "Prior OHS","EUROSCORE", "CAD")

data$Variable = Variable

data2 = data %>% dplyr::select(Variable, Diff.Un, Diff.Adj)

write_csv(data2,
          "D:/opcab/opcab_paper/propensity_model/data_dc.csv")

    # the balance looks good.
    # now to extract the data-set using 1:1 matching.
    # get the data-set.

df_m <- match.data(gm)

df_m %>% count(opcab)

# now to save this dataaset for further analysis.

write_csv(df_m,
    "G:/opcab/opcab_paper/propensity_model/prop_match_data.csv")

# now to see the cox model and then km plot for the matched data.

df_m$surv_years <- (df_m$survival_days + 1) / 365.24

km <- survfit(Surv(surv_years, died) ~ opcab, data = df_m)

ggsurvplot(km,
    censor.size = 0,
    conf.int = T,
    risk.table = T,
    xlim = c(0, 10),
    surv.scale = "percent",
    legend.label = c("ONCAB", "OPCAB"))

# get the Cox model with robust standard errors.

coxm <- coxph(Surv(surv_years, died) ~ opcab + incomplete_revascularisation, data = df_m)

cox_st <- coxph(Surv(surv_years, died) ~ opcab + strata(subclass) + incomplete_revascularisation,
data = df_m)

summary(cox_st)

summary(coxm) # this is the result after matching 1:1.

# doing a sub-group analysis for OPCAB/ONCAB and incomplete grafting.
# for OPCAB and for ONCAB separately.

# using the adjusted data.

tableone::CreateCatTable(vars = "opcab",
        data = df_m,
        strata = c("incomplete_revascularisation"))

# for incomp == 1.

d1 = df_m %>% filter(incomplete_revascularisation == 1)

m1 = coxph(Surv(surv_years, died) ~ opcab, data = d1)

summary(m1)

# now adjusted for all the other variables along with opcab.

formula <- Surv(surv_years, died) ~ age_at_surgery + gender + bmi + diabetes +
dialysis_dependence + systemic_hypertension + smoker + hyperlipidemia +
copd + peripheral_vascular_disease + preop_lvef + elective + urgent + emergency +
left_main_disease + preop_mi + preop_cva + prior_cardiac_surgery + logistic_euroscore +
 opcab

m1_adj = coxph(formula, data = d1)

d2 = df_m %>% filter(incomplete_revascularisation == 0)

m2 = coxph(Surv(surv_years, died) ~ opcab, data = d2)

summary(m2)

m2_adj = coxph(formula, data = d2)

summary(m2_adj)

# create new term for interaction.

df_m$inc_opcab = df_m$incomplete_revascularisation*df_m$opcab

formula <- Surv(surv_years, died) ~ age_at_surgery + gender + bmi + diabetes +
  dialysis_dependence + systemic_hypertension + smoker + hyperlipidemia +
  copd + peripheral_vascular_disease + preop_lvef + elective + urgent + emergency +
  left_main_disease + preop_mi + preop_cva + prior_cardiac_surgery + logistic_euroscore +
  opcab + incomplete_revascularisation + inc_opcab

m_interact = coxph(formula, data = df_m)

# some more code to fill the tables.

df <- read_csv("D:/opcab/opcab_paper/propensity_model/prop_match_data.csv")

# male gender.

tableone::CreateCatTable(vars = "gender",
                         data = df,
                         strata = c("opcab"))

# LOS median IQR and p-value:

h <- tableone::CreateContTable(vars = "hospitallenthof_stay",
                          data = df,
                          strata = c("opcab"),
                          testNonNormal = T)

print(h, nonnormal = c(" hospitallenthof_stay"))

library(mosaic)

favstats(hospitallenthof_stay ~ opcab, data = df)

# survival years and pt-years follow-up:

df$surv_years <- df$survival_days/365.24

mean(df$surv_years) * 1161

df %>% count(died)

319/(mean(df$surv_years) * 1161)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     28.06.2017
#modificado: 09.12.2019

#1. FUNCTIONS
source("misc_v2.3.r")

#2. READ DATA
f1 <- "../data/lmktattract.csv"
x_all <- read.table(file=f1,header=TRUE,sep=",",dec=".",row.names=1)
dim(x_all)

# 3. ANALYSE DATA
set.seed(12345)

main1 <- "Labour market attractiveness"  #title for plots
col1 <- c(rbind(hsv(h=seq(0,1,len=8),s=1/3,v=5/5)[1:7],  #very light
                hsv(h=seq(0,1,len=8),s=2/3,v=5/5)[1:7],  #light
                hsv(h=seq(0,1,len=8),s=3/3,v=5/5)[1:7],  #normal
                hsv(h=seq(0,1,len=8),s=3/3,v=4/5)[1:7])) #dark
names(col1) <- rownames(x_all)           #colours for EU28

#normalize and scale data
n_all <- c(1,  #pop_Total
           5,  #pop_Y[]
           1,  #ARPR
           1,  #low_work
           1,  #rooms_pp
           1,  #mat_depriv
           1,  #AROPE
           6,  #emp_Y[]_ED[]
           2,  #emp_T[]
           3,  #emp_Y[]
           20, #emp_Y[]_Nace[]
           2,  #unemp_Y[]
           1,  #GDP
           1,  #GVAgr
           1,  #disp_income
           1,  #training
           27, #earn_OC[]_Nace[]
           1)  #expend_ED5-8
w_all <- rep(1/n_all,times=n_all)
x_norm <- t(apply(scale(x_all),1,function(x){x*w_all}))

#calculate distances
#from help(dist): "Missing values are allowed, and are excluded from all
#  computations involving the rows within which they occur. If some columns are
#  excluded in calculating a [...] distance, the sum is scaled up proportionally
#  to the number of columns used."
x_dist <- dist(x_norm,method="euclidean")

#perform Social Network Analysis
f1 <- "../results/lmktattract_1/net"
plot_sna_v2(x_dist,col1=col1,edge_thr=0.65,f1=f1,main=main1)
analyse_net(x_dist,f1=f1)

#perform Partition Around Medoids analysis
f1 <- "../results/lmktattract_1/pam"
plot_pam_v2(x_dist,col1=col1,f1=f1,main=main1)
kbest <- 10
f1 <- paste("../results/lmktattract_1/pam_grps",kbest,sep="")
plot_pam_v2(x_dist,kbest=kbest,col1=col1,f1=f1,main=main1)


library("caret")
library ("e1071")
library ("klaR")
library("rpart")
library("gbm")

setwd('/Users/birupakhya/Desktop')

# read csv, convert date to proper format,
# choose only required columns, rename adjusted close to avoid ambiguity
snp500 <- read.csv('s&p500_1990_2017.csv')
snp500$Date <- as.Date(snp500$Date, '%Y-%m-%d')
snp500 <- snp500[,c('Date', 'Adj.Close')]
colnames(snp500)[2] <- 'snp_adj_close'

bond10yr <- read.csv('10_Yr_Bond_rates.csv')
bond10yr$Date <- as.Date(bond10yr$Date, '%Y-%m-%d')
bond10yr <- bond10yr[,c('Date', 'Adj.Close')]
colnames(bond10yr)[2] <- 'bond10yr_adj_close'

crudeoil <- read.csv('DCOILWTICO.csv')
crudeoil$DATE <- as.Date(crudeoil$DATE, '%Y-%m-%d')
crudeoil$crude_oil_price_usd <- as.numeric(crudeoil$crude_oil_price_usd)
colnames(crudeoil)[2] <- 'crude_oil_price_usd'

# check missing values
colSums(is.na(snp500))
colSums(is.na(bond10yr))
colSums(is.na(crudeoil))

# select common dates, exclude others from the dataset. Minimise to 6848 rows.
require(sqldf)
merged_df <- sqldf('SELECT *
                   FROM snp500
                   INNER JOIN bond10yr ON (snp500.Date = bond10yr.Date)
                   INNER JOIN crudeoil ON (snp500.Date = crudeoil.DATE)')

# select only required rows
merged_df$sq_no <- seq(1, nrow(merged_df))
merged_df <- merged_df[, c('sq_no', 'Date', 'snp_adj_close', 'bond10yr_adj_close', 'crude_oil_price_usd')]

# compute price change for snp500
snp_pc1 = c(); snp_pc2= c(); snp_pc3 = c(); snp_pc4 = c(); snp_pc5 = c(); priceDir = c();
for (i in 7:nrow(merged_df)){
  snp_pc1[i] <- (merged_df$snp_adj_close[i - 1] - merged_df$snp_adj_close[i - 2])
  snp_pc2[i] <- (merged_df$snp_adj_close[i - 1] - merged_df$snp_adj_close[i - 3])
  snp_pc3[i] <- (merged_df$snp_adj_close[i - 1] - merged_df$snp_adj_close[i - 4])
  snp_pc4[i] <- (merged_df$snp_adj_close[i - 1] - merged_df$snp_adj_close[i - 5])
  snp_pc5[i] <- (merged_df$snp_adj_close[i - 1] - merged_df$snp_adj_close[i - 6])
  priceDir[i] <- ifelse((merged_df$snp_adj_close[i] - merged_df$snp_adj_close[i - 1]) > 0, 1, 0)
}

# compute price change for bond10yr
bnd_pc1 = c(); bnd_pc2= c(); bnd_pc3 = c(); bnd_pc4 = c(); bnd_pc5 = c();
for (i in 7:nrow(merged_df)){
  bnd_pc1[i] <- (merged_df$bond10yr_adj_close[i - 1] - merged_df$bond10yr_adj_close[i - 2])
  bnd_pc2[i] <- (merged_df$bond10yr_adj_close[i - 1] - merged_df$bond10yr_adj_close[i - 3])
  bnd_pc3[i] <- (merged_df$bond10yr_adj_close[i - 1] - merged_df$bond10yr_adj_close[i - 4])
  bnd_pc4[i] <- (merged_df$bond10yr_adj_close[i - 1] - merged_df$bond10yr_adj_close[i - 5])
  bnd_pc5[i] <- (merged_df$bond10yr_adj_close[i - 1] - merged_df$bond10yr_adj_close[i - 6])
}

# compute price change for crude oil
oil_pc1 = c(); oil_pc2= c(); oil_pc3 = c(); oil_pc4 = c(); oil_pc5 = c();
for (i in 7:nrow(merged_df)){
  oil_pc1[i] <- (merged_df$crude_oil_price_usd[i - 1] - merged_df$crude_oil_price_usd[i - 2])
  oil_pc2[i] <- (merged_df$crude_oil_price_usd[i - 1] - merged_df$crude_oil_price_usd[i - 3])
  oil_pc3[i] <- (merged_df$crude_oil_price_usd[i - 1] - merged_df$crude_oil_price_usd[i - 4])
  oil_pc4[i] <- (merged_df$crude_oil_price_usd[i - 1] - merged_df$crude_oil_price_usd[i - 5])
  oil_pc5[i] <- (merged_df$crude_oil_price_usd[i - 1] - merged_df$crude_oil_price_usd[i - 6])
}

# create categorical values for snp
snp.sd = sd(merged_df$snp_adj_close)
snp_cat1 = c(); snp_cat2= c(); snp_cat3 = c(); snp_cat4 = c(); snp_cat5 = c();
for (i in 7:nrow(merged_df)){

  snp_cat1[i] = ifelse(snp_pc1[i] < -1 * snp.sd, 'awful',
                       (ifelse((snp_pc1[i] >= -1 * snp.sd && snp_pc1[i] < -0.3 * snp.sd), 'Bad',
                               (ifelse((snp_pc1[i] >= -0.3 * snp.sd && snp_pc1[i] < 0.3 * snp.sd), 'Unchanged',
                                       (ifelse((snp_pc1[i] >= 0.3 * snp.sd && snp_pc1[i] < snp.sd), 'Good',
                                               (ifelse((snp_pc1[i] >= snp.sd), 'Great', 'None')))))))))
  snp_cat2[i] = ifelse(snp_pc2[i] < -1 * snp.sd, 'awful',
                       (ifelse((snp_pc2[i] >= -1 * snp.sd && snp_pc2[i] < -0.3 * snp.sd), 'Bad',
                               (ifelse((snp_pc2[i] >= -0.3 * snp.sd && snp_pc2[i] < 0.3 * snp.sd), 'Unchanged',
                                       (ifelse((snp_pc2[i] >= 0.3 * snp.sd && snp_pc2[i] < snp.sd), 'Good',
                                               (ifelse((snp_pc2[i] >= snp.sd), 'Great', 'None')))))))))

  snp_cat3[i] = ifelse(snp_pc3[i] < -1 * snp.sd, 'awful',
                       (ifelse((snp_pc3[i] >= -1 * snp.sd && snp_pc3[i] < -0.3 * snp.sd), 'Bad',
                               (ifelse((snp_pc3[i] >= -0.3 * snp.sd && snp_pc3[i] < 0.3 * snp.sd), 'Unchanged',
                                       (ifelse((snp_pc3[i] >= 0.3 * snp.sd && snp_pc3[i] < snp.sd), 'Good',
                                               (ifelse((snp_pc3[i] >= snp.sd), 'Great', 'None')))))))))

  snp_cat4[i] = ifelse(snp_pc4[i] < -1 * snp.sd, 'awful',
                       (ifelse((snp_pc4[i] >= -1 * snp.sd && snp_pc4[i] < -0.3 * snp.sd), 'Bad',
                               (ifelse((snp_pc4[i] >= -0.3 * snp.sd && snp_pc4[i] < 0.3 * snp.sd), 'Unchanged',
                                       (ifelse((snp_pc4[i] >= 0.3 * snp.sd && snp_pc4[i] < snp.sd), 'Good',
                                               (ifelse((snp_pc4[i] >= snp.sd), 'Great', 'None')))))))))
  snp_cat5[i] = ifelse(snp_pc5[i] < -1 * snp.sd, 'awful',
                       (ifelse((snp_pc5[i] >= -1 * snp.sd && snp_pc5[i] < -0.3 * snp.sd), 'Bad',
                               (ifelse((snp_pc5[i] >= -0.3 * snp.sd && snp_pc5[i] < 0.3 * snp.sd), 'Unchanged',
                                       (ifelse((snp_pc5[i] >= 0.3 * snp.sd && snp_pc5[i] < snp.sd), 'Good',
                                               (ifelse((snp_pc5[i] >= snp.sd), 'Great', 'None')))))))))

}

# create categorical values for 10yrbond
bnd.sd = sd(merged_df$bond10yr_adj_close)
bnd_cat1 = c(); bnd_cat2= c(); bnd_cat3 = c(); bnd_cat4 = c(); bnd_cat5 = c();
for (i in 7:nrow(merged_df)){

  bnd_cat1[i] = ifelse(bnd_pc1[i] < -1 * bnd.sd, 'awful',
                       (ifelse((bnd_pc1[i] >= -1 * bnd.sd && bnd_pc1[i] < -0.3 * bnd.sd), 'Bad',
                               (ifelse((bnd_pc1[i] >= -0.3 * bnd.sd && bnd_pc1[i] < 0.3 * bnd.sd), 'Unchanged',
                                       (ifelse((bnd_pc1[i] >= 0.3 * bnd.sd && bnd_pc1[i] < bnd.sd), 'Good',
                                               (ifelse((bnd_pc1[i] >= bnd.sd), 'Great', 'None')))))))))
  bnd_cat2[i] = ifelse(bnd_pc2[i] < -1 * bnd.sd, 'awful',
                       (ifelse((bnd_pc2[i] >= -1 * bnd.sd && bnd_pc2[i] < -0.3 * bnd.sd), 'Bad',
                               (ifelse((bnd_pc2[i] >= -0.3 * bnd.sd && bnd_pc2[i] < 0.3 * bnd.sd), 'Unchanged',
                                       (ifelse((bnd_pc2[i] >= 0.3 * bnd.sd && bnd_pc2[i] < bnd.sd), 'Good',
                                               (ifelse((bnd_pc2[i] >= bnd.sd), 'Great', 'None')))))))))

  bnd_cat3[i] = ifelse(bnd_pc3[i] < -1 * bnd.sd, 'awful',
                       (ifelse((bnd_pc3[i] >= -1 * bnd.sd && bnd_pc3[i] < -0.3 * bnd.sd), 'Bad',
                               (ifelse((bnd_pc3[i] >= -0.3 * bnd.sd && bnd_pc3[i] < 0.3 * bnd.sd), 'Unchanged',
                                       (ifelse((bnd_pc3[i] >= 0.3 * bnd.sd && bnd_pc3[i] < bnd.sd), 'Good',
                                               (ifelse((bnd_pc3[i] >= bnd.sd), 'Great', 'None')))))))))

  bnd_cat4[i] = ifelse(bnd_pc4[i] < -1 * bnd.sd, 'awful',
                       (ifelse((bnd_pc4[i] >= -1 * bnd.sd && bnd_pc4[i] < -0.3 * bnd.sd), 'Bad',
                               (ifelse((bnd_pc4[i] >= -0.3 * bnd.sd && bnd_pc4[i] < 0.3 * bnd.sd), 'Unchanged',
                                       (ifelse((bnd_pc4[i] >= 0.3 * bnd.sd && bnd_pc4[i] < bnd.sd), 'Good',
                                               (ifelse((bnd_pc4[i] >= bnd.sd), 'Great', 'None')))))))))
  bnd_cat5[i] = ifelse(bnd_pc5[i] < -1 * bnd.sd, 'awful',
                       (ifelse((bnd_pc5[i] >= -1 * bnd.sd && bnd_pc5[i] < -0.3 * bnd.sd), 'Bad',
                               (ifelse((bnd_pc5[i] >= -0.3 * bnd.sd && bnd_pc5[i] < 0.3 * bnd.sd), 'Unchanged',
                                       (ifelse((bnd_pc5[i] >= 0.3 * bnd.sd && bnd_pc5[i] < bnd.sd), 'Good',
                                               (ifelse((bnd_pc5[i] >= bnd.sd), 'Great', 'None')))))))))

}

# create categorical values for 10yrbond
oil.sd = sd(merged_df$crude_oil_price_usd)
oil_cat1 = c(); oil_cat2= c(); oil_cat3 = c(); oil_cat4 = c(); oil_cat5 = c();
for (i in 7:nrow(merged_df)){

  oil_cat1[i] = ifelse(oil_pc1[i] < -1 * oil.sd, 'awful',
                       (ifelse((oil_pc1[i] >= -1 * oil.sd && oil_pc1[i] < -0.3 * oil.sd), 'Bad',
                               (ifelse((oil_pc1[i] >= -0.3 * oil.sd && oil_pc1[i] < 0.3 * oil.sd), 'Unchanged',
                                       (ifelse((oil_pc1[i] >= 0.3 * oil.sd && oil_pc1[i] < oil.sd), 'Good',
                                               (ifelse((oil_pc1[i] >= oil.sd), 'Great', 'None')))))))))
  oil_cat2[i] = ifelse(oil_pc2[i] < -1 * oil.sd, 'awful',
                       (ifelse((oil_pc2[i] >= -1 * oil.sd && oil_pc2[i] < -0.3 * oil.sd), 'Bad',
                               (ifelse((oil_pc2[i] >= -0.3 * oil.sd && oil_pc2[i] < 0.3 * oil.sd), 'Unchanged',
                                       (ifelse((oil_pc2[i] >= 0.3 * oil.sd && oil_pc2[i] < oil.sd), 'Good',
                                               (ifelse((oil_pc2[i] >= oil.sd), 'Great', 'None')))))))))

  oil_cat3[i] = ifelse(oil_pc3[i] < -1 * oil.sd, 'awful',
                       (ifelse((oil_pc3[i] >= -1 * oil.sd && oil_pc3[i] < -0.3 * oil.sd), 'Bad',
                               (ifelse((oil_pc3[i] >= -0.3 * oil.sd && oil_pc3[i] < 0.3 * oil.sd), 'Unchanged',
                                       (ifelse((oil_pc3[i] >= 0.3 * oil.sd && oil_pc3[i] < oil.sd), 'Good',
                                               (ifelse((oil_pc3[i] >= oil.sd), 'Great', 'None')))))))))

  oil_cat4[i] = ifelse(oil_pc4[i] < -1 * oil.sd, 'awful',
                       (ifelse((oil_pc4[i] >= -1 * oil.sd && oil_pc4[i] < -0.3 * oil.sd), 'Bad',
                               (ifelse((oil_pc4[i] >= -0.3 * oil.sd && oil_pc4[i] < 0.3 * oil.sd), 'Unchanged',
                                       (ifelse((oil_pc4[i] >= 0.3 * oil.sd && oil_pc4[i] < oil.sd), 'Good',
                                               (ifelse((oil_pc4[i] >= oil.sd), 'Great', 'None')))))))))
  oil_cat5[i] = ifelse(oil_pc5[i] < -1 * oil.sd, 'awful',
                       (ifelse((oil_pc5[i] >= -1 * oil.sd && oil_pc5[i] < -0.3 * oil.sd), 'Bad',
                               (ifelse((oil_pc5[i] >= -0.3 * oil.sd && oil_pc5[i] < 0.3 * oil.sd), 'Unchanged',
                                       (ifelse((oil_pc5[i] >= 0.3 * oil.sd && oil_pc5[i] < oil.sd), 'Good',
                                               (ifelse((oil_pc5[i] >= oil.sd), 'Great', 'None')))))))))

}

# combine all the columns for the final time and remove the top 7 rows that have NA value for categories
final_merged_df <- data.frame(priceDir, snp_cat1, snp_cat2, snp_cat3, snp_cat4, snp_cat5, bnd_cat1, bnd_cat2, bnd_cat3, bnd_cat4, bnd_cat5, oil_cat1, oil_cat2, oil_cat3, oil_cat4, oil_cat5 )
final_merged_df <- tail(final_merged_df, -6)

# partition dataset into training and test
train <- final_merged_df[1:5131,]
test <- final_merged_df[5132:nrow(final_merged_df),]

# Modelling using NaiveBayes
model.NB <- NaiveBayes(priceDir ~ snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5 ,data=train)
predictions <- predict(model.NB, test)
confusionMatrix(test$priceDir, predictions$class)

# Modelling using Recursive Partition Tree
model.rpt <- rpart(priceDir ~ snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5, data=train, cp=0)
plot(model.rpt)
text(model.rpt, use.n= T, digits=3, cex=0.6)
prediction.rpt <- predict(model.rpt, newdata = test, type="class")
printcp(model.rpt)
control <- trainControl(method = "cv", number = 10 , savePredictions = TRUE)
price.rpt.cv <- train (priceDir ~ snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5, data = train , method = "rpart", trControl = control)
predict.rpt.cv <- predict(price.rpt.cv, newdata = test)
confusionMatrix(predict.rpt.cv, test$priceDir)

# Modelling using Gradient Boosting
# model.gbm <- gbm((unclass(priceDir)-1) ~ snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5, data=train, n.trees=5000, interaction.depth =6, shrinkage=0.01)
# prediction.gbm <- predict(model.gbm, newdata = test, n.trees=5000, type="response")
# head(prediction.gbm[])
# tail(prediction.gbm[])
# predict.f <- ifelse(prediction.gbm>0.5,1,0)
# predict.f - test$priceDir

# prepare training scheme
control <- trainControl(method="repeatedcv", number=10, repeats=3)
# train the GBM model
set.seed(7)
modelGbm <- train(priceDir~snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5, data=final_merged_df, method="gbm", trControl=control, verbose=FALSE)
# train the NaiveBayes model
set.seed(7)
modelNb <- train(priceDir~snp_cat3+ snp_cat4 + snp_cat5 + bnd_cat4 + bnd_cat5 + oil_cat1 + oil_cat2 + oil_cat3 + oil_cat4 + oil_cat5, data=final_merged_df, method="nb", trControl=control, verbose=FALSE)
# collect resamples
results <- resamples(list(GBM=modelGbm, NB=modelNb))
# summarize the distributions
summary(results)
# boxplots of results
bwplot(results)
# dot plots of results
dotplot(results)


# Copyright (c) 2020, Zolisa Bleki
# SPDX-License-Identifier: BSD-3-Clause

matrix_type <- c("regular", "diagonal", "identity")

validate_output <- function(res) {

    if (res$info < 0) {
        stop("Possible illegal value in one of the inputs")
    }
    else if (res$info > 0) {
        stop(
            "Either the leading minor of the ", res$info, "'th order is not
            positive definite (meaning the covariance matrix is also not
            positive definite), or factorization of one of the inputs
            returned a factor with a zero in the ", res$info, "'th diagonal."
        )
    }
    else {
        res$out
    }
}

hptrunc_mvn <- function(rng, mean, cov, g, r, diag, out) {

    stopifnot(
        is.vector(mean),
        is.matrix(cov),
        is.matrix(g),
        is.vector(r),
        is.logical(diag),
        length(mean) == nrow(cov),
        nrow(cov) == ncol(cov),
        nrow(cov) == ncol(g)
    )

    if (is.null(out))
        out <- rep(0, length(mean))

    res <- .Call(C_hpmvn, rng, mean, cov, g, r, diag, out, PACKAGE = "htnorm")

    validate_output(res)
}

strprec_mvn <- function(rng, mean, a, phi, omega, str_mean, a_id, o_id, out) {

    stopifnot(
        is.vector(mean),
        is.matrix(a),
        is.matrix(phi),
        is.matrix(omega),
        is.logical(str_mean),
        nrow(omega) == ncol(omega),
        ncol(omega) == nrow(phi),
        length(mean) == nrow(a),
        nrow(a) == ncol(a)
    )

    if (!is.element(a_id, matrix_type) || !is.element(o_id, matrix_type))
        stop("`a_type` and `o_type` need to be one of {'regular', 'diagonal', 'identity'}")

    a_id <- switch(
        a_id,
        "regular" = as.integer(0),
        "diagonal" = as.integer(1),
        "identity" = as.integer(2)
    )
    o_id <- switch(
        o_id,
        "regular" = as.integer(0),
        "diagonal" = as.integer(1),
        "identity" = as.integer(2)
    )

    if (is.null(out))
        out <- rep(0, length(mean))

    res <- .Call(
        C_spmvn,
        rng,
        mean,
        a,
        phi,
        omega,
        str_mean,
        a_id,
        o_id,
        out,
        PACKAGE = "htnorm"
    )

    validate_output(res)
}

#' Sample from a multivariate normal truncated on a hyperplane or a multivariate
#' normal with a structured precision. `HTNGenerator` returns an object that
#' can be used to sample from such a distribution.
#'
#' @param seed A random seed. It must be a positive integer. If not specified
#'  then it defaults to NULL, which means a random seed is used.
#' @param gen The type of random number generator to use internally. It must
#'  either "xrs128p" (Xoroshiro128plus) or "pcg64" (PCG64). If not specified
#'  then this parameter defaults to "xrs128p".
#' @return A generator object that can be used to sample from the supported
#'  distributions.
#' @references Cong, Yulai; Chen, Bo; Zhou, Mingyuan. Fast Simulation of
#'  Hyperplane-Truncated Multivariate Normal Distributions. Bayesian Anal.
#'  12 (2017), no. 4, 1017--1037. doi:10.1214/17-BA1052.
#'  https://projecteuclid.org/euclid.ba/1488337478
#'
#' @examples
#' mean <- rnorm(1000)
#' cov <- matrix(rnorm(1000 * 1000), ncol=1000)
#' cov <- cov %*% t(cov)
#' G <- matrix(rep(1, 1000), ncol=1000)
#' r <- c(0)
#' rng <- HTNGenerator(seed=12345, gen="pcg64")
#' samples <- rng$hyperplane_truncated_mvnorm(mean, cov, G, r)
#' # verify if sampled values sum to zero
#' sum(samples)
#'
#' out <- rep(0, 1000)
#' eig <- eigen(cov)
#' phi <- eig$vectors
#' omega <- diag(eig$values)
#' a <- diag(runif(length(mean)))
#' rng$structured_precision_mvnorm(mean, a, phi, omega, a_type = "diagonal", out = out)
HTNGenerator <- function(seed = NULL, gen = "xrs128p") {

    if (is.numeric(seed)) {
        if (seed < 0)
            stop("`seed` cannot be negative.")
        seed <- as.integer(seed)
        if (!is.finite(seed))
            stop("`seed` cannot be converted to an integer")
    }
    else if (!is.null(seed)) {
        stop("`seed` cannot be a non-numeric value")
    }

    gen <- switch(gen, "xrs128p" = as.integer(0), "pcg64" = as.integer(1))
    if (is.null(gen))
        stop("`gen` needs to one of {'xrs128p', 'pcg64'}")

    res <- list("rng" = .Call(C_get_rng, seed, gen, PACKAGE = "htnorm"))
    class(res) <- "HTNGenerator"

    res$hyperplane_truncated_mvnorm <- function(
        mean, cov, g, r, diag = FALSE, out = NULL
    ) {
        if (is.null(out)) {
            hptrunc_mvn(res$rng, mean, cov, g, r, diag, out)
        }
        else {
            invisible(hptrunc_mvn(res$rng, mean, cov, g, r, diag, out))
        }
    }

    res$structured_precision_mvnorm <- function(
        mean, a, phi, omega, str_mean = FALSE, a_type = "regular", o_type = "regular", out= NULL
    ) {
        if (is.null(out)) {
            strprec_mvn(
                res$rng, mean, a, phi, omega, str_mean, a_type, o_type, out
            )
        }
        else {
            invisible(
                strprec_mvn(
                    res$rng, mean, a, phi, omega, str_mean, a_type, o_type, out
                )
            )
        }
    }

    res
}


paramNames <- c("AB0", "Ab0", "aB0", "ab0" ,"bA", "ba", "dA", "da", "r")

plot_pop <- function(BDtestdata) {
  plot(BDtestdata$AB_mean ~ BDtestdata$t, ylim=c(0,100), type='l', col = "red", lwd = 5, ylab = "# Individuals", xlab = "Time", cex.axis = 1.5, cex.lab = 1.5)
  lines(BDtestdata$Ab_mean ~ BDtestdata$t, col = "red", lty = "dashed", lwd = 5)
  lines(BDtestdata$aB_mean ~ BDtestdata$t,  col = "blue", lwd = 5)
  lines(BDtestdata$ab_mean ~ BDtestdata$t, lty = "dashed",col = "blue", lwd = 5)
  lines(BDtestdata$AB_mean+BDtestdata$Ab_mean+BDtestdata$aB_mean+BDtestdata$ab_mean ~ BDtestdata$t, lty="dotted", col = "black", lwd = 5)
  legend(3600,100, legend=c("AB","Ab","aB","ab","Total"), col = c("red","red","blue","blue","black"), lty = c("solid","dashed","solid","dashed","dotted"), lwd = 5, cex = 1.5)
}

plot_intro <- function(BDtestdata) {
  plot(BDtestdata$FA_mean ~ BDtestdata$t, ylim=c(0,1), type='l', col = "red", lwd = 5, ylab = "# fraction B-alleles", xlab = "Time", cex.axis = 1.5, cex.lab = 1.5)
  lines(BDtestdata$Fa_mean ~ BDtestdata$t, col = "blue", lwd = 5)
}

RunAllSimulation <- function(pars){
  pkgIntrogression::BDSim(100, 5000, pars, progressbar = FALSE)
}

function(input, output, session) {
    getParams <- function() {
      input[["recalc"]]

      params <- list()
      length(params) <- 10
      params <- lapply(paramNames, function(p) {input[[p]]})
      names(params) <- paramNames
      as.list(params)
  }

  navA <- eventReactive(input$recalc, RunAllSimulation(getParams()))

  output$plot_popdynamic <- renderPlot({
    suppressWarnings(plot_pop(navA()))
  })

  output$plot_introgression <- renderPlot({
   suppressWarnings(plot_intro(navA()))
  })

  output$write_fixation <- renderText({
    paste("The probability of extinction: ", navA()$extinct)
  })

  #output$a_lociPlot <- renderPlotly({
  #allelefrequencies
  #dataallelemean <-tidyr::gather(as.data.frame(navA()[[3]]), locus, value, 2:ncol(as.data.frame(navA()[[3]])))
  #dataallelevar <-tidyr::gather(as.data.frame(navA()[[4]]), locus, value, 2:ncol(as.data.frame(navA()[[4]])))
  #dataallele <- dplyr::bind_cols(dataallelemean,dataallelevar[3])
  #dataallele <- dplyr::mutate(dataallele, col=factor(locus,locus))
  #allelefrequencyplot <- ggplot(dataallele, aes(col, value, ymin=value-sqrt(value1),ymax=value+sqrt(value1))) +
  #geom_pointrange(aes(frame = Generation), shape=22) +
  #theme_minimal() +
  #xlab("Locus") +
  #ylab("Allelefrequency") +
  #theme(axis.text.x = element_blank())

  #suppressWarnings(ggplotly(allelefrequencyplot))
  # })

}


# source('C:/Users/parkinso/indus_ix/input_data_scripts/renewable_exclusion_zones.r')

require(rgeos)
require(rgdal)
require(raster)
require(ggmap)
require(dplyr)
require(rasterVis)
require(maptools)
memory.limit(size=1e9)

# ISWEL folder for data
setwd( 'P:/is-wel/indus/message_indus' )

# basins to check
basin = c('Indus')

# Define continental tiles from hydroBASINS
cnt_list = c('af', 'as', 'au', 'ca', 'eu', 'na', 'sa')
wkd_dir1 = paste( getwd(), "input/hydrosheds/elevation/", sep = '/' )
wkd_dir2 = paste( getwd(), "input/hydrosheds/flow_accumulation/", sep = '/' )
wkd_dir3 = paste( getwd(), "input/hydrosheds/river_network/", sep = '/' )
wkd_dir4 = paste( getwd(), "input/hydrosheds/flow_direction/", sep = '/' )
cnt_ext = lapply( cnt_list, function(cnt){ extent( raster( paste ( paste( wkd_dir1, c(paste(cnt,'_dem_15s_grid/',paste(cnt,'_dem_15s/',sep=''),paste(cnt, '_dem_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) ) ) } )
names(cnt_ext) = cnt_list

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste0(basin,'_bcu'), verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
proj4string(basin.sp)=proj4string(basin.spdf)
basin.sp = spTransform( basin.sp, crs( basin.spdf ) )
buff.sp = gBuffer( basin.sp, width=0.1 )
buff2.sp = gBuffer( basin.sp, width=10 )
proj4string(basin.sp) = proj4string(basin.spdf)
proj4string(buff.sp) = proj4string(basin.spdf)
proj4string(buff2.sp) = proj4string(basin.spdf)

# Check which hydrobasins tiles to include for this basin
tiles_incl = sapply( names(cnt_ext), function(cnt){
	polyg = as( cnt_ext[[cnt]] , 'SpatialPolygons' )
	proj4string(polyg) = proj4string(basin.sp)
	if( unlist( gIntersects( polyg, basin.sp ) ) ){ return( cnt ) }
	} )
cnt = unlist( tiles_incl[!is.null(tiles_incl)] )

# Elevation raster used to harmonize
elevation.raster = raster( paste( paste( wkd_dir1, c(paste(cnt,'_dem_15s_grid/',paste(cnt,'_dem_15s/',sep=''),paste(cnt, '_dem_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) )
elevation.raster = mask( x = crop( elevation.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( elevation.raster, extent( basin.sp ), snap="out") ) )

## Exclusion 0: Don't install above max elevation and where slope above max slope

slope_max = 11.3 # Eurek et al. (2017) assumes a max slope of 20% or 11.3 degrees for wind
elevation_max = 3500 # Eurek et al. and Pietzcker et al. assume a max elevation of 2500 meters for wind and PV- moved to 3500 to account for high elevation settlements in the Indus

slope.raster = terrain( elevation.raster, opt='slope', unit='degrees', neighbors=8 )
exclusion_topo.raster = slope.raster
exclusion_topo.raster[ slope.raster[] < slope_max ] = NA
exclusion_topo.raster[ elevation.raster[] < elevation_max ] = NA
exclusion_topo.raster[ !is.na( exclusion_topo.raster[] ) ] = 1

## Exclusion 1: Don't install where population density greater than 250 people per square km

# Urban population - using SSP2 in 2060
urbmax.raster = raster(paste('input/NCAR_population/raw/SSP Population Projections/SSP2/Urban/ASCII/SSP2urb',2060,'.txt', sep = ''))
urbmax.raster = mask( x = crop( urbmax.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( urbmax.raster, extent( basin.sp ), snap="out") ) )

# Rural population - using SSP2 in 2060
rurmax.raster = raster(paste('input/NCAR_population/raw/SSP Population Projections/SSP2/Rural/ASCII/SSP2rur',2060,'.txt', sep = ''))
rurmax.raster = mask( x = crop( rurmax.raster, extent( basin.sp ), snap = "out" ), mask = rasterize( basin.sp, crop( rurmax.raster, extent( basin.sp ), snap="out") ) )

# total population and density
totmax.raster = rurmax.raster + urbmax.raster
totdens.raster = totmax.raster / area( totmax.raster )
exclusion_popdens.raster = totdens.raster
exclusion_popdens.raster[ exclusion_popdens.raster[] < 250 ] = NA
exclusion_popdens.raster[ exclusion_popdens.raster[] > 0 ] = 1

## Exclusion 2: Don't install more than 250 km away from the nearest cell with more than 100 people

exclusion_distpop.raster = totdens.raster
exclusion_distpop.raster[ exclusion_distpop.raster[] < 100 ] = NA
exclusion_distpop.raster[ exclusion_distpop.raster[] > 0 ] = 1
exclusion_distpop.raster = distance( exclusion_distpop.raster ) / 1000
exclusion_distpop.raster[ exclusion_distpop.raster[] <= 250 ] = NA
exclusion_distpop.raster[ exclusion_distpop.raster[] > 250 ] = 1 # flag cells with pop greater than 100km away

## Exclusion 3: Don't install in protecte areas

# protected areas from input data file
exclusion_protected.raster = raster('input/protected_area_data/Data/WDPA_July2016-shapefile/highres_wdpa.tiff')
exclusion_protected.raster = mask( x = crop( exclusion_protected.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( exclusion_protected.raster, extent( basin.sp ), snap="out") ) )
exclusion_protected.raster[ exclusion_protected.raster < 1 ] = NA
exclusion_protected.raster[ !is.na(exclusion_protected.raster) ] = 1

## Exclusion 4: Don't install on lakes

# water bodies - lakes
print( 'Working on lakes - takes about 5 mins to import the data!')
lakes = readOGR('input/hydrosheds/hydrolakes/HydroLAKES_polys_v10_shp/HydroLAKES_polys_v10_shp','HydroLAKES_polys_v10',verbose=FALSE)
if( basin == 'Zambezi' ){ flt = 'Africa' }
if( basin == 'Indus' ){ flt = 'Asia' }
lakes = lakes[ which( lakes@data$Continent == flt ), ]
lakes = gIntersection(lakes,spTransform(basin.sp,crs(lakes)))
lakes.raster = rasterize(lakes, elevation.raster)
exclusion_lakes.raster = lakes.raster
rm(lakes)
gc()

## Exclusion 5: Don't install over forested area

# Forest cover
urls = unlist(read.table('input/treecover2000.txt',stringsAsFactors=FALSE)[,1])
cntr_urls = do.call( rbind, lapply( urls, function(uu){
	y = unlist(strsplit(uu,'_'))[4]
	if(grepl('S',y)){y=-1*as.numeric(unlist(strsplit(y,'S'))[1])}else{y=as.numeric(unlist(strsplit(y,'N'))[1])}
	x = unlist(strsplit(unlist(strsplit(uu,'_'))[5],'[.]'))[1]
	if(grepl('W',x)){x=-1*as.numeric(unlist(strsplit(x,'W'))[1])}else{x=as.numeric(unlist(strsplit(x,'E'))[1])}
	return( data.frame( x = x, y =y ) )
	} ) )
cntr_urls$id = seq(1,nrow(cntr_urls))
coordinates(cntr_urls) = ~ x + y
gridded(cntr_urls) = TRUE
cntr_urls = raster(cntr_urls)
print( 'Working on forest cover maps')
forest_cover.raster = do.call(merge, lapply( urls[ unlist(extract(cntr_urls,buff2.sp)) ], function(uu){
	print( paste( '-----', which( urls[ unlist(extract(cntr_urls,basin.sp)) ] == uu ), 'of', length(urls[ unlist(extract(cntr_urls,basin.sp)) ]), sep = ' ' ) )
	if( !file.exists(paste('input/treecover',unlist(strsplit(uu,'/'))[6],sep='/')) ){ download.file( uu, paste('input/treecover',unlist(strsplit(uu,'/'))[6],sep='/'), mode='wb' ) }
	return( aggregate( raster( paste('input/treecover',unlist(strsplit(uu,'/'))[6],sep='/') ), fact=20, fun="mean" ) )
	} ) )
forest_cover.raster = mask( x = crop( forest_cover.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( forest_cover.raster, extent( basin.sp ), snap="out") ) )
gc()
exclusion_forest_cover.raster = forest_cover.raster / 100
exclusion_forest_cover.raster[ exclusion_forest_cover.raster <= 0 ] = NA

## Create map showing the percent of grid cell area available for wind / solar
exclusion.list = list( 	exclusion_topo.raster,
						exclusion_popdens.raster,
						exclusion_distpop.raster,
						exclusion_protected.raster,
						exclusion_lakes.raster,
						exclusion_forest_cover.raster )

# harmonize to elevation raster scale using bilinear interpolation
exclusion.stack = stack( lapply( 1:length(exclusion.list), function( iii ){
	r = resample( exclusion.list[[iii]], elevation.raster, method = 'bilinear' )
	r[ is.na( r ) ] = 0
	r = mask( x = crop( r, extent( basin.sp ), snap = "out" ), mask = rasterize( basin.sp, crop( r, extent( basin.sp ), snap="out") ) )
	return(r)
	} ) )

# Combine the exclusion zone maps
exclusion.raster = sum( exclusion.stack )
exclusion.raster[ exclusion.raster[] > 1 ] = 1

# Avaiable area is the inverse of the exclusion zone map
available_area_fraction.raster = 1 - exclusion.raster

# Test plot
pdf( 'input/exclusion_zones.pdf', width = 7, height = 7 )
print( 	levelplot( 	stack( exclusion.stack, exclusion.raster ),
					main = 'Fraction of area unavailable for wind/solar',
					names.attr = c('Population Density','Population Distance','Protected Areas','Lakes','Forest Cover', 'Combined'),
					par.settings = 'BuRdTheme' ) )
dev.off()

# Output available area to .asc
writeRaster( exclusion.raster, filename = 'input/fraction_grid_cell_available_wind_solar.asc', format = 'ascii', overwrite = TRUE )


# Convert factor to numeric for convenience
Orange$Tree <- as.numeric(Orange$Tree)
ntrees <- max(Orange$Tree)

# get the range for the x and y axis
xrange <- range(Orange$age)
yrange <- range(Orange$circumference)

# set up the plot
plot(xrange, yrange, type = "n", xlab = "Age (days)",
ylab = "Circumference (mm)")
colors <- rainbow(ntrees)
linetype <- c(1 : ntrees)
plotchar <- seq(18, 18 + ntrees, 1)

# add lines
for (i in 1 : ntrees) {
    tree <- subset(Orange, Tree == i)
    lines(tree$age, tree$circumference, type = "b", lwd = 1.5,
    lty = linetype[i], col = colors[i], pch = plotchar[i])
}

# add a title and subtitle
title("Tree Growth", "example of line plot")

# add a legend
legend(xrange[1], yrange[2], 1 : ntrees, cex = 0.8, col = colors,
pch = plotchar, lty = linetype, title = "Tree")

# fitdist


#run imports
source('_imports.r')

#quick viz of the pipeline
tar_glimpse()
#tar_visnetwork() #less quick but more info

#make the targets as a rstudio job
(
	"targets::tar_make()"
	%>% (function(x){
		temp_file = tempfile()
		write(x,file=temp_file)
		return(temp_file)
	})
	%>% rstudioapi::jobRunScript(
		workingDir = getwd()
	)
)

#open a shiny dashboard to watch the progress
tar_watch(
	seconds = 10
	, outdated = FALSE
	, targets_only = TRUE
	, port = 59627 #just a random port
)

#when done, gather results (could add all the below as new targets too)
a = bind_rows(tar_read(summaries))

#show diagnostics & timing
(
	a
	%>% select(-var_summary)
	%>% pivot_longer(cols=c(-model,-n,-k,-iteration))
	%>% ggplot()
	+ facet_wrap(
		~name
		, scales = 'free'
	)
	+ geom_histogram(
		aes(
			x = value
			, fill = interaction(model,n,k)
		)
		, alpha = .5 #for when there are multiple models being compared
		, position = 'identity' #default is stacked, which sucks
	)
)

#show the per-parameter diagnostics
(
	a
	%>% filter(
		num_divergent==0 # possibly questionable!!
	)
	%>% select(var_summary,model,n,k,iteration)
	%>% unnest(var_summary)
	%>% filter(
		!is.na(rhat) # some parameters are constant in the mvn model
	)
	%>% select(rank,rhat,ess_bulk,ess_tail,model,n,k,iteration)
	%>% pivot_longer(cols=c(-model,-n,-k,-iteration))
	%>% ggplot()
	+ facet_wrap(
		~name
		, scales = 'free'
	)
	+ geom_histogram(
		aes(
			x = value
			, fill = interaction(model,n,k)
		)
		, alpha = .5 #for when there are multiple models being compared
		, position = 'identity' #default is stacked, which sucks
	)
)

# define a function to compute the dECDF confidence ellipse
#   very possibly not the right thing to do! (came up with this myself)
bootstrap_decdf_ci = function(n,bootstrap_iterations=1e5,interval_perc=.9){
	expected_rank = (1:n)/n - (1/n/2)
	deltas = matrix(
		NA
		, nrow = n
		, ncol = bootstrap_iterations
	)
	for(i in 1:bootstrap_iterations){
		deltas[,i] = sort(runif(n)) - expected_rank
	}
	lo = apply(deltas,1,quantile,probs=(1-interval_perc)/2)
	hi = apply(deltas,1,quantile,probs=1-(1-interval_perc)/2)
	return(tibble(expected_rank,lo,hi))
}

#compute the CI ellipse given the number of iterations (assumed to be the same across models)
ci_ellipse = bootstrap_decdf_ci(max(a$iteration))

#show the dECDF for a specific parameter (plus the ci)
(
	a
	%>% filter(
		num_divergent==0 # possibly questionable!!
	)
	%>% select(var_summary,model,n,k,iteration)
	%>% unnest(var_summary)
	%>% filter(
		variable=='means[1]'
		, rhat<1.01 # possibly questionable!!
	)
	%>% group_by(variable,model,n,k)
	%>% arrange(rank)
	%>% mutate(
		expected_rank = (1:n())/n() - (1/n()/2)
		, delta = rank - expected_rank
	)
	%>% ggplot()
	+ geom_ribbon(
		data = ci_ellipse
		, aes(
			x = expected_rank
			, ymin = lo
			, ymax = hi
		)
		, fill = 'transparent'
		, colour = 'black'
		, linetype = 3
	)
	+ geom_line(
		aes(
			x = expected_rank
			, y = delta
			, colour = interaction(variable,model,n,k)
		)
	)
	+ scale_x_continuous(limits=c(0,1),expand=c(0,0))
	+ theme(
		aspect.ratio = 1
	)
)

#define a function that generates a distribution of
# observed_ecdf-to-expected_ecdf correlations under circumstances
# where the data leading to the observed ecdf are indeed generated
# from the distribution leading to the expected ecdf
get_sim_r = function(n,iterations=1e5){
	expected_rank = (1:n)/n - (1/n/2)
	sim_r = rep(NA, iterations)
	for(i in 1:iterations){
		sim_r[i] = cor(sort(runif(n)),expected_rank)
	}
	return(sim_r)
}

#compute a distribution of r-from-the-null given the number of iterations (assumed to be the same across models)
sim_r = get_sim_r(max(a$iteration))

#for each variable, compute an omnibus test of the ecdf
(
	a
	%>% filter(
		num_divergent==0 # possibly questionable!!
	)
	%>% select(var_summary,model,n,k,iteration)
	%>% unnest(var_summary)
	%>% filter(
		rhat<1.01 # possibly questionable!!
	)
	%>% group_by(variable,model,n,k)
	%>% arrange(rank)
	%>% summarise(
		obs_r = cor(rank,(1:n())/n() - (1/n()/2))
		, .groups = 'drop'
	)
	%>% group_by(variable,model,n,k)
	%>% transmute(
		rp = mean(obs_r>sim_r)
		, sig = case_when(rp<.05~'*',T~'') #arbitrary
	)
	%>% arrange(model,n,k,variable)
) -> rp_vals

View(rp_vals)


##
## Prepare England hunger risk index data for mapping
##
library(tidyverse)
library(readxl)
library(rgdal)
library(rmapshaper)
library(spdplyr)

data.dir = "data"

#############################################################################################
## Load boundaries
##
# Middle Layer Super Output Areas (using super generalised clipped because they're the smallest file size)
# source: http://geoportal.statistics.gov.uk/datasets/middle-layer-super-output-areas-december-2011-super-generalised-clipped-boundaries-in-england-and-wales
# I manually removed all Wales MSOAs using QGIS to generate the shapefile used here
msoa_bounds = readOGR(dsn = data.dir,
                      layer = "MSOA_England",
                      verbose = F)

# transform to WGS84 - web Mercator
msoa_bounds = spTransform(msoa_bounds, CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"))

# simplify the boundaries
msoa_bounds = ms_simplify(msoa_bounds)

# get rid of columns we don't need
msoa_bounds = msoa_bounds %>% select(msoa11cd, msoa11nm)

#############################################################################################
## Load hunger index
##
hunger = read_excel(file.path(data.dir, "Oct2018_MSOA_model_BritishRedCross.xlsx"))  # note that this file isn't shipped with the GitHub repository

# merge the hunger risk rate quintiles into the map data
msoa_bounds@data = msoa_bounds@data %>%
  left_join(hunger %>% select(MSOAcode, RiskRateQ), by = c("msoa11cd" = "MSOAcode"))


# H0: HDT-IC == OSTRICH
# Compare means with one-way ANOVA

ostrich <- read.csv('../beara/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-ic/_median_vm.csv')
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 1.387e-05
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.5622
#mean(hdt$ms) # 0.03779415
# HDT-IC < OSTRICH

ostrich <- read.csv('../beara/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-ic/_median_dm.csv')
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.5306667
#mean(hdt$ms) # 0.1093232
# HDT-IC < OSTRICH

ostrich <- read.csv('../beara/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../beara/query/hdt-ic/_median_vq.csv')
# => Reject H0
#mean(ostrich$lookup.mus.inf) # 0.896
#mean(hdt$ms) # 0.365846
# HDT-IC < OSTRICH

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-ic/_median_vm.csv')
#t.test(ostrich$lookup.mus, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus) # 0.1846292
#mean(hdt$ms) # 0.1033203
# HDT-IC < OSTRICH

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-ic/_median_dm.csv')
#t.test(ostrich$lookup.mus, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus) # 0.2104713
#mean(hdt$ms) # 0.4033166
# HDT-IC > OSTRICH !

ostrich <- read.csv('../bearb-daily/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-daily/query/hdt-ic/_median_vq.csv')
# => Reject H0
#mean(ostrich$lookup.mus) # 0.294
#mean(hdt$ms) # 7.52071
# HDT-IC > OSTRICH !

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_vm.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-ic/_median_vm.csv')
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.3094276
#mean(hdt$ms) # 0.08732993
# HDT-IC < OSTRICH

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_dm.csv')
ostrich <- ostrich[which(ostrich$patch_start==0,ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-ic/_median_dm.csv')
#t.test(ostrich$lookup.mus.inf, hdt$ms)
# p: 2.2e-16
# => Reject H0, unequal means
#mean(ostrich$lookup.mus.inf) # 0.3272151
#mean(hdt$ms) # 0.4127122
# HDT-IC > OSTRICH !

ostrich <- read.csv('../bearb-hourly/query/ostrich/_median_vq.csv')
ostrich <- ostrich[which(ostrich$offset==0),]
hdt <- read.csv('../bearb-hourly/query/hdt-ic/_median_vq.csv')
# => Reject H0
#mean(ostrich$lookup.mus.inf) # 0.814
#mean(hdt$ms) # 106.392
# HDT-IC > OSTRICH !


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

par(mai=c(0.2,0.25,0.8,0.25),omi=c(0.75,0.2,0.85,0.2),cex=0.75,
	family="Lato Light",las=1)

# Import data and prepare chart

x<-read.xls("myData/popclass.xlsx", encoding="latin1")

right<-t(as.matrix(data.frame(800,x$F)))
left<--t(as.matrix(data.frame(800,x$M)))

myColour_right<-c(par("bg"),rgb(255,0,210,150,maxColorValue=255))
myColour_left<-c(par("bg"),rgb(191,239,255,maxColorValue=255))

# Create charts and other elements

b1<-barplot(right,axes=F,horiz=T,axis.lty=0,border=NA,col=myColour_right,xlim=c(-8000,8000))
barplot(left,axes=F,horiz=T,axis.lty=0,border=NA,col=myColour_left,xlim=c(-7500,7500),add=T)

abline(v=seq(0,6000,by=2000)+800,col="darkgrey",lty=3)
abline(v=seq(-6000,0,by=2000)-800,col="darkgrey",lty=3)

mtext(format(seq(0,6000,by=2000),big.mark="."),at=seq(0,6000,by=2000)+800,1,line=0,cex=0.95)
mtext(format(abs(seq(-6000,0,by=2000)),big.mark="."),at=seq(-6000,0,by=2000)-800,1,line=0,cex=0.95)
text(0,b1,x$des,cex=1.25,font=3)

mtext("Men",3,line=1,adj=0.25,cex=1.5,col="darkgrey")
mtext("Women",3,line=1,adj=0.75,cex=1.5,col="darkgrey")

# Titling

mtext("Age structure of the population in Germany",3,line=2,adj=0,cex=1.75,family="Lato Black",outer=T)
mtext("Values in thousand per year of age",3,line=-0.5,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: www.destatis.de/bevoelkerungspyramide, own calculations",1,line=2,adj=1.0,cex=0.95,font=3,outer=T)
mtext("...",1,line=2,adj=0,cex=0.95,font=3,outer=T)
dev.off()


left.panel = function() {

    comp = read.csv("qd-tree-comparison.csv")
    filtered = comp %>% filter(tag == "uniform")
    plot(q.size ~ compression, filtered, pch=21, col=NA, bg=rgb(0,0,0,alpha=0.01), log='xy', yaxt='n', xlab=expression(delta), ylab="Digest Size (bytes)", ylim=c(70,6e3), cex=0.4, xlim=c(7,1100))
    points(t.size ~ compression, filtered, pch=21, col=NA, bg=rgb(0,0,0,alpha=0.01), cex=0.4)
    lines(q.size ~ compression, filtered %>% group_by(compression) %>% summarise(q.size=mean(q.size)), type='c')
    lines(t.size ~ compression, filtered %>% group_by(compression) %>% summarise(t.size=mean(t.size)), type='c')

    axis(side=2, at=c(100, 200, 500, 1000,2e3,5e3), labels=c("100", "200", "500", "1kB","2kB","5kB"))
    lines(c(7,16), c(954,954), col='grey')
    lines(c(25,160), c(954,954), col='grey')
    lines(c(250,1100), c(954,954), col='grey')

    text(25, 2500, expression(Q-digest), cex=0.7)
    text(400, 4000, expression(italic(t)-digest), cex=0.7)

    lines(c(20, 20), c(750, 270), col='grey')
    lines(c(20, 20), c(180, 110), col='grey')
    text(20, 85, expression(delta[italic(q)]==20), cex=0.7)

    lines(c(200, 200), c(750, 110), col='grey')
    text(200, 85, expression(delta[italic(t)]==200), cex=0.7)
}

right.panel = function(small=F) {
    boxplot(e2 ~ q, comp %>% filter(tag == "uniform", compression==20 ),
            boxwex=0.3, at=1:11-0.17, xaxt='n', col='grey',
            ylab="Absolute Error", xlab=expression(italic(q)),
            ylim=c(0,0.091), lwd=0.7, cex=0.5, cex.axis=0.9)

    boxplot(e1 ~ q, comp %>% filter(tag == "uniform", compression==200 ),
            boxwex=0.3, at=1:11+0.17, xaxt='n', add=T, lwd=0.7, cex=0.5, yaxt='n')

    axis(side=1, at=1:11,
         labels=c(expression(10^-5), expression(10^-4), expression(10^-3),
                  "0.01", "0.1", "0.5",
                  "0.9", "0.99", "0.999", "0.9999", "0.99999"),
         las=2, cex.axis=0.9)

    abline(h=0, col=rgb(0,0,0,alpha=0.2), lwd=1)
    if (small) {
        x.legend = 5.5
        cex.legend = 0.9
    } else {
        x.legend = 5.1
        cex.legend = 0.65
    }
    legend(x.legend, 0.092,
           legend=expression(italic(t)-"digest  " (delta[italic(t)]==200),
                             Q-"digest "(delta[italic(q)]==20)),
           fill=c('white', 'grey'), cex=cex.legend)
}

require(dplyr)
pdf(file="qd-sizes.pdf", width=4.5, height=2, pointsize=9, family='serif')
layout(matrix(c(1,2), nrow=1))

par(cex.axis=0.8)
par(cex.lab=1.1)
par(mar=c(3.2, 3.3, 0.2, 0.2))
par(mgp=c(2.0, 0.5, 0))
par(tcl=-0.3)
par(las=2)

left.panel()
right.panel()
dev.off()

pdf(file="qd-sizes-small.pdf", width=3, height=2.2, pointsize=9, family='serif')
par(cex.axis=0.8)
par(cex.lab=1.3)
par(mar=c(3.2, 3.3, 0.2, 0.2))
par(mgp=c(2.0, 0.5, 0))
par(tcl=-0.3)
par(las=2)

right.panel(small=T)
dev.off()


## collection of R packages for D.S
library(tidyverse)
## A new package which provides a set of tools for efficiently manipulating datasets in R
library(dplyr)
## A R package dedicated to Data Visualization
library(ggplot2)
## A package for creating interactive, publication-quality graphs
library(plotly)
## A package that contains a lot of outlines of continents, countries, states, and counties that have been with R
library(maps)
## A package that contains demographic data on the United States at the county and state levels
library(usdata)

## Data Loading
incarceration <- read.csv("https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv")

## Filtered Data for jail rates data
entire_country_jail_rate <- incarceration %>% mutate(total_jail_rate = round(((total_jail_pop / total_pop)*100),2)) %>%
  mutate(black_jail_rate = round(((black_jail_pop / black_pop_15to64)*100),2)) %>% mutate(white_jail_rate = round(((white_jail_pop / white_pop_15to64)*100),2)) %>%
  select (year, region, total_jail_rate, white_jail_rate, black_jail_rate)

## Data of jail rates in south region
south_states <- entire_country_jail_rate %>% filter(region == "South") %>% slice(31:49)
mean_south_total <- round(mean(south_states$total_jail_rate),2)
mean_south_white <- round(mean(south_states$white_jail_rate),2)
mean_south_black <- round(mean(south_states$black_jail_rate),2)

## Black jail rate over white jail rate data in south region
black_white_diff_south <- south_states %>% mutate(black_white_diff = round((black_jail_rate / white_jail_rate),2)) %>%
                                                    select(year, region, black_white_diff)

## Data of jail rates in west region
west_states <- entire_country_jail_rate %>% filter(region == "West") %>% slice (31:49)
mean_west_total <- round(mean(west_states$total_jail_rate),2)
mean_west_white <- round(mean(west_states$white_jail_rate),2)
mean_west_black <- round(mean(west_states$black_jail_rate),2)

## Black Jail Rate / White Jail Rate (West)
black_white_diff_west <- west_states %>% mutate(black_white_diff = round((black_jail_rate / white_jail_rate),2)) %>%
  select(year, region, black_white_diff)

## Data of jail rates in south region
midwest_states <- entire_country_jail_rate %>% filter(region == "Midwest") %>% slice(31:49)
mean_midwest_total <- round(mean(midwest_states$total_jail_rate),2)
mean_midwest_white <- round(mean(midwest_states$white_jail_rate),2)
mean_midwest_black <- round(mean(midwest_states$black_jail_rate),2)

## Black Jail Rate / White Jail Rate (Midwest)
black_white_diff_midwest <- midwest_states %>% mutate(black_white_diff = round((black_jail_rate / white_jail_rate),2)) %>%
  select(year, region, black_white_diff)

## Mean value of black jail rate over white jail rate in different regions
mean_south <- round(mean(black_white_diff_south$black_white_diff),2)
mean_west <- round(mean(black_white_diff_west$black_white_diff),2)
mean_midwest <- round(mean(black_white_diff_midwest$black_white_diff),2)

## Combined data of black jail rate over white jail rate data in different regions
black_white_diff_combined <- rbind(black_white_diff_west, black_white_diff_south, black_white_diff_midwest)

## Comparison of black jail rate over white jail rate data in different regions (Trends over-time chart)
ggp_total <- ggplot(black_white_diff_combined, aes(x = year, y = black_white_diff, color = region)) + geom_line()
print(ggp_total + labs(title = "Black Over White Jail Rate By Regions (2000-2018)", y = "Black over White Jail Rate", x= "Year", color = "Region"))

## Change in jail rate of black people in different regions during 2000-2018 (Variable Comparison Chart)
black_south <- south_states %>% select(year, region, black_jail_rate)
black_west <- west_states %>% select(year, region, black_jail_rate)
black_midwest <- midwest_states %>% select(year, region, black_jail_rate)
black <- rbind(black_south, black_west, black_midwest)

bar_black <- ggplot(black, aes(x = year, y = black_jail_rate, fill = region)) + geom_col(position = "dodge")
print(bar_black + labs(title = "Change in Jail Rate of Black in Different Regions (2000-2018)", y = "Black Jail Rate (%)", x = "Year", color = "Region"))

## Black jail rate over total jail rate in 2018 in the United States (MAP)
data_map <- incarceration %>% mutate(white_jail_rate = round(((white_jail_pop / white_pop_15to64)*100),2)) %>%
  mutate(black_jail_rate = round((black_jail_pop / black_pop_15to64)*100),2) %>%
  select (year, state, county_name, white_jail_rate, black_jail_rate, fips) %>% filter(year == 2018)

data_map <- data_map %>% mutate(black_over_white = round(((black_jail_rate / white_jail_rate)*100),2)) %>%
  select(state, county_name, black_over_white, fips)

map_shapes <- map_data("county") %>%
  unite(polyname, region, subregion, sep = ",") %>% left_join(county.fips, by="polyname")

map_data <- map_shapes %>% left_join(data_map, by="fips")

blank_theme <- theme_bw() +
  theme(
    axis.line = element_blank(),
    axis.text = element_blank(),
    axis.ticks = element_blank(),
    axis.title = element_blank(),
    plot.background = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    panel.border = element_blank()
  )

final_map <- ggplot(map_data) +
  geom_polygon(
    mapping = aes(x = long, y =lat, group = group, fill = black_over_white),
    color = "gray", size = 0.3
  ) +
  coord_map() +
  scale_fill_continuous(limits = c(0, max(map_data$black_over_white)), na.value = "white", low = "yellow", high = "red") + blank_theme +
  ggtitle("Black Jail Rate over White Jail Rate in the United States") +
  guides(fill=guide_legend(title="Black over white jail rate"))

final_map


## Code to produce JSON data set for budget Sankey diagram
## Simple one with just Fund -> Purpose
## read in data set and create summary table.
costs <- read.csv("./sankey/budg-11.csv")
yum <- tapply(costs$Closing.Balance,INDEX=list(costs$FUND.DESC,costs$PURP.1.DESC),FUN=sum, na.rm=T)
yum[is.na(yum)] <-0

library("RJSONIO")

## Create nodes list
aa <- c(rownames(yum), colnames(yum))
names(aa) <- rep("name", length(aa))
cc <- fromJSON("./sankey/energy.json")
nn <- NULL
for(ii in 1:length(aa)) nn <- c(nn,list(aa[ii]))
ee <- cc
ee[["nodes"]] <- nn

## Create links list
library(bipartite)
ff <- web2edges(yum1, return=TRUE)
rownames(ff) <- NULL
ff <- data.frame(ff)
ff$row <- ff$row-1
ff$col <- ff$col-1
colnames(ff) <- c("source", "target", "value")

ll <- NULL
for(ii in 1:nrow(ff)) ll <- c(ll,list(unlist(ff[ii,])))
ee[["links"]] <- ll

## save to file.
cat(toJSON(ee),file="./sankey/budg.json")

########################
## Let's kick it up a notch with FUND -> PURPOSE -> OBJECT.DESC
# Need to build on codes above
yum2 <- tapply(costs$Closing.Balance,INDEX=list(costs$PURP.1.DESC,costs$OBJECT.DESC),FUN=sum, na.rm=T)

aa <- c(rownames(yum), colnames(yum), colnames(yum2))
names(aa) <- rep("name", length(aa))
cc <- fromJSON("./sankey/energy.json")
nn <- NULL
for(ii in 1:length(aa)) nn <- c(nn,list(aa[ii]))
gg <- cc
gg[["nodes"]] <- nn

nodevec <- as.character(unlist(gg$nodes))
hh <- web2edges(yum2, return=TRUE)
rownames(hh) <- NULL
hh <- data.frame(hh)
hh$row <- hh$row-1+length(rownames(yum))
hh$col <- hh$col-1+length(rownames(yum))
colnames(hh) <- c("source", "target", "value")

ww <- rbind(ff,hh)

ll <- NULL
for(ii in 1:nrow(ww)) ll <- c(ll,list(unlist(ww[ii,])))
gg[["links"]] <- ll

cat(toJSON(gg),file="./sankey/cpcc2.json")

########################
## Unwieldly.
## Maybe just for academic departments?
## FUND -> PURPOSE -> OBJECT.DESC -> UNIT.DESC
yum3 <- tapply(costs$Closing.Balance,INDEX=list(costs$OBJECT.DESC,costs$UNIT.DESC),FUN=sum, na.rm=T)

facsub <- as.character(unique(costs$UNIT.DESC[costs$OBJECT.DESC=="FT Faculty" | costs$OBJECT.DESC=="PT Faculty"]))
facsub <- as.character(unique(costs$UNIT.DESC[costs$UNIT.1==3]))
acadunits <- read.csv("/projects/CBD/crosta/data/CostsPerCredit0708-0910.csv")
## only include curriculum budget codes as last stop.
facsub <- as.character(unique(costs$UNIT.DESC[costs$UNIT %in% unique(acadunits$UnitId)]))
yum3 <- yum3[,facsub]

aa <- c(rownames(yum), colnames(yum), colnames(yum2), colnames(yum3))
names(aa) <- rep("name", length(aa))
cc <- fromJSON("/home/crosta/public_html/sankey/energy.json")
nn <- NULL
for(ii in 1:length(aa)) nn <- c(nn,list(aa[ii]))
qq <- cc
qq[["nodes"]] <- nn

nodevec <- as.character(unlist(gg$nodes))
zz <- web2edges(yum3, return=TRUE)
rownames(zz) <- NULL
zz <- data.frame(zz)
zz$row <- zz$row-1+length(rownames(yum))+length(rownames(yum2))
zz$col <- zz$col-1+length(rownames(yum))+length(rownames(yum2))
colnames(zz) <- c("source", "target", "value")

vv <- rbind(ff,hh,zz)

ll <- NULL
for(ii in 1:nrow(vv)) ll <- c(ll,list(unlist(vv[ii,])))
qq[["links"]] <- ll

cat(toJSON(qq),file="./sankey/cpcc3.json")

########### ISOLATE spending on FT and PT faculty  ###############
faculty <- subset(costs, subset=OBJECT.DESC=="FT Faculty" | OBJECT.DESC=="PT Faculty")
#faculty <- subset(costs, subset=(OBJECT.DESC=="FT Faculty" | OBJECT.DESC=="PT Faculty") & UNIT %in% unique(acadunits$UnitId))
facsum <- with(faculty, tapply(Closing.Balance, INDEX=list(as.character(UNIT.DESC), as.character(OBJECT.DESC)), FUN=sum))
facsum <- data.frame(facsum)
facsum$total <- rowSums(facsum[,c(1,2)], na.rm=T)
facsum$pctFT <- 100*facsum$FT.Faculty/facsum$total
facsum$pctPT <- 100*facsum$PT.Faculty/facsum$total
hist(facsum$pctFT)
plot(density(facsum$pctFT, na.rm=T))
#############################################################