library("gmp")
BinarySpaghettiSort <- function(values, reverse=F) {
  length <- length(values)
  if (length>30) {
    print("Input vector too long for R, if you need to use longer vectors use GMP for R and libgmp3-dev")
    return <- values
  }
  sorted <- c()
  maximum <- max(values)
  minimum <- min(values)
  binary_spaghetti_heads_index <- rep(0, (maximum-minimum+1))

  for (i in seq_along(values)) {
    n = values[[i]]
    position <- (n-minimum+1)
    binary_spaghetti_heads_index[position] <- binary_spaghetti_heads_index[position] + bitwShiftL(1,(length-i))
  }
  index <- 1
  start <- 1
  stop <- length(binary_spaghetti_heads_index)
  pace <- 1
  if (reverse==T) {
    start <- length(binary_spaghetti_heads_index)
    stop <- 1
    pace <- -1
  }
  for (i in seq(start,stop,pace)) {
    vxor <- binary_spaghetti_heads_index[i]
    while (vxor > 0) {
      k <- round(log2(vxor), digits = 0)
      sorted[index] <- values[length-k]
      vxor <- bitwXor(vxor, bitwShiftL(1,k))
      index <- index + 1
    }
  }
  return <- sorted
}


library(doMC)
registerDoMC(cores=4)

setwd("~/Desktop/chapter 2")
mydata <- read.csv("WA_Fn-UseC_-HR-Employee-Attrition.csv")
mydata$EmployeeNumber=mydata$Over18=mydata$EmployeeCount=mydata$StandardHours = NULL

library(caret)
library(caretEnsemble)

control <- trainControl(method="repeatedcv", number=10, repeats=10, savePredictions=TRUE, classProbs=TRUE,index=createMultiFolds(mydata$Attrition, k=10, times=10))
algorithmList <- c('C5.0', 'nb', 'glm', 'knn', 'svmRadial')
set.seed(10000)
models <- caretList(Attrition~., data=mydata, trControl=control, methodList=algorithmList)
results <- resamples(models)
results

summary(results)

# correlation between results
modelCor(results)

stackControl <- trainControl(method="repeatedcv", number=10, repeats=10, savePredictions=TRUE, classProbs=TRUE)
# stack using glm
stack.glm <- caretStack(models, method="glm", trControl=stackControl)
print(stack.glm)

stack.rf <- caretStack(models, method="rf", trControl=stackControl)
print(stack.rf)


pacman::p_load(foreign)
#
# machine = read.table("machine.data", sep=",")
# names(machine)[1] <- "vendor name"
# names(machine)[2] <- "Model Name"
# names(machine)[3] <- "MYCT"
# names(machine)[4] <- "MMIN"
# names(machine)[5] <- "MMAX"
# names(machine)[6] <- "CACH"
# names(machine)[7] <- "CHMIN"
# names(machine)[8] <- "CHMAX"
# names(machine)[9] <- "PRP"
# names(machine)[10] <- "ERP"
# machine$`vendor name` = as.factor(machine$`vendor name`)
#
# idx= which(colnames(machine) == "Model Name")
# machine = machine[ ,-idx] #usuni?cie nie potrzebnej danej
#
# summary(machine)
#
# pacman::p_load(corrplot)
# machine.cor <- sapply(machine,function(x) as.numeric(x))
# cor_matrix=cor(machine.cor)
# corrplot.mixed(cor_matrix)

rmse <- function(actual, predicted){
  sqrt(mean((actual - predicted)^2))
}
mse <- function(actual, predicted){
  mean((actual - predicted)^2)
}
wczytaj_machine <- function(){
  machine = read.table("machine.data", sep=",")
  names(machine)[1] <- "vendor name"
  names(machine)[2] <- "Model Name"
  names(machine)[3] <- "MYCT"
  names(machine)[4] <- "MMIN"
  names(machine)[5] <- "MMAX"
  names(machine)[6] <- "CACH"
  names(machine)[7] <- "CHMIN"
  names(machine)[8] <- "CHMAX"
  names(machine)[9] <- "PRP"
  names(machine)[10] <- "ERP"
  machine$`vendor name` = as.factor(machine$`vendor name`)

  idx= which(colnames(machine) == "Model Name")
  machine = machine[ ,-idx] #usuni?cie nie potrzebnej danej
  idx= which(colnames(machine) == "ERP")
  machine = machine[ ,-idx] #usuni?cie nie potrzebnej danej

  machine = as.data.frame(sapply(machine, as.numeric))#zmiana na numeryczne i "ramke"
  set.seed(123)
  indexy <- sample(nrow(machine), size = trunc(0.25* nrow(machine)) )
  train <- machine[indexy, ]
  test <- machine[-indexy, ]

  tmp <- lm(PRP~1 , data = machine)
  forward <- step(tmp, direction = "forward", scope = list(upper=.~.+`vendor name`+MYCT+MMIN+MMAX+CACH+CHMIN+CHMAX), trace=0)
  summary(forward)$r.squared#0.8648239

  tmp <- lm(PRP~+`vendor name`+MYCT+MMIN+MMAX+CACH+CHMIN+CHMAX , data = machine)
  backward <- step(tmp, direction = "backward", scope = list(upper=.~.+`vendor name`+MYCT+MMIN+MMAX+CACH+CHMIN+CHMAX), trace=0)
  summary(backward)$r.squared#0.8648239

  tmp <- lm(PRP~. , data = machine)
  both <- step(tmp, direction = "both", scope = list(upper=.~.+`vendor name`+MYCT+MMIN+MMAX+CACH+CHMIN+CHMAX), trace=0)
  summary(both)$r.squared #0.8648239

  nazwyKolumn <- variable.names(both) #wszystkie wybrały to samo
  nazwyKolumn[1] <- "PRP" #poprawka nazwy

  return (list("columns" = nazwyKolumn, "train" = train, "test"=test))
}

svm_machine <- function(kolumny, dane, kernel = "radial"){
  model = svm(PRP~., data=dane[,kolumny], kernel = kernel, type="nu-regression")
  return (model)
}


# RANGESCALE.R
#
# R program to define a function to rangescale columns of a matrix

rangescale <- function(X) {

	Xmax <- apply(X, 2, max)
	Xscaled = scale(X, scale=Xmax, center=FALSE)

	return(Xscaled)
}


rm(list = ls())
# setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)

seed = 1234
set.seed(seed)

# ( '[-40,-20]' '[-6,-2]' '[-6.1,-1.2]' '[-2,-0.2]'  '[[-6,-2],[2,6]]' '[0.2,2]'   '[2,6]' '[1.2,6]'  '[20,40]' )
simulate.mse = function(epsilon, samples, operation, simple, input.size, subset.ratio, overlap.ratio, range.a, range.b, range.mirror) {
  # matrix = (data, row, cols)
  # runif = generate random numbers of len of the 1st arg with ranges a to b
  X = matrix(runif(samples * input.size, range.a, range.b), samples, input.size)

  if (range.mirror) {
    # rbinom(n (|obvs|), size, prob) = rbinom(number of runs, ntrials, success prob)
    # rbinom(400, size = 10, prob = 0.2) = gives the results of 400 runs of 10 coin flips each, returning the number of successes in each run.
    # creates a sign matrix (of -1 and 1s) using a binomial dist
    X.sign = matrix(rbinom(samples * input.size, 1, 0.5), samples, input.size) * 2 - 1
    X = X * X.sign
  }

  evaluate = function(epsilon) {
    # X = [N, in], W = [In, 1], Y = [N,1]
    subset.size = floor(subset.ratio * input.size)
    a.start = 1
    a.end = a.start + subset.size

    # single layer operation
    if (operation == 'add') {
      Y = matrix(rowSums(X[, a.start:a.end]) - (rowSums(abs(X)) * epsilon))
    } else if (operation == 'sub') {
      Y = matrix((X[, a.start] - X[, a.end]) - (rowSums(abs(X)) * epsilon))
    } else if (operation == 'mul') {
      relevant.inp.calc = (1 - epsilon)^2 * apply(X[, a.start:a.end], 1, prod)
      # if there's no irrelevant inputs then we'll just multiply by 1
      if (a.end == ncol(X)) {
        irrelevant.inp.calc = 1
      }else {
        irrelevant.inp.calc = apply(1 - (epsilon * abs(X[, (a.end + 1):ncol(X)])), 1, prod)
      }
      Y = matrix(relevant.inp.calc * irrelevant.inp.calc)
    } else if (operation == 'div') {
      relevant.inp.calc = ((1 - epsilon) / (1 + epsilon)) * (X[, a.start] / X[, a.end])
      # if there's no irrelevant inputs then we'll just multiply by 1
      if (a.end == ncol(X)) {
        irrelevant.inp.calc = 1
      }else {
        irrelevant.inp.calc = apply(1 - (epsilon * abs(X[, (a.end + 1):ncol(X)])), 1, prod)
      }
      Y = matrix(relevant.inp.calc * irrelevant.inp.calc)
    }
    return(Y)
  }

  errors = (evaluate(epsilon) - evaluate(0))**2
  return(mean(errors))
}

# ( '[-40,-20]' '[-6,-2]' '[-6.1,-1.2]' '[-2,-0.2]'  '[[-6,-2],[2,6]]' '[0.2,2]'   '[2,6]' '[1.2,6]'  '[20,40]' )
cases = rbind()
for (operation in c('add', 'sub', 'mul', 'div')) {
  cases = rbind(cases,
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = -40, range.b = -20, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = -6, range.b = -2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = -6.1, range.b = -1.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = -2, range.b = -0.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = T),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = 0.2, range.b = 2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = 1.2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 2, subset.ratio = 0.5, overlap.ratio = 0, range.a = 20, range.b = 40, range.mirror = F)
  )
}
for (operation in c('add', 'sub')) {
  cases = rbind(cases,
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = -40, range.b = -20, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = -6, range.b = -2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = -6.1, range.b = -1.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = -2, range.b = -0.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = T),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = 0.2, range.b = 2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = 1.2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 10, subset.ratio = 0.1, overlap.ratio = 0, range.a = 20, range.b = 40, range.mirror = F),

                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = -40, range.b = -20, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = -6, range.b = -2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = -6.1, range.b = -1.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = -2, range.b = -0.2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = T),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = 0.2, range.b = 2, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = 2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = 1.2, range.b = 6, range.mirror = F),
                c(parameter = 'extrapolation.range', operation = operation, simple = F, input.size = 100, subset.ratio = 0.01, overlap.ratio = 0, range.a = 20, range.b = 40, range.mirror = F)
  )
}

eps = data.frame(rbind(
  c(operation = 'mul', epsilon = 0.0001),
  c(operation = 'add', epsilon = 0.0001),
  c(operation = 'sub', epsilon = 0.0001),
  c(operation = 'div', epsilon = 0.0001)
))

dat = data.frame(cases) %>%
  merge(eps) %>%
  mutate(
    simple = as.logical(as.character(simple)),
    input.size = as.integer(as.character(input.size)),
    subset.ratio = as.numeric(as.character(subset.ratio)),
    overlap.ratio = as.numeric(as.character(overlap.ratio)),
    range.a = as.numeric(as.character(range.a)),
    range.b = as.numeric(as.character(range.b)),
    range.mirror = as.logical(as.character(range.mirror)),
    epsilon = as.numeric(as.character(epsilon))
  ) %>%
  rowwise() %>%
  mutate(
    threshold = simulate.mse(epsilon, 1000000, operation, simple, input.size, subset.ratio, overlap.ratio, range.a, range.b, range.mirror),
    extrapolation.range = ifelse(range.mirror, ifelse(range.b <= 0, paste0('U[', range.b * -1, ',', range.a * -1, '] & U[', range.a, ',', range.b, ']'), paste0('U[-', range.b, ',-', range.a, '] & U[', range.a, ',', range.b, ']')), paste0('U[', range.a, ',', range.b, ']')), # if a and b are -ve then want: [[+,+],[-,-]]
    operation = paste0('op-', operation)
  )

# TODO - set samples to 1000000
write.csv(dat, file = "1e-4_eps_thrs_sltr.csv", row.names = F)
print("Script completed.")


# Load/run the main Python script
source_python("src/rfe.py")
support <- support("C:\\DM2\\r-binary-classification")

Churn <- normalizedDataset$isChurn
drops <- c("isChurn")

#PCA doesn't help the company to understand what variables are more important
pca<- prcomp( normalizedDataset[ ,!(names(normalizedDataset) %in% drops)],
              center = TRUE,
              scale. = TRUE)

# Plot of the variances (y-axis)
# associated with the PCs (x-axis).
plot(pca, type = "l")

summary(pca)

comp3 <- pca$x[,1:4]
comp3[,4] <- normalizedDataset$isChurn
colnames(comp3)[4] <- 'isChurn'
comp3 <- as.data.frame(comp3)


x <- read.csv('/usercode/files/titanic.csv')

v <- x[x$Age>=18,]
tapply(v$Pclass, v$Survived, mean)

SoloLearn/R/Analyzing Data with R - Titanic Survivors .r


