# wahpenayo at gmail dot com
# 2018-02-24
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/zana')) {
  setwd('e:/porta/projects/zana')
} else {
  setwd('c:/porta/projects/zana')
}
source('src/scripts/r/functions.r')
#-----------------------------------------------------------------
make.huber <- function (epsilon) {
  a <- 0.5 / epsilon
  b <- -0.5 * epsilon
  function (x) { ifelse((abs(x)<=epsilon),a*x*x,abs(x) + b) } }
#-----------------------------------------------------------------
make.huber <- function (epsilon) {
  function (x) {
    ifelse((abs(x)<=0.5*epsilon),
      x*x/epsilon,
      abs(x) - 0.25*epsilon) } }
#-----------------------------------------------------------------
dev.on(
  file=file.path('tst','huber'),
  aspect=0.5,
  width=1280)
h <- make.huber(1.0)
plot.function(h,from=-3,to=3,n=101)
dev.off()
#-----------------------------------------------------------------
make.huberqr <- function (epsilon,p) {
  q <- p-1
  lower <- -p * epsilon
  upper <- (1-p) * epsilon
  a0 <- (0.5*(1-p)) / (p*epsilon)
  a1 <- (0.5*p) / ((1-p)*epsilon)
  b <- -0.5 * p * (1-p) * epsilon
  function (x) {
    ifelse((x<=lower),
      ((p-1)*x) + b,
      ifelse((x<=0.0),
        a0*x*x,
        ifelse((x<=upper),
          a1*x*x,
          (p*x) + b))) } }
#-----------------------------------------------------------------
dev.on(file=file.path('tst','huberqr'), aspect=0.5, width=1280)
h <- make.huberqr(1.0,0.25)
plot.function(h,from=-3,to=3,n=101)
dev.off()
#-----------------------------------------------------------------


library(ggplot2)
library(data.table) # for fread()
library(ggthemes) # Themes

# Used to label the countries
pointsToLabel <- c("Russia", "Venezuela", "Iraq", "Myanmar", "Sudan",
                   "Afghanistan", "Congo", "Greece", "Argentina", "Brazil",
                   "India", "Italy", "China", "South Africa", "Spane",
                   "Botswana", "Cape Verde", "Bhutan", "Rwanda", "France",
                   "United States", "Germany", "Britain", "Barbados", "Norway", "Japan",
                   "New Zealand", "Singapore")

# Reads the document, drop = 1 skips the first column
d <- fread('economist-project-data.csv', drop = 1)

# Create the scatterplot
plot <- ggplot(d, aes(x = CPI, y = HDI, color = Region))
# Create circles
plot <- plot + geom_point(size = 4, shape = 1)
# Creates a line through data
# se = F removes the gray area around the line
# method = 'lm' means linear modeling
plot <- plot + geom_smooth(aes(group = 1), method = 'lm', formula = y~log(x), se = F, color = 'red') # Linear regression
# Add text to the circles
plot <- plot + geom_text(aes(label = Country), color = 'gray20', data = subset(d, Country %in% pointsToLabel), check_overlap = T)
plot <- plot + scale_x_continous(limits = c(.9, 10.5), breaks = 1:10)
plot <- plot + theme_economist_white() # theme to mimic the economist


pdf('SRR4238351_subsamp.sorted.rseqc.junctionSaturation_plot.pdf')
x=c(5,10,15,20,25,30,35,40,45,50,55,60,65,70,75,80,85,90,95,100)
y=c(9,15,21,22,23,24,26,28,29,29,31,34,35,38,38,38,38,38,42,42)
z=c(9,15,22,23,24,26,28,31,33,33,36,40,41,44,44,44,44,45,49,49)
w=c(0,0,1,1,1,2,2,3,4,4,5,6,6,6,6,6,6,7,7,7)
m=max(0,0,0)
n=min(0,0,0)
plot(x,z/1000,xlab='percent of total reads',ylab='Number of splicing junctions (x1000)',type='o',col='blue',ylim=c(n,m))
points(x,y/1000,type='o',col='red')
points(x,w/1000,type='o',col='green')
legend(5,0, legend=c("All junctions","known junctions", "novel junctions"),col=c("blue","red","green"),lwd=1,pch=1)
dev.off()


user.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/user-degree.txt", quote="\"")
#job.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/job-degree.txt", quote="\"")
#process.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/process-degree", quote="\"")

pdf(file="/Users/daidong/Documents/gitrepos/triton-private/papers/meta-graph/exps/udegree.pdf",height=5, width=8,bg="white")
x = user.degree$V1
y = user.degree$V2

s = sum(y)

maxX=max(log10(x))
maxY=max(log10(y))

plot(log10(x), log10(y), xaxt="n", yaxt="n", xlab="Degree", ylab="Number of Vertices", xlim=c(0, maxX), ylim=c(0, maxY))