#' Calculate a zoom given a bounding box
#'
#' Calculate a zoom given a bounding box
#'
#' calc_zoom can calculate a zoom based on either (1) a data frame with longitude and latitude variables, (2) a longitude range and latitude range, or (3) a bounding box.  the specification for (1) is identical to that of most R functions, for (2) simply put in a longitude range into lon and a latitude range into lat, and for (3) put the bounding box in for the lon argument.
#'
#' @param lon longitude, see details
#' @param lat latitude, see details
#' @param data (optional) a data frame containing lon and lat as variables
#' @param adjust number to add to the calculated zoom
#' @param f argument to pass to make_bbox
#' @export
#' @seealso \code{\link{make_bbox}}
#' @examples
#' \dontrun{
#'
#' # data specification
#' calc_zoom(lon, lat, wind)
#'
#'
#' # range specification
#" lon_range <- extendrange( wind$lon )
#" lat_range <- extendrange( wind$lat )
#' calc_zoom(lon_range, lat_range)
#'
#'
#' # box specification
#' box <- make_bbox(lon, lat, data = crime)
#' calc_zoom(box)
#'
#' }
#'
calc_zoom <- function(lon, lat, data, adjust = 0, f = .05){

  if(!missing(adjust)) stopifnot(is.integer(adjust))

  # compute lon_range and lat_range for all specifications
  if(missing(data)){  # either ranges or a box

  	if(missing(lat)){ # a box
  	  bbox <- lon
  	  errorString <-
  	    "if specifying a bounding box, the format should match that of make_bbox."
  	  if(length(bbox) != 4) stop(errorString, call. = FALSE)
  	  if(!all(names(bbox) == c("left", "bottom", "right", "top")))
  	    stop(errorString, call. = FALSE)
      lon_range <- bbox[c("left", "right")]
      lat_range <- bbox[c("bottom", "top")]

  	} else { # ranges
  	  if(length(lon) != 2 || length(lat) != 2 || !is.numeric(lon) || !is.numeric(lat))
  	    stop("if specifying ranges, they both must be of length 2 and numeric.")

      lon_range <- sort(lon)
      lat_range <- sort(lat)
  	}

  } else { # data argument is specified
    lon <- data[,deparse(substitute(lon))]
    lat <- data[,deparse(substitute(lat))]
    bbox <- make_bbox(lon, lat, f = f)
    lon_range <- bbox[c("left", "right")]
    lat_range <- bbox[c("bottom", "top")]
  }

  lonlength <- diff(lon_range)
  latlength <- diff(lat_range)
  zoomlon <- ceiling(log2(360 * 2/lonlength))
  zoomlat <- ceiling(log2(180 * 2/latlength))
  zoom <- max(zoomlon, zoomlat)

  zoom + adjust
}


 ZSPTRF Example Program Results

 Details of factorization
                    1                 2                 3                 4
 1  (-0.3900,-0.7100)
 2  (-7.8600,-2.9600) (-2.8300,-0.0300)
 3  ( 0.5279,-0.3715) (-0.6078, 0.2811) ( 4.4079, 5.3991)
 4  ( 0.4426, 0.1936) (-0.4823, 0.0150) (-0.1071,-0.3157) (-2.0954,-2.2011)

 IPIV
           -3                -3                 3                 4


library ('factoextra')
library ('mclust')
data = read.table ({{i.infile | quote}}, sep="\t", header={{args.cnames | R}}, row.names={{args.rnames | lambda x: 'NULL' if not x else int(x)}}, check.names=F)
if ({{args.transpose | R}}) {
	data = t(data)
}

data = data[, apply(data, 2, sd)!=0, drop=F]
mc        = Mclust (data, G={{args.minc}}:{{args.maxc}})
clustfile = file.path ({{o.outdir | quote}}, "clusters.txt")
write.table (mc$classification, clustfile, quote=F, col.names = F, sep="\t")
clustfig  = file.path ({{o.outdir | quote}}, "clusters.png")
do.call(png, c(list(file = clustfig), {{args.devpars | Rlist}}))
labels    = colnames(data)
print (fviz_cluster (mc, main = ""))
dev.off()


library(e1071)
dataset <- read.csv('kdd_cup_test_1.csv',head=FALSE)
index <- 1:nrow(dataset)
testindex <- sample(index, trunc(length(index)*30/100))
testset <- dataset[testindex,]
trainset <- dataset[-testindex,]
sink("summary_svm.txt")
model <- svm(V42~., data = trainset)
summary(model)
prediction <- predict(model, testset[,-42])
tab <- table(actual = testset[,42],predictions=prediction)
tn<-tab[1,1]
cat("tn")
tn
cat("fp")
fp<-tab[1,2]
fp
cat("fn")
fn<-tab[2,1]
fn
cat("tp")
tp<-tab[2,2]
tp


library(EpiEstim)
library(tidyverse)
library(lubridate)

reported_cases <- read_csv("E:\\Pythonfiles\\Github_Programs\\EstmatingRtDeepL\\Rt_Methods_Comparision\\ontario_cases.csv")
reported_cases$date <- ymd(reported_cases$date)
head(reported_cases)

## make config
config_lit <- make_config(
  mean_si = 12.0,
  std_si = 5.2
)

epiestim_res_lit <- estimate_R(
  incid = reported_cases$confirm,
  method = "parametric_si",
  config = config_lit
)
ontario_epiestim_export <- as.data.frame(epiestim_res_lit$I_local)

write_csv(epiestim_res_lit$R, "ontario_epiestim_Rt.csv")
write_csv(ontario_epiestim_export, "ontario_epiestim_It.csv")


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 12, 2016
# ref: http://harding.edu/fmccown/r/
# clear; Rscript piePlot.r ; rm *~

# inputs: nothing
# outputs: figures/piePlot1.eps

# set the working directory
setwd("~/Copy/Programming/R/rprograms/plotting/2dplots/")

# Start device driver to save output to figure.pdf
#postscript(file="figures/piePlot1.eps", height=3.5, width=5)

# Define cars vector with 5 values
cars <- c(1, 3, 6, 4, 9)

# Create a pie chart for cars
pie(cars)

#Now let's add a heading, change the colors, and define our own labels:
# Define cars vector with 5 values
cars <- c(1, 3, 6, 4, 9)

# Create a pie chart with defined heading and
# custom colors and labels
pie(cars, main="Cars", col=rainbow(length(cars)),
   labels=c("Mon","Tue","Wed","Thu","Fri"))

#Now let's change the colors, label using percentages, and create a legend:
# Define cars vector with 5 values
cars <- c(1, 3, 6, 4, 9)

# Define some colors ideal for black & white print
colors <- c("white","grey70","grey90","grey50","black")

# Calculate the percentage for each day, rounded to one
# decimal place
car_labels <- round(cars/sum(cars) * 100, 1)

# Concatenate a '%' char after each value
car_labels <- paste(car_labels, "%", sep="")

# Create a pie chart with defined heading and custom colors
# and labels
pie(cars, main="Cars", col=colors, labels=car_labels,
   cex=0.8)

# Create a legend at the right
legend(1.5, 0.5, c("Mon","Tue","Wed","Thu","Fri"), cex=0.8,
   fill=colors)

# Turn off device driver (to flush output)
#dev.off()


# calculate long-term observed temperature change by latitude
# using UDel, GISS, and ERSST 1900-2014
#  get UDel data at http://climate.geog.udel.edu/~climate/html_pages/Global2014/air_temp_2014.tar.gz (233MB file)
#  get ERSST data at https://www1.ncdc.noaa.gov/pub/data/cmb/ersst/v4/ascii/ (used a small bash loop)
#  get GISS https://data.giss.nasa.gov/gistemp/
# at 2x2° (aggregate UDel to 2x2, ERSST already there, GISS already there)

library(reshape2)

############################################################
# Read in UDel ascii files and average by 2x2° within years
############################################################

# find files
files <- list.files('data/udel/air_temp_2014')

# extract years
m <- regexpr('[[:digit:]]{4}', files)
years <- as.numeric(regmatches(files, m))

# extract the data and average to 2x2
tempsarray = array(data=NA, dim=c(90, 180, length(files))) # giant array stack of all temperature data (lat, lon, year)
	dimnames(tempsarray)[[1]] = seq(-89, 89, by=2)
	dimnames(tempsarray)[[2]] = seq(-179, 179, by=2)
	dimnames(tempsarray)[[3]] = years

tmpl <- expand.grid(lat=seq(-89, 89, by=2), lon=seq(-179, 179, by=2)) # template with all lats and lons

for(i in 1:length(files)){ # for each file
	print(files[i])
	x <- read.table(paste('data/udel/air_temp_2014/', files[i], sep=''), header=FALSE)
	names(x) <- c('lon', 'lat', 'jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')

	# add 2x2 grid indicators
	x$longrid <- floor(x$lon/2)*2+1
	x$latgrid <- floor(x$lat/2)*2+1

	# average within years
	x$ave <- rowMeans(x[,c('jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')])

	# average within 2x2 grids
	x2 <- aggregate(list(ave = x$ave), by=list(lat=x$latgrid, lon=x$longrid), FUN=mean)

	# add missing lat/lons
	x3 <- merge(tmpl, x2, all.x=TRUE)

	# reshape
	x4 <- melt(x3, id.vars=c('lat', 'lon'), measure.vars=c('ave'))
	x5 <- acast(x4, lat ~ lon) # easy with reshape2!

	# add to tempsarray
	tempsarray[,,i] = x5
}

	# quick look
	dim(tempsarray)
	summary(tempsarray)
	image(t(tempsarray[,,1])) # looks great!
	image(t(tempsarray[,,100])) # looks great!
	tempsarray['1','-61',110] # tropics
	tempsarray['-89','-99',110] # antarctic
	tempsarray['89','-99',110] # arctic: missing
	tempsarray['65','-121',110] # northern canada
		dimnames(tempsarray)[[3]][110] # 2009

	range(tempsarray['-89','-97',], na.rm=TRUE) # antarctic: always cold
	range(tempsarray['65','-121',], na.rm=TRUE) # northern canada
	range(tempsarray['1','-61',], na.rm=TRUE) # tropics: warm