ticks=seq(0, maxX, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(1, at=ticks, labels=labels)

ticks=seq(0, maxY, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(2, at=ticks, labels=labels, las=1)

invisible(dev.off())


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

 devtools::install_github("ellisp/nzelect/pkg2")

 library(leaflet)
 library(nzcensus)
 library(Metrics)
 library(ggplot2)
 library(scales)
 library(boot)
 library(dplyr)
 library(Hmisc)
 library(mgcv)
 library(caret)
 library(grid)
 library(stringr)
 library(ggrepel)
 library(glmnet)
 library(maps)

 tmp <- AreaUnits2013[AreaUnits2013$WGS84Longitude  0 & !is.na(AreaUnits2013$MedianIncome2013), ]

 palette <- colorQuantile("RdBu", NULL, n = 10)

 labels <- paste0(tmp$AU_NAM, " $", format(tmp$MedianIncome2013, big.mark = ","))

 leaflet() %>%
     addProviderTiles("CartoDB.Positron") %>%
     addCircles(lng = tmp$WGS84Longitude, lat = tmp$WGS84Latitude,
                color = pal(-tmp$MedianIncome2013),
                popup = labs,
                radius = 500) %>%
     addLegend(
         pal = pal,
         values = -tmp$MedianIncome2013,
         title = "Quantile of median<brhousehold income",
         position = "topleft",
         bins = 5)

 au <- AreaUnits2013 %>%
     select(-AU2014, -AU_NAM, -NZTM2000Easting, -NZTM2000Northing) %>%
     select(-PropWorked40_49hours2013, -Prop35to39_2013, -PropFemale2013)

 row.names(au) <- AreaUnits2013$AU_NAM

 names(au) <- gsub("_2013", "", names(au))

 names(au) <- gsub("2013", "", names(au))

 names(au) <- gsub("Prop", "", names(au))

 au <- au[complete.cases(au), ]

 data_use <- au

 dim(data_use)

 data_use <- data_use[the_data$WGS84Longitude > 100, ]

 names(data_use) <- make.names(names(data_use))

 names(data_use)

 reg_data <- spearman2(MedianIncome ~ ., data = data_use)
 reg_data[order(-reg_data[ ,6])[1:15], ]

 reg_formula <- terms(MedianIncome ~
                         s(FullTimeEmployed, k = 6) +
                         s(InternetHH, k = 6) +
                         s(NoQualification, k = 5) +
                         s(UnemploymentBenefit, k = 5) +
                         s(Smoker, k = 5) +
                         s(Partnered, k = 5)  +
                         s(Managers, k = 4) +
                         s(Bachelor, k = 4) +
                         s(SelfEmployed, k = 4) +
                         s(NoMotorVehicle, k = 4) +
                         s(Unemployed, k = 3) +
                         s(Labourers, k = 3) +
                         s(Worked50_59hours, k = 3) +
                         s(Separated, k = 3) +
                         s(Maori, k = 3) +
                         s(WGS84Longitude, WGS84Latitude) +
                         .,
                     data = data_use)

 gam_model <- gam(reg_formula, data = data_use)

 par(bty = "l", mar = c(5,4, 2, 1))

 par(mar = rep(2, 4))

 plot(gam_model, residuals = TRUE, pages = 1, shade = TRUE, seWithMean = TRUE, ylab = "")

 rmses_gam_boot <- boot(data = data_use, statistic = fit_gam, R = 99)

 rmses_gam_boot

 gam_rmse <- mean(rmses_gam_boot$t)

 gam_rmse

Chapter 05/1Generalized additive model - Measuring household income of New Zealand.r


drought_data <- read.csv("drought_data_new.csv",header = TRUE, sep = ",")
diff_c_d <- read.csv("drought_control_vs_treated.csv", header = TRUE,sep = ",")
real_c_d <- read.csv("drought_c_d_real.csv",header = TRUE,sep = ",")

pca <- prcomp(real_c_d[,8])
summary(pca)

plot(scale(pca$x[,1]),xlim = c(1,12), xlab = "Cultivars", ylab = "PC1",
          main="Classification using Proline percent changes", pch=c(21),
          bg = c("red", "green","blue")[unclass(real_c_d$Species)],
     legend("topleft", title="Type of Species", inset = 0.01, horiz = TRUE,
            c("T. Erecta", "T. Patula","T. Tenuifolia"), fill=c("red", "green","blue")))

# a <- text(pca$x[,1], labels = real_c_d$Species, cex=0.7, col="blue")


# get *n* degree polynomial trend surface from point shapefile
# originally made to produce maps of Saffir-Simpson index for all Atlantic hurricanes in HURDAT
# TODO: add basemap to png
# TODO: choose best polynomial based on data
# TODO: export tif
# args are: 1) input GIS vector points, 2) polynomial degree, 3) trmat grid dimensions (n X n)
# example use: Rscript --vanilla $0 AL032009.shp 1 500

# load prereqs
library(methods) # this is only required when running with Rscript
library(maptools)
library(spatial)
# get user args
args <- commandArgs(trailingOnly = TRUE)
# load points
d <- readShapePoints(args[1])
# get name of layer without file extension - assumes a period then a file extension then end of line
# needed for plot title, png filename
layerName <- unlist(strsplit(basename(args[1]),"\\."))[1]
# numeric fields are numeric
# TODO loop over user arg list of fields
d$lon <- as.numeric(as.character(d$lon))
d$lat <- as.numeric(as.character(d$lat))
d$sshws <- as.numeric(as.character(d$sshws))
# make trend surface
t <- surf.ls(as.numeric(args[2]),d$lon,d$lat,d$sshws)
# make trend surface over grid
g <- trmat(t,bbox(d)[1,1],bbox(d)[1,2],bbox(d)[2,1],bbox(d)[2,2],as.numeric(args[3]))
# enforce min (0) and max (particular to the HURDAT points)
# first find the SSHWS max
maxsshws <- max(d$sshws)
# now enforce 0 min and SSHWS max on trend grid
g$z <- round(replace(replace(g$z,g$z>maxsshws,maxsshws),g$z<0,0))
# visual
png(paste("/tmp/",layerName,".png",sep=''))
image(g)
title(main=paste(layerName, ", ",args[2]," Degree Polynomial",sep=''))
contour(g,labcex=1,add=T,nlevels=maxsshws)
points(d$lon,d$lat)
dev.off()


cat(sapply(as.double(readLines(tail(commandArgs(), n=1))), function(t) {
  r <- 0
  if (t >= 2^31) {
    t <- t - 2^31
    r <- 1
  }
  s <- as.integer(t)
  while (s > 0) {
    s <- bitwAnd(s, s - 1)
    r <- r + 1
  }
  r %% 3
}), sep="\n")


#' Function to return (a + b)*(a + b)
#' Takes in numeric a and b as input.
#' @param a numeric value
#' @param b a numeric value added after b
#' @return The output of the function
#' @export
#' @examples
#' calculation_2(2,3)
#' calculation_2(5,8)

calculation_2 <- function(a,b) {
  output <- a^2 + 2*a*b + b^2
  output
}


## AUROC2
## Area under ROC type 2 curve
## translated from matlab script type2roc.m by Fleming & Lau (2014)
## taken from
## https://github.com/smfleming/meta_dots/blob/master/type2roc.m
## authored: Steve Fleming 2012

calculate_auroc2 <- function(corrects, subjectiveRatings, numRatings) {
  ratings <- rev(c(1:numRatings))

  hits <- function(x) {subjectiveRatings==x & corrects}
  falsealarms <- function(x) {subjectiveRatings==x & abs(corrects-1)}

  type2hits_list <- lapply(ratings,hits)
  type2falsealarms_list <- lapply(ratings,falsealarms)

  type2hits_listsums <- 0.5 + sapply(type2hits_list,sum)
  type2falsealarms_listsums <- 0.5 + sapply(type2falsealarms_list,sum)

  H2s <- type2hits_listsums / sum(type2hits_listsums)
  FA2s <- type2falsealarms_listsums / sum(type2falsealarms_listsums)

  cumulative_H2s <- c(0,cumsum(H2s))
  cumulative_FA2s <- c(0, cumsum(FA2s))

  k <- function(i) {(cumulative_H2s[i+1] - cumulative_FA2s[i])^2 - (cumulative_H2s[i] - cumulative_FA2s[i+1])^2}
  ## k(i) = (cum_H2(c+1) - cum_FA2(c))^2 - (cum_H2(c) - cum_FA2(c+1))^2;

  ks <- sapply(rev(ratings), k)

  aoc <- 0.5 + 0.25*sum(ks)
  return(aoc)
}


# Set the seed to make partition reproductible
set.seed(1)
is.debug = TRUE
# Prepare, split train and test
if (is.debug == TRUE)  {
  train.size <- floor(0.7 * nrow(data))
  train.index <- sample(seq_len(nrow(data)), size = train.size)
  train.data <- data[train.index, ]
  test.data <- data[-train.index, ]
  rm(train.index)
} else {
  train.data = data
}

#feature.selection = c(2,3,4,5,6,12,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41)
feature.selection = 1:41
# First layer, use decision tree to classify is.attack

# train.data = train.data[train.data$label != 'normal', ]
test.data = test.data[test.data$label != 'normal', ]
real.test.data = real.test.data[real.test.data$label != 'normal', ]
random.forest.model = randomForest(attack.type ~ ., data=train.data[c(feature.selection, 45)], importance=TRUE, ntree=200)

if (is.debug == TRUE) {
  y.hat = predict(random.forest.model, test.data[feature.selection])
  print(confusionMatrix(y.hat, test.data$attack.type))
  y.hat = predict(random.forest.model, real.test.data[feature.selection])
  print(confusionMatrix(y.hat, real.test.data$attack.type))
}
println('Training finished')
# Second Layer
# println('Training abnormal data classifier...')
# abnormal.data = data[data$is.attack == TRUE,]
#
# if (is.debug == TRUE) {
#   train.size <- floor(0.3 * nrow(abnormal.data))
#   train.index <- sample(seq_len(nrow(abnormal.data)), size = train.size)
#   train.data <- abnormal.data[train.index, ]
#   test.data <- abnormal.data[-train.index, ]
# } else {
#   train.data = abnormal.data
# }
#
#
# nb.model <- naiveBayes(attack.type ~ ., data = train.data[c(feature.selection, 44)])
# random.forest.model = randomForest(attack.type ~ ., data=train.data[c(feature.selection, 44)], importance=TRUE, ntree=2000)

println('Training normal/abnormal data classifier...')
## Scale does not help to improve accuracy
# train.data[1:41] = scale(data.matrix(train.data[1:41]))
# real.test.data[1:41] = scale(data.matrix(real.test.data[1:41]))
# test.data[1:41] = scale(data.matrix(test.data[1:41]))

train.dos = train.data[train.data$attack.type=='dos', feature.selection]
train.normal = train.data[train.data$attack.type=='normal', feature.selection]
train.probe = train.data[train.data$attack.type=='probe', feature.selection]
train.r2l = train.data[train.data$attack.type=='r2l', feature.selection]
train.u2r = train.data[train.data$attack.type=='u2r', feature.selection]

train.dos = data.matrix(train.dos)
train.normal = data.matrix(train.normal)
train.probe = data.matrix(train.probe)
train.r2l = data.matrix(train.r2l)
train.u2r = data.matrix(train.u2r)
test.data = test.data[test.data$label != 'normal',]
real.test.data = real.test.data[real.test.data$attack.type != 'normal',]

<<<<<<< HEAD

  dt.model = rpart(is.attack ~ ., data=train.data[,c(feature.selection,43)])
  y.hat = predict(dt.model, test.data[,feature.selection])

  result1 = confusionMatrix(round(y.hat), as.numeric(test.data$is.attack))

  y.hat =predict(dt.model, real.test.data[,feature.selection])
  result2 = confusionMatrix(round(y.hat), as.numeric(real.test.data$is.attack))
  print(c(i,result1$overall[['Accuracy']],result2$overall[['Accuracy']]))
=======
for (i in c(5)) {

  dos.centers = kmeans(train.dos, centers = i*6 ,iter.max = 10)$centers
#   normal.centers = kmeans(train.normal, centers = i*3,iter.max = 10)$centers
  probe.centers = kmeans(train.probe, centers = i,iter.max = 10)$centers
  r2l.centers = kmeans(train.r2l, centers = i,iter.max = 10)$centers
  u2r.centers = kmeans(train.u2r, centers = i,iter.max = 10)$centers
  y.labels = c(rep('dos',dim(dos.centers)[1]),
#                 rep('normal',dim(normal.centers)[1]),
                   rep('probe',dim(probe.centers)[1]),
                       rep('r2l',dim(r2l.centers)[1]),
                           rep('u2r',dim(u2r.centers)[1]))
  x.centers = rbind(dos.centers,  probe.centers, r2l.centers, u2r.centers)

  y.hat = knn(x.centers, data.matrix(test.data[,feature.selection]), y.labels, k=1)
  result1 = confusionMatrix(as.character(y.hat), as.character(test.data$attack.type))

  y.hat = knn(x.centers, data.matrix(real.test.data[,feature.selection]), y.labels, k=1)
  result2 = confusionMatrix(as.character(y.hat), as.character(real.test.data$attack.type))
  print(c(i, result1$overall[['Accuracy']], result2$overall[['Accuracy']]))
}
>>>>>>> kmeans

train.data = train.data[train.data$label != 'normal', ]
test.data = test.data[test.data$label != 'normal', ]
real.test.data = real.test.data[real.test.data$label != 'normal', ]
nb.model <- naiveBayes(attack.type ~ ., data = train.data[c(feature.selection, 44)])

if (is.debug == TRUE) {
  y.hat = predict(nb.model, test.data[feature.selection])
  print(confusionMatrix(y.hat, test.data$attack.type))
  y.hat = predict(nb.model, real.test.data[feature.selection])
  print(confusionMatrix(y.hat, real.test.data$attack.type))
}
println('Training finished')
# Second Layer
# println('Training abnormal data classifier...')
# abnormal.data = data[data$is.attack == TRUE,]
#
# if (is.debug == TRUE) {
#   train.size <- floor(0.3 * nrow(abnormal.data))
#   train.index <- sample(seq_len(nrow(abnormal.data)), size = train.size)
#   train.data <- abnormal.data[train.index, ]
#   test.data <- abnormal.data[-train.index, ]
# } else {
#   train.data = abnormal.data
# }
#
#
# nb.model <- naiveBayes(attack.type ~ ., data = train.data[c(feature.selection, 44)])

# random.forest.model = randomForest(attack.type ~ ., data=train.data[c(feature.selection, 44)], importance=TRUE, ntree=2000)

# if (is.debug == TRUE) {
#   y.hat = predict(nb.model, test.data[feature.selection])
#   print(confusionMatrix(y.hat, test.data[,44]))
# }

# println('Training finished')


#test
args <- commandArgs(trailingOnly = TRUE)
infile <- args[1]
outfile <- args[2]
outdir <- args[3]

setwd(outdir)
Data <- read.delim(file=infile,header=F)
Pvalue <-c()
chivalue <- c()
Ratiodiff <-c()
for (i in 1:nrow(Data)) {
	compare <- matrix(c(Data[i,5],Data[i,8],Data[i,10],Data[i,13]),nr=2)
	compare <- round(compare)
	result <- fisher.test(compare)		#,alternative = "greater"
	result2 <- chisq.test(compare,simulate.p.value=F,B=40000)
	rdiff <- Data[i,9] - Data[i,14]
	Pvalue <- c(Pvalue,result$p.value)
	chivalue <- c(chivalue,result2$p.value)
	Ratiodiff <- c(Ratiodiff,rdiff)
}
FDR <- p.adjust(chivalue,method = "BH")

Data <- cbind(Data,Ratiodiff)
Data <- cbind(Data,Pvalue)
Data <- cbind(Data,chivalue)
Data <- cbind(Data,FDR)
write.table(Data,file=outfile,row.names=F,append=F,quote=F,sep='\t')


#!/usr/bin/Rscript

library("vegan")

files <- list.files(path=".", pattern="*.tab", full.names=T, recursive=FALSE)
files

lapply(files, function(x) {
  df <- read.table(x,sep=" ",header=T)

  simpson.div <- diversity(df[, 3], index = "simpson")
  cat(toString(c(x,simpson.div)), file="Simpson.txt",append = TRUE, sep = "\n")

  invsimpson.div <- diversity(df[, 3], index = "invsimpson")
  cat(toString(c(x,invsimpson.div)), file="InvSimpson.txt",append = TRUE, sep = "\n")

  shannon.div <- diversity(df[, 3], index = "shannon")
  cat(toString(c(x,shannon.div)), file="ShanonDiv.txt",append = TRUE, sep = "\n")

  pielou.eve <- shannon.div/log(nrow(df))
  clonality <- 1 - pielou.eve
  cat(toString(c(x,clonality)), file="Pielou.txt",append = TRUE, sep = "\n")

})


library(R6)

#' Handy Statistics
#'
#' @export

Stat <- R6Class("Stat",

  public=list(
    digits=NA,
    nsmall=NA,
    initialize = function(digits=2, nsmall=2){
      self$digits <- digits
      self$nsmall <- nsmall
    },
    preety = function(n){
      format(n, digits=self$digits, nsmall=self$nsmall)
    },
    avg = function(df, col){
      self$preety(mean(df[,col], na.rm=TRUE))
    },
    std = function(df, col){
      self$preety(sd(df[,col], na.rm=TRUE))
    },
    sum = function(df, col){
      self$preety(sum(df[,col], na.rm=TRUE))
    },
    nopp = function(df, col){
      NULL
    },
    blank = function(df, col){
      " "
    },
    id = function(df, col){
      df[1, col]
    },
    p50 = function(df, col){
      self$preety(median(df[,col], na.rm=TRUE))
    },
    iqr = function(df, col){
      self$preety(IQR(df[,col], na.rm=TRUE))
    },
    prev = function(n, t){
      self$preety(n / t * 100)
    },
    count = function(df, col){
      format(sum(!is.na(df[,col])), digits=0, nsmall=0)
    }
  )
)


####################################################################################
# mwc_2way(fit, v1, v2)
#
# Description
# -----------
# Take a fitted model and two panel dimensions, and return a revised estimate of
# the parameter covariance matrix clustered on each of the dimensions, as in
# Cameron, Gelbach & Miller 2006
#
# Arguments
# ---------
#       fit             Fitted model
#       v1,2            Panel dimensions on which to cluster
#
####################################################################################

mwc_2way <- function(fit, v1, v2){

    # give proper names, attributes etc. to return matrix
    retvar <- robcov(fit, v1)$var
    retvar[,] <- 0

    # list factors and interactions to cluster on and the corresponding signs
    clustervars <- list(v1,
                        v2,
                        interaction(v1,v2))
    signs <- c(1,1,-1)

    for(i in 1:NROW(signs)){

        curclusvar <- clustervars[[i]]
        cursign <- signs[i]

        # calculate a finite-clusters inflation factor
        D <- NROW(unique(curclusvar))
        inflator <- D/(D-1)

        retvar <- retvar + cursign*inflator*robcov(fit, curclusvar)$var

    }

    return(retvar)
}

####################################################################################
# mwc_3way(fit, v1, v2, v3)
#
# Description
# -----------
# Take a fitted model and three panel dimensions, and return a revised estimate of
# the parameter covariance matrix clustered on each of the dimensions, as in
# Cameron, Gelbach & Miller 2006
#
# Arguments
# ---------
#       fit             Fitted model
#       v1,2,3          Panel dimensions on which to cluster
#
####################################################################################

mwc_3way <- function(fit, v1, v2, v3){

    # give proper names, attributes etc. to return matrix
    retvar <- robcov(fit, v1)$var
    retvar[,] <- 0

    # list factors and interactions to cluster on and the corresponding signs
    clustervars <- list(v1,
                        v2,
                        v3,
                        interaction(v1,v2),
                        interaction(v2,v3),
                        interaction(v1,v3),
                        interaction(v1,v2,v3))
    signs <- c(1,1,1,-1,-1,-1,1)

    for(i in 1:NROW(signs)){

        curclusvar <- clustervars[[i]]
        cursign <- signs[i]

        # calculate a finite-clusters inflation factor
        D <- NROW(unique(curclusvar))
        inflator <- D/(D-1)

        retvar <- retvar + cursign*inflator*robcov(fit, curclusvar)$var

    }

    return(retvar)
}


library(ggplot2)
setwd('/home/enrico/Dropbox/SFEM/validation/FEIII2016/')
#results_0.1 <- read.csv('performance_fraction_0.1.csv')
#results_0.2 <- read.csv('performance_fraction_0.2.csv')
#results_0.3 <- read.csv('performance_fraction_0.3.csv')
#results_0.4 <- read.csv('performance_fraction_0.4.csv')
#results_0.5 <- read.csv('performance_fraction_0.5.csv')
#results_0.6 <- read.csv('performance_fraction_0.6.csv')
#results_0.7 <- read.csv('performance_fraction_0.7.csv')
#results_0.8 <- read.csv('performance_fraction_0.8.csv')
#results_0.9 <- read.csv('performance_fraction_0.9.csv')
#p1<-results_0.1['f']$f
#p2<-results_0.2['f']$f
#p3<-results_0.3['f']$f
#p4<-results_0.4['f']$f
#p5<-results_0.5['f']$f
#p6<-results_0.6['f']$f
#p7<-results_0.7['f']$f
#p8<-results_0.8['f']$f
#p9<-results_0.9['f']$f

data <- read.csv('sfem_validation_results.csv')

#list of f-score with 0.1 of the gold standard
F1 <- data[data$frac == 0.1,]$F
F2 <- data[data$frac == 0.2,]$F
F3 <- data[data$frac == 0.3,]$F
F4 <- data[data$frac == 0.4,]$F
F5 <- data[data$frac == 0.5,]$F
F6 <- data[data$frac == 0.6,]$F
F7 <- data[data$frac == 0.7,]$F
F8 <- data[data$frac == 0.8,]$F
F9 <- data[data$frac == 0.9,]$F

m1 = mean(F1)
m2 = mean(F2)
m3 = mean(F3)
m4 = mean(F4)
m5 = mean(F5)
m6 = mean(F6)
m7 = mean(F7)
m8 = mean(F8)
m9 = mean(F9)

min1 = min(F1)
min2 = min(F2)
min3 = min(F3)
min4 = min(F4)
min5 = min(F5)
min6 = min(F6)
min7 = min(F7)
min8 = min(F8)
min9 = min(F9)

max1 = max(F1)
max2 = max(F2)
max3 = max(F3)
max4 = max(F4)
max5 = max(F5)
max6 = max(F6)
max7 = max(F7)
max8 = max(F8)
max9 = max(F9)
#max10 = max(p10)

pointstoplot<-c(m1,m2,m3,m4,m5,m6,m7,m8,m9)

s1 = sd(p1)
s2 = sd(p2)
s3 = sd(p3)
s4 = sd(p4)
s5 = sd(p5)
s6 = sd(p6)
s7 = sd(p7)
s8 = sd(p8)
s9 = sd(p9)
#s10 = sd(p10)

indexes<-c(10,20,30,40,50,60,70,80,90)
sds<-c(s1,s2,s3,s4,s5,s6,s7,s8,s9)
mins<-c(min1,min2,min3,min4,min5,min6,min7,min8,min9)
maxes<-c(max1,max2,max3,max4,max5,max6,max7,max8,max9)
up_bound <- c(m1+s1,m2+s2,m3+s3,m4+s4,m5+s5,m6+s6,m7+s7,m8+s8,m9+s9)
low_bound <- c(m1-s1,m2-s2,m3-s3,m4-s4,m5-s5,m6-s6,m7-s7,m8-s8,m9-s9)
x = cbind(data.frame(indexes,pointstoplot, sds, low_bound, up_bound))

qplot(x=indexes, y=pointstoplot, xlab="Percentage of Training Data Used", ylab="F-Measure") + geom_errorbar(aes(ymin=low_bound, ymax=up_bound))

#estimating the growth speed with a linear fit
indexes_fit <- indexes/100 #rescale to 0-1
fit <- lm(pointstoplot ~ indexes_fit, weights = 1/sds**2) #setting the estimated variances as errors
summary(fit)


########################################################################
#                                                                      #
#   lib/finite-group.rb                                                #
#                                                                      #
########################################################################
=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::OperatorDomain>))
/
((<Algebra::Set>))
/
((<Algebra::Group>))
/
((<Algebra::QuotientGroup>))

= Algebra::OperatorDomain

群が作用する集合の性質を集めたモジュールです。
((<Group>)) クラスがインクルードしています。

== ファイル名:
* ((|finite-group.rb|))

== メソッド:

--- right_act(other)
    ((|self|)) と ((|other|)) の積を返します。すなわち ((|self|))
    の元 ((|x|)) と ((|other|)) の元 ((|y|)) に対して (({x * y})) の
    形の元の集合（((|Set|))）を返します。

--- act
    ((<right_act>)) のエイリアスです。

--- left_act(other)
    ((|self|)) と ((|other|)) の積を返します。すなわち ((|self|))
    の元 ((|x|)) と ((|other|)) の元 ((|y|)) に対して (({y * x})) の
    形の元の集合（((|Set|))）を返します。

--- right_quotient(other)
    ((|self|)) を ((|other|)) で割った右剰余類の集合（((|Set|))）
    を返します。

--- quotient
--- right_coset
--- coset
    ((<right_quotient>)) のエイリアスです。

--- left_quotient(other)
    ((|self|)) を ((|other|)) で割った左剰余類の集合（((|Set|))）
    を返します。

--- left_coset
    ((<left_quotient>)) のエイリアスです。

--- right_representatives(other)
    右剰余類 ((<right_quotient>)) から取った代表元の集合を返します。

--- representatives
    ((<right_representatives>)) のエイリアスです。

--- left_representatives(other)
    左剰余類 ((<left_quotient>)) から取った代表元の集合を返します。

--- right_orbit!(other)
    ((|self|)) を ((|other|)) を繰り返し右から作用させて広げます。
    作用は ((|*|)) によります。

--- orbit!
    ((<right_orbit!>)) のエイリアスです。

--- left_orbit!(other)
    ((|self|)) を ((|other|)) を繰り返し左から作用させて広げます。
    作用は ((|*|)) によります。

= Algebra::Set

== ファイル名:
* ((|finite-group.rb|))
  ここでは ((|finite-set.rb|)) で定義された ((<Set|URL:finite-set.html>))
  に付け加えるべきメソッドを定義しています。

== インクルードしているモジュール:

* ((|OperatorDomain|))

== メソッド:

--- *
    ((<act>)) のエイリアスです。

--- /
    ((<quotient>)) のエイリアスです。

--- %
    ((<representatives>)) のエイリアスです。

--- increasing_series([x])
    ((|x|)) から始まる増大列の配列を返します。これは次のコードと同値
    です。

      def increasing_series(x = unit_group)
        a = []
        loop do
          a.push x
          if x >= (y = yield x)
            break
          end
          x = y
        end
        a
      end

--- decreasing_series([x])
    ((|x|)) から始まる減少の配列を返します。これは次のコードと同値
    です。

      def decreasing_series(x = self)
        a = []
        loop do
          a.push x
          if x <= (y = yield x)
            break
          end
          x = y
        end
        a
      end

= Algebra::Group

== ファイル名:
* ((|finite-group.rb|))

== スーパークラス:
* ((|Set|))

== クラスメソッド:

--- ::new(u, [g0, g1, ...]])
    ((|u|)) を単位元とし、((|g0|)), ((|g1|)), ... で構成される群を
    返します。

--- ::generate_strong(u, [g0, [g1, ...]])
    単位元を ((|u|))、強生成元を ((|g0|)), ((|g1|)), ... として、
    生成される群を返します。

== メソッド:

--- quotient_group(u)
    正規部分群 ((|u|)) による剰余群を返します。

--- separate
    ブロックを真とする元からなる部分群を返します。

--- to_a
    各要素を配列にして返します。最初の要素は単位元です。

--- unity
    単位元を返します。

--- unit_group
    単位元で生成される単位群を返します。

--- semi_complete!
    現在の要素を掛け合わせて半群を構成します。

--- semi_complete
    現在の要素を掛け合わせて半群を構成たものを返します。

--- complete!
    現在の要素を掛け合わせて群を構成します。

--- complete
    現在の要素を掛け合わせて群を構成たものを返します。

--- closed?
    群として閉じているとき真を返します。

--- subgroups
    全ての部分群の集合を返します。

--- centralizer(s)
    ((|self|)) における ((|s|)) の中心化群を返します。

--- center
    ((|self|)) の中心化群を返します。

--- center?(x)
    ((|self|)) の中で元 ((|x|)) が中心に含まれているとき、真を返します。

--- normalizer(s)
    ((|self|)) における ((|s|)) の正規化群を返します。

--- normal?(s)
    ((|s|)) が ((|self|)) の正規部分群であるとき真を返します。

--- normal_subgroups
    全ての正規部分群の集合を返します。

--- conjugacy_class(x)
    元 ((|x|)) の共役類を返します

--- conjugacy_classes
    ((|self|)) の全ての共役類の集合を返します。

--- simple?
    単純群であるとき、真を返します。

--- commutator([h])
    ((|self|)) と ((|h|)) との交換子群を返します。((|h|)) を省略
    すると ((|self|)) が用いられます。

--- D([n])
    ((|n|)) 番目の交換子群を返します。(({D(0) = 自分自身})),
    (({D(n+1) = [D[n], D[n]]})) で定義されています。
    ((|n|)) を省略すると 1 が用いられます。

--- commutator_series
    (({[D(0), D(1), D(2),..., D(n)]})) という配列を返します。この配列は
    (({D(n) == D(n+1)})) となる ((|n|)) で停止します。

--- solvable?
    可解群であるとき真を返します。

--- K([n])
    (({K(0) = 自分自身})),
    (({K(n+1) = [self, K[n]]})) で定義される群を返します。
    ((|n|)) を省略すると 1 が用いられます。

--- descending_central_series
    降中心列
    (({[K(0), K(1), K(2),..., K(n)]})) という配列を返します。この配列は
    (({K(n) == K(n+1)})) となる ((|n|)) で停止します。

--- Z([n])
    (({Z(0) = 単位群})),
    (({Z(n+1) = separate{|x| commutator(Set[x]) <= Z(n-1)}}))
    で定義される群を返します。
    ((|n|)) を省略すると 1 が用いられます。

--- ascending_central_series
    昇中心列
    (({[Z(0), Z(1), Z(2),..., Z(n)]})) という配列を返します。この配列は
    (({Z(n) == Z(n+1)})) となる ((|n|)) で停止します。

--- nilpotent?
    冪零群であるとき真を返します。

--- nilpotency_class
    冪零クラスを返します。冪例群でないとき ((|nil|)) を返します。

= Algebra::QuotientGroup

== ファイル名:
* ((|finite-group.rb|))

== スーパークラス:
* ((|Group|))

== クラスメソッド:
--- new(u, [g0, [g1,...]])
    ((|self|)) の正規部分群を ((|u|)) として、
    ((|u|)), ((|g0|)), ((|g1|)), .. を剰余類とする剰余群を返します。

== メソッド:

--- inverse
    逆元を返します

--- inv
    ((<inverse>)) のエイリアスです。

=end


#---------
#Title
#---------
#Respiratory control and thermal sensibility in benthic
#life stages of porcelain crab (Petrolisthes laevigatus).
#-----------------------------------------------

#---------
#Cleaning working space
rm(list=ls())
#Creator: 20160817 FPL
#Modifications: 20170408 CG
today<-format(Sys.Date(),"%Y%m%d")
#--------------------------------------------
#From Linux
# get working directory
setwd("D:/Dropbox/FL+WB/PELA/data")
# setwd("~/Insync/Laboratorio.Poblaciones.Marinas/Publicaciones/Plasticidad pela/analisis/datos")
getwd()     #verifico directorio
#----------------------------------------------

#-----------------------------------------------
#Libraries
#-----------------------------------------------
library(plotrix);library(ggplot2);library(nlme);
library(car);library(multcomp);
#-----------------------------------------------

#------------------------------------------------
#reading my data
#------------------------------------------------
pela<-read.csv("data.pela.csv", header=TRUE,
               sep=",",dec=".", strip.white=TRUE)
names(pela)
summary(pela)
str(pela)
#------------------------------------------------

#---------------------------------------------------------------------------
#Units for each explicative variable
#---------------------------------------------------------------------------
#dry_weight_g: individual dry weight,expressed in grams
#mo2: metabolic rate, expressed as mg O2 por hour per individual
#mo2.1: metabolic rate, expressed as mg O2 per hour per gram dry weight
#mo2.2: metabolic rate, expressed as mmol O2 per hour per gram dry weight
#mo2.3: metabolic rate, expressed as umol O2 per hour per gram dry weight
#mo2.4: metabolic rate, expressed as umol O2 por hour per individual
#---------------------------------------------------------------------------

#--------------------------------------------------------
#Transformation of variables wrongly assigned to numeric
#--------------------------------------------------------
pela$stage=as.factor(pela$stage)
pela$oxygen_mg=as.numeric(pela$oxygen_mg)
pela$saturation=as.numeric(pela$saturation)
pela$mo2=as.numeric(pela$mo2)
pela$temperature=as.factor(pela$temperature)
#--------------------------------------------------------

pela$kpa.mean<-ifelse(pela$kpa==2.07 | pela$kpa==2.36 | pela$kpa==2.65, 2.36,
               ifelse(pela$kpa==4.14 | pela$kpa==4.71 | pela$kpa==5.30, 4.71,
               ifelse(pela$kpa==8.29 | pela$kpa==9.43 | pela$kpa==10.60, 9.44,
               ifelse(pela$kpa==12.43 | pela$kpa==14.14 | pela$kpa==15.89, 14.15,
               ifelse(pela$kpa==18.65 | pela$kpa==21.21 | pela$kpa==23.84, 21.23, NA)))))