# Write out
save(tempsarray, file=paste('data/udel/udel2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

##############################################################
# Read in GISS netcdf files (already at 2x2) and calculate annual average
##############################################################
require(ncdf4)

# get data from 2x2 grid
	# read in
n = nc_open('data/gisstemp/gistemp250.nc') # Open the netCDF file
# print(n) # get information about the file format

inarray = ncvar_get(n, 'tempanomaly') # dim order: 180 lon x 90 lat x 1651 time (observations are monthly, time measured in days since Jan 1, 1800). 0 lon is at date line.
	# dim(inarray)
dimnames(inarray)[[1]] <- ncvar_get(n, 'lon')
dimnames(inarray)[[2]] <- ncvar_get(n, 'lat')
dimnames(inarray)[[3]] <- paste(rep(1880:2017, rep(12,138)), formatC(1:12, width=2, flag=0), sep='-')[1:dim(inarray)[3]]

nc_close(n)

	# annual average
	# reshape so month a separate dimension
temp <- melt(inarray, varnames=c('lon', 'lat', 'time'), value.name='lst')
temp$year <- as.numeric(substr(temp$time, 1, 4))
temp$mo <- as.numeric(substr(temp$time, 6, 7))
temp2 <- acast(temp[temp$year %in% 1900:2014,], lat ~ lon ~ year ~ mo, value.var='lst') # dim order: lat x lon x year x mo
years <- as.numeric(dimnames(temp2)[[3]])

	# average
tempsarray <- apply(temp2, MARGIN=c(1,2,3), FUN=mean)

	# Write out
save(tempsarray, file=paste('data/gisstemp/giss2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

# get data from zonal average
n = nc_open('data/gisstemp/zonmap.nc')
print(n)
gisslat <- ncvar_get(n, 'temperature') # dim order: 1404 time (monthly 1900-2017) x 46 lat
colnames(gisslat) <- ncvar_get(n, 'lat')
rownames(gisslat) <- paste(rep(1900:2017, rep(12,118)), formatC(1:12, width=2, flag=0), sep='-')[1:nrow(gisslat)]

nc_close(n)

##############################################################
# Read in ERSST ascii files (already at 2x2)
##############################################################

# find files
files <- list.files('data/ersstv4/ersst_ascii/')

# extract years
m <- regexpr('[[:digit:]]{4}', files)
years <- as.numeric(regmatches(files, m))

# extract the data (lat/lons are grid centers)
tempsarray = array(data=NA, dim=c(89, 180, length(files))) # giant array stack of all temperature data (lat, lon, year).
	dimnames(tempsarray)[[1]] = seq(-88, 88, by=2)
	dimnames(tempsarray)[[2]] = seq(0, 358, by=2) # so grid extent is -1 to 359 (not 0 to 360)
	dimnames(tempsarray)[[3]] = years

for(i in 1:length(files)){ # for each file
	print(files[i])
	thisfile = paste('data/ersstv4/ersst_ascii/', files[i], sep='')
	x <- read.fwf(thisfile, widths=rep(6,89)) # library(readr) has a faster function
	x[x == -9999] = NA # mask out land
	x = x/100 # temperatures stored at degC * 100

	thisarray = array(data=NA, dim=c(89, 180, 12)) # array stack of temperature data (lat, lon, month).
	for(j in 1:12){ # for each month in this file
		theselines = (180*j-179):(180*j) # one month is 180 longitude lines
		thisarray[,,j] = t(as.matrix(x[theselines,]))
	}
	tempsarray[,,i] <- apply(thisarray, MARGIN=c(1,2), FUN=mean)
}

	# quick look
	dim(tempsarray)
	image(t(tempsarray[,,110]))
	tempsarray[45,90,110] # middle of the pacific
	tempsarray[1,90,110] # antarctic
	tempsarray[89,90,110] # arctic

# Write out
save(tempsarray, file=paste('data/ersstv4/ersst2x2ann_', years[1], '_', max(years), '.rdata', sep=''))

####################################
# Calculate warming global average
####################################
# read in data from earlier
load('data/udel/udel2x2ann_1900_2014.rdata') # tempsarray
	udel <- tempsarray
load('data/ersstv4/ersst2x2ann_1900_2014.rdata')
	ersst <- tempsarray

# read in GISS zonal average for comparison
giss <- read.csv('data/gisstemp/GLB.Ts.csv', skip=1, na.strings='***') #J.D has annual mean

# average, weighted by grid size
# see https://gis.stackexchange.com/questions/29734/how-to-calculate-area-of-1-x-1-degree-cells-in-a-raster
	# lst
f0 <- (as.numeric(dimnames(udel)[[1]])-1)*pi/180
f1 <- (as.numeric(dimnames(udel)[[1]])+1)*pi/180
l0 <- as.numeric(dimnames(udel)[[2]])[1]*pi/180 # all the same, so just use the first
l1 <- as.numeric(dimnames(udel)[[2]])[2]*pi/180
R <- 6371 # earth radius in km
wgt <- (sin(f1) - sin(f0)) * (l1 - l0) * R^2 # grid sizes in km for each latitudinal band
wgt <- matrix(wgt, byrow=FALSE, nrow=length(wgt), ncol=dim(udel)[2]) # matrix of weights

lstave <- apply(udel, MARGIN=3, FUN=weighted.mean, w=wgt, na.rm=TRUE)

	# sst
f0 <- (as.numeric(dimnames(ersst)[[1]])-1)*pi/180 # grid cell boundaries in radians
f1 <- (as.numeric(dimnames(ersst)[[1]])+1)*pi/180
l0 <- as.numeric(dimnames(ersst)[[2]])[1]*pi/180 # all the same, so just use the first
l1 <- as.numeric(dimnames(ersst)[[2]])[2]*pi/180
R <- 6371 # earth radius in km
wgt <- (sin(f1) - sin(f0)) * (l1 - l0) * R^2 # grid sizes in km for each latitudinal band
wgt <- matrix(wgt, byrow=FALSE, nrow=length(wgt), ncol=dim(ersst)[2]) # matrix of weights

sstave <- apply(ersst, MARGIN=3, FUN=weighted.mean, w=wgt, na.rm=TRUE)

# rates of warming (linear regression)
lstmod <- lm(I(lstave-lstclim) ~ as.numeric(names(lstave)))
sstmod <- lm(I(sstave-sstclim) ~ as.numeric(names(sstave)))
gissmod <- lm(J.D ~ Year, data=giss[giss$Year %in% 1901:2012,])

	# quick plot
	lstclim <- mean(lstave[as.numeric(names(lstave)) %in% 1961:1990]) # 1961-1990 climatology for plotting
	sstclim <- mean(sstave[as.numeric(names(sstave)) %in% 1961:1990]) # 1961-1990 climatology for plotting

	plot(as.numeric(names(lstave)), lstave-lstclim, type='l', ylim=c(-1,1), col='green')
	lines(as.numeric(names(sstave)), sstave-sstclim, col='blue')
	with(giss[giss$Year %in% 1900:2014,], lines(Year, J.D, col='dark green'))
	abline(h=0, lty=3)

	abline(lstmod, col='green', lty=2)
	abline(sstmod, col='blue', lty=2)
	abline(gissmod, col='dark green', lty=2)

# rates of warming (difference)
mean(lstave[as.numeric(names(lstave)) %in% 2005:2014]) - mean(lstave[as.numeric(names(lstave)) %in% 1900:1919])
mean(sstave[as.numeric(names(sstave)) %in% 2005:2014]) - mean(sstave[as.numeric(names(sstave)) %in% 1900:1919])

####################################
# Calculate warming by latitude
####################################
# read in annual gridded data from earlier
load('data/udel/udel2x2ann_1900_2014.rdata') # tempsarray
	udel <- tempsarray
load('data/ersstv4/ersst2x2ann_1900_2014.rdata')
	ersst <- tempsarray
load('data/gisstemp/giss2x2ann_1900_2014.rdata')
	giss <- tempsarray

# read in GISS lat averages (monthly)
n = nc_open('data/gisstemp/zonmap.nc')
gisslat <- ncvar_get(n, 'temperature') # dim order: 1404 time (monthly 1900-2017) x 46 lat
colnames(gisslat) <- ncvar_get(n, 'lat')
rownames(gisslat) <- paste(rep(1900:2017, rep(12,118)), formatC(1:12, width=2, flag=0), sep='-')[1:nrow(gisslat)]

# latitudinal average warming (1995-2014 minus 1900-1919)
	# UDel lst
udelwarm <- apply(udel[,,96:115], MARGIN=c(1,2), FUN=mean) - apply(udel[,,1:20], MARGIN=c(1,2), FUN=mean) # warming by grid cell
udelwarmave <- rowMeans(udelwarm, na.rm=TRUE) # mean across grid cells in a lat band
udelwarmsd <- apply(udelwarm, MARGIN=1, FUN=sd, na.rm=TRUE) # SD across grid cells in a lat band
udlats <- as.numeric(names(udelwarmave)) # extract latitudes

	# ERSST sst
ersstwarm <- apply(ersst[,,96:115], MARGIN=c(1,2), FUN=mean) - apply(ersst[,,1:20], MARGIN=c(1,2), FUN=mean)
ersstwarmave <- rowMeans(ersstwarm, na.rm=TRUE)
ersstwarmsd <- apply(ersstwarm, MARGIN=1, FUN=sd, na.rm=TRUE)
erlats <- as.numeric(names(ersstwarmave))

	# GISS
gisswarm <- apply(giss[,,96:115], MARGIN=c(1,2), FUN=mean, na.rm=TRUE) - apply(giss[,,1:20], MARGIN=c(1,2), FUN=mean, na.rm=TRUE)
gisswarmave <- rowMeans(gisswarm, na.rm=TRUE)
gisswarmsd <- apply(gisswarm, MARGIN=1, FUN=sd, na.rm=TRUE)
gslats <- as.numeric(names(gisswarmave))

	# GISS zonal average lst (no SD possible from zonal average)
gisszonewarmave <- apply(gisslat[1141:1380,], MARGIN=2, FUN=mean) - apply(gisslat[1:240,], MARGIN=2, FUN=mean) # warming by lat band
gszonelats <- as.numeric(names(gisszonewarmave))

# write out
write.csv(data.frame(lat=udlats, warm=udelwarmave, sd=udelwarmsd), file='temp/lstwarmlat.csv', row.names=FALSE)
write.csv(data.frame(lat=gslats, warm=gisswarmave, sd=gisswarmsd), file='temp/lstwarmlat_giss.csv', row.names=FALSE)
write.csv(data.frame(lat=gszonelats, warm=gisszonewarmave), file='temp/lstwarmlat_gisszone.csv', row.names=FALSE)
write.csv(data.frame(lat=erlats, warm=ersstwarmave, sd=ersstwarmsd), file='temp/sstwarmlat.csv', row.names=FALSE)

###########################
# plots
###########################
lstwarmlat <- read.csv('temp/lstwarmlat.csv')
sstwarmlat <- read.csv('temp/sstwarmlat.csv')
lstwarmlatgiss <- read.csv('temp/lstwarmlat_giss.csv')
lstwarmlatgisszone <- read.csv('temp/lstwarmlat_gisszone.csv')

# warming (1995-2014 minus 1900-1919) by latitude
	cols <- c('#b2df8a', '#1f78b4', '#222222') # land, ocean, GISS
	cols2 <- c('#b2df8a55', '#1f78b455', '#22222255') # land, ocean partially transparent
	lw <- 2 # line width

	i.1 <- complete.cases(lstwarmlat) & lstwarmlat$lat < -66.25 # for polygon plotting
	i.2 <- complete.cases(lstwarmlat) & lstwarmlat$lat > -52.75 # for polygon plotting
	i2.1 <- complete.cases(lstwarmlatgiss) & lstwarmlatgiss$lat < -66.25 # for polygon plotting
	i2.2 <- complete.cases(lstwarmlatgiss) & lstwarmlatgiss$lat > -52.75 # for polygon plotting
	i3 <- complete.cases(sstwarmlat)

	quartz(w=4,h=4)
	plot(0, 0, xlab='Latitude (°N)', ylab='Historical warming (°C)', ylim=c(-1.5,3.5), xlim=c(-90,90), type='n') # just to set it up
	with(lstwarmlat[i.1,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[1], border=NA))
	with(lstwarmlat[i.2,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[1], border=NA))
	with(lstwarmlatgiss[i2.1,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[3], border=NA))
	with(lstwarmlatgiss[i2.2,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[3], border=NA))
	with(sstwarmlat[i3,], polygon(c(lat, rev(lat)), c(warm+sd, rev(warm-sd)), col=cols2[2], border=NA))
	with(lstwarmlat, lines(lat, warm, col=cols[1], lwd=lw))
	with(lstwarmlatgiss, lines(lat, warm, col=cols[3], lwd=lw))
	with(sstwarmlat, lines(lat, warm, col=cols[2], lwd=lw))

	with(lstwarmlatgisszone, lines(lat, warm, col='black', lwd=1, lty=2))


setwd("C://Users//nan66//Google Drive//stt864//LAB4")
library("nlme")
library("lme4")
load(file="GOTermlist.RData")
load(file="Alldata.Rdata")
load(file="pvalset.Rdata")
load(file="pvalset2.Rdata")
## Attach packages needed. Attach them by the following order!!

## Find the genes belong to the GO term GO:0006955

Goterms<-Alldata$originaldata[,128:130]
mc<-dim(Goterms)[1]
# GOTermlist<-NULL
# for (j in 1:mc)
# {
#  	list<-NULL
#  	for (k in 1:3)
# 	     {
# 		GOTerm22283<-as.character(Goterms[j,k])
# 		getGoTerms<-unlist(strsplit(GOTerm22283,"///"))
# 		repj<-rep(j,length(getGoTerms))
# 		newlist<-cbind(repj,getGoTerms)
# 		list<-rbind(list,newlist)
# 	     }
#  	GOTermlist<-rbind(GOTermlist,list)
# }

GO0006955<-which(GOTermlist[,2]=="GO:0006955")
rownums<-as.numeric(GOTermlist[GO0006955,1])
subsetGenes<-Alldata$originaldata[rownums,c(3:110)]
write.table(subsetGenes,file="subsetGenes.txt")

## Define factors: Beverage, Subject and Hours

samIDs<-names(subsetGenes)
Beverages<-(
	 (samIDs%in%Alldata$trt1)*1
	+(samIDs%in%Alldata$trt2)*2
	+(samIDs%in%Alldata$trt3)*3
	+(samIDs%in%Alldata$trt4)*4
	)
Subject<-(
	 (samIDs%in%Alldata$ind1)*1
	+(samIDs%in%Alldata$ind2)*2
	+(samIDs%in%Alldata$ind3)*3
	+(samIDs%in%Alldata$ind4)*4
	+(samIDs%in%Alldata$ind5)*5
	+(samIDs%in%Alldata$ind6)*6
	)
hours<-(
	 (samIDs%in%Alldata$time_h0)*0
	+(samIDs%in%Alldata$time_h1)*1
	+(samIDs%in%Alldata$time_h2)*2
	+(samIDs%in%Alldata$time_h4)*4
	+(samIDs%in%Alldata$time_h12)*12
	)
## Q3 Fit a linear mixed model with Beverage as fixed effects, time and individual effects as random effects

BeverFac<-as.factor(Beverages)
hourFac<-as.factor(hours)
resp<-as.numeric(subsetGenes[1,])
library("lme4")
numgenes<-dim(subsetGenes)[1]
# pvalset<-rep(0,numgenes)
# pvalset2<-rep(0,numgenes)
# for (i in 1:numgenes)
# {
#  resp<-as.numeric(subsetGenes[i,])
#  lmmd2<-lmer(resp~BeverFac+(1|Subject)+(1|hours))
#  Zstat<-summary(lmmd2)$coefficients[4,3]
#  Zstat2<-(summary(lmmd2)$coefficients[3,1]-summary(lmmd2)$coefficients[4,1])/sqrt(vcov(lmmd2)[3,3]+vcov(lmmd2)[4,4]-2*vcov(lmmd2)[4,3])
#  pvalset[i]<-2*(1-pnorm(abs(Zstat)))
#  pvalset2[i]<-2*(1-pnorm(abs(Zstat2)))
# }
smallest<-which.min(pvalset)
smallest2<-which.min(pvalset2)

newresp<-as.numeric(subsetGenes[smallest,])
lmmd3<-lmer(newresp~BeverFac+(1|Subject)+(1|hours))
summary(lmmd3)

(summary(lmmd3)$coefficients[3,1]-summary(lmmd3)$coefficients[4,1])/sqrt(vcov(lmmd3)[3,3]+vcov(lmmd3)[4,4]-2*vcov(lmmd3)[4,3])

###REML for time random effect
lm3<-lm(newresp~BeverFac+Subject+hours)
summary(lm3)
anova(lm3)
sigmahat<-sqrt(0.07058)
sigmahat
sigmahat_Subject<-(0.15870-0.07058)/1
sigmahat_hours<-(0.34036-0.07058)/1
sigmahat_hours

## Q5 Plot the curves: gene expression versus hours

plot(hours,newresp,type="n",xlab="Hours", ylab="gene expression")
for (sub in 1:6)
 for (bever in 1:4)
{
points(
	hours[(Subject==sub)&(Beverages==bever)],
	newresp[(Subject==sub)&(Beverages==bever)],
	col=bever,pch=sub
	)
lines(
	hours[(Subject==sub)&(Beverages==bever)],
	newresp[(Subject==sub)&(Beverages==bever)],
	col=bever
	)
}

## Linear mixed effects models with cubic time effects

hours2<-(hours^2)
hours3<-(hours^3)
combfacs<-Subject*10+Beverages
glscsh<-gls(
	resp~BeverFac+hours+hours2+hours3,
	correlation=corCompSymm(form=~1|combfacs),
	weights=varIdent(form=~1|combfacs),
	method="REML"
	)

glsarh1<-gls(
	resp~BeverFac+hours+hours2+hours3,
	correlation=corAR1(form=~1|combfacs),
	weights=varIdent(form=~1|combfacs),
	method="REML"
	)

glscsM2<-gls(
	resp~BeverFac+BeverFac*hours+BeverFac*hours2+BeverFac*hours3,
	correlation=corCompSymm(form=~1|combfacs),
	method="REML"
	)

glscshM2<-gls(
	resp~BeverFac+BeverFac*hours+BeverFac*hours2+BeverFac*hours3,
	correlation=corCompSymm(form=~1|combfacs),
	weights=varIdent(form=~1|combfacs),
	method="REML"
	)

## Define new data set for Q7

Combdata<-cbind(newresp,hours,Subject,Beverages,combfacs)
unicombfacs<-Combdata[Combdata[,2]==0,5]
newcombdata<-NULL
for (i in 1:length(unicombfacs))
{
 subcomb<-Combdata[Combdata[,5]==unicombfacs[i],]
 Yvec<-subcomb[,1]
 Hvec<-subcomb[,2]
 Zvec<-((Yvec[Hvec!=0]-Yvec[Hvec==0])>0)+0
 newcombdata<-rbind(newcombdata,cbind(Zvec,subcomb[Hvec!=0,c(2:5)]))
}

newcombdata1<-list(
	Zvec=newcombdata[,1],
	hours=newcombdata[,2],
	Subject=newcombdata[,3],
	Beverages=newcombdata[,4],
	combfacs=newcombdata[,5])
newcombdata1$Beverages<-as.factor(newcombdata1$Beverages)
newcombdata1$hours<-as.factor(newcombdata1$hours)

## GLMM with the default Laplace approximation

glmRandomIntcept1<- glmer(
	 newcombdata1$Zvec~newcombdata1$Beverages
	+newcombdata1$hours
	+(1|newcombdata1$combfacs),
	family=binomial)
summary(glmRandomIntcept1)

## Another way to fit using Laplace approximation

library(glmmML)
glmRandomIntcept2<-glmmML(
	newcombdata1$Zvec~newcombdata1$Beverages+newcombdata1$hours,
	family=binomial,
	cluster=newcombdata1$combfacs)
summary(glmRandomIntcept2)

## Fit the model using the penalized quasi-likelihood

library(MASS)
newcombdata2<-data.frame(newcombdata1)
glmRandomIntcept3<-glmmPQL(Zvec~Beverages+hours,
	random=~1|combfacs,
	family=binomial,data=newcombdata2)
summary(glmRandomIntcept3)

## Fit the model using adaptive Gauss-Hermite qudrature(AGQ)
## nAGQ: the number of points per axis for evaluating the adaptive Gauss-Hermite approximation to the log-likelihood.

glmRandomIntcept4<-glmer(
						newcombdata1$Zvec~newcombdata1$Beverages
						+newcombdata1$hours+(1|newcombdata1$combfacs),
						nAGQ=8,family=binomial
						)
summary(glmRandomIntcept4)

oldpar <- par(mfrow = c(2, 3))
plot(residuals(glmRandomIntcept1))
plot(residuals(glmRandomIntcept3))
plot(residuals(glmRandomIntcept4))
qqnorm(residuals(glmRandomIntcept1))
abline(0,1)
qqnorm(residuals(glmRandomIntcept3))
abline(0,1)
qqnorm(residuals(glmRandomIntcept4))
abline(0,1)
par(oldpar)


####################
## SVM Model
## Kernel types - linear, polynomial, radial, sigmoid
####################
##############################
## MODELS
##############################
kern_type = "polynomial"
#TSLA
tsla.svm.factors <- c('LR1.2', 'LR3.2','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
tsla.svm.formula <- as.formula(paste('as.factor(PosR.2)~', paste(tsla.svm.factors, collapse = '+')))
tsla.svm.model <- svm(tsla.svm.formula, data = data.split$train.data, kernel = kern_type)
tsla.svm.eval <- SvmEval2(tsla.svm.model, data.split$test.data)
#PYPL --------------
pypl.svm.factors <- c('LR1.3', 'LR3.3','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
pypl.svm.formula <- as.formula(paste('as.factor(PosR.3)~', paste(pypl.svm.factors, collapse = '+')))
pypl.svm.model <- svm(pypl.svm.formula, data = data.split$train.data, kernel = kern_type)
pypl.svm.eval <- SvmEval2(pypl.svm.model, data.split$test.data)
#SQ---------------
sq.svm.factors <- c('LR1.4', 'LR3.4','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
sq.svm.formula <- as.formula(paste('as.factor(PosR.4)~', paste(sq.svm.factors, collapse = '+')))
sq.svm.model <- svm(sq.svm.formula, data = data.split$train.data, kernel = kern_type)
sq.svm.eval <- SvmEval2(sq.svm.model, data.split$test.data)
#AAPL----------------------
aapl.svm.factors <- c('LR1.5', 'LR3.5','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
aapl.svm.formula <- as.formula(paste('as.factor(PosR.5)~', paste(aapl.svm.factors, collapse = '+')))
aapl.svm.model <- svm(aapl.svm.formula, data = data.split$train.data, kernel = kern_type)
aapl.svm.eval <- SvmEval2(aapl.svm.model, data.split$test.data)
#V-----------------------
v.svm.factors <- c('LR1.6', 'LR3.6','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
v.svm.formula <- as.formula(paste('as.factor(PosR.6)~', paste(v.svm.factors, collapse = '+')))
v.svm.model <- svm(v.svm.formula, data = data.split$train.data, kernel = kern_type)
v.svm.eval <- SvmEval2(v.svm.model, data.split$test.data)
#FB-----------------------
fb.svm.factors <- c('LR1.7', 'LR3.7','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
fb.svm.formula <- as.formula(paste('as.factor(PosR.7)~', paste(fb.svm.factors, collapse = '+')))
fb.svm.model <- svm(fb.svm.formula, data = data.split$train.data, kernel = kern_type)
fb.svm.eval <- SvmEval2(fb.svm.model, data.split$test.data)
#AMD-----------------------
amd.svm.factors <- c('LR1.8', 'LR3.8','LR1','LR3','LR1.1','LR3.1','LR1.10', 'LR3.10')
amd.svm.formula <- as.formula(paste('as.factor(PosR.8)~', paste(amd.svm.factors, collapse = '+')))
amd.svm.model <- svm(amd.svm.formula, data = data.split$train.data, kernel = kern_type)
amd.svm.eval <- SvmEval2(amd.svm.model, data.split$test.data)
############################
## BULK LIST BASED ACTIONS
############################
evaluations <- list(tsla.svm.eval, pypl.svm.eval, sq.svm.eval,
                    aapl.svm.eval, v.svm.eval, fb.svm.eval, amd.svm.eval)
names(evaluations) <- basket2
models <- list(tsla.svm.model, pypl.svm.model, sq.svm.model,
               aapl.svm.model, v.svm.model, fb.svm.model, amd.svm.model)
names(models) <- basket2
##############################
## FILENAME DETAILS
##############################
filename <- sprintf("%s ANALYSIS %s.txt", "SVM", toString(format(Sys.time(), "%Y-%m-%d %H-%M-%S")))
############################
## SAVE TO FILE
############################
sink(filename)
Filter(function(x) x$accuracy > 0.5, evaluations)
sink()


# two way ANOVA

# R assumes data files are in row-column format
# ratweight2.txt is in that format

rat <- read.table('ratweight2.txt',header=T, as.is=T)

# I prefer to read columns as is and explicitly convert
#  those I want to factors.  That avoids much confusion
#  when a column of numbers is to be considered a factor.
# others are very comfortable with the default behaviour

# the reshape package provides a way to transpose and reshape
#  data.  I still find it easier to manipulate data in SAS
#  because you have access to a data programming language

# convert amount and type to factors
rat$amount.f <- as.factor(rat$amount)
rat$type.f <- as.factor(rat$type)

rat.lm <- lm(gain~amount.f + type.f + amount.f:type.f, data=rat)

# the : indicates the interaction between two factors

# the * indicates all main effects and interactions

rat.lm2 <- lm(gain~amount.f*type.f, data=rat)

# fits exactly the same model.

# print out the anova table
anova(rat.lm)

# aov() is a wrapper to lm() that adds useful info for ANOVA models

rat.aov <- aov(gain~amount.f + type.f + amount.f:type.f, data=rat)

# you can get the anova table
summary(rat.aov)  # or anova(rat.aov)

# R's facilities for 'beyond the ANOVA table' are limited

# you can get tables of marginal means and their se's

model.tables(rat.aov, se=T, type='means')
# model.tables does not work for lm() results

# and differences among pairs and adjusted p-values
#  using Tukey's HSD

TukeyHSD(rat.aov)

# se.contrast() provides a way to get the se of a contrast
# but it doesn't give you the estimate of that contrast!!
# you have to compute that by hand????
# If someone knows something to the contrary, please let me know

# I don't know any equivalent of the SAS 'slice'.

# more importantly, and hence, NOTE and HUGE warning:
#  All the R functions work best (sometimes only work)
#   when  the data is balanced!!!!

# when the data is unbalanced, R's built-in functions
#   don't work well

# R reports type I (sequential) SS.
# You can get type III SS by specifically requesting
#  an orthogonal set of contrasts (e.g. contr.helmert,
#  see contrasts for how to change the contrast),
#  then using drop1()

# model.tables() reports some sort of marginal mean,
#  but it is not the average of cell means

# model.tables() is completely misleading
#   if you are missing a cell in a factorial design,
#  the marginal means are not estimable, but
#    model.tables() still reports something!!

# TukeyHSD() has the same problem
#  Worse, it doesn't even give you a warning that the
#    design is unbalanced.

# My sense is that you can get R to provide valid answers to questions,
#  but you have to work at it and you have to know a lot of details
#    (e.g. choice of constrast matrices)
#  Who would know that you have to reset the default contrasts
#    to get valid type III tests?
#  This is especially true if you want answers that go beyond the ANOVA
#   table.  You have to work very hard to get those sorts of answers
#   from R.  SAS makes everything much easier.

# If anyone has information to the contrary,
#  especially for unbalanced data, please let me know.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/ratweight.r


#!/usr/bin/env Rscript

getInput <- function(){
    fname <- "four.txt"
    contents <- readChar(fname, file.info(fname)$size)
    ls <- strsplit(contents, "\n\n")
    return(ls)
}
lines <- getInput()
inpNums <- strsplit(lines[[1]][1], ",")[[1]]
mx <- lapply(lines, tail, length(lines[[1]])-1)[[1]]

# A
checkBingo <- function(mat){
    for (i in 1:5) {
        row <- mat[i,]; col <- mat[,i]
        if (all(is.na(row)) || all(is.na(col))){
            return (TRUE)
        }
    }
    return (FALSE)
}

mat <- matrix(0, nrow = 5, ncol = 5)
count <- length(inpNums) ### A
count <- 0 ### B

for (m in mx) {
    mm <- matrix(scan(text = m, what = integer()),nrow = 5,byrow = TRUE)
    for (n in inpNums) {
        mm[mm == n] <- NA
        if (checkBingo(mm)) {
            i <- which (n == inpNums)
            ### A: if (i < count) {
            if (i > count) {
                print(count)
                mat <- mm
                count <- i
                ### A: next
            }
            break ## B
        }
    }
}
mat[is.na(mat)] <- 0
print(strtoi(inpNums[count]) * sum(mat))


beta_predict <- function(p, calib){
  p <- pmax(1e-16, pmin(p, 1-1e-16))
  d <- data.frame(p)
  if (calib$parameters == "abm"){
    d$lp <- log(p)
    d$l1p <- -log(1-p)
  }else if (calib$parameters == "am"){
    d$lp <- log(p / (1 - p))
  }else if (calib$parameters == "ab"){
    d$lp <- log(2 * p)
    d$l1p <- log(2*(1-p))
  }
  return(predict(calib$model, newdata=d, type="response"))
}


E04BBJ Example Program Results

The minimum lies in the interval 4.49340946 to 4.49340952
Its estimated position is 4.49340946,
where the function value is -0.2172
and the gradient is -3.8e-16 (machine dependent)
6 function evaluations were required


#' Continuous Boyce Index (CBI) with weighting
#'
#' This function calculates the Continuous Boyce Index (CBI), a measure of model accuracy for presence-only test data.
#' @param pres Numeric vector. Predicted values at presence sites.
#' @param contrast Numeric vector. Predicted values at absence/background sites.
#' @param numBins Positive integer. Number of (overlapping) bins into which to divide predictions.
#' @param binWidth Positive numeric. Size of a bin. Each bin will be \code{binWidth * (max - min)} where \code{max} and \code{min}. If \code{autoWindow} is \code{FALSE} (the default) then \code{min} is 0 and \code{max} is 1. If \code{autoWindow} is \code{TRUE} then \code{min} and \code{max} are the maximum and minimum value of all predictions in the background and presence sets (i.e., not necessarily 0 and 1).
#' @param presWeight Numeric vector same length as \code{pres}. Relative weights of presence sites. The default is to assign each presence a weight of 1.
#' @param contrastWeight Numeric vector same length as \code{contrast}. Relative weights of background sites. The default is to assign each presence a weight of 1.
#' @param autoWindow Logical. If \code{FALSE} calculate bin boundaries starting at 0 and ending at 1 + epsilon (where epsilon is a very small number to assure inclusion of cases that equal 1 exactly). If \code{TRUE} (default) then calculate bin boundaries starting at minimum predicted value and ending at maximum predicted value.
#' @param method Character. Type of correlation to calculate. The default is \code{'spearman'}, the Spearman rank correlation coefficient used by Boyce et al. (2002) and Hirzel et al. (2006), which is the traditional CBI. In contrast, \code{'pearson'} or \code{'kendall'} can be used instead.  See [stats::cor()] for more details.
#' @param dropZeros Logical. If TRUE then drop all bins in which the frequency of presences is 0.
#' @param graph Logical. If TRUE then plot P vs E and P/E versus bin.
#' @param na.rm Logical. If \code{TRUE} then remove any presences and associated weights and background predictions and associated weights with \code{NA}s.
#' @param bg Same as \code{contrast}. Included for backwards compatibility. Ignored if \code{contrast} is not \code{NULL}.
#' @param bgWeight Same as \code{contrastWeight}. Included for backwards compatibility. Ignored if \code{contrastWeight} is not \code{NULL}.
#' @param ... Other arguments (not used).
#' @return Numeric value.
#' @details CBI is the Spearman rank correlation coefficient between the proportion of sites in each prediction class and the expected proportion of predictions in each prediction class based on the proportion of the landscape that is in that class. Values >0 indicate the model's output is positively correlated with the true probability of presence.  Values <0 indicate it is negatively correlated with the true probability of presence.
#' @references Boyce, M.S., Vernier, P.R., Nielsen, S.E., and Schmiegelow, F.K.A.  2002.  Evaluating resource selection functions.  \emph{Ecological Modeling} 157:281-300)
#' @references Hirzel, A.H., Le Lay, G., Helfer, V., Randon, C., and Guisan, A.  2006.  Evaluating the ability of habitat suitability models to predict species presences.  \emph{Ecological Modeling} 199:142-152.
#' @seealso \code{\link[stats]{cor}}, \code{\link{fpb}}, \code{\link{aucWeighted}}, \code{link[enmSdm]{contBoyce2x}}
#' @examples
#' set.seed(123)
#' pres <- sqrt(runif(100))
#' contrast <- runif(1000)
#' contBoyce(pres, contrast)
#' contBoyce2x(pres, contrast)
#' presWeight <- c(rep(1, 10), rep(0.5, 90))
#' contBoyce(pres, contrast, presWeight=presWeight)
#' contBoyce2x(pres, contrast, presWeight=presWeight)
#' \donttest{
#' # compare stability of CBI calculated with ecospat.boyce() in ecospat package
#' library(ecospat)
#' set.seed(123)
#' results <- data.frame()
#' for (perform in c(1, 1.5, 2)) {
#' 	for (i in 1:30) {
#'
#'    pres <- runif(100)^(1 / perform)
#'    contrast <- runif(1000)
#'
#'    cbi_enmSdm <- contBoyce(pres, contrast)
#'    cbi_ecospat <- ecospat.boyce(contrast, pres, PEplot=FALSE)$Spearman.cor
#'
#'    results <- rbind(
#'      results,
#'      data.frame(
#'        performance = rep(perform, 2),
#'        method = c('enmSdm', 'ecospat'),
#'        cbi = c(cbi_enmSdm, cbi_ecospat)
#'      )
#'    )
#'
#' 	}
#'
#' }
#'
#' results$performance[results$performance == 1] <- 'poor'
#' results$performance[results$performance == 1.5] <- 'OK'
#' results$performance[results$performance == 2] <- 'good'
#'
#' results$category <- paste0(results$method, '\n', results$performance)
#'
#' par(mfrow=c(1, 2))
#' boxplot(cbi ~ category,
#' 	data=results,
#' 	ylab='CBI',
#' 	main='CBI of poor, OK, and good models',
#' 	border=c(rep('darkred', 3),
#' 	rep('darkblue', 3))
#' )
#' plot(results$cbi,
#' 	pch=rep(c(21, 22, 23, 24), each=2),
#' 	contrast=ifelse(results$method == 'ecospat', 'darkred', 'cornflowerblue'),
#' 	main='Pairs of CBIs',
#' 	ylab='CBI'
#' )
#' legend('bottomright', fill=c('darkred', 'cornflowerblue'), legend=c('ecospat', 'enmSdm'))
#' }
#' @export

contBoyce <- function(
  pres,
  contrast,
  numBins = 101,
  binWidth = 0.1,
  presWeight = rep(1, length(pres)),
  contrastWeight = rep(1, length(contrast)),
  autoWindow = TRUE,
  method = 'spearman',
  dropZeros = TRUE,
  graph = FALSE,
  na.rm = FALSE,
  bg = NULL,
  bgWeight = NULL,
  ...
) {

  if (missing(contrast) & !is.null(bg)) contrast <- bg
  if (missing(contrastWeight) & !is.null(bgWeight)) contrastWeight <- bgWeight

  # if all NAs
  if (all(is.na(pres)) | all(is.na(contrast)) | all(is.na(presWeight)) | all(is.na(contrastWeight))) return(NA)

  # catch errors
  if (length(presWeight) != length(pres)) stop('You must have the same number of presence predictions and presence weights ("pres" and "presWeight").')
  if (length(contrastWeight) != length(contrast)) stop('You must have the same number of absence/background predictions and absence/background weights ("contrast" and "contrastWeight").')

  # # remove NAs
  # if (na.rm) {

  # cleanedPres <- omnibus::naOmitMulti(pres, presWeight)
  # pres <- cleanedPres[[1]]
  # presWeight <- cleanedPres[[2]]

  # cleanedContrast <- omnibus::naOmitMulti(contrast, contrastWeight)
  # contrast <- cleanedContrast[[1]]
  # contrastWeight <- cleanedContrast[[2]]

  # }

  # right hand side of each class (assumes max value is >0)
  lowest <- if (autoWindow) { min(c(pres, contrast), na.rm=na.rm) } else { 0 }
  highest <- if (autoWindow) { max(c(pres, contrast), na.rm=na.rm) + omnibus::eps() } else { 1 + omnibus::eps() }

  windowWidth <- binWidth * (highest - lowest)

  lows <- seq(lowest, highest - windowWidth, length.out=numBins)
  highs <- seq(lowest + windowWidth + omnibus::eps(), highest, length.out=numBins)

  ##########
  ## MAIN ##
  ##########

  ## initiate variables to store predicted/expected (P/E) values
  freqPres <- freqContrast <- rep(NA, length(numBins))

  ### tally proportion of test presences/background sites in each class
  for (countClass in 1:numBins) {

    # number of presence predictions in this class
    presInBin <- pres >= lows[countClass] & pres < highs[countClass]
    presInBin <- presInBin * presWeight
    freqPres[countClass] <- sum(presInBin, na.rm=na.rm)

    # number of background predictions in this class
    bgInBin <- contrast >= lows[countClass] & contrast < highs[countClass]
    bgInBin <- bgInBin * contrastWeight
    freqContrast[countClass] <- sum(bgInBin, na.rm=na.rm)

  } # next predicted value class

  # mean bin prediction
  meanPred <- rowMeans(cbind(lows, highs))

  # add small number to each bin that has 0 background frequency but does have a presence frequency > 0
  if (any(freqPres > 0 & freqContrast == 0)) {
    smallValue <- min(0.5 * c(presWeight[presWeight > 0], contrastWeight[contrastWeight > 0]))
    freqContrast[freqPres > 0 & freqContrast == 0] <- smallValue
  }

  # remove classes with 0 presence frequency
  if (dropZeros && 0 %in% freqPres) {
    zeros <- which(freqPres == 0)
    meanPred[zeros] <- NA
    freqPres[zeros] <- NA
    freqContrast[zeros] <- NA
  }

  # remove classes with 0 background frequency
  if (any(0 %in% freqContrast)) {
    zeros <- which(freqContrast == 0)
    meanPred[zeros] <- NA
    freqPres[zeros] <- NA
    freqContrast[zeros] <- NA
  }

  P <- freqPres / sum(presWeight, na.rm=TRUE)
  E <- freqContrast / sum(contrastWeight, na.rm=TRUE)
  PE <- P / E

  # plot
  if (graph) {
    par(mfrow=c(1, 2))
    lims <- c(0, max(P, E, na.rm=TRUE))
    plot(E, P, col='white', xlab='Expected', ylab='Predicted', main='P/E\nNumbered from lowest to highest class', xlim=lims, ylim=lims)
    text(E, P, labels=1:numBins, col=1:20)
    plot(meanPred, PE, type='l', xlab='Mean Prediction in Bin', ylab='P/E Ratio', main='CBI\nNumbered from lowest to highest class')
    text(meanPred, PE, labels=1:numBins, col='blue')
  }

  # remove NAs
  out <- omnibus::naOmitMulti(meanPred, PE)
  meanPred <- out[[1]]
  PE <- out[[2]]

  # calculate continuous Boyce index (cbi)
  cbi <- stats::cor(x=meanPred, y=PE, method=method)
  cbi

}


#
# Test if variance is increasing with fligner,  the modified Brown-Forsythe Levene-type, or quantile regression
#

require(lawstat)
require(quantreg)

#
# Test if fligner-Killen test can detect differences
#
ff<-data.frame(year=2000:2014,delta_year_patch=c(rnorm(5,sd=0.001),rnorm(5,sd=0.005),rnorm(5,sd=0.01)),period=rep(1:2,each=8,length.out=15))
sim_delta_t <-function(sde=0.001,type=1,ini=0,long=15)
{
	x<-numeric(15)
	if(type==1){
		for(ii in 2:long)
		{
			x[ii] <- x[ii-1] + rnorm(1,sd=ii*sde)
		}
	} else {
		x <- rnorm(long,sd=sde)
	}	require(lawstat)
	require(quantreg)

	#
	# Test if fligner-Killen test can detect differences
	#
	ff<-data.frame(year=2000:2014,delta_year_patch=c(rnorm(5,sd=0.001),rnorm(5,sd=0.005),rnorm(5,sd=0.01)),period=rep(1:2,each=8,length.out=15))
	sim_delta_t <-function(sde=0.001,type=1,ini=0,long=15)
	{
		x<-numeric(15)
		if(type==1){
			for(ii in 2:long)
			{
				x[ii] <- x[ii-1] + rnorm(1,sd=ii*sde)
			}
		} else {
			x <- rnorm(long,sd=sde)
		}
		return(x)
	}
	ff$delta_year_patch<- sim_delta_t(0.001,0)
	plot(ff$year, ff$delta_year_patch)
	#debugonce(sim_delta_t)

	pwr <- data_frame()
	# require(doParallel)
	# cn <-detectCores()
	# cl <- makeCluster(cn)
	# registerDoParallel(cl)
	#
	# pwr <-foreach(i=1:1000,.combine="rbind",.packages=c("quantreg","lawstat")) %dopar%
	pwr <-rdply(1000,
				{
					ff$delta_year_patch<- sim_delta_t()
					#plot(ff$year, ff$delta_year_patch)
					fli<-fligner.test(ff$delta_year_patch,ff$period)
					inc<-lnested.test(ff$delta_year_patch,ff$period,bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
					dec<-lnested.test(ff$delta_year_patch,ff$period,tail="left",bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
					q10<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.10)),se="boot",R=999))[2,]
					q50<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.50)),se="boot",R=999))[2,]
					q90<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.90)),se="boot",R=999))[2,]

					return(data_frame(mean=mean(ff$delta_year_patch),var=var(ff$delta_year_patch),fli=fli$p.value,inc=inc$p.value,dec=dec$p.value,q10=q10[[4]],q50=q50[[4]],q90=q90[[4]]))
				}
	)

	filter(pwr,fli<0.05) %>% summarise(fli=n()/nrow(pwr))
	filter(pwr,inc<0.05) %>% summarise(inc=n()/nrow(pwr))
	filter(pwr,dec<0.05) %>% summarise(dec=n()/nrow(pwr))
	filter(pwr,q10<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pwr,q50<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pwr,q90<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pwr,q10<0.05 | q50<0.05 | q90<0.05) %>% summarise(quat=n()/nrow(pwr))
	pwr$type<-"pow"

	pw1 <-rdply(100,
				{
					ff$delta_year_patch<- sim_delta_t(0.001,0)
					#plot(ff$year, ff$delta_year_patch)
					fli<-fligner.test(ff$delta_year_patch,ff$period)
					inc<-lnested.test(ff$delta_year_patch,ff$period,bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
					dec<-lnested.test(ff$delta_year_patch,ff$period,tail="left",bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
					q10<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.10)),se="boot",R=999))[2,]
					q50<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.50)),se="boot",R=999))[2,]
					q90<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.90)),se="boot",R=999))[2,]

					return(data_frame(mean=mean(ff$delta_year_patch),var=var(ff$delta_year_patch),fli=fli$p.value,inc=inc$p.value,dec=dec$p.value,q10=q10[[4]],q50=q50[[4]],q90=q90[[4]],type="FPos"))
				})
	filter(pw1,fli<0.05) %>% summarise(nfli=n()/nrow(pwr))
	filter(pw1,inc<0.05) %>% summarise(nfli=n()/nrow(pwr))
	filter(pw1,dec<0.05) %>% summarise(nfli=n()/nrow(pwr))
	filter(pw1,q10<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pw1,q50<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pw1,q90<0.05) %>% summarise(quat=n()/nrow(pwr))
	filter(pw1,q10<0.05 | q50<0.05 | q90<0.05) %>% summarise(quat=n()/nrow(pwr))

	return(x)
}
ff$delta_year_patch<- sim_delta_t(0.001,0)
plot(ff$year, ff$delta_year_patch)
#debugonce(sim_delta_t)

pwr <- data_frame()
# require(doParallel)
# cn <-detectCores()
# cl <- makeCluster(cn)
# registerDoParallel(cl)
#
# pwr <-foreach(i=1:1000,.combine="rbind",.packages=c("quantreg","lawstat")) %dopar%
pwr <-rdply(1000,
			{
				ff$delta_year_patch<- sim_delta_t()
				#plot(ff$year, ff$delta_year_patch)
				fli<-fligner.test(ff$delta_year_patch,ff$period)
				inc<-lnested.test(ff$delta_year_patch,ff$period,bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
				dec<-lnested.test(ff$delta_year_patch,ff$period,tail="left",bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
				q10<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.10)),se="boot",R=999))[2,]
				q50<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.50)),se="boot",R=999))[2,]
				q90<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.90)),se="boot",R=999))[2,]

				return(data_frame(mean=mean(ff$delta_year_patch),var=var(ff$delta_year_patch),fli=fli$p.value,inc=inc$p.value,dec=dec$p.value,q10=q10[[4]],q50=q50[[4]],q90=q90[[4]]))
			}
)

filter(pwr,fli<0.05) %>% summarise(fli=n()/nrow(pwr))
filter(pwr,inc<0.05) %>% summarise(inc=n()/nrow(pwr))
filter(pwr,dec<0.05) %>% summarise(dec=n()/nrow(pwr))
filter(pwr,q10<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pwr,q50<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pwr,q90<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pwr,q10<0.05 | q50<0.05 | q90<0.05) %>% summarise(quat=n()/nrow(pwr))
pwr$type<-"pow"