table(pela$stage, pela$kpa.mean)
# ordeno niveles etapa
pela$stage<- factor(pela$stage, levels = c("Embryo","Megalopae","Juvenile","Adult"))
#-----------------------------------------------------------------------
# Estimo Pc y creo graficos
#-----------------------------------------------------------------------------
library(segmented)
# Adultos
# Temperatura = 6
t6<-subset(pela, temperature==6 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t6)
# modelo lineal
lm6.1<-lm(mo2.3~kpa.mean,data=t6)
abline(lm6.1$coefficients,col="red")
# polinomial
lm6.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t6)
lines(sort(t6$kpa.mean), fitted(lm6.2)[order(t6$kpa.mean)], col='blue', type='b')
#
AIC(lm6.1, lm6.2)
# Estima P critico
pcrit1 <- segmented(lm6.1,
                    seg.Z = ~ kpa.mean,
                    psi = 9)
summary(pcrit1)
pcrit1$psi
pcrit2 <- segmented(lm6.2,
                    seg.Z = ~ poly(kpa.mean, 3),
                    psi = 4)
abline(v=pcrit1$psi[2], lwd=2) # Pcritico???

# Adultos
# Temperatura = 12
t12<-subset(pela, temperature==12 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t12)
# modelo lineal
lm12.1<-lm(mo2.3~kpa.mean,data=t12)
abline(lm12.1$coefficients,col="red")
# polinomial
lm12.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t12)
lines(sort(t12$kpa.mean), fitted(lm12.2)[order(t12$kpa.mean)], col='blue', type='b')
#
AIC(lm12.1, lm12.2)
# Estima P critico
pcrit_t12a <- segmented(lm12.1,
                    seg.Z = ~ kpa.mean,
                    psi =7)
summary(pcrit_t12a)
pcrit_t12a$psi

# Adultos
# Temperatura = 18
t18<-subset(pela, temperature==18 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t18)
# modelo lineal
lm18.1<-lm(mo2.3~kpa.mean,data=t18)
abline(lm18.1$coefficients,col="red")
# polinomial
lm18.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t18)
lines(sort(t18$kpa.mean), fitted(lm18.2)[order(t18$kpa.mean)], col='blue', type='b')
#
AIC(lm18.1, lm18.2)
# Estima P critico
pcrit_t18a <- segmented(lm18.1,
                        seg.Z = ~ kpa.mean,
                        psi =14)
summary(pcrit_t12a)
pcrit_t12a$psi
#---------------------------------------------------
## Trabajo con media por tratamiento
#--------------------------------------------
pela1<-aggregate(cbind(mo2,mo2.1, mo2.2,mo2.3,mo2.4)~stage+kpa.mean+temperature,data=pela, mean)
# Adultos
# Temperatura = 6
t6<-subset(pela1, temperature==6 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t6)
# modelo lineal
lm6.1<-lm(mo2.3~kpa.mean,data=t6)
abline(lm6.1$coefficients,col="red")
# polinomial
lm6.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t6)
lines(sort(t6$kpa.mean), fitted(lm6.2)[order(t6$kpa.mean)], col='blue', type='b')
#
AIC(lm6.1, lm6.2)
# Estima P critico
pcrit1 <- segmented(lm6.1,
                    seg.Z = ~ kpa.mean,
                    psi = 9)
summary(pcrit1)
pcrit1$psi
# no  resulto con el modelo polinomial
pcrit2 <- segmented(lm6.2,
                    seg.Z = ~ poly(kpa.mean, 3),
                    psi = 4)
abline(v=pcrit1$psi[2], lwd=2) # Pcritico???

# Adultos
# Temperatura = 12
t12<-subset(pela1, temperature==12 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t12)
# modelo lineal
lm12.1<-lm(mo2.3~kpa.mean,data=t12)
abline(lm12.1$coefficients,col="red")
# polinomial
lm12.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t12)
lines(sort(t12$kpa.mean), fitted(lm12.2)[order(t12$kpa.mean)], col='blue', type='b')
#
AIC(lm12.1, lm12.2)
# Estima P critico
pcrit_t12a <- segmented(lm12.1,
                        seg.Z = ~ kpa.mean,
                        psi =5)
# Errorrrrrrrrrrrrrrr

# Adultos
# Temperatura = 18
t18<-subset(pela1, temperature==18 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t18)
# modelo lineal
lm18.1<-lm(mo2.3~kpa.mean,data=t18)
abline(lm18.1$coefficients,col="red")
# polinomial
lm18.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t18)
lines(sort(t18$kpa.mean), fitted(lm18.2)[order(t18$kpa.mean)], col='blue', type='b')
#
AIC(lm18.1, lm18.2)
# Estima P critico
pcrit_t18a <- segmented(lm18.1,
                        seg.Z = ~ kpa.mean,
                        psi =8)
# ERROR
# psi  es un valor inicial que se le da

#--------------------------------------------------------

#--------------------------------------------------------------------
## Calculamos Pc de acuerdo a Mueller and Seymor (2011).
#The regulation index: a new method for assessing
#the relationship between oxygen consumption and environmental oxygen
#--------------------------------------------------------------------
# Adultos
# Temperatura = 6
t6<-subset(pela, temperature==6 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t6)
# modelo lineal
lm6.1<-lm(mo2.3~kpa.mean,data=t6)
#abline(lm6.1$coefficients,col="red")
# linea recta ("Perfect conformity")
v1<-data.frame(aggregate(mo2.3~kpa.mean, t6,mean))[c(1,5),]
m1<-lm(mo2.3~kpa.mean,data=v1)
abline(m1, col="blue")
# polinomial
lm6.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t6)
AIC(lm6.1, lm6.2)
lines(sort(t6$kpa.mean), fitted(lm6.2)[order(t6$kpa.mean)], col='blue', type='b')
# Estima P critico (Distancia maxima entre linea recta y la curva)
pre.t6=data.frame(kpa.mean=seq(2.36,21.23,0.1))
pre.t6$curva<-predict(lm6.2,newdata = pre.t6)
pre.t6$recta<-predict(m1,newdata = pre.t6)
lines(pre.t6$kpa.mean,pre.t6$curva, col="red")
lines(pre.t6$kpa.mean,pre.t6$recta, col="red")
# observo el punto de mayor diferencia
pre.t6$dif<-pre.t6$curva-pre.t6$recta
subset(pre.t6,dif==max(pre.t6$dif)) # P.critico= 9.16 kpa

# Adultos
# Temperatura = 12
t12<-subset(pela, temperature==12 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t12)
# modelo lineal
lm12.1<-lm(mo2.3~kpa.mean,data=t12)
#abline(lm6.1$coefficients,col="red")
# linea recta ("Perfect conformity")
v2<-data.frame(aggregate(mo2.3~kpa.mean, t12,mean))[c(1,5),]
m2<-lm(mo2.3~kpa.mean,data=v2)
abline(m2, col="blue")
# polinomial
lm12.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t12)
AIC(lm12.1, lm12.2)
lines(sort(t12$kpa.mean), fitted(lm12.2)[order(t12$kpa.mean)], col='blue', type='b')
# Estima P critico (Distancia maxima entre linea recta y la curva)
pre.t12=data.frame(kpa.mean=seq(2.36,21.23,0.1))
pre.t12$curva<-predict(lm12.2,newdata = pre.t12)
pre.t12$recta<-predict(m2,newdata = pre.t12)
lines(pre.t12$kpa.mean,pre.t12$curva, col="red")
lines(pre.t12$kpa.mean,pre.t12$recta, col="red")
# observo el punto de mayor diferencia
pre.t12$dif<-pre.t12$curva-pre.t12$recta
subset(pre.t12,dif==max(pre.t12$dif)) # P.critico= 15.46 kpa

# Adultos
# Temperatura = 18
t18<-subset(pela, temperature==18 & stage=="Adult")
plot(mo2.3~kpa.mean,data=t18)
# modelo lineal
lm18.1<-lm(mo2.3~kpa.mean,data=t18)
#abline(lm6.1$coefficients,col="red")
# linea recta ("Perfect conformity")
v3<-data.frame(aggregate(mo2.3~kpa.mean, t18,mean))[c(1,5),]
m3<-lm(mo2.3~kpa.mean,data=v3)
abline(m3, col="blue")
# polinomial
lm18.2<-lm(mo2.3 ~ poly(kpa.mean, 3), data = t18)
AIC(lm18.1, lm18.2)
lines(sort(t18$kpa.mean), fitted(lm18.2)[order(t18$kpa.mean)], col='blue', type='b')
# Estima P critico (Distancia maxima entre linea recta y la curva)
pre.t18=data.frame(kpa.mean=seq(2.36,21.23,0.1))
pre.t18$curva<-predict(lm18.2,newdata = pre.t18)
pre.t18$recta<-predict(m3,newdata = pre.t18)
lines(pre.t18$kpa.mean,pre.t18$curva, col="red")
lines(pre.t18$kpa.mean,pre.t18$recta, col="red")
# observo el punto de mayor diferencia
pre.t18$dif<-pre.t18$curva-pre.t18$recta
subset(pre.t18,dif==max(pre.t18$dif)) # P.critico= 15.76 kpa


#!/usr/bin/Rscript

arg <- commandArgs(trailingOnly=TRUE)

rtt <- function(filepath)
{

require(TeachingDemos, quietly=TRUE, warn.conflicts=FALSE)
require(gplots, quietly=TRUE, warn.conflicts=FALSE)

cat("  reading log-file...\n")

tdat <- read.table(filepath, header=T)
headernames <- names(tdat)

if (length(grep("birth.rate", headernames)) == 0) {
	stop ("rates not found. please check if the input file is correct.")
}

nrates <- length(tdat) - 1
y.val <- NULL
upper <- NULL
lower <- NULL

for (n in 2:(nrates+1)) {
	y.val <- append(y.val,mean(tdat[,n]), after=length(y.val))
	upper <- append(upper, emp.hpd(tdat[,n], conf=0.95)[2], after=length(upper))
	lower <- append(lower, emp.hpd(tdat[,n], conf=0.95)[1], after=length(lower))
}

x.val <- seq(from=1, to=nrates)
x.val <- (x.val-0.5)*-1
dat <- cbind(x.val, y.val, upper, lower)
colnames(dat) <- c("Time", "Mean rate", "95%HPD upper", "95%HPD lower")

output <- gsub ("\\.log$", ".pdf", filepath)
pdf (file=output)
	plotCI(x=dat[,1], y=dat[,2], ui=dat[,3], li=dat[,4], err="y", col=NULL, barcol="black", lwd=1, sfrac=0.01, gap=0, xlim=c((nrates*-1),0), ylim=c(floor(min(dat[,4]*10))/10, ceiling(max(dat[,3]*10))/10), xlab="Time [myr]", ylab="Net diversification rate [r]", main="Rates-through-time plot", cex.main=0.9)
	par(new=TRUE)
	plot(spline(dat[,1], dat[,2]), type="l", xlim=c((nrates*-1),0), ylim=c(floor(min(dat[,4]*10))/10,ceiling(max(dat[,3]*10))/10), axes=FALSE, xlab="", ylab="")
dev.off()

output2 <- gsub ("\\.log$", ".txt", filepath)
write.table(round(dat, digits=4), file=output2, quote=FALSE, col.names=TRUE, row.names=FALSE, sep="\t")
cat("  results are saved in: ", sprintf("%s", output), " and ", sprintf("%s", output2), "\n\n")
}

rtt(as.character(arg[1]))


# Run from command line:
# Rscript train.R
# Rscript train.R --x 0.2
# Rscript train.R --x 0.2 --noise 0.3

suppressMessages(library(argparser))

p <- arg_parser("train")
p <- add_argument(p, "--x", help = "x", default = 0.1)
p <- add_argument(p, "--noise", help = "noise", default = 0.1)
argv <- parse_args(p)

x <- as.numeric(argv$x)
noise <- as.numeric(argv$noise)

loss <- (sin(5 * x) * (1 - tanh(x^2)) + rnorm(1) * noise)

cat("loss:", loss, "\n")


is.square <- function(x)
{
   sqrx <- sqrt(x)
   err <- abs(sqrx - round(sqrx))
   err < 100*.Machine$double.eps
}
any(is.square(nonsqr(1:1e6)))


 ZTRSNA Example Program Results

 S
       9.9E-01    1.0E+00    9.8E-01    9.8E-01

 SEP
       8.4E+00    8.0E+00    5.8E+00    5.8E+00

 Approximate error estimates for eigenvalues of T (machine-dependent)
       2.1E-15    2.1E-15    2.1E-15    2.1E-15

 Approximate error estimates for right eigenvectors of T (machine-dependent)
       2.5E-16    2.6E-16    3.5E-16    3.5E-16


library(igraph)
library(maps)
library(vegan)
library(RColorBrewer)
library(fields)

Sys.setlocale("LC_TIME", "C") #Needed for identical()
Sys.setlocale("LC_COLLATE", "C")

## Get case data

dataDir <- '../data'

tmpf <- function(){
  fn <- file.path(dataDir, 'PEDvweeklyreport-state-ts-01-08-14.csv')
  ret <- read.csv(fn)
  ret[1:9, c('CA', 'MD', 'NE', 'WY')] <- 0
  key <- order(colnames(ret)[-c(1:2)])
  ret <- cbind(ret[, c(1:2)], ret[, -c(1:2)][, key])
  ret$Unk <- NULL
  target <- structure(list(week = structure(c(20L, 29L, 32L, 8L, 12L),
.Label = c("10/13/2013", "10/20/2013", "10/27/2013", "10/6/2013",
"11/10/2013", "11/17/2013", "11/24/2013", "11/3/2013", "12/1/2013",
"12/15/2013", "12/22/2013", "12/29/2013", "12/8/2013", "4/15/2013",
"4/22/2013", "4/29/2013", "5/13/2013", "5/20/2013", "5/27/2013",
"5/6/2013", "6/10/2013", "6/16/2013", "6/23/2013", "6/3/2013",
"6/30/2013", "7/14/2013", "7/21/2013", "7/28/2013", "7/7/2013",
"8/11/2013", "8/18/2013", "8/25/2013", "8/4/2013", "9/1/2013",
"9/15/2013", "9/22/2013", "9/29/2013", "9/8/2013"), class = "factor"),
totalNumberSwineAccessions = c(17L, 34L, 26L, 90L, 134L), CA = c(0, 0,
0, 0, 1), CO = c(1L, 1L, 0L, 0L, 0L), IA = c(8L, 6L, 2L, 38L, 54L), IL
= c(0L, 1L, 0L, 1L, 14L), IN = c(3L, 2L, 1L, 1L, 3L), KS = c(0L, 4L,
3L, 6L, 4L), KY = c(0L, 0L, 0L, 0L, 0L), MD = c(0, 0, 0, 0, 0), MI =
c(0L, 0L, 0L, 2L, 0L), MN = c(1L, 2L, 2L, 7L, 20L), MO = c(0L, 0L, 0L,
2L, 4L), NC = c(0L, 3L, 4L, 14L, 18L), NE = c(0, 0, 0, 0, 2), NY =
c(0L, 0L, 0L, 0L, 0L), OH = c(0L, 2L, 1L, 5L, 5L), OK = c(0L, 11L,
10L, 10L, 2L), PA = c(1L, 0L, 3L, 1L, 0L), SD = c(0L, 0L, 0L, 0L, 3L),
TN = c(0L, 0L, 0L, 1L, 1L), TX = c(0L, 0L, 0L, 1L, 1L), WI = c(0L, 0L,
0L, 1L, 0L ), WY = c(0, 0, 0, 0, 1)), .Names = c("week",
"totalNumberSwineAccessions", "CA", "CO", "IA", "IL", "IN", "KS",
"KY", "MD", "MI", "MN", "MO", "NC", "NE", "NY", "OH", "OK", "PA",
"SD", "TN", "TX", "WI", "WY" ), row.names = c(4L, 13L, 20L, 30L, 38L),
class = "data.frame")
  stopifnot(identical(target, ret[c(4,13,20,30,38),]))
  ret
}

caseData <- tmpf()

unwanted <- c('week', 'totalNumberSwineAccessions', 'Unk')
ind <- which(!colnames(caseData) %in% unwanted)
observed <- caseData[, ind]

## Get cross correlations

n <- ncol(observed)
CC <- matrix(nrow=n, ncol=n)

getcc <- function(x,y, lag=1){
    foo <- ccf(x, y, plot=FALSE)
    ind <- which(foo$lag == lag)
    foo$acf[ind]
}

for(i in seq_len(n)){
    for(j in seq_len(n)){
        ## CC[i,j] will be high if deviations from the mean in series i
        ## are shifted to the left of similar deviations to the mean in series j
        ## i.e. i's deviations are indicative of j's future deviations
        CC[i,j] <- getcc(observed[,j], observed[,i])
    }
}

colnames(CC) <- rownames(CC) <- colnames(observed)

check_cc_directionality <- function(){
    t <- 1:100 * .25
    x <- sin(t)
    ## y is shifted to the right
    y <- sin(t-1)

    xylag1 <- getcc(x, y)
    yxlag1 <- getcc(y,x)
    main <- paste('getcc(x, y) ==', round(xylag1,2),
                  '; getcc(y,x) == ', round(yxlag1,2))
    if(xylag1 > yxlag1){
        conc <- 'left arg delayed by lag'
    } else{
        conc <- 'right arg delayed by lag'
    }
    plot(x~t, type='l', ylab='f(t)', main=main, sub=conc)
    lines(y~t, col=2)
    legend('topright', col=1:2, legend=c('x', 'y'), lty=1)
}

png('direction-check.png')
check_cc_directionality()
dev.off()

## Get shared-border neighborhoods

nbEdgelist <- read.csv(file.path(dataDir, 'state_neighbors_fips.txt'), header=FALSE)
data(state.fips)
g <- graph.data.frame(nbEdgelist, directed=FALSE)
g <- simplify(g)
key <- match(V(g)$name, state.fips$fips)
abb <- state.fips$abb[key]
V(g)$name <- as.character(abb)
vids <- which(V(g)$name %in% colnames(caseData))
g2 <- induced.subgraph(g, vids)
nms <- colnames(observed)
nhood <- as.matrix(g2[nms,nms])

## Get shipment flows

ep <- read.csv(file.path(dataDir, 'edge-proportionalities.csv'))
key <- match(colnames(observed), colnames(ep))
ep <- ep[key, key]
rownames(ep) <- colnames(ep)

### assertions based on inspection of original .xls file
stopifnot(ep['CA', 'IL'] == 9415)
stopifnot(ep['MI', 'KS'] == 6)
stopifnot(ep['IL', 'IA'] == 1424813)
stopifnot(ep['KY', 'IA'] == 17658)
stopifnot(ep['MO', 'IA'] == 2389932)
stopifnot(ep['OK', 'CA'] == 16762)
stopifnot(ep['MO', 'CA'] == 645)

epl <- log10(ep +1)
epl <- data.matrix(epl)
## We discard the within-state flows because they do not enter into
## the analysis. Thus it is mostly a matter of how the plots will
## look, and because the original spreadsheet had no data on
## within-state flows (they were added for some other analyses based
## on an assumption of 90% of total flow), there's no good reason to
## include them in the plot.
diag(epl) <- NA

key <- match(colnames(ep), colnames(CC))
CC <- CC[key,key]

## Get great circle distance

key <- match(colnames(CC), state.abb)

cx <- state.center$x[key]
cy <- state.center$y[key]

n <- ncol(CC)
centerDists <- matrix(nrow=n, ncol=n)

# Calculates the geodesic distance between two points specified by radian latitude/longitude using the
# Haversine formula (hf)
# source: http://www.r-bloggers.com/great-circle-distance-calculations-in-r/
gcd.hf <- function(long1, lat1, long2, lat2) {
      R <- 6371 # Earth mean radius [km]
        delta.long <- (long2 - long1)
        delta.lat <- (lat2 - lat1)
        a <- sin(delta.lat/2)^2 + cos(lat1) * cos(lat2) * sin(delta.long/2)^2
        c <- 2 * asin(min(1,sqrt(a)))
        d = R * c
        return(d) # Distance in km
  }

deg2rad <- function(deg) return(deg*pi/180)

getCenterDist <- function(state1,state2){
    long1 <- deg2rad(cx[state1])
    long2 <- deg2rad(cx[state2])
    lat1 <- deg2rad(cy[state1])
    lat2 <- deg2rad(cy[state2])
    gcd.hf(long1, lat1, long2, lat2)
}

for(i in seq_len(n)){
    for(j in seq_len(n)){
        centerDists[i,j] <- getCenterDist(i, j)
    }
}

colnames(centerDists) <- rownames(centerDists) <- colnames(CC)

## hypothesis tesing

doTest <- function(M1, M2, symmetrize=FALSE, ...){
    getMat <- function(x) switch(x, 'shipment'=epl, 'cor'=CC,
                     'gcd'=-centerDists, 'sharedBord'=nhood)
    x <- getMat(M1)
    y <- getMat(M2)
    if(symmetrize){
        x <- x + t(x)
        y <- y + t(y)
    }
    mantel(x, y, ...)
}

mats <- c('shipment', 'cor', 'gcd', 'sharedBord')
methods <- c('spearman', 'pearson')
symmetrize <- c(TRUE, FALSE)
des <- expand.grid(M1=mats, M2=mats, method=methods, symmetrize=symmetrize, stringsAsFactors=FALSE)
des <- des[des$M1 != des$M2, ]
des$permutations <- 10000

res <- list()
for(i in seq_len(nrow(des))){
    print(i)
    res[[i]] <- do.call(doTest, as.list(des[i,]))
}

des$r <- sapply(res, '[[', 'statistic')
des$pValues <- sapply(res, '[[', 'signif')

sink('mantel-table.txt')
pander::pander(des)
sink()

## plotting

### diagnostics

df <- data.frame(epl=unclass(as.dist(epl)), CC=unclass(as.dist(CC)))
m <- lm(CC~epl, data=df)
pdf('diagnostics.pdf')
plot(m)
dev.off()

### correlelogram

#mcor <- mantel.correlog(D.eco=CC, D.geo=epl, r.type='pearson')

### heat map

image.plot.ebo <- function (..., add = FALSE, nlevel = 64, horizontal = FALSE,
                            legend.shrink = 0.9, legend.width = 1.2,
                            legend.mar = ifelse(horizontal, 3.1, 5.1),
                            legend.lab = NULL, legend.line = 2,
                            graphics.reset = FALSE, bigplot = NULL,
                            smallplot = NULL, legend.only = FALSE,
                            col = tim.colors(nlevel), lab.breaks = NULL,
                            axis.args = NULL, legend.args = NULL,
                            midpoint = FALSE, border = NA, lwd = 1,
                            panelLab=NULL) {
    old.par <- par(no.readonly = TRUE)
    info <- imageplot.info(...)
    if (add) {
        big.plot <- old.par$plt
    }
    if (legend.only) {
        graphics.reset <- TRUE
    }
    if (is.null(legend.mar)) {
        legend.mar <- ifelse(horizontal, 3.1, 5.1)
    }
    temp <- imageplot.setup(add = add, legend.shrink = legend.shrink,
                            legend.width = legend.width, legend.mar = legend.mar,
                            horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)
    smallplot <- temp$smallplot
    bigplot <- temp$bigplot
    if (!legend.only) {
        if (!add) {
            par(plt = bigplot)
        }
        if (!info$poly.grid) {
            image(..., add = add, col = col, axes=FALSE)
            addAxis1 <- function(x, y, z,...){
                labs <- paste(names(y), c('', '      '))
                axis(1, at=y, labels = labs, las = 2, line = -0.5, tick = 0,
        cex.axis = 0.8)
            }
            addAxis1(...)
            addAxis2 <- function(x, y, z,...){
                labs <- paste(names(x), c('', '      '))
                axis(2, at=x, labels = labs, las = 1, line = -0.5, tick = 0,
        cex.axis = 0.8)
            }
            addAxis2(...)
            mtext(panelLab, side=2, las=2, at=par()$usr[2], line=par()$mar[2] - 1, cex=1.5)
        }
        else {
            poly.image(..., add = add, col = col, midpoint = midpoint,
                       border = border, lwd.poly = lwd)
        }
        big.par <- par(no.readonly = TRUE)
    }
    if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
        par(old.par)
        stop("plot region too small to add legend\n")
    }
    ix <- 1
    minz <- info$zlim[1]
    maxz <- info$zlim[2]
    binwidth <- (maxz - minz)/nlevel
    midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth)
    iy <- midpoints
    iz <- matrix(iy, nrow = 1, ncol = length(iy))
    breaks <- list(...)$breaks
    par(new = TRUE, pty = "m", plt = smallplot, err = -1)
    if (!is.null(breaks) & !is.null(lab.breaks)) {
        axis.args <- c(list(side = ifelse(horizontal, 1, 4),
                            mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2),
                            at = breaks, labels = lab.breaks), axis.args)
    }
    else {
        axis.args <- c(list(side = ifelse(horizontal, 1, 4),
                            mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)),
                       axis.args)
    }
    if (!horizontal) {
        if (is.null(breaks)) {
            image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "",
                  ylab = "", col = col)
        }
        else {
            image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "",
                  ylab = "", col = col, breaks = breaks)
        }
    }
    else {
        if (is.null(breaks)) {
            image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "",
                  ylab = "", col = col)
        }
        else {
            image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "",
                  ylab = "", col = col, breaks = breaks)
        }
    }
    do.call("axis", axis.args)
    box()
    if (!is.null(legend.lab)) {
        legend.args <- list(text = legend.lab, side = ifelse(horizontal,
                                                   1, 4), line = legend.line)
    }
    if (!is.null(legend.args)) {
        do.call(mtext, legend.args)
    }
    mfg.save <- par()$mfg
    if (graphics.reset | add) {
        par(old.par)
        par(mfg = mfg.save, new = FALSE)
        invisible()
    }
    else {
        par(big.par)
        par(plt = big.par$plt, xpd = FALSE)
        par(mfg = mfg.save, new = FALSE)
        invisible()
    }
}