pw1 <-rdply(100,
			{
				ff$delta_year_patch<- sim_delta_t(0.001,0)
				#plot(ff$year, ff$delta_year_patch)
				fli<-fligner.test(ff$delta_year_patch,ff$period)
				inc<-lnested.test(ff$delta_year_patch,ff$period,bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
				dec<-lnested.test(ff$delta_year_patch,ff$period,tail="left",bootstrap = T,num.bootstrap = 999,correction.method="zero.correction")$N[2]
				q10<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.10)),se="boot",R=999))[2,]
				q50<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.50)),se="boot",R=999))[2,]
				q90<-coef(summary(rq((delta_year_patch)~year,data=ff,tau=c(.90)),se="boot",R=999))[2,]

				return(data_frame(mean=mean(ff$delta_year_patch),var=var(ff$delta_year_patch),fli=fli$p.value,inc=inc$p.value,dec=dec$p.value,q10=q10[[4]],q50=q50[[4]],q90=q90[[4]],type="FPos"))
			})
filter(pw1,fli<0.05) %>% summarise(nfli=n()/nrow(pwr))
filter(pw1,inc<0.05) %>% summarise(nfli=n()/nrow(pwr))
filter(pw1,dec<0.05) %>% summarise(nfli=n()/nrow(pwr))
filter(pw1,q10<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pw1,q50<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pw1,q90<0.05) %>% summarise(quat=n()/nrow(pwr))
filter(pw1,q10<0.05 | q50<0.05 | q90<0.05) %>% summarise(quat=n()/nrow(pwr))