pdf('cors-heatmap.pdf')
orderings <- heatmap(data.matrix(epl), scale='none')
dev.off()

makeImagePlot <- function(M, orderings, ...){
    x <- data.matrix(M)[orderings$rowInd, orderings$colInd]
    x <- t(x)
    col <- brewer.pal(9, 'Blues')
    nc <- ncol(x)
    nr <- nrow(x)
    xi <- 1:nr
    yi <- 1:nc
    names(xi) <- colnames(x)
    names(yi) <- rownames(x)
    image.plot.ebo(x=xi, y=yi, z=x, horizontal=FALSE,col=col, graphics.reset=TRUE, ...)
}

pdf('matrices.pdf', width=8.7/2.54, height=12/2.54)
layout(matrix(1:2, ncol=1))
par(mar=c(4,4.5,.5,.5))
makeImagePlot(M=data.matrix(epl), orderings=orderings, xlab='Destination', ylab='Source',
              legend.args=list(text=expression(paste(Log[10], '(swine shipped)')),
                  line=2.9, side=4), panelLab='A')
par(mar=c(4,4.5,1,.5))
CCnoDiag <- CC
diag(CCnoDiag) <- NA
makeImagePlot(M=data.matrix(CCnoDiag), orderings=orderings, xlab='Leading state', ylab='Lagging state',
              legend.args=list(text='Cross correlation', line=2.9, side=4), panelLab='B')
dev.off()

##

library(ggplot2)
library(reshape2)
library(scales)
library(plyr)

mts <- melt(caseData, id='week')
keepers <- c('MN', 'KS',
             'IL', 'OK',
             'IA', 'NC')
test <- mts$variable %in% keepers
mts <- mts[test, ]
mts$variable <- factor(mts$variable, levels=keepers)
mts$x <- as.Date(as.character(mts$week), format='%m/%d/%Y')
labdf <- ddply(mts, 'variable', summarize, minx=x[1], maxy=max(value))
labdf$minx[labdf$variable == 'OK'] <- as.Date('2013-11-01')

tmpf <- function(df){
    g <- ggplot(df, aes(x=x, y=value, group=variable))
    g <- g + geom_hline(yintercept=0, size=0.5, col='grey')
    g <- g + geom_step(direction="vh")
    g <- g + facet_wrap(~variable, ncol=2, scales='free_y')
    g <- g + scale_x_date()
    g <- g + scale_y_discrete(breaks=pretty_breaks(n=2))
    g <- g + xlab('Date') + ylab('Cases')
    g <- g + theme_classic()
    g <- g + theme(strip.background = element_blank(),
                   strip.text.x = element_blank())
    g <- g + theme(plot.margin=unit(c(0,2,0,0),"mm"))
    g <- g + geom_text(data=labdf, hjust=0, vjust=1,
                       aes(x=minx, y=maxy, label=variable))
    g
}

g <- tmpf(mts)

ggsave('ts.pdf', width=8.6/2.54, height=6/2.54)


#' HSI_index
#'
#' Computes the Heat Strain Index. HSI is the ratio of the demand for sweat evaporation to capacity of evaporation (Ereq on Emax).
#' This denotes also the percent of skin wettedness, which is a good predictor of warm discomfort.
#'

#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Relative humidity in percentage.
#' @param wind numeric Windspeed in meter per second.
#' @param tr numeric Mean radiant temperature in degC.
#' @param M numeric    Metabolic work in Watt per mq of the subject.
#' @param W   numeric  Mechanical work rate in Watt per mq of the subject.
#' @param clo numeric  Available basic clothing insulation in clo.
#' @param param character Index requested HSI or AET Allowable exposure time in minutes.
#' @return HSI index
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords HSI
#' @references Belding et al 1955. Index for evaluating heat stress in terms of resulting physiological strain. Heat Pip Air Condit 27, 129 36.
#' @export
#'
HSI_index=function(t,rh,wind,tr,M,W,clo,param="HSI") {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("vel", as.array(wind))
                         ct$assign("tr", as.array(tr))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$assign("clo", as.array(clo))
                         ct$assign("param", as.array(param))
                         ct$eval("var res=[]; for(var i=0, len=ta.length; i < len; i++){ res[i]=HSI_index(ta[i],rh[i],vel[i],tr[i],M[0],W[0],clo[0],param[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(poLCA)
source('lcaCode/poLCA.r')

drinkMods0 <- map(1:5,
                  ~poLCA(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin,nclass=.,nrep=10,na.rm=FALSE,verbose=FALSE)
                  )

drinkMods1 <- map(1:5,
                  ~poLCA(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=.,nrep=20,na.rm=FALSE,verbose=FALSE,maxiter=2000)
                  )

drinkMods1a <- map(1:5,
                  ~poLCA(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=.,nrep=20,na.rm=FALSE,verbose=FALSE,impVal=1,maxiter=2000)
                  )

drinkMods1b <- map(1:5,
                  ~poLCA(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=.,nrep=20,na.rm=FALSE,verbose=FALSE,impVal=.5,maxiter=2000)
                  )

save(drinkMods0,drinkMods1,drinkMods1a,drinkMods1b,file='mods1-5.RData')

bics0 <- map_dbl(drinkMods0,~.$bic)
bics1 <- map_dbl(drinkMods1,~.$bic)
bics1a <- map_dbl(drinkMods1a,~.$bic)
bics1b <- map_dbl(drinkMods1b,~.$bic)

pairs(cbind(bics1,bics1a,bics1b))

rbind(bics1,bics1a,bics1b)

ggplot(mapping=aes(x=rep(1:5,2),y=c(bics0,bics1),color=rep(c('Old','New'),each=5)))+geom_point()+geom_line()
ggplot(mapping=aes(x=rep(2:5,2),y=c(bics0[-1],bics1[-1]),color=rep(c('Old','New'),each=4)))+geom_point()+geom_line()

which.min(bics0)
which.min(bics1)

mod2 <- poLCAord(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=2,na.rm=FALSE,nrep=50,verbose=FALSE,maxiter=2000)
mod2a<- poLCAord(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=2,na.rm=FALSE,nrep=50,verbose=FALSE,impVal=.5,maxiter=2000)
mod2b<- poLCAord(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin2,nclass=2,na.rm=FALSE,nrep=50,verbose=FALSE,impVal=1,maxiter=2000)
mod30 <- poLCAord(cbind(everDrink,preteen,drink30days,bought,drinkHeavy,drinkVheavy)~1,data=drinkBin,nclass=3,na.rm=FALSE,nrep=50,verbose=FALSE,maxiter=2000)

save(mod2,mod2a,mod2b,mod30,file='models.RData')

makeplot2(mod2,cnames=c('No','Yes'))
ggsave('plotNew.pdf')
makeplot2(mod30,cnames=c('No','Yes'))
ggsave('plotOld.pdf')

table(mod2$predclass,mod30$predclass)

drinkBin2[which(mod2$predclass==1&mod30$predclass==3),]


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);
		  ### +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u);   #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b0;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u*exp(-b0*n)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.04,0.01);
b0 ~ normal(0.004,0.001);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

M=50   ###, 75, 100, .... till 193

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[1:M,2]

setwd("./covid19modelrisk/output/model_with_E")

###########
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_GM.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_IT.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_JP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_SP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_UK.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_US.csv")
  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_AU.csv")

################
  E=E[1:M,4]
###  E5=E[,5]

#### no E
## E=rep(1,M)

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.04,b0=0.004,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

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

### Germany
u=0.24
b0=0.031#u*0.08 ###

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004

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

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=1

pdf(paste("M2_IQR_5_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b0","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2"), inc_warmup = T,  nrow = 2, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

Epars_m=Epars_m*E

Epars_5=Epars_5*E
Epars_9=Epars_9*E

pdf(paste("M2_IQR_5_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_IQR_5_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

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

### Germany
u=0.24
b0=0.031#u*0.08 ###

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004


#' Seasonally Adjusted Series for Continued Unemployment Claims, weekly (automatic outlier identification, TC outlier specified, log)
#'
#' A time series object with seasonal adjustment generated for weekly continued unemployment
#' claims from a model fit to the logged series that includes automatically identified outliers with a temporary
#' change outlier (TC) specified for the 13th week of 2020
#'
#' @format An xts time series object for seasonally adjusted CC from January 31, 2004 to January 29, 2022
"cc_sa_tc_log"


correlogI <- function(x, dt, method = "euclidean", nc = NULL, thresh = NULL, alpha = 0.05, tail = "upper", seq.bonferroni = TRUE){
  if(!is.vector(x)) stop("\"x\" must be a vector")
  if(!is.data.frame(dt) & !is.matrix(dt)) stop("\"dt\" must be a data frame or matrix")
  if(length(dt[1, ]) != 2) stop("\"dt\" must have two columns")
  if(length(x) != length(dt[ ,1])) stop("number of \"dt\" rows must be iqual to \"x\" length")
  if(!(is.null(nc) | is.null(thresh))) stop("one of \"nc\" or \"thresh\" must be specified")
  if(sum(tail %in% c("two", "upper", "lower")) == 0) stop("tail must be one of: \"two\", \"upper\", \"lower\"")

  # Distance matrix
  D <- as.matrix(dist(dt, method = "euclidean"))

  # Number of observations
  n <- dim(D)[1]

  if(is.null(nc) & is.null(thresh)){
    # Number of classes: Sturges' rule
    nc <- round(1 + (1/log10(2)) * log10(length(D[upper.tri(D, diag = FALSE)])), 0)
    thresh <- (max(D) / nc)
  }

  if(!is.null(thresh)){
    if(thresh >= max(D)) stop(paste("\"thresh\" must be less than maximum distance:", round(max(D), 2)))
    # Define nc by informed threshold distance
    nc <- round(max(D) / thresh, 0)
  }

  if(!is.null(nc)){
    # Ensure that nc is integer
    nc <- round(nc, 0)
    thresh <- (max(D) / nc)
  }

  # Distance classses (equal length)
  d <- array((1:nc) * thresh, nc, list(1:nc))

  # Data frame with variables to each class
  res <- data.frame(class = 1:nc, distMax = d, I = NA, W = NA, varI = NA)
  if(tail == "two" | tail == "upper"){
    res$Ia.up <- NA
    if(seq.bonferroni == TRUE) res$Ia.up.bonf <- NA
  }
  if(tail == "two" | tail == "lower"){
    res$Ia.lo <- NA
    if(seq.bonferroni == TRUE) res$Ia.lo.bonf <- NA
  }
  res$pvalue <- NA
  res[ ,"."] <- NA

  # Correction to bicaucal test
  if(tail == "two") alpha <- alpha / 2

  # Expected I
  EI <- -(n - 1)^-1

  # For each distance classes
  for(cl in 1:nc){
    # Binary weight
    if(cl == 1) w <- D <= d[cl]
    else w <- D > d[cl - 1] & D <= d[cl]

    # Convert logical to numeric and dicart upper triangle, including diagonal (simetric weight matrix)
    w[upper.tri(w, diag = TRUE)] <- 0

    # Number of pais in distance class
    res$W[cl] <- sum(w)

    # Checking if there are pairs in distance classe
    if(res$W[cl] != 0){
      # Moran I
      res$I[cl] <- ((1 / res$W[cl]) * sum(w * ((x - mean(x)) %o% (x - mean(x))))) / ((1/n) * sum((x - mean(x))^2))

      # Variance
      S1 <- (1/2) * sum((w + t(w)) ^ 2)

      S2 <- sum((apply(w, 1, sum) + apply(w, 2, sum)) ^ 2)

      b2 <- (n * sum((x - mean(x)) ^ 4)) / ((sum((x - mean(x)) ^ 2)) ^ 2)

      num1 <- n * ( (((n^2) - (3*n) + 3) * S1) - (n*S2) + (3 * (res$W[cl]^2)) )
      num2 <- b2 * ( (((n^2) - n) * S1) - (2*n*S2) + (6 * (res$W[cl]^2)) )
      den <- (n-1) * (n-2) * (n-3) * (res$W[cl]^2)

      res$varI[cl] <- ((num1 - num2) / den) - (EI ^ 2)

      # Correction to small n
      if((4 * (n - sqrt(n))) < res$W[cl] & res$W[cl] <= (4 * ((2*n) - (3*sqrt(n)) + 1)))
        kalpha <- sqrt(10 * alpha)
      else kalpha <- 1

      # Critical Ialpha with correction to small n
      if(tail == "two" | tail == "upper"){
        res$Ia.up[cl] <- (kalpha * EI) + abs(qnorm(alpha, 0, 1)) * sqrt(res$varI[cl])
        if(seq.bonferroni == TRUE)
          res$Ia.up.bonf[cl] <- (kalpha * EI) + abs(qnorm(alpha / cl, 0, 1)) * sqrt(res$varI[cl])
      }
      if(tail == "two" | tail == "lower"){
        res$Ia.lo[cl] <- (kalpha * EI) - abs(qnorm(alpha, 0, 1)) * sqrt(res$varI[cl])
        if(seq.bonferroni == TRUE)
          res$Ia.lo.bonf[cl] <- (kalpha * EI) - abs(qnorm(alpha / cl, 0, 1)) * sqrt(res$varI[cl])
      }

      # Probability
      if(tail == "two")
        res$pvalue[cl] <-  2 * pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]), lower.tail = ifelse(res$I[cl] >= EI, FALSE, TRUE))

      if(tail == "upper")
        res$pvalue[cl] <- pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]), lower.tail = FALSE)

      if(tail == "lower")
        res$pvalue[cl] <- pnorm(res$I[cl], (kalpha * EI), sqrt(res$varI[cl]))

      # Significance
      if(seq.bonferroni == TRUE)
        res[cl, "."] <- ifelse(res$pvalue[cl] < (ifelse(tail == "two", (alpha * 2), alpha) / cl), "*", "")
      else res[cl, "."] <- ifelse(res$pvalue[cl] < ifelse(tail == "two", (alpha * 2), alpha), "*", "")
    }
  }

  return(list(EI = EI,
              alpha = alpha,
              tail = tail,
              seq.bonferroni = seq.bonferroni,
              result = res))
}