# <-- encoding UTF-8 -->
# Empirical study on CHARLS dataset (county level)
# -------------------------------------
## DOC STRING
#
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------

# -------------------------------------
## SECTION 0: ENVIRONMENT
library(car)  # qqplots
library(plm)  # panel data models & Hausman test
library(nlme)  # gls estimation
library(nortest)  # normality tests
library(openxlsx)  # easy xlsx IO
source("./src/plottools.r")  # easy plotting tools
source("./src/paneltools.r")  # PANEL TOOLS

# environment par dict
envCHARLS$Output <- "./output/proc_3_CHARLS/"  # alter output directory

# -------------------------------------
## SECTION 1: (ROBUST) POOL DATA MODEL WITH FGLS & OLS
cat("\nSECTION 1: (ROBUST) POOL DATA MODELS ON CHARLS DATASET, ALL FINAL SPECIFICATIONS")
# NOTE: in this section, we seen the panel data set "dfp_CHARLS" as a pool dataset,
#       use OLS & GLS to estimate every final specification in li_Eq_CHARLS;
# NOTE: if extra normality tests on residuals required, please use the library nortest:: & shapiro.test()

# 1.0 prepare a collection of estimated models
li_ModPoolOLS_CHARLS <- list()
li_ModPoolGLS_CHARLS <- list()

# 1.1 estimation & print summaries
for(tmpYname in envCHARLS$Ynames){
    # slice a temp dataset
    tmpdf <- li_Dat_CHARLS[[tmpYname]]
    # 1.1.1 estimation
    li_ModPoolOLS_CHARLS[[tmpYname]] <- lm( li_Eq_CHARLS[[tmpYname]], tmpdf )
    li_ModPoolGLS_CHARLS[[tmpYname]] <- nlme::gls( li_Eq_CHARLS[[tmpYname]], tmpdf )
    # 1.1.2 run-time log
    cat("\n---------------------------------------------------------------\n***** FORMULA *****:\n")
    print( li_Eq_CHARLS[[tmpYname]] ); print("\n")
    # 1.1.3 print summary
    print( summary( li_ModPoolOLS_CHARLS[[tmpYname]] ) )
    print( summary( li_ModPoolGLS_CHARLS[[tmpYname]] ) )

}

# -------------------------------------
## SECTION 2: FIXED INDIVIDUAL EFFECT & RANDOM INDIVIDUAL EFFECT MODEL & HAUSSMAN
cat("\nSECTION 2: FIXED INDIVIDUAL EFFECT & RANDOM INDIVIDUAL EFFECT MODEL")
# --------------
# 2.0 prepare collections
li_ModFix_CHARLS <- list()  # for fixed individual effect models
li_ModRan_CHARLS <- list()  # for random individual effect models
df_Haussman_CHARLS <- data.frame(
    Equation = envCHARLS$Ynames,  # dependents
    Chisq = 0,  # Haussman Statistics (X2)
    pVal_Chisq = 0,  # p-value
    ChisqRobust = 0,  # robust Haussman Statistics (through an auxiliary regression)
    pVal_ChisqRobust = 0  # p-value
)

# 2.1 loop on health outcomes, estimate & perform Haussman test
for(tmpYname in envCHARLS$Ynames){
    # slice a temp dataset
    tmpdf <- li_DatPlm_CHARLS[[tmpYname]]

    # 2.1.1 fixed effect model (OLS estimator + robustSE)
    li_ModFix_CHARLS[[tmpYname]] <- plm::plm( li_Eq_CHARLS[[tmpYname]], data = tmpdf,
                                              effect = "individual", model = "within" )
    # 2.1.2 random effect model (FGLS estimator)
    li_ModRan_CHARLS[[tmpYname]] <- plm::pggls( li_Eq_CHARLS[[tmpYname]], data = tmpdf,
                                              effect = "individual", model = "random" )

    # 2.1.3 Haussman test (H0: random effect, if phtest(fixed, random))
    tmp <- plm::phtest( li_ModFix_CHARLS[[tmpYname]], li_ModRan_CHARLS[[tmpYname]], method = "chisq" )
    df_Haussman_CHARLS$Chisq[df_Haussman_CHARLS$Equation == tmpYname] <- tmp$statistic
    df_Haussman_CHARLS$pVal_Chisq[df_Haussman_CHARLS$Equation == tmpYname] <- tmp$p.value
    # 2.1.4 robust Haussman test (H0: random effect)
    tmp <- plm::phtest( li_ModFix_CHARLS[[tmpYname]], li_ModRan_CHARLS[[tmpYname]], method = "aux",
                        vcov = function(x) plm::vcovHC(x, method="white2",type="HC3")   )
    df_Haussman_CHARLS$ChisqRobust[df_Haussman_CHARLS$Equation == tmpYname] <- tmp$statistic
    df_Haussman_CHARLS$pVal_ChisqRobust[df_Haussman_CHARLS$Equation == tmpYname] <- tmp$p.value

    # 2.1.4 summary, print the effect models
    cat("\n---------------------------\n")
    cat("FIXED INDIVIDUAL EFFECT MODEL: ",tmpYname,"\n")
    print(   summary(  li_ModFix_CHARLS[[tmpYname]], vcov = vcovHC(li_ModFix_CHARLS[[tmpYname]])  )   )
}

# 2.2 print & output the results of Haussman tests
cat("\n---------------------------\n")
cat("HAUSSMAN TEST RESULT; H0: SHOULD USE RANDOM INDIVIDUAL EFFECT","\n")
print(df_Haussman_CHARLS)
write.csv(df_Haussman_CHARLS, file = paste(sep="",envCHARLS$Output,"HaussmanTest_CHARLS.csv"))

# -------------------------------------
## SECTION 3: NORMALITY OF THE BENCHMARK MODEL (FIXED INDIVIDUAL EFFECT MODEL)
cat("\nSECTION 3: NOTMALITY OF THE BENCHMARK MODEL (FIXED INDIVIDUAL EFFECT MODEL)")
#       H0: normal distribution
# ---------------
df_NormTest_CHARLS <- list(
    Test = c( "Shapiro-Wilk", "Pearson Chi-square", "Lilliefor",
              "Anderson-Darling", "Cramer-von Mises" )  # test names
)  # saves p-values; converted to a df later

for(tmpYname in envCHARLS$Ynames){
    # 3.1 qqplots: plotting & output
    pdf(file = paste(sep="",envCHARLS$Output,"ResidQQ_FixIndi_CHARLS_",tmpYname,".pdf"), width = 12, height = 10)
    func_easyQQnorm( residuals(li_ModFix_CHARLS[[tmpYname]]), ylab = paste(sep="","resid(",tmpYname,")"), alpha = 0.05 )
    dev.off()
    # 3.2 normality tests
    tmp <- residuals(li_ModFix_CHARLS[[tmpYname]])
    df_NormTest_CHARLS[[tmpYname]] <- c(
        shapiro.test( tmp )$p.value,  # Shapiro-Wilk test
        nortest::pearson.test( tmp )$p.value,  # Peason chi-sqaure test
        nortest::lillie.test( tmp )$p.value,  # Kolmogorov-Smirnov test
        nortest::ad.test( tmp )$p.value,  # Anderson-Darling test
        nortest::cvm.test( tmp )$p.value  # Cramer-von Mises test
    )
}

# 3.3 convert to a dataframe then output
df_NormTest_CHARLS <- data.frame(df_NormTest_CHARLS)
write.csv(df_NormTest_CHARLS,file = paste(sep="",envCHARLS$Output,"NormTest_CHARLS.csv"))

# -------------------------------------
## SECTION 4: (ROBUST) TWO-WAYS FIXED EFFECT MODEL & CONSISTENCY WITH ONE-WAY FIXED INDIVIDUAL EFFECT MODEL
cat("\nSECTION 4: (ROBUST) TWO-WAYS FIXED EFFECT MODEL & CONSISTENCY WITH ONE-WAY FIXED INDIVIDUAL EFFECT MODEL")
# --------------
li_ModTwo_CHARLS <- list()
df_exHaussman_CHARLS <- df_Haussman_CHARLS  # use the same structure

# 4.1 estimate & Haussman
for(tmpYname in envCHARLS$Ynames){
    # slice a temp data
    tmpdf <- li_DatPlm_CHARLS[[tmpYname]]

    # 4.1.1 estimate a two-way model
    li_ModTwo_CHARLS[[tmpYname]] <- plm::plm( li_Eq_CHARLS[[tmpYname]], tmpdf, effect = "twoways", model = "within" )
    # 4.1.2 Haussman test (original)
    tmp <- df_exHaussman_CHARLS$Equation == tmpYname
    tmp2 <- plm::phtest( li_ModFix_CHARLS[[tmpYname]], li_ModTwo_CHARLS[[tmpYname]] )
    df_exHaussman_CHARLS$Chisq <- tmp2$statistic
    df_exHaussman_CHARLS$pVal_Chisq <- tmp2$p.value
    # 4.1.2 Robust Haussman test (auxiliary regression based)
    tmp2 <- plm::phtest( li_ModFix_CHARLS[[tmpYname]], li_ModTwo_CHARLS[[tmpYname]], method = "aux" )
    df_exHaussman_CHARLS$ChisqRobust <- tmp2$statistic
    df_exHaussman_CHARLS$pVal_ChisqRobust <- tmp2$p.value

    # print the two-way model
    print( summary( li_ModTwo_CHARLS[[tmpYname]], vcov = vcovHC(li_ModTwo_CHARLS[[tmpYname]])   ) )  # summary, using robust cov-mat estimates

}

# 4.2 convert the results of Haussman test to a df, then output
df_exHaussman_CHARLS <- data.frame(df_exHaussman_CHARLS)
write.csv(df_exHaussman_CHARLS, file=paste(sep="",envCHARLS$Output,"exHaussman_2Wayor1Way_CHARLS.csv"))

# -------------------------------------
## SECTION 5: (ROBUST) ADD EXTRA POSSIBLE VARIABLE:
# NOTE:
#
#
#
# ----------

# -------------------------------------
## SECTION 6: FORMATTED OUTPUT (FOR MS WORD)
# NOTE: in this section, we formatted the results for MS WORD software,
#       then output as excel file (because .csv may lead strings to be recognized as numbers )
# -----------
li_Report_CHARLS <- list()  # a list to save formatted reports
for(tmpYname in envCHARLS$Ynames){
    # 6.1 temp df
    tmpdf1 <- format_plm( summary(li_ModFix_CHARLS[[tmpYname]] , vcov = vcovHC(li_ModFix_CHARLS[[tmpYname]])  ) ,
                          Yname = paste(sep="",tmpYname,"_FixIndi_OLS_HCse") )  # fixed  individual effect, OLS estimator + robustSE
    tmpdf2 <- format_pggls( summary(li_ModRan_CHARLS[[tmpYname]]) ,
                            Yname = paste(sep="",tmpYname,"_RanIndi_FGLS") )  # random individual effect, FGLS estimator
    tmpdf3 <- format_plm(   summary(li_ModTwo_CHARLS[[tmpYname]] ,  vcov = vcovHC(li_ModTwo_CHARLS[[tmpYname]]) ) ,
                            Yname = paste(sep="",tmpYname,"_TwoWays_OLS_HCse") )  # two-ways fixed effect model + robustSE
    tmpdf4 <- format_gls(   summary(li_ModPoolGLS_CHARLS[[tmpYname]])  ,
                            Yname = paste(sep="",tmpYname,"_Pooling_GLS") )  # Pooling, GLS estimator
    tmpdf5 <- format_lm(    summary(li_ModPoolOLS_CHARLS[[tmpYname]])  ,
                            Yname = paste(sep="",tmpYname,"_Pooling_OLS") )  # Pooling, OLS estimator
    # 6.2 merging
    li_Report_CHARLS[[tmpYname]] <- plyr::join(
        tmpdf1, tmpdf2,
        by = "Variable", type = "full"
    )
    li_Report_CHARLS[[tmpYname]] <- plyr::join(
        li_Report_CHARLS[[tmpYname]], tmpdf3,
        by = "Variable", type = "full"
    )
    li_Report_CHARLS[[tmpYname]] <- plyr::join(
        li_Report_CHARLS[[tmpYname]], tmpdf4,
        by = "Variable", type = "full"
    )
    li_Report_CHARLS[[tmpYname]] <- plyr::join(
        li_Report_CHARLS[[tmpYname]], tmpdf5,
        by = "Variable", type = "full"
    )

}
# 6.3 garbage collection
rm( tmpdf1, tmpdf2, tmpdf3, tmpdf4, tmpdf5 )

# print info
print(li_Report_CHARLS)

# output to excel
openxlsx::write.xlsx(li_Report_CHARLS, file = paste(sep="",envCHARLS$Output,"RegReport_CHARLS.xlsx") )

df_Haussman_CHARLS


#' MLE for the Zero-truncated Poisson Lognormal mixture distribtuion
#'
#' `ztplnmMLE` fits the Zero-truncated Poisson lognormal mixture distribution
#' to data and estimates parameters mean `mu`, standard deviation `sig` and
#' mixture weight `theta` in the lognormal distribution.
#'
#' The function searches the maximum likelihood estimators of mean vector `mu`,
#' standard deviation vector `sig` and mixture weight vector `theta` using the
#' optimization procedures in \code{\link{nlminb}}.
#'
#' @param n a vector of counts
#' @param K number of components
#' @param lower_mu,upper_mu numeric values of lower and upper bounds for mean of
#' the variables's natural logarithm.
#' @param lower_sig,upper_sig numeric values of lower and upper bounds for
#' standard deviation of the variables's natural logarithm
#' @param lower_theta,upper_theta numeric values of lower and upper bounds for
#'  mixture weights.
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @param message mean of lognormal distribution in sample 3.
#' @return \item{convergence}{An integer code. 0 indicates successful
#' convergence.}
#' @return \item{iterations}{Number of iterations performed.}
#' @return \item{message}{A character string giving any additional information
#' returned by the optimizer, or NULL. For details, see PORT documentation.}
#' @return \item{evaluation}{Number of objective function and gradient function
#'  evaluations}
#' @return \item{mu}{Maximum likelihood estimates of mu}
#' @return \item{sig}{Maximum likelihood estimates of sig}
#' @return \item{theta}{Maximum likelihood estimates of theta}
#' @return \item{loglik}{loglikelihood}
#' @examples
#' y <- rztplnm(100, c(1, 10), c(2, 1), c(0.2, 0.8))
#' ztplnmMLE(y)
#' @export
ztplnmMLE <- function(n,
                      K = 2,
                      lower_mu = rep(0, K),
                      upper_mu = rep(log(max(n)), K),
                      lower_sig = rep(0.001, K),
                      upper_sig = rep(10, K),
                      lower_theta = rep(0.001, K),
                      upper_theta = rep(0.999, K),
                      type1 = TRUE,
                      message = FALSE) {

  if (K == 1) {warning("`ztplnMLE` is faster for K = 1")}

  n <- n[n > 0]
  max_abund <- log(max(n))

  if (message) {
    sink("/dev/null")  # now suppresses
    fit0 <- try(mixtools::normalmixEM(log(n), k = K, maxrestart = 20))
    sink()
  } else {
    fit0 <- try(mixtools::normalmixEM(log(n), k = K, maxrestart = 20))
  }

  # set initial values using normalmixEM for better convergence
  if (class(fit0) == "try-error") {
    params <- c(rep(1, 2 * K), rep(1 / K, K))
  } else {
    params <- c(fit0$mu, fit0$sig, fit0$lambda)
  }

  loglik <- function(params, n) {
    mu <- params[1:K]
    sig <- params[(K + 1):(2 * K)]
    theta <- params[(2 * K + 1):(3 * K)]
    theta <- theta / sum(theta)
    if (type1) {
      lik <- do_dztplnm(n, mu, sig, theta)
    } else lik <- do_dztplnm2(n, mu, sig, theta)
    return(-sum(log(lik), na.rm = TRUE))
  }

  fit <- try(nlminb(start = params, # inital parameters
                    loglik, # function to be minimized (i.e., -logLike)
                    gradient = NULL,
                    lower = c(lower_mu, lower_sig, lower_theta),
                    upper = c(upper_mu, upper_sig, upper_theta),
                    n = n,
                    TRUE))

  fit$mu <- fit$par[1:K]
  fit$sig <- fit$par[(K + 1):(2 * K)]
  theta <- fit$par[(2 * K + 1):(3 * K)]
  fit$theta <- theta / sum(theta)
  fit$par <- NULL
  fit$loglik <- -fit$objective
  fit$objective <- NULL
  return(fit)
}


subroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror)

# The segment k1->k2 is a diagonal of a quadrilateral
# with a vertex at j (the point being added to the
# triangulation).  If the LOP is not satisfied, swap
# it for the other diagonal.
# Called by addpt.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
logical shdswp

# If vertices k1 and k2 are not connected there is no diagonal to swap.
# This could happen if vertices j, k1, and k2 were colinear, but shouldn't.
call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror)
if(nerror > 0) return
if(!shdswp) return

# Get the other vertex of the quadrilateral.
call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then
if(nerror > 0) return
call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex.
if(nerror > 0) return
if(kk!=k) {
        shdswp = .false.
        return
}

# Check whether the LOP is satisified; i.e. whether
# vertex k is outside the circumcircle of vertices j, k1, and k2
call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror)
if(nerror > 0) return

# Do the actual swapping.
if(shdswp) {
        call delet(k1,k2,nadj,madj,ntot,nerror)
	if(nerror > 0) return
	call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps)
	if(nerror > 0) return
}
return
end


library(bivpois) # loading of bivpois library
data(ex4.ita91)  # loading ex4.ita91 data from bivpois library
#
# formula for modeling of lambda1 and lambda2
form1 <- ~c(team1,team2)+c(team2,team1)
xtemp<-readline(prompt = "Press Enter to Continue")
#
# Model 1: Double Poisson
ex4.m1<-lm.bp( g1~1, g2~1, l1l2=form1, zeroL3=TRUE, data=ex4.ita91)
#
# Models 2-5: bivariate Poisson models
ex4.m2<-lm.bp(g1~1,g2~1, l1l2=form1, data=ex4.ita91)
ex4.m3<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1, data=ex4.ita91)
ex4.m4<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team2, data=ex4.ita91)
ex4.m5<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1+team2, data=ex4.ita91)
#
# Model 6: Zero Inflated Model
ex4.m6 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=0)
#
# Models 7-11: Diagonal Inflated Bivariate Poisson Models
ex4.m7 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='geometric' )
ex4.m8 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=1)
ex4.m9 <-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=2)
ex4.m10<-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, jmax=3)
ex4.m11<-lm.dibp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='poisson' )
#
# Models 12: Diagonal Inflated Double Poisson Model
ex4.m12 <- lm.dibp( g1~1,g2~1, l1l2=form1, data=ex4.ita91, distribution='poisson', zeroL3=TRUE )
# --------------------------------------------------------------------------

#
# --------------------------------------------------------------------------
# monitoring parameters for model 1: Dbl Poisson
ex4.m1$coef		# all parameters
ex4.m1$beta1		# model parameters for lambda1
ex4.m1$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m1$beta2[1]		# Intercpept for lambda2.
ex4.m1$beta2[1]-ex4.m1$beta2[2]	# estimated home effect