#' Simple single-parameter adaptive metropolis
#' @param target Target function (returning log unnormalised posterior density);
#' 	this function should take the parameter as its first argument and a data list as its second
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param iter Number of iterations
#' @param scale Scale for the proposal distribution, if NA, the algorithm will adaptively
#' 		choose a scale
#' @param ... Additional named parameters to pass to m_adapt
#'
#' @return A list, with three components: 'chain' is the markov chain, 'scale'
#' 		is the scale parameter used, and 'accept' is the acceptance rate
metropolis = function(target, initial, data, iter = 5000, scale = NA, ...) {

	# check that the target distribution is defined at the initial value
	if(!is.finite(target(initial, data)))
		stop("Target distribution undefined at the initial value, choose better inits")

	# adaptation, if needed
	if(is.na(scale))
		scale = m_adapt(target, initial, data, ...)

	# do the sampling
	result = m_sample(target, initial, data, scale, iter)

	# save the scale as well, because this allows resuming the chain
	result$scale = scale
	return(result)
}

#' Worker function to actually do the sampling
#' @param target Target function (returning log unnormalised posterior density);
#' 	this function should take the parameter as its first argument and a data list as its second
#' @param state Initial state (parameter value)
#' @param data Data to pass to the target
#' @param iter Number of iterations
#' @param scale Scale for the proposal distribution
#' @return A list with two elements, chain (the markov chan) and accept, the acceptance rate
m_sample = function(target, state, data, scale, iter) {
	# set up the markov chain
	chain = numeric(iter)

	# keep track of how many times we accept the proposals
	# the acceptance rate is an important diagnostic
	accept = 0

	for(i in 1:iter) {
		# propose a value and accept/reject, updating the chain with the new value
		chain[i] = m_propose(state, scale, target, data)

		if(chain[i] != state) {
			# if the value changed, that was an acceptance
			# increment the accept variable, and update state
			accept = accept + 1
			state = chain[i]
		}
	}

	return(list(chain = chain, accept = accept/iter))
}

#' Runs the adaptation phase of the metropolis sampler
#' @param target Target function
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param chunk_size Number of iterations in each chunk before adapting
#' @param max_chunk Maximum number of chunks before stopping adaptation
#' @param accept_range Target range of acceptance rates
#' @param scale Initial guess for the scale
#' @param scale_step By how much should we multiply the scale if the acceptance is too large,
#' 		or divide if the acceptance rate is too small
#' @return Scale parameter after adaptation
m_adapt = function(target, initial, data, chunk_size = 100, max_chunk = 100,
			accept_range = c(0.2, 0.4), scale = 1, scale_step = 1.1) {

	accept_rate = 0
	nchunk = 0
	while(nchunk < max_chunk & (accept_rate < min(accept_range) |
							accept_rate > max(accept_range))) {
		chunk = m_sample(target, initial, data, scale, iter = chunk_size)
		accept_rate = chunk$accept
		initial = chunk$chain[length(chunk$chain)]

		if(accept_rate < min(accept_range)) {
			scale = scale / scale_step
		} else if(accept_rate > min(accept_range)) {
			scale = scale * scale_step
		}
		nchunk = nchunk + 1
	}
	cat("Finished adaptation after", nchunk, "chunks of", chunk_size,
		"iterations; acceptance rate:\n", "   ", accept_rate, "\n")
	return(scale)
}

#' Simpler adaptation phase, converges around 50% acceptance
#' @param target Target function
#' @param initial Initial value of the parameter
#' @param data Data to pass to the target
#' @param scale Initial guess for the scale
m_adapt_simple = function(target, initial, data, scale = 1, adapt_iter = 5000) {
	accept = 0
	chain = numeric(adapt_iter)

	state = initial
	for(i in 1:adapt_iter) {
		# propose a value and accept/reject, updating the current state with the new value
		chain[i] = m_propose(state, scale, target, data)

			if(chain[i] == state) {
				## rejection, decrease the scale
				scale = scale / 1.1
			} else {
				## acceptance, increase the scale, acceptance rate, and update state
				scale = scale * 1.1
				accept = accept + 1
				state = chain[i]
			}
	}
	cat("Finished adaptation; acceptance rate = ", accept/adapt_iter, "\n")
	return(scale)
}

#' Propose and select candidate values for the metropolis algorithm
#' @param state Current state of the chain
#' @param scale Scale of the proposal distribution
#' @param target Target distribution density function
#' @param data Data for the target distribution
#' @return New value in the chain
m_propose = function(state, scale, target, data) {
	# choose a candidate value from the proposal distribution
	candidate = rnorm(1, state, scale)

	# compute the log posterior density at the current state and the candidate value
	ld_cand = target(candidate, data)
	ld_current = target(state, data)

	# compute the acceptance probability r, making sure the density is finite
	# r is the ratio of densities: (d_cand / d_current)
	# because r should be the exponential of the difference of log densities
	if(!is.finite(ld_cand)) {
		r = 0
	} else {
		r = exp(ld_cand - ld_current)
	}

	# now choose a value such that the chance of choosing d_cand is equal to r
	# the easiest way is to draw a random uniform number U on (0,1) and compare it to r
	# pr(U < r) = r (acceptance), pr(U >= r) = 1 - r (rejection)
	# could also use sample() to do this, but it's slower
	U = runif(1)
	if(U < r) {
		val = candidate
	} else {
		val = state
	}
	return(val)
}

#' Compute highest posterior density interval for a single parameter
#' @param samples A vector of mcmc samples
#' @param density The (minimum) probability density contained in the interval
hpdi = function(samples, density = 0.9) {
	n = length(samples)
	samples = sort(samples)
	n_include = ceiling(density * n)
	lower = 1:(n - n_include)
	upper = lower + n_include
	width = samples[upper] - samples[lower]
	i = which.min(width)
	c(samples[lower[i]], samples[upper[i]])
}


context("construct")

DF = data.frame(expand.grid(x1=LETTERS[1:3], x2=LETTERS[4:5])[-3,], value=1:5,
                stringsAsFactors=FALSE)

Gref = structure(c(1L, 2L, NA, 3L, 4L, 5L), .Dim = c(3L, 2L),
                 .Dimnames = list(x1=c("A", "B", "C"), x2=c("D", "E")))

test_that("summing elements from data.frame to array", {
    G = construct(value ~ x1 + x2, data=DF)
    G2 = construct(DF, value ~ x1 + x2)
    #   D E
    # A 1 3
    # B 2 4
    # C 0 5

    expect_equal(G, Gref)
    expect_equal(G2, Gref)
})

test_that("axis variable is NA, should be omitted + print warning", {
    DFna = rbind(DF, NA)
    expect_warning(Gna <- construct(value ~ x1 + x2, data=DFna))
    expect_warning(Gna2 <- construct(DFna, value ~ x1 + x2))
    expect_equal(Gna, Gref)
    expect_equal(Gna2, Gref)
})

test_that("ambiguous row", {
    DFa = rbind(DF, c("A","D",6))
    expect_error(construct(value ~ x1 + x2, data=DFa))
    expect_error(construct(DFa, value ~ x1 + x2))
})

test_that("only one dependent variable", {
    expect_error(construct(value + other ~ x1 + x2, data=DF))
})


#Worldclim2 precipitation model.
#clearn environment, load packages.
rm(list=ls())
library(runjags)

#output path for precipitation summary object.
out.path <- '/fs/data3/caverill/NEFI_microbial/worldclim2_uncertainty/precipitation_JAGS_model.rds'

#load data
prec <- readRDS('/fs/data3/caverill/NEFI_microbial/worldclim2_uncertainty/worldclim2_prec_uncertainty.rds')

#subset prec for prelim fitting.
prec <- prec[sample(nrow(prec),30000),]

#setup runjags model. precipitation has constant variance.
#setup runjags model. Same model for temperature and precipitation.
prec.model = "
model {
  #setup priors for model predictors.
  for(j in 1:N.preds){
    m[j] ~ dnorm(0, .0001) #flat uninformative priors.
  }

  #elevation affects uncertainty.
  #tau is still a function of sigma.
  #sigma is now a funtion of an intercept (as before) and elevation, with a parameter that gets fitted.
  k0 ~ dunif(0,100)
  k1 ~ dnorm(0, .0001)

  #fit a linear model
  #should be a way to store predictors as a list with an intercept.
  #then just multiply the m vector by the predictor list for the linear component of the model.
  for(i in 1:N){
    y.hat[i] <- m[1]*1 + m[2]*x[i]
    sigma[i] <- k0 + k1*elev[i]
      tau[i] <- pow(sigma[i], -2)
        y[i] ~ dnorm(y.hat[i], tau[i])
  }
} #close model loop.
"

#Setup data objects.
prec.data <- list(      y = prec$observed,
                        x = prec$predicted,
                        elev = prec$elev,
                        N = length(prec$observed),
                        N.preds = 2)

#pick starting values based on lm fits to help chain mixing and speed convergence.
start.prec <- list()
prec.freq <- lm(observed ~ predicted, data = prec)
start.prec[[1]] <- list(k0 = 47, k1 = 0.003, m = c(coef(prec.freq)))
start.prec[[2]] <- lapply(start.prec[[1]],'*',1.01)
start.prec[[3]] <- lapply(start.prec[[1]],'*',0.99)

#fit precipitation model. This number of samples gives clean looking distributions.
prec.out <- run.jags(prec.model,
                     data = prec.data,
                     adapt = 200,
                     burnin = 1000,
                     sample = 3000,
                     n.chains = 3,
                     monitor = c('m','k0','k1'),
                     inits = start.prec
)
#summarize and plot output.
prec.summary <- data.frame(summary(prec.out))
plot(prec.out)

#save output.
saveRDS(prec.summary,out.path)


library(e1071)

model_svm <- svm(as.factor(status) ~ . , data=train_table[,my_features])

pred = predict(model_svm, train_table[,my_features])

sens_svm = sum(train_table$status=="TP" & pred=="TP") / sum(train_table$status=="TP")
TDR_svm = sum(train_table$status == "TP" & pred == "TP") / sum(pred == "TP")

kfold_spec = c()
kfold_sens = c()
kfold_TDR = c()

folds <- createFolds(train_table$status, 10)

for(i in 1:10){
  print(paste("fold: ",i,sep=""))
  test = train_table[folds[[i]],]
  train = train_table[-folds[[i]],]

  propTP = as.numeric(table(train$status)["TP"] / nrow(train))
  propFP = as.numeric(table(train$status)["FP"] / nrow(train))

  svm_fold = svm(as.factor(status) ~ . , data=train[,my_features])
  test$prediction = predict(svm_fold, test[,my_features])
  kfold_sens = c(kfold_sens, (sum(test$status == "TP" & test$prediction == "TP") / sum(test$status == "TP")) )
  kfold_spec = c(kfold_spec, (sum(test$status == "FP" & test$prediction == "FP") / sum(test$status == "FP")) )
  kfold_TDR = c(kfold_TDR, (sum(test$status == "TP" & test$prediction == "TP") / sum(test$prediction == "TP")) )
}

boxplot(data.frame("TDR"=kfold_TDR, "sensitivity"=kfold_sens), col="lightgrey", ylim=c(0.85,1), outpch=20, outcex=0.75, axes=F, staplelwd=2)
axis(side=3, at=c(1,2), labels=c("TDR","sensitivity"), col = NA, col.ticks = NA)
axis(side=2, at=c("0.85","0.90","0.95","1"))


#-- run ICA on "RF_selec" and plot results

#-- run ICA taking groupingvar out (2 dimensions kept)
p=icafast(RF_selec%>% select (-groupingvar),2,center=T,maxit=100)
#-- take groupingvar back in result
ICA= cbind(p$Y, RF_selec   %>% select (groupingvar))

#- change name for plotting and plot
names(ICA) = c("Component_1", "Component_2",  "groupingvar")
pls=ICA %>% ggplot (aes (x=Component_1, y=Component_2, color = groupingvar))+
  geom_point()+
  labs (title=paste0(numberofvariables, " variables used as RF_selec to the ICA"))

#print(pls)