-sum(ex4.m1$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m1$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------
# monitoring parameters for model 2: Biv Poisson (lamdba1, lambda2, constant lamdba3)
#
#
# monitoring parameters for model 1: Dbl Poisson
ex4.m2$beta1		# model parameters for lambda1
ex4.m2$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m2$beta3		# model parameters for lambda3. Here beta3 has only the intercept
ex4.m2$beta2[1]		# Intercpept for lambda2.
ex4.m2$beta2[1]-ex4.m2$beta2[2]	# estimated home effect

-sum(ex4.m2$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m2$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------

# --------------------------------------------------------------------------
# monitoring parameters for model 8: Biv Poisson with Dis(1) diagonal distribution
#
#
# monitoring parameters for model 1: Dbl Poisson
ex4.m8$beta1		# model parameters for lambda1
ex4.m8$beta2		# model parameters for lambda2.
			# All are the same as in beta1 except the intercept
ex4.m8$beta3		# model parameters for lambda3. Here beta3 has only the intercept
ex4.m8$beta2[1]		# Intercpept for lambda2.
ex4.m8$beta2[1]-ex4.m8$beta2[2]	# estimated home effect

-sum(ex4.m8$coef[ 2:18]) # estimating the effect for 18th level of attack (team1..team2) [Verona]
-sum(ex4.m8$coef[19:35]) # estimating the effect for 18th level of defence(team2..team1) [Verona]

ex4.m8$beta3		 # parameters for lambda3 (here the intercept)
exp(ex4.m8$beta3)	 # lambda3 (here constant)
ex4.m8$diagonal.distribution # printing details for the diagonal distribution
ex4.m8$p		 # mixing proportion
ex4.m8$theta		 # printing theta parameters
xtemp<-readline(prompt = "Press Enter to Continue")
#
# --------------------------------------------------------------------------

# --------------------------------------------------------------------------
# monitoring parameters for model 8: Biv Poisson with Dis(1) diagonal distribution
#
#
ex4.m8$diagonal.distribution            # printing details for the diagonal distribution
round(ex4.m8$beta1,2)		        # model parameters for lambda1
round(ex4.m8$beta2[1],2)		# Intercpept for lambda2.
round(ex4.m8$beta2[1]-ex4.m8$beta2[2],2)# estimated home effect
#
# estimating the effect for 18th level of attack (team1..team2) [Verona]
round(-sum(ex4.m8$coef[ 2:18]),2)
# estimating the effect for 18th level of defence(team2..team1) [Verona]
round(-sum(ex4.m8$coef[19:35]),2)
#
ex4.m8$beta3		 # parameters for lambda3 (here the intercept)
exp(ex4.m8$beta3)	 # lambda3 (here constant)
ex4.m8$p		 # mixing proportion
ex4.m8$theta		 # printing theta parameters
#
# --------------------------------------------------------------------------


##' Calculate risk ratios for mass testing in Slovakia
##'
##' @return alist of two lists: "figures" (containing Fig. 2a and 2b in the manuscript) and "tables" (containing the total prevalence risk ratios in pilot regions ("pilot") and those regions that had two rounds of testing ("nation")
##' @importFrom dplyr filter rowwise mutate select
##' @importFrom tidyr pivot_longer separate pivot_wider
##' @importFrom ggplot2 ggplot aes geom_errorbar geom_point xlab scale_color_brewer scale_y_continuous position_dodge coord_flip theme_classic theme ylab geom_hline scale_color_manual scale_x_discrete
##' @importFrom scales percent
##' @importFrom epitools epitab
##' @export
risk_ratios <- function() {
  ret_fig <- list()
  ret_rr <- list()

  ms.tst %>%
    filter(pilot == T) %>%
    rowwise() %>%
    mutate(pRR_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("upper")],
           pRR_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")],
           pRR_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(county, pRR_12, pRR.lo_12, pRR.hi_12, pRR_23, pRR.lo_23, pRR.hi_23, pRR_13, pRR.lo_13, pRR.hi_13) -> pRR_pilot

  ret_fig[["b"]] <- pRR_pilot %>%
    pivot_longer(c(-county)) %>%
    separate(name, c("name", "round"), "_") %>%
    pivot_wider(names_from = name, values_from = value) %>%
    ggplot(aes(x=county, y=1-pRR, ymin=1-pRR.lo, ymax=1-pRR.hi, color = round)) +
    geom_errorbar(width = 0.0, position = position_dodge(width = 0.3)) +
    geom_point(position = position_dodge(width = 0.3)) +
    xlab("\n\n\n\n") + ylab("Reduction in prevalence\n(1 - prevalence risk ratio)") +
    scale_color_brewer(palette = "Dark2",
                       name = "Comparisons",
                       labels = c("pilot vs round 1", "pilot vs round 2", "round 1 vs 2")) +
    scale_y_continuous(labels = scales::percent,
                       breaks = c(0,.25,.5,.75,1),
                       limits = c(0,1)) +
    coord_flip() +
    theme_classic() +
    theme(legend.position = c(.15,.7))

  ## pilot prevalence RR overall
  ms.tst %>%
    filter(pilot == T) %>%
    select(attendance_1, attendance_2, attendance_3, positive_1, positive_2, positive_3) %>%
    summarise_all(sum) %>%
    mutate(pRR_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_12 = epitab(c(attendance_1-positive_1,positive_1,attendance_2-positive_2,positive_2),method = "riskratio")$tab[2,c("upper")],
           pRR_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_23 = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")],
           pRR_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi_13 = epitab(c(attendance_1-positive_1,positive_1,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(pRR_12, pRR.lo_12, pRR.hi_12, pRR_23, pRR.lo_23, pRR.hi_23, pRR_13, pRR.lo_13, pRR.hi_13) -> pRR_pilot_sum
  ret_rr[["pilot"]] <- 1-pRR_pilot_sum %>% round(2)

  ## mass test prevalence RR by county
  ms.tst %>%
    filter(!is.na(positive_2) & !is.na(positive_3) & !is.na(attendance_2) & !is.na(attendance_3)) %>%
    rowwise() %>%
    mutate(pRR = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(county, region, pRR, pRR.lo, pRR.hi) -> pRR_mass
  ret_rr[["county"]] <- pRR_mass

  ms.tst %>%
    filter(!is.na(positive_2) & !is.na(positive_3) & !is.na(attendance_2) & !is.na(attendance_3)) %>%
    select(positive_2, attendance_2, positive_3, attendance_3) %>%
    summarise_all(sum) %>%
    mutate(pRR = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("riskratio")],
           pRR.lo = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("lower")],
           pRR.hi = epitab(c(attendance_2-positive_2,positive_2,attendance_3-positive_3,positive_3),method = "riskratio")$tab[2,c("upper")]) %>%
    select(pRR, pRR.lo, pRR.hi) %>%
    mutate(county = "Overall")-> pRR_mass_sum
  ret_rr[["all"]] <- 1-(pRR_mass_sum %>% select(-county)) %>% round(2)

  ret_fig[["a"]] <- pRR_mass %>%
    ggplot(aes(x=interaction(region,county,lex.order = T), y=1-pRR, ymin=1-pRR.lo, ymax=1-pRR.hi, color = region)) +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR, alpha=.7, color="red") +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR.lo, alpha=.5, color="red", lty="dotted") +
    geom_hline(yintercept = 1-pRR_mass_sum$pRR.hi, alpha=.5, color="red", lty="dotted") +
    geom_errorbar(width = 0.0) +
    geom_point() +
    xlab("") + ylab("Reduction in prevalence between mass testing rounds\n(1 - prevalence risk ratio)") +
    scale_color_manual(values = c("#636363","#3182bd","#969696","#6baed6","#bdbdbd","#9ecae1","#d9d9d9"),
                       name = "Region") +
    scale_y_continuous(labels = scales::percent,
                       limits = c(0,1)) +
    scale_x_discrete(labels = make_labels) +
    coord_flip() +
    theme_classic() +
    theme(legend.position = c(.15,.85))

  return(list(figures = ret_fig, tables = ret_rr))
}


plotCellHist = function(deviation, plot, title) {
  hist(deviation$deviation, breaks=seq(-5,5,by=0.1), main=title, xlab=NA, ylab=NA,
       col='grey', xlim=c(-1.0, 1.0), border=NA)
  abline(v=-0.5, lty=2)
  abline(v=0.5, lty=2)
}

deviation = read.delim("deviation.csv")
pdf("deviation.pdf", width=6, height=1.8, pointsize=10)
layout(matrix(c(1,2,3), 1, 3, byrow=T), heights=c(700,200))
#layout.show(4)
old = par(mar=c(2.5,2,3,0.5), lwd=0.2)
plotCellHist(deviation[deviation$tag == "uniform" & deviation$Q > 0.3 & deviation$Q < 0.7,], "uniform-deviation.png", "Uniform q=0.3 ... 0.7")
plotCellHist(deviation[deviation$tag == "gamma" & deviation$Q > 0.3 & deviation$Q < 0.7,], "gamma-deviation.png", "Gamma(0.1, 0.1) q=0.3 ... 0.7")

plotCellHist(deviation[deviation$tag == "gamma" & deviation$mean > 0.01 & deviation$mean < 0.015,], "gamma-low.png", "Gamma, q=0.01")
par(old)
dev.off()


### Pre-processing using Caret

We need to pre-process our data before we can use it for modeling. Let’s check if the data has any missing values:

sum(is.na(train))
#[1] 86

Next, let us use Caret to impute these missing values using KNN algorithm. We will predict these missing values based on other attributes for that row. Also, we’ll scale and center the numerical data by using the convenient ``preprocess()`` in Caret.

#Imputing missing values using KNN.Also centering and scaling numerical columns
preProcValues <- preProcess(train, method = c("knnImpute","center","scale"))

library('RANN')
train_processed <- predict(preProcValues, train)
sum(is.na(train_processed))
#[1] 0

It is also very easy to use one hot encoding in Caret to create dummy variables for each level of a categorical variable. But first, we’ll convert the dependent variable to numerical.

#Converting outcome variable to numeric
train_processed$Loan_Status<-ifelse(train_processed$Loan_Status=='N',0,1)

id<-train_processed$Loan_ID
train_processed$Loan_ID<-NULL

#Checking the structure of processed train file
str(train_processed)
#'data.frame':         614 obs. of  12 variables:
#$ Gender           : Factor w/ 3 levels "","Female","Male": 3 3 3 3 3 3 3 3 3 3 ...
#$ Married          : Factor w/ 3 levels "","No","Yes": 2 3 3 3 2 3 3 3 3 3 ...
#$ Dependents       : Factor w/ 5 levels "","0","1","2",..: 2 3 2 2 2 4 2 5 4 3 ...
#$ Education        : Factor w/ 2 levels "Graduate","Not Graduate": 1 1 1 2 1 1 2 1 1 #1 ...
#$ Self_Employed    : Factor w/ 3 levels "","No","Yes": 2 2 3 2 2 3 2 2 2 2 ...
#$ ApplicantIncome  : num  0.0729 -0.1343 -0.3934 -0.4617 0.0976 ...
#$ CoapplicantIncome: num  -0.554 -0.0387 -0.554 0.2518 -0.554 ...
#$ LoanAmount       : num  0.0162 -0.2151 -0.9395 -0.3086 -0.0632 ...
#$ Loan_Amount_Term : num  0.276 0.276 0.276 0.276 0.276 ...
#$ Credit_History   : num  0.432 0.432 0.432 0.432 0.432 ...
#$ Property_Area    : Factor w/ 3 levels "Rural","Semiurban",..: 3 1 3 3 3 3 3 2 3 2 #...
#$ Loan_Status      : num  1 0 1 1 1 1 1 0 1 0 ...
Now, creating dummy variables using one hot encoding:

#Converting every categorical variable to numerical using dummy variables
dmy <- dummyVars(" ~ .", data = train_processed,fullRank = T)
train_transformed <- data.frame(predict(dmy, newdata = train_processed))

#Checking the structure of transformed train file
str(train_transformed)
#'data.frame':         614 obs. of  19 variables:
#$ Gender.Female          : num  0 0 0 0 0 0 0 0 0 0 ...
#$ Gender.Male            : num  1 1 1 1 1 1 1 1 1 1 ...
#$ Married.No             : num  1 0 0 0 1 0 0 0 0 0 ...
#$ Married.Yes            : num  0 1 1 1 0 1 1 1 1 1 ...
#$ Dependents.0           : num  1 0 1 1 1 0 1 0 0 0 ...
#$ Dependents.1           : num  0 1 0 0 0 0 0 0 0 1 ...
#$ Dependents.2           : num  0 0 0 0 0 1 0 0 1 0 ...
#$ Dependents.3.          : num  0 0 0 0 0 0 0 1 0 0 ...
#$ Education.Not.Graduate : num  0 0 0 1 0 0 1 0 0 0 ...
#$ Self_Employed.No       : num  1 1 0 1 1 0 1 1 1 1 ...
#$ Self_Employed.Yes      : num  0 0 1 0 0 1 0 0 0 0 ...
#$ ApplicantIncome        : num  0.0729 -0.1343 -0.3934 -0.4617 0.0976 ...
#$ CoapplicantIncome      : num  -0.554 -0.0387 -0.554 0.2518 -0.554 ...
#$ LoanAmount             : num  0.0162 -0.2151 -0.9395 -0.3086 -0.0632 ...
#$ Loan_Amount_Term       : num  0.276 0.276 0.276 0.276 0.276 ...
#$ Credit_History         : num  0.432 0.432 0.432 0.432 0.432 ...
#$ Property_Area.Semiurban: num  0 0 0 0 0 0 0 1 0 1 ...
#$ Property_Area.Urban    : num  1 0 1 1 1 1 1 0 1 0 ...
#$ Loan_Status            : num  1 0 1 1 1 1 1 0 1 0 ...

#Converting the dependent variable back to categorical
train_transformed$Loan_Status<-as.factor(train_transformed$Loan_Status)
Here, “fullrank=T” will create only (n-1) columns for a categorical column with n different levels. This works well particularly for the representing categorical predictors like gender, married, etc. where we only have two levels: Male/Female, Yes/No, etc. because 0 can be used to represent one class while 1 represents the other class in same column.