#-- run ICA taking groupingvar out (3 dimensions kept)
p=icafast(RF_selec%>% select (-groupingvar),3,center=T,maxit=100)
#- take groupingvar back in result
ICA= cbind(p$Y, RF_selec   %>% select (groupingvar),metadata   %>% select (animal_ID))

#-- plot in 3d, with ID as labels

names(ICA) = c("Component_1", "Component_2", "Component_3","groupingvar","animal_ID")
ICA$groupingvar=as.factor(ICA$groupingvar)
pls2= plotly::plot_ly(data = ICA, x=~Component_1, y=~Component_2,
                    z=~Component_3, color=~groupingvar,
                    #colors = c("blue", "green", "violet"),
                    text = ~paste ("animal: ",animal_ID),
                    type ="scatter3d", mode= "markers")
#pls2


# para 80 muestras
## http://www.bearcave.com/misl/misl_tech/wavelets/matrix/index.html

# establece el directorio de trabajo
setwd("/home/jorge/Documents/TesisNoFallout")

# leer un archivo csv con todas las muestras
muestras=read.table("muestra_una_caida.csv", sep=",", header=FALSE, col.names = c("X","Y","Z"))
#muestras=read.table("muestra_un_caminando_lento.csv", sep=",", header=FALSE, col.names = c("X","Y","Z"))
#muestras=read.table("muestra_un_subir_escaleras.csv", sep=",", header=FALSE, col.names = c("X","Y","Z"))

# convierte los valores leidos a números
muestras$X=as.numeric(muestras$X)
muestras$Y=as.numeric(muestras$Y)
muestras$Z=as.numeric(muestras$Z)

# realiza un vector suma para trabajar un solo conjunto de coeficientes y no uno de cada eje
# simplifica el trabajo
vSuma=sqrt(((muestras$X)^2)+(muestras$Y)^2+(muestras$Z)^2)

# crea una funcion para obtener los coeficientes
getCoef <- function(vector) {
  nivel = length(vector)
  multiplo = (trunc(length(vector)/8))*8
  k <- c(vector[1:multiplo]) # length 80
  matrizT <- c(1,1,0,0,0,0,0,0,
               1,-1,0,0,0,0,0,0,
               0,0,1,1,0,0,0,0,
               0,0,1,-1,0,0,0,0,
               0,0,0,0,1,1,0,0,
               0,0,0,0,1,-1,0,0,
               0,0,0,0,0,0,1,1,
               0,0,0,0,0,0,1,-1)
  matrizT <- matrix(matrizT, nrow = 8, ncol = 8)
  matrizS <- matrix(k,nrow=8, ncol = length(k)/8)
  x <- (1/sqrt(2)) * matrizT %*% matrizS
  View(x)
  y <- c(x)
  ai <- y[seq(1, length(y), 2)]
  imp <- ai[10:20]
  ai
}

ai <- getCoef(vSuma)
print(ai)
plot(ai)

Transformada Wavelet Haar Y Arbol de Decisiones/coeficientes_wavelets.r


library(contextual)
horizon <- 500
simulations <- 1000
ProbClick <- c(0.1, 0.3, 0.7)

bandit <- BasicBernoulliBandit$new(weights = ProbClick)

policy <- EpsilonFirstPolicy$new(time_steps = 100)

agent <- Agent$new(policy, bandit)

simulator <- Simulator$new(agent, horizon, simulations, do_parallel = FALSE)

history <- simulator$run()

plot(history, type = "average", regret = FALSE, lwd = 2, legend_position = "bottomright")

plot(history, type = "cumulative", regret = FALSE, rate = TRUE, lwd = 2)

plot(history, type = "arms")


numbers_1 <- function(x) {
  x <- as.character(x)
  x <- strsplit(x, "")
  x <- unlist(x)
  digit.vector <- factor(x, levels = 0:9)
  res <- table(digit.vector)
  as.numeric(res)
}

numbers_2 <- function(x) {
  x <- paste(x, collapse = "")
  z <- nchar(x)
  x <- as.double(x)
  y <- rep(0, 10)
  for (i in seq_len(z)) {
    k <- x %% 10
    y[k + 1] <- y[k + 1] + 1
    x <- x %/% 10
  }
  y
}


# Loading table from log file, space separated
# Create Grouped & Stacked Bar Plot

rm(list = ls())

# set working directory to current source directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

print(this.dir)

#X11()
######## data #########
fileNameData = "data.dat"
tableData=read.table(fileNameData)
######## legend #########
fileNameLegend = "legend.dat"
legendData=read.table(fileNameLegend)

legendData2 <- c() #(data="",nrow=1,ncol=2*length(legendData))
for (name in names(legendData)) {
  legendData2 <- c(legendData2, as.character(as.character(legendData[[name]])), "")
}

nrElements  = dim(tableData)[2]
nrImages    = dim(tableData)[1]

# each block one SNR, with 7 categories for that SNR

# reorganize data matrix
loopAll <- 1:nrElements
every1 <- loopAll[seq(1, length(loopAll), 3)]
every2 <- loopAll[1+seq(1, length(loopAll), 3)]
every3 <- loopAll[2+seq(1, length(loopAll), 3)]
L = length(every1) # nr of folders

# add last row,sum per each column
tableDataCum = colSums (tableData, na.rm = FALSE, dims = 1)

tableData = rbind(tableData, tableDataCum)

# fill the values for output with zeros
plotData <- matrix(data=0, nrow=3,ncol=2*L)  # plotData for barplot

for (imageIdx in 1:(nrImages+1)) {

  print(imageIdx)

  for (i in 1:L) {

    a = tableData[imageIdx, every1[i]] # TP
    b = tableData[imageIdx, every2[i]] # FP
    c = tableData[imageIdx, every3[i]] # FN

    #print(c(a, b, c))

    # to normalize
    plotData[1,2*i-1] = a/(a+c)
    plotData[2,2*i-1] = c/(a+c)
    plotData[3,2*i  ] = b/(a+c)

    #plotData[1,2*i-1] = a
    #plotData[2,2*i-1] = c
    #plotData[3,2*i  ] = b

  }

  if (imageIdx<=nrImages) {
    filename = paste("ratesImg",imageIdx,".pdf", sep="")
  }
  else {
    filename = paste("alltogether.pdf", sep="")

    # in case of the last row (sum) add the values to plotDataTable so that each column corresponds to one folder (category)

  }

  pdf(file=filename, width = 5, height = 2) # in inches
  # Trim off excess margin space (bottom, left, top, right)
  # xpd=TRUE enable things to be drawn outside the plot region
  par(mar=c(1.9, 3.5, 0.5, 1.5),mgp=c(2.4, 0.7, 0), xpd=TRUE)

  colors=c(rgb(0,0,1,0.3),rgb(1,0,0,0.3),rgb(0,1,0,0.3))
  bardensity <- t(t(c(15,15,0)))
  barangle <- t(t(c(45,135,0)))
  spacing <-c(.75, .15)

  barplot(plotData,
          space=spacing,
          #xlab = "CONFIGURATION",
          ylab = "TP/FP/FN RATE",
          names.arg = legendData2,
          #legend.text = c("TP", "FP","FN"),
          col = colors,
          beside=FALSE

  )
  barplot(plotData,
          space=spacing,
          #xlab = "CONFIGURATION",
          ylab = "TP/FP/FN RATE",
          names.arg = legendData2,
          #legend.text = c("TP", "FP","FN"),
          col = "black",
          beside=FALSE,
          density = bardensity,
          angle = barangle,
          add=T
  )

  # Add legend to top right, outside plot region
  legend("topright", inset=c(-0.08,0), c("TP", "FN","FP"), fill= colors, bty = "n")
  dev.off()

}
# print last row for report table every 3rd goes to one column
print("table data")
print(tableData)
plotDataTable <- matrix(data=0, nrow=3,ncol=2*L) # plot in the table

for (i in 1:L) {

  a = tableData[nrImages+1, every1[i]] # TP
  b = tableData[nrImages+1, every2[i]] # FP
  c = tableData[nrImages+1, every3[i]] # FN

  plotDataTable[1,2*i-1] = a;
  plotDataTable[2,2*i-1] = b;
  plotDataTable[3,2*i-1] = c;

      plotDataTable[1,2*i] = a/(a+c);
      plotDataTable[2,2*i] = b/(a+c);
      plotDataTable[3,2*i] = c/(a+c);

}

print("table data TP (TPR);FP (FPR);FN in rows")
print(legendData2)
print(plotDataTable)


for(i in 1:9) print(Y(fac)(i))
for(i in 1:9) print(Y(fib)(i))


#########################################Subsetting###############################
##This might form an important aspect in Data analysis where we might want to work on a subset of data

##Subset on vectors
v<-c(1,2,3,4,5)
v[v>3]  #Output all elements greater than 3

attach(mtcars)
data<-mtcars

str(data)
##Subset on matrices and data frames
#a. Calling by cell positions

data1<-data[,2:11]
data1
data1<-data[1:10,2:11]
data1

data[,-1]
data[setdiff(names(data),'mpg')]

class(data1[,c(2,3)]) # explain this

data1[,1, drop=F] #droping str ?

#b. By using column names- two methods
data1<-data[,c("mpg","cyl")]

name<-c("mpg","cyl","disp","hp")
data1<-data[names(data) %in% name] ## %in% comes in handy for subsetting

#c. Using a subset function ##from help identify the argument to be given
data1<-subset(data,mpg>25,select=mpg:carb) #From data extracts all the records whose mpg>25 and all columns

#d. The same dataframe can be obtained in another way
data1<-data[mpg>25,]

##Multiple conditions can be given using "&" or "|"
data2<-data[mpg>25 & hp>75,]
data2<-subset(data,mpg>25 | gear==5,select=mpg:carb)

##Using which.max
data[which.max(mpg),]

##Using which.min
data[which.min(mpg),]

##Using which
data[which(data$mpg==max(data$mpg)),]
data[which(row.names(data) %in% c("Mazda RX4","Datsun 710")),]

detach(mtcars)

################################Data Exploration and Data Aggregation Methods#######################
##These form an important aspect especially for data exploration, data understanding and to processing
## the data for model building
##A data frame can have multiple datatypes in it like numeric, factor and logical.
library(plyr)
attach(baseball)
dfBB<-baseball
str(dfBB) ##outputs what to which type each variable belong to.
summary(dfBB) ## gives the overall summary of the data,we observe that the stats are given for numerical
## attributes, if characters then class and mode are mentioned.

##Conversion of variable types if necessary
##We can consider "teams" as a factor so that we can compare runs batted and home runs for teams
dfBB$team<-as.factor(dfBB$team)
str(dfBB$team)
##We do this appropriate conversions first

##Missing Values
##To count the number of missing values
sum(is.na(dfBB)) ##Gives the number of missing values in the data. What to do with the missing values ?

#option1. Omit all records with NA values
data1<-na.omit(dfBB)  ##it omits all the records which has atleast one NA value in it
data2<-dfBB[complete.cases(dfBB),]  ##another way

#Option2. If the missing values are few, then we can impute these missing values
library(DMwR)
data3<-centralImputation(dfBB) #Central Imputation
sum(is.na(data3))

data4<-knnImputation(dfBB[,-c(1,4,5)],scale=T,k=5) #KNN Imputation
sum(is.na(data4))

write.csv(data3, "data_imputed.csv", row.names=FALSE)


# Load the MNIST digit recognition dataset into R
# http://yann.lecun.com/exdb/mnist/
# assume you have all 4 files and gunzip'd them
# creates train$n, train$x, train$y  and test$n, test$x, test$y
# e.g. train$x is a 60000 x 784 matrix, each row is one digit (28x28)
# call:  show_digit(train$x[5,])   to see a digit.
# brendan o'connor - gist.github.com/39760 - anyall.org

load_mnist <- function() {
  load_image_file <- function(filename) {
    ret = list()
    f = file(filename,'rb')
    readBin(f,'integer',n=1,size=4,endian='big')
    ret$n = readBin(f,'integer',n=1,size=4,endian='big')
    nrow = readBin(f,'integer',n=1,size=4,endian='big')
    ncol = readBin(f,'integer',n=1,size=4,endian='big')
    x = readBin(f,'integer',n=ret$n*nrow*ncol,size=1,signed=F)
    ret$x = matrix(x, ncol=nrow*ncol, byrow=T)
    close(f)
    ret
  }
  load_label_file <- function(filename) {
    f = file(filename,'rb')
    readBin(f,'integer',n=1,size=4,endian='big')
    n = readBin(f,'integer',n=1,size=4,endian='big')
    y = readBin(f,'integer',n=n,size=1,signed=F)
    close(f)
    y
  }
  train <<- load_image_file('mnist/train-images-idx3-ubyte')
  test <<- load_image_file('mnist/t10k-images-idx3-ubyte')

  train$y <<- load_label_file('mnist/train-labels-idx1-ubyte')
  test$y <<- load_label_file('mnist/t10k-labels-idx1-ubyte')
}

show_digit <- function(arr784, col=gray(12:1/12), ...) {
  image(matrix(arr784, nrow=28)[,28:1], col=col, ...)
}