#  Functions used in the Settlement Vegetation analysis from Simon Goring:

#  The Morisita density estimator:
morisita <- function(processed.data, correction.factor = NULL, veil=FALSE) {
  #  Function to calculate stem density using the morista function.  The input
  #  is 'processed.data', which should be the file 'used.data'.  'correction
  #  factor' is the modified Cottam Correction factor determined in
  #  'load.estimate.correction.R' using a generalized linear model (with a Gamma
  #  distribution).

  azim <- processed.data[,c('az1', 'az2', 'az3', 'az4')]
  diam <- processed.data[,c('diam1', 'diam2', 'diam3', 'diam4')]
  dist <- processed.data[,c('dist1', 'dist2', 'dist3', 'dist4')]
  spec <- processed.data[,c('species1', 'species2', 'species3', 'species4')]
  corn <- processed.data[,'corner']

  if(veil){
    diam[diam < 8] <- NA #double check that this is corrected veil line, and do we want to use it?
  }

  diam[diam == 0 & !spec == 'No tree'] <- NA

  #m.diam <- diam/100 #diameters are in cm already
  m.diam <- (diam * 2.54) / 100 # convert diameter from inches to meters

  dist <- floor(apply(dist, 2, function(x)as.numeric(as.character(x))))
  azim <- floor(apply(azim, 2, function(x)as.numeric(as.character(x))))

  #  This tells us how many quadrats are used.  I'd prefer to use all points
  #  where samples are drawn from two quadrats, but in some cases it seems that
  #  there are NAs in the data.
  #  If a point has recorded azimuths we state that they must be in two different
  #  quadrats:

  two.quads <- apply(azim[,1:2], 1, function(x) sum(!is.na(unique(floor(x/90)))))

  #  There are 10,155 points for which the first two trees were sampled in the
  #  same quadrat.  In general these are randomly distributed, but interestingly
  #  there's a big clump of them in Wisconsin.  Even so, there are lots of other
  #  points around.  We can accept that these points are categorically wrong.
  #
  #
  #  sum((two.quads == 1 & !(is.na(azim[,1]) | is.na(azim[,2]))))

  #  we need to change:

  two.quads[((two.quads < 2 & (is.na(azim[,1]) | is.na(azim[,2]))) &
               !(is.na(dist[,1]) | is.na(dist[,2])))] <- 2

  #  Exclusions include:
  #  Plots with a tree as plot center:
  two.quads[dist[,1] == 0] <- 0

  #  Plots where one of the trees has no measured diameter:
  two.quads[is.na(diam[,1]) | is.na(diam[,2])] <- 0

  #  Plots where a distance to tree is missing:
  two.quads[is.na(dist[,1]) | is.na(dist[,2])] <- 0
  #  This is the same as k in Charlie's spreadsheet:

  q <- two.quads

  #  Tree dist is measured in links in the dataset, I am converting to
  #  meters and adding one half a dimater (in cm), on Charlie's advice.

     m.dist <- dist * 0.201168 + 0.5 * m.diam # convert distances from chains (links) to meters
     #m.dist <- dist + 0.5 * m.diam
  #  rsum is the sum of the squared radii, in cases where there are two trees in
  #  the same quadrant I'm going to drop the site, as I will with any corner
  #  with only one tree since the morista density estimator can't calculate
  #  density with less than two trees, and requires two quadrats.

  #  I'm going to let the NAs stand in this instance.
  rsum <- rowSums((m.dist[,1:2])^2, na.rm=T)
  #rmax <- max(m.dist[,1:2], na.rm=T)
  #rmax<- apply(m.dist[,1:2], 1, max, na.rm= T)

  #  A set of conditions to be met for the rsum to be valid:
  rsum[rowSums(is.na(m.dist[,1:2])) == 2 |  q < 2 | rsum == 0 | rowSums(m.dist[,1:2], na.rm=T) < 0.6035] <- NA
  #rmax[rowSums(is.na(m.dist[,1:2])) == 2 |  q < 2 | rmax == 0 | rowSums(m.dist[,1:2], na.rm=T) < 0.6035] <- NA

  #  From the formula,
  #  lambda = kappa * theta * (q - 1)/(pi * n) * (q / sum_(1:q)(r^2))
  #  here, n is equal to 1.
  #  units are in stems / m^2

  #charilies morisita.est have separate corrections for each type of corner
  morisita.est <- ((q - 1) / (pi * 1)) * (2 / rsum) *
    correction.factor$kappa  * correction.factor$theta* correction.factor$zeta * correction.factor$phi

  morisita.est[q < 2] <- NA

  #  Now they're in stems / hectare
  morisita.est <- morisita.est * 10000

  #  Basal area is the average diameter times the stem density.
  #  The stem density is measured in trees / ha.
  met.rad <- (diam / 2) * 2.54 / 100
  #met.rad <- (diam / 2)/100
  basal.area <- morisita.est * rowSums(pi * met.rad^2, na.rm=TRUE)

  basal.area[ q < 2 ] <- NA

 # radius <- max(m.dist, na.rm = TRUE)
  #plot.area <- pi*rmax/2 # calculate average plot area
  return(list(morisita.est, basal.area))

}


###Calc R2 between DGN-predicted and observed expression in GTEx pilot 9 tissues
date <- Sys.Date()
"%&%" = function(a,b) paste(a,b,sep="")

#predfile<-'/Volumes/im-lab/nas40t2/smozaffari/Elastic_Net/GTEx_pilot_predicted' ##on tarbell
predfile<-'/Users/heather/Dropbox/PrediXcan/GTEx/GTEx_pilot_predicted_from_DGN_elasticNet_alpha0.5' ##local copy

#obsdir<-'/Volumes/im-lab/nas40t2/nknoblauch/predixmod_Inputs/peer_factors/' ##on tarbell
obsdir<-'/Users/heather/Dropbox/PrediXcan/GTEx/gtex-exp/' ##local copy

my.dir <- '/Volumes/im-lab/nas40t2/hwheeler/PrediXcan-Paper/scripts/Heather/make-figures/'

pilotfile<-my.dir %&% 'pilot-GTEx.SubjectDS.v10.1.DRAFT.txt'
pilot<-read.table(pilotfile,header=T)
pilotlist<-pilot$SUBJID

pred<-read.table(predfile,header=T)
rownames(pred)<-pred[,1]
tpred<-t(pred[,-1])
predid<-scan(my.dir %&% 'GTEx_pilot_predicted_from_DGN_elasticNet_alpha0.5_ID.list','character')
rownames(tpred)<-predid

tissuelist<-scan(my.dir %&% 'GTEx_nine_tissues','character')

nmatrix<-matrix(0,ncol=2,nrow=length(tissuelist))

for(i in 1:length(tissuelist)){
  tis <- tissuelist[i]
  obs<-readRDS(obsdir %&% "GTEx_PrediXmod." %&% tis %&% ".exp.adj.15PEERfactors.3PCs.gender.IDxGENE.RDS")
  genefile <- obsdir %&% "GTEx_PrediXmod." %&% tis %&% ".exp.adj.15PEERfactors.3PCs.gender.GENENAME.list"
  idfile <- obsdir %&% "GTEx_PrediXmod." %&% tis %&% ".exp.adj.15PEERfactors.3PCs.gender.ID.list.fixed"
  genelist <- scan(genefile,"character")
  idlist <- scan(idfile,"character")
  colnames(obs) <- genelist
  rownames(obs) <- idlist

  commonIDs<-intersect(rownames(tpred),rownames(obs))
  commonIDs<-intersect(commonIDs,pilotlist)
  newpred<-tpred[commonIDs,]
  newobs<-obs[commonIDs,]
  n<-length(commonIDs)
  nmatrix[i,]<-c(tis,n)

  commonGenes<-intersect(colnames(newpred),colnames(obs))

  resultsmat <- matrix(0,ncol=2,nrow=length(commonGenes))
  colnames(resultsmat) <- c('R2','p')
  rownames(resultsmat) <- commonGenes

  for(j in 1:length(commonGenes)){
    gene<-commonGenes[j]
    res<-cor.test(newobs[,gene],newpred[,gene])
    info<-c(round(res$estimate^2,5),signif(res$p.value,5))
    resultsmat[j,]<-info
  }

  finalres<-resultsmat[order(resultsmat[,1],decreasing=T),]
  write.table(finalres,file="train.DGN-WB_test.GTEX_" %&% tis %&% "_R2.txt",quote=F)
}

write.table(nmatrix,file="GTEx_pilot_sample_sizes.txt",quote=F,row.names=F,col.names=F)


#' The Balsakhi Remedial Tutoring data
#'
#' An example RCT dataset
#'
#' @format A data frame with 10,198 rows and 76 variables:
#'
#' \describe{
#'	\item{studentid}{Student ID}
#'	\item{std}{Grade}
#'	\item{schoolid}{School ID}
#'	\item{div}{Division code}
#'	\item{gender}{String variable for gender}
#'	\item{age}{Age}
#'	\item{researchgroup}{Supervising group for evaluation}
#'	\item{sessiond}{School session (morning or afternoon)}
#'	\item{std3tc}{Treatment school for grade 3}
#'	\item{std4tc}{Treatment school for grade 4 CAL program}
#'	\item{caltc}{CALTC}
#'	\item{precheated}{Cheated on pre-test}
#'	\item{prehelped}{Helped on pre-test}
#'	\item{prelater}{Took the pre-test at a later date}
#'	\item{pre_tot}{Absolute total score on pre-test}
#'	\item{prepapersubtotal}{Total points possible on pre-test}
#'	\item{pretakehome}{Test was administered at home}
#'	\item{standardtemp}{}
#'	\item{midcheated}{Cheated on mid-test}
#'	\item{midhelped}{Helped on mid-test}
#'	\item{midlater}{Took the mid-test at a later date}
#'	\item{mid_tot}{Absolute total score on mid-test}
#'	\item{midpapersubtotal}{Total points possible on mid-test}
#'	\item{midtakehome}{Test was administered at home}
#'	\item{postcheated}{Cheated on post-test}
#'	\item{posthelped}{Helped on post-test}
#'	\item{postlater}{Took the post-test at a later date}
#'	\item{post_tot}{Absolute total score on post-test}
#'	\item{postpapersubtotal}{Total points possible on post-test}
#'	\item{posttakehome}{Test was administered at home}
#'	\item{attritprepost}{Attrition from pre to post}
#'	\item{attritpremid}{Attrition from pre to mid}
#'	\item{attritmidpost}{Attrition from mid to post}
#'	\item{pre_verb}{Absolute verbal score on pre-test}
#'	\item{pre_math}{Absolute math score on pre-test}
#'	\item{mid_verb}{Absolute verbal score on mid-test}
#'	\item{mid_math}{Absolute math score on mid-test}
#'	\item{post_verb}{Absolute verbal score on post-test}
#'	\item{post_math}{Absolute math score on post-test}
#'	\item{bal}{Dummy for balsakhi treatment}
#'	\item{male}{Male}
#'	\item{rank}{rank of (pre_tot) by schoolid std}
#'	\item{bot20}{In bottom 20 in school-grade on pre-test}
#'	\item{third}{Third in pre_tot distribution}
#'	\item{divid}{Unique for school, grade}
#'	\item{numstud}{Number of students in school-grade}
#'	\item{thirdinschool}{Third in pre_tot in school, std}
#'	\item{bigschool}{School-grade bigger than 50 students}
#'	\item{numthird}{Num of Stud in third in school}
#'	\item{pre_mathnorm}{Normalized math score on pre-test}
#'	\item{mid_mathnorm}{Normalized math score on mid-test}
#'	\item{post_mathnorm}{Normalized math score on post-test}
#'	\item{pre_verbnorm}{Normalized verbal score on pre-test}
#'	\item{mid_verbnorm}{Normalized verbal score on mid-test}
#'	\item{post_verbnorm}{Normalized verbal score on post-test}
#'	\item{pre_totnorm}{Normalized total score on pre-test}
#'	\item{mid_totnorm}{Normalized total score on mid-test}
#'	\item{post_totnorm}{Normalized total score on post-test}
#'	\item{premath1std}{Passed standard 1 math competencies in pre-test}
#'	\item{premath2std}{Passed standard 2 math competencies in pre-test}
#'	\item{premath3std}{Passed standard 3 math competencies in pre-test}
#'	\item{preverb1std}{Passed standard 1 verbal competencies in pre-test}
#'	\item{preverb2std}{Passed standard 2 verbal competencies in pre-test}
#'	\item{preverb3std}{Passed standard 3 verbal competencies in pre-test}
#'	\item{midmath1std}{Passed standard 1 math competencies in mid-test}
#'	\item{midmath2std}{Passed standard 2 math competencies in mid-test}
#'	\item{midmath3std}{Passed standard 3 math competencies in mid-test}
#'	\item{midverb1std}{Passed standard 1 verbal competencies in mid-test}
#'	\item{midverb2std}{Passed standard 2 verbal competencies in mid-test}
#'	\item{midverb3std}{Passed standard 3 verbal competencies in mid-test}
#'	\item{postmath1std}{Passed standard 1 math competencies in post-test}
#'	\item{postmath2std}{Passed standard 2 math competencies in post-test}
#'	\item{postmath3std}{Passed standard 3 math competencies in post-test}
#'	\item{postverb1std}{Passed standard 1 verbal competencies in post-test}
#'	\item{postverb2std}{Passed standard 2 verbal competencies in post-test}
#'	\item{postverb3std}{Passed standard 3 verbal competencies in post-test}
#' }
#' @source \url{https://www.povertyactionlab.org/evaluation/balsakhi-remedial-tutoring-vadodara-and-mumbai-india}
"balsakhi"


suppressMessages(library(fmlr))

m = 3
n = 2
x = cpumat(m, n)
x$fill_linspace(1, m*n)
xr = x$to_robj()

y = cpumat(m, n)
y$fill_eye()
yr = y$to_robj()

v = cpumat(n)
v$fill_linspace(1, n)
vr = v$to_robj()

source("internals/common.r")
source("internals/linalg.r")


library(jsonlite)
library(httr)

#collect data
r <- GET("https://api.iextrading.com/1.0/stock/market/batch",
         query = list(symbols = "aapl,goog,fb,govt",
                      types = "chart",
                      range = "2y", last = "5")
)

#clean up data
r1 <- content(r)
rappl <- enframe(unlist(r1$AAPL$chart))
rfb <- enframe(unlist(r1$FB$chart))
rgoog <- enframe(unlist(r1$GOOG$chart))
rgovt <- enframe(unlist(r1$GOVT$chart))

rappl_dates <- filter(rappl, name=="date")
rappl_close <- filter(rappl, name=="close")
rfb_close <- filter(rfb, name=="close")
rgoog_close <- filter(rgoog, name=="close")
rgovt_close <- filter(rgovt, name=="close")

df <- data.frame(rappl_dates[2], rappl_close[2], rfb_close[2], rgoog_close[2], rgovt_close[2])
df <- df %>%
  rename(date="value", aapl_close="value.1", fb_close="value.2", goog_close="value.3", govt_close="value.4")

#make monkey picks

df <- df %>%
  mutate(mpick = floor(runif(nrow(df), min=2, max=6))) %>%
  mutate(mpick_val = ifelse(mpick==2, aapl_close,
                            ifelse(mpick==3, fb_close,
                                   ifelse(mpick==4,goog_close,
                                          ifelse(mpick==5,govt_close, 0))))) %>%
  mutate(mpick_next = floor(runif(nrow(df), min=2, max=6))) %>%
  mutate(mnext_val = ifelse(mpick_next==2, aapl_close,
                            ifelse(mpick_next==3, fb_close,
                                   ifelse(mpick_next==4,goog_close,
                                          ifelse(mpick_next==5,govt_close, 0))))) %>%
  mutate(day_profit=(as.numeric(mpick_val)-as.numeric(mnext_val)))
sum(df$day_profit)

#plot monkey returns
df %>%
  sample_frac(.1) %>%
  ggplot(mapping=aes(x=date, y=day_profit)) + geom_point()

#function to return dataframe for ticker
iex_dat <- function(tick){
  r <- GET("https://api.iextrading.com/1.0/stock/market/batch",
           query = list(symbols = tick,
                        types = "chart",
                        range = "2y", last = "5")
  )
  r1 <- content(r)
  rtick <- enframe(unlist(r1[[tick]]$chart))
  rdates <- filter(rtick, name=="date")
  rclose <- filter(rtick, name=="close")
  rhigh <- filter(rtick, name=="high")
  rlow <- filter(rtick, name=="low")
  rvolume <- filter(rtick, name=="volume")
  df <- data.frame(rdates[2], rclose[2], rhigh[2], rlow[2], rvolume[2])
  df <- df %>%
    rename(date="value", close="value.1", high="value.2", low="value.3", volume="value.4")
  return(df)
}

test <- iex_dat("AAPL")


#!/usr/bin/env Rscript

suppressMessages(library("optparse"))
suppressMessages(library("ggdendro"))
suppressMessages(library("ggplot2"))
suppressMessages(library("vegan"))
suppressMessages(library("R.utils"))
suppressMessages(library("reshape2"))
suppressMessages(library("ape"))

# set arguments
option_list = list (
  make_option(c("-m", "--matrix"),
              type = "character",
              default = "",
              help = "Distance matrix",
              metavar="character"
  ),
  make_option(c("-o", "--out_dir"),
              type = "character",
              default = '',
              help = "Output directory (--file dir)"
  ),
  make_option(c("-s", "--sort"),
              type = "logical",
              default = FALSE,
              action = "store_true",
              help = "Sort columns/rows"
  )
);

opt_parser  = OptionParser(option_list = option_list)
opt         = parse_args(opt_parser)
out.dir     = opt$out_dir
matrix.file = normalizePath(opt$matrix)
sort.names  = opt$sort

# check arguments
if (nchar(matrix.file) == 0) {
  stop("Missing --matrix")
}

if (!file.exists(matrix.file)) {
  stop(paste("Bad matrix file", matrix.file))
}

if (nchar(out.dir) == 0) {
  out.dir = dirname(matrix.file)
}
out.dir = normalizePath(out.dir)

if (!dir.exists(out.dir)) {
  dir.create(out.dir)
}

df = read.table(file = matrix.file, header = TRUE, check.names = F)

if (sort.names) {
  df = df[order(colnames(df)), order(colnames(df))]
}

#
# Dendrogram
#
print("Writing dendrogram")
fit = hclust(as.dist(df), method = "ward.D2")
dg = ggdendro::ggdendrogram(fit, rotate=T) + ggtitle("Dendrogram")
img.height = 5
num.samples = nrow(df)

if (num.samples < 1) {
    stop("No samples!")
}

if (num.samples > 25) {
  img.height = num.samples * .25
}

#options(bitmapType='cairo')
ggsave(file = file.path(out.dir, "dendrogram.png"),
       limitsize = FALSE,
       width = 5,
       height = img.height,
       plot = dg)

#
# Write Newick, fan dendrogram
#
print("Writing dendrogram in Newick format")
write.tree(phy = as.phylo(fit), file = file.path(out.dir, "tree.newick"))
png(filename = file.path(out.dir, "dendrogram_fan.png"))
plot(as.phylo(fit), type = "fan")
invisible(dev.off())

#
# PCOA plot
#
print("Writing PCOA")
fiz_pcoa = rda(df)
p1 = round(fiz_pcoa$CA$eig[1]/sum(fiz_pcoa$CA$eig)*100, digits = 2)
p2 = round(fiz_pcoa$CA$eig[2]/sum(fiz_pcoa$CA$eig)*100, digits = 2)
xlabel = paste0("PCoA1 (", p1, "%)")
ylabel = paste0("PCoA2 (", p2, "%)")

pdf(file.path(out.dir, "pcoa.pdf"), 7, 7)
biplot(fiz_pcoa,
      display = "sites",
      col     = "black",
      cex     = 2,
      xlab    = paste(xlabel),
      ylab    = paste(ylabel)
)
points(fiz_pcoa,
      display = "sites",
      col     = "black",
      cex     = .5,
      pch     = 20
)
title(main = "PCOA")
invisible(dev.off())

# Heatmap
print("Writing heatmap")
tri.df = 1 - df # nearness
tri.df[upper.tri(tri.df)] = NA
counts = na.omit(melt(as.matrix(tri.df)))
colnames(counts) = c("s1", "s2", "value")

hm = ggplot(counts, aes(s1, s2)) +
 ggtitle('Shared Reads (Normalized)') +
 theme_bw() +
 xlab('Sample1') +
 ylab('Sample2') +
 geom_tile(aes(fill = value), color='white') +
 scale_fill_gradient(low = 'white',
                     high = 'darkblue',
                     space = 'Lab',
                     limits = c(0, 1)) +
 theme(axis.text.x = element_text(angle=45, hjust = 1),
       axis.ticks = element_blank(),
       axis.title.x = element_blank(),
       axis.title.y = element_blank(),
       axis.line = element_blank(),
       panel.border = element_blank(),
       panel.grid.major = element_blank())

ggsave(file = file.path(out.dir, "heatmap.png"), width = 5, height = 5, plot=hm)

printf("Done, see output in '%s'\n", out.dir)


#' Scaling
#'
#' @description Transform numeric to percentage
#'
#' @param x numeric vector
#' @param sum need to sum the value (T/F)
#'
#' @return numeric vector
#' @export
#'
#' @examples
#'
#' x <- c(.4,.6)
#'
#' as_perc(x)
#'

as_perc <- function(x, sum = F){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(sum == F){
    out <- 100*x
  }else{
    out <- 100*x/sum(x)
  }

  return(out)

}


# a fake dataset with plot data for an experiment with 12 plots and a fenced and unfenced treatment, each replicated twice per plot.

n_plots <- 12

d_plot <- list()

d_plot$plot <- rep(1:n_plots, each = 2)
d_plot$year <- rep(c("2013", "2014"), times = n_plots)
d_plot$grazing <-  exp(runif(n_plots*2,0,6.5))
d_plot$mowing <-  3-floor(log(d_plot$grazing)) + abs(as.integer(rnorm(n_plots*2,2,1)))
  d_plot$mowing[d_plot$mowing < 0] <- 0
d_plot$fertilization <-  exp(runif(n_plots*2,0,5))
d_plot$temp <- rep(rnorm(2,14,1), each = n_plots) + rnorm(n_plots*2, 0, 0.5)
d_plot$precipitation <- rep(rnorm(2,660,25), each = n_plots) + rnorm(n_plots*2, 0, 10)

write.csv(as.data.frame(d_plot), file = "radvanced/plots.csv", row.names = FALSE)

# a fake dataset with observational data of species abundance and evenness

d_raw <- list()
d_raw$ID <- 1:(n_plots*4)
d_raw$plot <- rep(1:n_plots, each = 4)
d_raw$fenced <- rep(c(TRUE, TRUE, FALSE, FALSE), times = n_plots)

intercept = 0.5; a = + 0.2; alpha = 1.0; b = +0.6 ; beta = 0.1; c = -0.003 ; gamma = 1.2 ; d = +0.008; e = +0.001

d_plot_2013 <- subset(as.data.frame(d_plot), year == "2013")[d_raw$plot,]

d_raw$shannon <- with(d_plot_2013, intercept + a * mowing^alpha + d_raw$fenced * b * grazing^beta + c * fertilization^gamma + d * temp + e * precipitation ) + rnorm(n_plots, 0, 0.2)
d_raw$shannon[d_raw$shannon < 0] <- 0

#plot(d_raw$shannon ~ d_plot_2013$fertilization)

d_raw$notes <- character(length = n_plots*4)
d_raw$notes[c(14,45)] <- "fence was trampled"
d_raw$notes[c(42)] <- "catch samples were lost"

write.csv(as.data.frame(d_raw), file = "radvanced/rawdata.csv", row.names = FALSE)

# a fake dataset with observational data of species abundance and evenness

d_raw <- list()
d_raw$ID <- 1:(n_plots*4)
d_raw$plot <- rep(1:n_plots, each = 4)
d_raw$fenced <- rep(c(TRUE, TRUE, FALSE, FALSE), times = n_plots)

intercept = 0.5; a = + 0.2; alpha = 1.0; b = +0.6 ; beta = 0.1; c = -0.003 ; gamma = 1.2 ; d = +0.008; e = +0.001

d_plot_2014 <- subset(as.data.frame(d_plot), year == "2014")[d_raw$plot,]

d_raw$shannon <- with(d_plot_2013, intercept + a * mowing^alpha + d_raw$fenced * b * grazing^beta + c * fertilization^gamma + d * temp + e * precipitation ) + rnorm(n_plots, 0, 0.2)
d_raw$shannon[d_raw$shannon < 0] <- 0

d_raw$notes <- character(length = n_plots*4)
d_raw$notes[c(25,26)] <- "rabbit calamity"

write.csv(as.data.frame(d_raw), file = "radvanced/rawdata2014.csv", row.names = FALSE)


# Team Rython: Dainius Masiliunas and Tim Weerman
# January 12, 2016
# Apache License 2.0

library(raster)

# Plot two plots: the country overview with a highlighted winner,
# and the municipality zoomed in.
PlotGreenestCity = function(winner, NetherlandsMap, NDVI, months)
{
        # Parameters for plotting 2 images with more margin space
        opar <- par(mfrow=c(1,2), mar=c(5.1,4.1,4.1,5.1))

        # First image
        plot(mask(mean(NDVI[[months]]), NetherlandsMap))
        plot(NetherlandsMap, add=TRUE)
        title(main = "Map of the Netherlands")
        title(xlab = "Longtitude")
        title(ylab = "Latitude")
        plot(winner, add = TRUE, border = "red", lwd = 3)

        #Second image
        plot(mask(mean(NDVI[[months]]), winner), xlim=c(extent(winner)@xmin, extent(winner)@xmax), ylim = c(extent(winner)@ymin, extent(winner)@ymax))
        plot(winner, border = "red", lwd = 3, axes=TRUE, add=TRUE)
        title(main = "Greenest City")
        title(xlab = "Longtitude")
        title(ylab = "Latitude")
        text(winner, labels = winner$NAME_2)

        par(opar)
}


# Master Thesis Project - Extreme Value Theory
# Introductory Task
# Killian Martin--Horgassan
# 19-02-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Elementary test
#x <- 5
#print(x)

# sourcing works

# Loading function 'NormMax'
source("/Users/kimartin/Desktop/R_files_pdm/NormMax.r")
source("/Users/kimartin/Desktop/R_files_pdm/InputIntroductoryTask.r")

# Calling function NormMax
#listMax <- NormMax()

# Input from keyboard
DIST <- InputIntroductoryTask()

# Calling function NormMax
listMax <- NormMax(length(DIST),DIST)


#control<-read.FLSMS.control()
#indices<-SMS2FLIndices(control)

##############################################################
# QQplot of catch and surveys

cleanup()
dev<-'Screen'
nox<-4; noy<-4;

n.other<-2  # BUG
a<-Read.catch.survey.residuals()

# survey residuals by fleet
fleet.names<-Read.fleet.names()

newplot(dev,nox,noy); i<-0
aa<-subset(a,data=='survey')
by(aa,list(aa$fleet,aa$Species.n),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   qqnorm(x$residual,main=' ',col=x$Age+1)
   qqline(x$residual)
   title(main=paste(fleet.names[x[1,]$Species.n-n.other,x[1,]$fleet]))
     i<<-i+1
   hist(x$residual,main=paste(x[1,]$Species,x[1,]$fleet),xlab='Residual')
})

by(a,list(a$Species,a$data),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   qqnorm(x$residual,main=' ')
   qqline(x$residual)
   title(main=paste(x[1,]$Species,x[1,]$data))
     i<<-i+1
   hist(x$residual,main=paste(x[1,]$Species,x[1,]$data),xlab='Residual')

})

by(a,list(a$Species,a$data),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   qqnorm(x$residual,main=' ')
   qqline(x$residual)
   title(main=paste(x[1,]$Species,x[1,]$data))
     i<<-i+1
   hist(x$residual,main=paste(x[1,]$Species,x[1,]$data),xlab='Residual')

})

by(a,list(a$Species),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   qqnorm(x$residual,main=' ',col=x$col)
   qqline(x$residual)
   title(main=paste(x[1,]$Species,' all'))
     i<<-i+1
})

hist(a$residual,main='all')


library(ggplot2)
library(reshape)
library(rtracklayer)
library(effsize)

wilcoxon.subset <- function(global, subset, col) {
  exclude <- subsetByOverlaps(global, setdiff(global, subset))
  df.global <- mcols(exclude)[, col]
  df.subset <- mcols(subset)[, col]

  # Drop non finite values (if log was applied)
  g <- df.global[is.finite(df.global)]
  s <- df.subset[is.finite(df.subset)]
  wilcox.test(s, g)
}

compute.effect.size.vs.global <- function(global, subset, col) {
  exclude <- subsetByOverlaps(global, setdiff(global, subset))
  df.global <- mcols(exclude)[, col]
  df.subset <- mcols(subset)[, col]

  # Drop non finite values (if log was applied)
  g <- df.global[is.finite(df.global)]
  s <- df.subset[is.finite(df.subset)]

  cohen.d(s, g)
}

args = commandArgs(trailingOnly=TRUE)

in.bins.file <- args[1]
in.iap.file <- args[2]
outfile <- args[3]

df <- read.table(in.bins.file, sep='\t', header=T)
values <- df[, c('chr', 'start', 'end', 'Martire2019.ATAC.H33WT','Martire2019.ATAC.H33KO', 'H3K9me3.WT')]
values$ATAC.logfc <- log2(values$Martire2019.ATAC.H33KO/values$Martire2019.ATAC.H33WT)

iap.ranges <- import(in.iap.file)
bins.grang <- makeGRangesFromDataFrame(values, keep.extra.columns = T)
iap.bins <- subsetByOverlaps(bins.grang, iap.ranges, minoverlap=2500)
iap.df <- data.frame(mcols(iap.bins))

df.melted <- melt(values, id.vars=c('chr','start','end'))
iap.melted <- melt(iap.df)

p <- ggplot(values, aes(x=ATAC.logfc, y=H3K9me3.WT)) +
  geom_point(color='#aaaaaa', alpha=0.2, size=0.8) +
  geom_point(data=iap.df, aes(x=ATAC.logfc, y=H3K9me3.WT), color='#409c70', alpha=0.7, size=0.8) +
  ylab('H3K9me3 RPGC') +
  xlab('ATAC-seq log2 H3.3KO/WT') +
  ggtitle('5kb bins') +
  theme_classic() +
  theme(legend.position='none') +
  geom_vline(xintercept=0, linetype='dotted') +
  ylim(0,30) +
  xlim(-5,5)

ggsave(outfile, plot=p, dpi=300)

# Wilcoxon ranked sum test significance for global values vs values at IAP bins
wilcoxon.subset(bins.grang, iap.bins, 'ATAC.logfc')
wilcoxon.subset(bins.grang, iap.bins, 'H3K9me3.WT')

# Effect size calculation
compute.effect.size.vs.global(bins.grang, iap.bins, 'ATAC.logfc')
compute.effect.size.vs.global(bins.grang, iap.bins, 'H3K9me3.WT')


################################################################################################
#
# Mark Cembrowski, Janelia Research Campus, Oct 15 2015
#
# This function takes a list of genes and renders a heatmap.  101515: extended to enable
# CPM-based data to be visualised.
#
# INPUT:
# geneList: character.  One or more gene names to plot; can be ENS IDs or gene short names.
#
# OPTIONAL ARGUMENTS:
# doNorm=F: logical. normalise each gene to its peak value
# replicates=F: logical. show individual replicates
# mask=c(): character.  mask any supplied samples from analysis and visualisation.
#
# OUTPUT:
# A heatmap is rendered for the input genes and returned.
#
################################################################################################

geneHeatmap <- function(geneList,doNorm=F,replicates=F,mask=c(),rangeMax=1e9,doFpkm=T,...){
	# Check for duplicate entries in gene list; eliminate them if present and
	# alert user.
	if(sum(duplicated(geneList))>0.1){
		warning('Duplicated entries in gene list; removing.')
		geneList <- geneList[!duplicated(geneList)]
	}

	# Check to make sure that geneList is character vector; unintended behaviour can
	# emerge if using factors.  If this happens, use the as.vector() wrapper.
	if(class(geneList)!='character'){
		geneList <- as.vector(geneList)
	}

	# Convert gene list to unique Ensembl IDs, if supplied with gene short names.
	if(!isGeneId(geneList)){
		geneList <- symToId(geneList)[[1]]
	}

	# Obtain FPKM values for geneList and associated it with gene_ids (outId=T).
	if(doFpkm){
		if(replicates){
			merged <- fpkmRepMat[geneList,]
		}else{
			merged <- fpkmPoolMat[geneList,]
		}
	}else{
		if(replicates){
			merged <- cpmRepMat[geneList,]
		}else{
			merged <- cpmPoolMat[geneList,]
		}
	}

	# If imposing a mask of samples, use here.
	if(length(mask)>0.1){merged <- .maskSamples(mask,replicates=replicates,fpkmMat=merged)}

	# Populate matrix with gene_id, gene_short_name, and FPKM values.
	merged <- cbind(rownames(merged),idToSym(rownames(merged)),merged)
	colnames(merged)[c(1,2)] <- c('gene_id','gene_short_name')

	# Generate a normalised version of this matrix and extracted melted FPKM values for later.
	normed <- sweep(merged[,-c(1,2)],1,apply(merged[,-c(1,2)],1,max),'/') # Remove 1 and 2 columns (gene info); normalise
	normed <- cbind(merged[,c(1,2)],normed)
	fpkmNorm <- melt(normed,value.var='fpkm',id.vars=c('gene_id','gene_short_name'))$value

	# Melt merged and attached normalised value.
	merged <- melt(merged,value.var='fpkm',id.vars=c('gene_id','gene_short_name'))
	colnames(merged)[c(3,4)] <- c('sample_name','fpkm')
	merged <- cbind(merged,fpkmNorm)

	# Clean up data frame for plotting; change gene_short_name vector to factor in
	# order to manipulate levels for plotting.  The initial rev(.) call plots
	# everything in alphabetical order on the y axis.
	merged$gene_short_name <- as.factor(merged$gene_short_name)

	# Reorder levels for plotting of y axis, in the order received from geneList.
	if(!isGeneId(geneList)){
		merged$gene_short_name <- factor(merged$gene_short_name,levels=geneList)
	}else{
		merged$gene_short_name <- factor(merged$gene_short_name,levels=idToSym(geneList))
	}

	preTrunc <- as.data.frame(round(merged$fpkm))
	colnames(preTrunc) <- 'fpkmPre'
	merged <- cbind(merged,preTrunc)

	if (rangeMax<1e5){
		# Track elements that are truncated.
		isTrunc <- merged$fpkm>rangeMax
		merged$fpkm <- pmin(merged$fpkm,rangeMax-0.0001)
	}

	# Define ggplot object.
	heatGr <- ggplot(merged,aes_string(x='gene_short_name',y='sample_name',label='fpkmPre'))

	# Define tile colouring.
	if (doNorm){
		heatGr <- heatGr + geom_tile(aes(fill=fpkmNorm),colour='white')
		theRangeMax <- 1
	}else{
		heatGr <- heatGr + geom_tile(aes(fill=fpkm),colour='white')
		theRangeMax <- max(merged$fpkm)
	}
	if (rangeMax<1e5){
		theRangeMax <- rangeMax+0.0001
	}

	# Define other stylistic features.
	heatGr <- heatGr + scale_fill_gradientn(colours=c('cyan','white','red'),
		values=c(0,0.5,1),guide='colorbar',limits=c(0,theRangeMax)) # Changed from green and purple.
	heatGr <- heatGr + theme(panel.background=element_blank())
	heatGr <- heatGr + theme(axis.text.x = element_text(angle=45,hjust=1))
	heatGr <- heatGr + labs(x='Gene',y='Cell type')

	heatGr <- heatGr + geom_text(data=subset(merged,merged$fpkmPre>rangeMax),aes_string(label='fpkmPre'),size=2)

	# Incorporate any other features.
	heatGr <- heatGr + theme(...)

	print(heatGr)

	invisible(heatGr)
}


library(knitr)
library(knitr)
library(dplyr)
library(ggvis)

library(shiny)
library(rmarkdown)

# Uvozimo funkcije za delo z datotekami XML.
 source("lib/xml.r", encoding = "UTF-8")

# Uvozimo funkcije za pobiranje in uvoz zemljevida.
source("lib/uvozi.zemljevid.r", encoding = "UTF-8")

library(dplyr)

pretvori.zemljevid <- function(zemljevid) {
  fo <- fortify(zemljevid)
  data <- zemljevid@data
  data$id <- as.character(0:(nrow(data)-1))
  return(inner_join(fo, data, by="id"))
}

mesta <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/ESP_adm_shp.zip",
                         "ESP_adm2", encoding = "UTF-8")
m1 <- match(mesta$NAME_2, podatki$Team)
mesta$points <- podatki$Points[m1]
mesta$gol_tekma <- podatki$`Goals_per_match`[m1]
mesta$pol <- pozicije$X19[m1]
mesta$povprecje <- pozicije$povprecna[m1]
mst <- pretvori.zemljevid(mesta)
zem1 <- ggplot() + geom_polygon(data = mst, aes(x=long, y=lat, group = group, fill=points),
                                color = "grey") + xlim(-10, 5) + ylim(35, 45) +
    scale_fill_continuous(low = "#69b8f6", high = "#142d45") + ggtitle("Spain")

zem3 <- ggplot() + geom_polygon(data = mst, aes(x=long, y=lat, group = group, fill=pol),
                                       color = "grey") + xlim(-10, 5) + ylim(35, 45) +
       scale_fill_continuous(low = "#69b8f6", high = "#142d45") + ggtitle("Spain")

zem2 <- zem3 + geom_point(data = mst %>% group_by(id, gol_tekma) %>% summarise(x = mean(long), y = mean(lat)),
                  aes(x = x, y = y, size=gol_tekma),color="green")

require(dplyr)
require(rvest)
require(gsubfn)
require(reshape2)
require(ggplot2)
require(mgcv)
require(shiny)


library(Rpathlength)
library(dplyr)

asym_params <- list(Nray=1e6, alphasca=0, n2=seq(from=1.5, to=1.8, by=0.05), h=10^seq(from=0, to=log10(1000), length.out=50), shape=0, max_its=-1, alphaabs_small=1e-3)
asym_res <- run_over_parameters(asymmetry_parameter_worker, asym_params, filename = "mpl_interp_10.rds", rerun=T, force_seed = T, seed_base = 1876, nthreads = 1)
asym_res %>% select(n2, h, lmean, g0, ginf, beta, psi) %>% write.table(file="pill_mpl.csv", row.names = F, col.names=F, sep=',')


#this function is for computing the input data list to the Bayesian computation

datalistfun<-function(df){

	residSD = 1#sqrt(mean(lmInfo$residuals^2)) # residual root mean squared deviation, not used now but see Kruschke 2015
	xMetSD = sd(df$SeedWeight, na.rm = T)
	SeedweightMean = mean(df$SeedWeight, na.rm=T)

	datalist<-list(
	Trait = df$Trait,
	Temp = as.factor(df$Temperature),
	Range = as.factor(df$Range),
	Pop = as.factor(df$Population),
	Tree = as.factor(df$Tree),

	yMean = mean(df$Trait, na.rm = T),
	ySD =sd(df$Trait, na.rm = T),
	residSD = residSD,

	SeedweightMean = SeedweightMean, #ANCOVA
	Seedweight=df$SeedWeight,
	xMetSD=xMetSD,

	NTEMP = nlevels(as.factor(df$Temperature)),
	NINDIV = dim(df)[1],
	NRANGE= nlevels(as.factor(df$Range)),
	NPOP=nlevels(as.factor(df$Population)),
	NTREE=nlevels(as.factor(df$Tree))
	)

	return(datalist)

	}

#	datalistfun(df_traits)

#This function is for initializing chains
initfun<-function(df, nchain = 4){

	NTEMP = nlevels(as.factor(df$Temperature))
	NRANGE= nlevels(as.factor(df$Range))
	NPOP=nlevels(as.factor(df$Population))
	NTREE=nlevels(as.factor(df$Tree))

	nchain <- nchain

	initial<-c(a0 = 0,a1 = rep(0,NTEMP), a2 = rep(0,NRANGE) , A3 = rep(0,NPOP),
		A4 = rep(0,NTREE), aMet=0)

	init<-list()
	for(j in 1:nchain){init[[j]]<-initial}

	return(init)

}

initfun(df_traits)

#This function execute the Bayesian computation (needs datalist fun and initfun)
InputDlply<-function(df, NECH = 2000, NBURN = 1000, NTHIN = 10, nchain = 4, MODEL = "mixed_model.txt",
parameters = c("b0","b1", "b2","B3", "c", "varP", "varF", "QST")){

	require(R2jags)

	datalist <- datalistfun(df = df)
	init <- initfun(df = df, nchain = nchain)

	mix <-jags(model.file=MODEL, data=datalist, n.chains=nchain, inits=init, parameters.to.save=parameters,
	n.iter=NECH , n.burnin=NBURN, n.thin=NTHIN)

	return(mix)

	}


# Test code for ADVI
setwd("~/Code/laplace_approximation/Script/advi")
.libPaths("~/Rlib/")

library(cmdstanr)
library(rstan)
library(bayesplot)
library(dplyr)
library(tidyr)
library(boot)
library(latex2exp)
# set_cmdstan_path("~/Code/laplace_approximation/cmdStan/")
set_cmdstan_path("~/Rlib/cmdstan/")

scriptDir <- dirname(getwd())
modelDir <- file.path(scriptDir, "models3")
dataDir <- file.path(scriptDir, "data")

# Let's now try fitting one of the horseshoe GLM models.
modelName <- "skim_logit"  # "bernoulli_logit_glm_rhs"  # "disease_map"
dataFile <- "prostate_200.data.R"  # "prostate_full.data.R"  # "disease_data_100.r"

data <- read_rdump(file.path(dataDir, dataFile))

mod <- cmdstan_model(paste0(modelDir, "/", modelName, "/",
                            modelName, ".stan"))

# For bernoulli_logit_glm_rhs, use tol_rel_obj = 0.005
# For skim_logit, use tol_rel_obj = 0.007
# For disease_map, use tol_rel_obj = 0.005
fit_vb <- mod$variational(data = data,
                          algorithm = "meanfield",
                          iter = 1e6,
                          output_samples = 1.2e4,  # 2e3
                          eta = 0.1,
                          tol_rel_obj = 0.007,
                          seed = 123)

pars <- c("lambda", "tau", "caux")
if (modelName == "skim_logit") pars <- c(pars, "xi")

samples_raw_vb <- fit_vb$draws(pars)

## Compare samples from HMC to samples from VB.
## Use the code in cluster_analysis_v2.r
source(file.path(scriptDir, "tools", "analysisTools.r"))

if (modelName == "bernoulli_logit_glm_rhs") {
  nChains <- 6
  nIter <- 2000
  nIter_total <- nChains * nIter

  delivDir <- file.path(scriptDir, "deliv", modelName, "cluster")

  stanfit <- readRDS(file = file.path(delivDir, paste0(modelName,
                                        "_1_to_4", "Fit.Rsave")))
  stanfit2 <- readRDS(file = file.path(delivDir, paste0(modelName,
                                         "_5_to_6", "Fit.Rsave")))
  check_hmc_diagnostics(stanfit)  # 0
  check_hmc_diagnostics(stanfit2)  # 13

  samples <- rstan::extract(stanfit, pars = pars)
  samples2 <- rstan::extract(stanfit2, pars = pars)
  log_lambda <- log(rbind(samples$lambda, samples2$lambda))

  index <- select_lambda(log_lambda, quant = 0.9, n_select = 6)
  index

  n_cov <- 5966  # 200
  log_lambda_vb <- log(samples_raw_vb[, 1:n_cov])
  index_vb <- select_lambda(log_lambda_vb, quant = 0.9, n_select = 6)
  index_vb

  quant_select_plot2(log_lambda, log_lambda_vb, quant = 0.9,
                     threshold = 2.5, algo_name1 = "(full) HMC",
                     algo_name2 = "ADVI")

  tau <- c(samples$tau, samples2$tau)
  caux <- c(samples$caux, samples2$caux)
  samples_standard <-
    data.frame(log_lambda_1816 = log_lambda[, 1816],
               log_lambda_2586 = log_lambda[, 2586],
               tau = log(tau), caux = log(caux))

  samples_vb <-
    data.frame(log_lambda_1816 = log_lambda_vb[, 1816],
               log_lambda_2586 = log_lambda_vb[, 2586],
               tau = log(samples_raw_vb[, 5967]),
               caux = log(samples_raw_vb[, 5968]))
  names(samples_vb) <- c("log_lambda_1816", "log_lambda_2586",
                         "tau", "caux")

  n_parm = 4
  samples_all <- rbind(samples_standard, samples_vb)
  samples_all <- gather(samples_all)
  samples_all$method <- rep(rep(c("(full) HMC", "ADVI"), each = 12000),
                                n_parm)
  key_labels <- c(TeX("$\\log \ c_{aux}$"), TeX("$\\log \\lambda_{1816}$"),
                  TeX("$\\log \\lambda_{2586}$"), TeX("$\\log \\tau$")
                  )
  samples_all$key <- factor(samples_all$key, label = key_labels)

  pdf(file = paste("advi_comp","Plots%03d.pdf", sep = ""),
      width = 12, height = 3, onefile = F)

  # dimension: 3 x 12
  sample_comparison_plot(samples_all, x = 0.99, y = 0.95)

  dev.off()
}

if (modelName == "skim_logit") {
  nChains <- 4
  nIter <- 3000
  nIter_total <- nChains * nIter

  delivDir <- file.path(scriptDir, "deliv", modelName, "cluster")
  stanfit <- readRDS(file = file.path(delivDir, paste0(modelName, "Fit.Rsave")))
  check_hmc_diagnostics(stanfit)  # 0

  samples <- rstan::extract(stanfit, pars = pars)
  log_lambda <- log(rbind(samples$lambda))

  index <- select_lambda(log_lambda, quant = 0.9, n_select = 6)
  index

  n_cov <- 200
  log_lambda_vb <- log(samples_raw_vb[, 1:n_cov])
  index_vb <- select_lambda(log_lambda_vb, quant = 0.9, n_select = 6)
  index_vb  # 86  26 106  50 194 166

  samples_standard <-
    data.frame(log_lambda_2581 = log_lambda[, 81],
               log_lambda_2586 = log_lambda[, 86],
               tau = log(samples$tau),
               caux = log(samples$caux),
               xi = log(samples$xi))

  samples_vb <-
    data.frame(log_lambda_2581 = log_lambda_vb[, 81],
               log_lambda_2586 = log_lambda_vb[, 86],
               tau = log(samples_raw_vb[, 201]),
               caux = log(samples_raw_vb[, 202]),
               xi = log(samples_raw_vb[, 203]))
  names(samples_vb) <- c("log_lambda_2581", "log_lambda_2586",
                         "tau", "caux", "xi")

  n_parm <- 5
  samples_all <- rbind(samples_standard, samples_vb)
  samples_all <- gather(samples_all)
  samples_all$method <- rep(rep(c("(full) HMC", "ADVI"), each = 12000),
                            n_parm)
  key_labels <- c(TeX("$\\log \ c_{aux}$"), TeX("$\\log \\lambda_{2581}$"),
                  TeX("$\\log \\lambda_{2586}$"), TeX("$\\log \\tau$"),
                  TeX("$\\log \\chi$")
  )
  samples_all$key <- factor(samples_all$key, label = key_labels)

  pdf(file = paste("advi_comp","Plots%03d.pdf", sep = ""),
      width = 12, height = 3, onefile = F)
  sample_comparison_plot(samples_all, x = 0.79, y = 0.99)
  dev.off()
}

if (modelName == "disease_map") {
  nChains <- 4
  nIter <- 500
  nIter_total <- nChains * nIter

  delivDir <- file.path(scriptDir, "deliv", modelName)
  stanfit <- readRDS(file = file.path(delivDir, paste0(modelName, "Fit.Rsave")))
  check_hmc_diagnostics(stanfit)  # 0

  pars <- c("alpha", "rho", "theta[1]", "theta[2]")
  samples_raw_standard <- rstan::extract(stanfit, pars)
  samples_standard <-
    data.frame(alpha = samples_raw_standard$alpha,
               rho = samples_raw_standard$rho,
               theta_1 = samples_raw_standard$`theta[1]`,
               theta_2 = samples_raw_standard$`theta[2]`)

  samples_raw_vb <- fit_vb$draws(pars)
  samples_vb <- data.frame(alpha = samples_raw_vb[, 1],
                           rho = samples_raw_vb[, 2],
                           theta_1 = samples_raw_vb[, 3],
                           theta_2 = samples_raw_vb[, 4])
  names(samples_vb) <- c("alpha", "rho", "theta_1", "theta_2")

  n_parm <- 4
  samples_all <- rbind(samples_standard, samples_vb)
  samples_all <- gather(samples_all)
  samples_all$method <- rep(rep(c("(full) HMC", "ADVI"), each = 2000),
                            n_parm)
  key_labels <- c(TeX("$\\alpha$"), TeX("$\\rho$"),
                  TeX("$\\theta_1$"), TeX("$\\theta_2$"))
  samples_all$key <- factor(samples_all$key, label = key_labels)

  sample_comparison_plot(samples_all, x = 0.99, y = 0.95)
}


#' Expectation step.
#'
#' @param p List of parameters.
#' @param item_data Matrix or dataframe of item responses.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#' @param item_type Vector of character values indicating the item type.
#' @param mean_predictors Possibly different matrix of predictors for the mean
#' impact equation.
#' @param var_predictors Possibly different matrix of predictors for the
#' variance impact equation.
#' @param theta Vector of fixed quadrature points.
#' @param samp_size Sample size in dataset.
#' @param num_items Number of items in dataset.
#' @param num_responses Number of responses for each item.
#' @param adaptive_quad Logical indicating whether to use adaptive quadrature.
#' @param num_quad Number of quadrature points used for approximating the
#' latent variable.
#' @param get_eap Logical indicating whether to compute EAP scores.
#' @param NA_cases Logical vector indicating missing observations.
#'
#' @return a \code{"list"} of posterior values from the expectation step
#'
#' @keywords internal
#'
Estep <-
  function(p,
           item_data,
           pred_data,
           item_type,
           mean_predictors,
           var_predictors,
           theta,
           samp_size,
           num_items,
           num_responses,
           adapt_quad,
           num_quad,
           get_eap,
           NA_cases) {

    # Make space for the trace lines and the E-tables.
    observed_ll <- 0
    itemtrace <- rep(list(NA),num_items)
    etable <- matrix(0, nrow = samp_size, ncol = num_quad)
    eap_scores <- if(get_eap) matrix(NA, nrow = length(NA_cases), ncol = 1)
    eap_sd <- if(get_eap) matrix(NA, nrow = length(NA_cases), ncol = 1)

    # Impact.
    alpha <- mean_predictors %*% p[[num_items+1]]
    phi <- exp(var_predictors %*% p[[num_items+2]])

    if(adapt_quad == TRUE) {
      theta <- mean(alpha) +
        sqrt(2*mean(phi))*statmod::gauss.quad(n = num_quad,
                                              kind = "hermite")$nodes
    }

    # Compute the trace lines.
    for (item in 1:num_items) {
      if(item_type[item] == "cfa") {
        itemtrace[[item]] <- gaussian_traceline_pts(p[[item]],
                                                    theta,
                                                    item_data[,item],
                                                    pred_data,
                                                    samp_size)
      } else if (item_type[item] == "2pl") {
        itemtrace[[item]] <- bernoulli_traceline_pts(p[[item]],
                                                     theta,
                                                     pred_data,
                                                     samp_size)
      } else {
        itemtrace[[item]] <- cumulative_traceline_pts(p[[item]],
                                                      theta,
                                                      pred_data,
                                                      samp_size,
                                                      num_responses[item],
                                                      num_quad)
      }
    }

    # Obtain E-table.
    for(i in 1:samp_size) {

      # Get weights for computing adaptive or fixed-point quadrature.
      posterior <- dnorm(theta,
                         mean = alpha[i],
                         sd = sqrt(phi[i]))

      # For each individual i, loop over items (j) and compute posterior
      # probability of response pattern.
      for(j in 1:num_items) {

        x <- item_data[i,j]
        if(is.na(x)) next

        if(item_type[j] == "cfa") { # Continuous responses.
          posterior <- posterior*itemtrace[[j]][i,]
        } else if(item_type[j] == "2pl") { # Binary responses.
          if(x == 1) {
            posterior <- posterior*(1-itemtrace[[j]][i,])
          } else {
            posterior <- posterior*itemtrace[[j]][i,]
          }
        } else if(item_type[j] == "graded") { # Ordered categorical responses.
          if(x == 1) {
            posterior <- posterior*(1-itemtrace[[j]][[1]][i,])
          } else if(x == num_responses[j]) {
            posterior <- posterior*itemtrace[[j]][[num_responses[j]-1]][i,]
          } else {
            posterior <- posterior*(itemtrace[[j]][[x-1]][i,]-
                                        itemtrace[[j]][[x]][i,])
          }
        }

      }

      # Normalize posterior.
      marginal <- sum(posterior, na.rm = TRUE)
      observed_ll <- observed_ll + log(marginal)
      if(marginal == 0) marginal <- 1
      etable[i,] <- posterior/marginal

      # EAPs.
      if(get_eap) {
        eap_scores[which(!NA_cases)[i]] <- sum(posterior*theta)/marginal
        eap_sd[which(!NA_cases)[i]] <-
          sqrt(sum(posterior*(theta-eap_scores[which(!NA_cases)[i]])**2)/marginal)
      }

    }

    # E-table matrix to be used in Q function and (possibly adaptive)
    # theta values.
    return(list(etable=etable,eap_scores=eap_scores,eap_sd=eap_sd,
                theta=theta,observed_ll=observed_ll))

  }

#' Expectation step with proxy data.
#'
#' @param p List of parameters.
#' @param item_data Matrix or dataframe of item responses.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#' @param item_type Vector of character values indicating the item type.
#' @param mean_predictors Possibly different matrix of predictors for the mean
#' impact equation.
#' @param var_predictors Possibly different matrix of predictors for the
#' variance impact equation.
#' @param prox_data Vector of observed proxy scores.
#' @param samp_size Sample size in dataset.
#' @param num_items Number of items in dataset.
#' @param num_responses Number of responses for each item.
#' @param get_eap Logical indicating whether to compute EAP scores.
#' @param NA_cases Logical vector indicating missing observations.
#'
#' @return a \code{"list"} of posterior values from the expectation step
#'
#' @keywords internal
#'
Estep_proxy <-
  function(p,
           item_data,
           pred_data,
           item_type,
           mean_predictors,
           var_predictors,
           prox_data,
           samp_size,
           num_items,
           num_responses,
           get_eap,
           NA_cases) {

    # Make space for the trace lines and the E-tables.
    observed_ll <- 0
    itemtrace <- rep(list(NA),num_items)
    etable <- matrix(0, nrow = samp_size, ncol = 1)
    eap_scores <- if(get_eap) matrix(NA, nrow = length(NA_cases), ncol = 1)
    eap_sd <- if(get_eap) matrix(NA, nrow = length(NA_cases), ncol = 1)

    # Impact.
    alpha <- mean_predictors %*% p[[num_items+1]]
    phi <- exp(var_predictors %*% p[[num_items+2]])

    # Compute the trace lines.
    for (item in 1:num_items) {
      if(item_type[item] == "cfa") {
        itemtrace[[item]] <- gaussian_traceline_pts_proxy(p[[item]],
                                                          prox_data,
                                                          item_data[,item],
                                                          pred_data,
                                                          samp_size)
      } else if (item_type[item] == "2pl") {
        itemtrace[[item]] <- bernoulli_traceline_pts_proxy(p[[item]],
                                                           prox_data,
                                                           pred_data)
      } else {
        itemtrace[[item]] <- cumulative_traceline_pts_proxy(p[[item]],
                                                      prox_data,
                                                      pred_data,
                                                      samp_size,
                                                      num_responses[item])
      }
    }

    # Obtain E-table.
    for(i in 1:samp_size) {

      # Get weights for computing adaptive or fixed-point quadrature.
      posterior <- dnorm(prox_data[i],
                         mean = alpha[i],
                         sd = sqrt(phi[i]))

      # For each individual i, loop over items (j) and compute posterior
      # probability of response pattern.
      for(j in 1:num_items) {

        x <- item_data[i,j]
        if(is.na(x)) next

        if(item_type[j] == "cfa") { # Continuous responses.
          posterior <- posterior*itemtrace[[j]][i,]
        } else if(item_type[j] == "2pl") { # Binary responses.
          if(x == 1) {
            posterior <- posterior*(1-itemtrace[[j]][i,])
          } else {
            posterior <- posterior*itemtrace[[j]][i,]
          }
        } else if(item_type[j] == "graded") { # Ordered categorical responses.
          if(x == 1) {
            posterior <- posterior*(1-itemtrace[[j]][[1]][i,])
          } else if(x == num_responses[j]) {
            posterior <- posterior*itemtrace[[j]][[num_responses[j]-1]][i,]
          } else {
            posterior <- posterior*(itemtrace[[j]][[x-1]][i,]-
                                      itemtrace[[j]][[x]][i,])
          }
        }

      }

      # Normalize posterior.
      observed_ll <- observed_ll + log(posterior)
      etable[i,] <- posterior

      # EAPs.
      if(get_eap) {
        eap_scores[which(!NA_cases)[i]] <- posterior*prox_data[i]
        eap_sd[which(!NA_cases)[i]] <-
          sqrt(posterior*(prox_data[i]-eap_scores[which(!NA_cases)[i]])**2)
      }

    }

    # E-table matrix to be used in Q function and (possibly adaptive)
    # theta values.
    return(list(etable=etable,eap_scores=eap_scores,eap_sd=eap_sd,observed_ll=observed_ll))

  }


#' ---
#' author: "Jenny Bryan"
#' output:
#'   html_document:
#'     keep_md: TRUE
#' ---

#+ setup, include = FALSE
library(knitr)
opts_chunk$set(fig.path = 'figure/stripplot-', error = TRUE)

#' Note: this HTML is made by applying `knitr::spin()` to an R script. So the
#' narrative is very minimal.

library(ggplot2)

#' pick a way to load the data
#gdURL <- "http://tiny.cc/gapminder"
#gapminder <- read.delim(file = gdURL)
#gapminder <- read.delim("gapminderDataFiveYear.tsv")
library(gapminder)
str(gapminder)

#' stripplots: univariate scatterplots (but w/ ways to also convey 1+ factors)
ggplot(gapminder, aes(x = continent, y = lifeExp)) + geom_point()

#' we have an overplotting problem; need to spread things out
ggplot(gapminder, aes(x = continent, y = lifeExp)) + geom_jitter()

#' we can have less jitter in x, no jitter in y, more alpha transparency
ggplot(gapminder, aes(x = continent, y = lifeExp)) +
  geom_jitter(position = position_jitter(width = 0.1, height = 0), alpha = 1/4)

#' boxplots -- covered properly elsewhere
ggplot(gapminder, aes(x = continent, y = lifeExp)) + geom_boxplot()

#' raw data AND boxplots
ggplot(gapminder, aes(x = continent, y = lifeExp)) +
  geom_boxplot(outlier.colour = "hotpink") +
  geom_jitter(position = position_jitter(width = 0.1, height = 0), alpha = 1/4)

#' superpose a statistical summary
ggplot(gapminder, aes(x = continent, y = lifeExp)) +
  geom_jitter(position = position_jitter(width = 0.1), alpha = 1/4) +
  stat_summary(fun.y = median, colour = "red", geom = "point", size = 5)

#' let's reorder the continent factor based on lifeExp
ggplot(gapminder, aes(reorder(x = continent, lifeExp), y = lifeExp)) +
  geom_jitter(position = position_jitter(width = 0.1), alpha = 1/4) +
  stat_summary(fun.y = median, colour = "red", geom = "point", size = 5)

sessionInfo()


library(maptools)
library(rgeos)
library(rgdal)
library(ggplot2)
# library(ggmap)
library(plyr)
library(dplyr)
library(data.table)
library(stringr)
library(maps)
library(htmltab)
options(stringaAsFactors = F)

# Helper files ------------------------------------------------------------

## get congressional election results

# https://github.com/TimeMagazine/congressional-election-results/tree/master/data

time_results_base = 'https://github.com/TimeMagazine/congressional-election-results/blob/master/data/results_%s.csv'

## us and state map data
us_map = map_data('usa')
us_state_map = map_data('state')

## get fips codes
county_state_fips <- fread("http://www2.census.gov/geo/docs/reference/codes/files/national_county.txt",
                              header = F, colClasses = "character")
setnames(county_state_fips, names(county_state_fips),
         c("state_short", "STATEFP", "COUNTYFP", "county_desc", "fips_class_code"))

state_fips = select(county_state_fips, contains('state')) %>%
unique()

## get CD shapefile data
setwd('~/congressional_research/tl_2016_us_cd115')

cd_shapefiles <- readOGR(dsn = ".", layer = "tl_2016_us_cd115")
polygon_data <-
  cd_shapefiles@data %>%
  mutate(
    polygon_center_lon = INTPTLON %>% as.character() %>% as.numeric(),
    polygon_center_lat = INTPTLAT %>% as.character() %>% as.numeric()
    ) %>%
  data.table(key = "GEOID")

cd_shapefiles_df <-
  fortify(cd_shapefiles, region = "GEOID") %>%
  data.table(key = "id")

cd_shapefiles_with_names <-
  cd_shapefiles_df[polygon_data] %>%
  left_join(state_fips) %>%
  mutate(
    cd_number = str_extract(NAMELSAD, '[0-9]+') %>% as.numeric()
    )

cd_continental_us =
  cd_shapefiles_with_names %>%
  filter(
    state_short %in% state.abb[!state.abb %in% c('AK', 'HI')]
    )

## get insurance coverage by congressional district
setwd('~/congressional_research/social_economic_data/congressional_district')

# GEO.id  GEO.id2 GEO.display-label
# Id  Id2 Geography

# HC01_VC130
# Estimate; HEALTH INSURANCE COVERAGE - Civilian noninstitutionalized population

# HC01_VC133
# Estimate; HEALTH INSURANCE COVERAGE - Civilian noninstitutionalized population - With health insurance coverage - With public coverage

# HC01_VC134
# Estimate; HEALTH INSURANCE COVERAGE - Civilian noninstitutionalized population - No health insurance coverage

colname_mappings = read.csv('ACS_15_5YR_DP03_with_ann.csv', nrows = 1)
cd_selected_economic_characteristics = fread('ACS_15_5YR_DP03_with_ann.csv', skip = 2, header = F, colClasses = 'character')
names(cd_selected_economic_characteristics) = names(colname_mappings)

selected_econ_vars = select(cd_selected_economic_characteristics, contains('GEO'), contains('VC13'))
econ_varnames = names(selected_econ_vars)[str_detect(names(selected_econ_vars), 'VC')]

# convert to numeric
for (var in econ_varnames) {
  selected_econ_vars[[var]] = str_replace_all(selected_econ_vars[[var]], '[^0-9\\.]', '') %>%
  as.numeric()
}

# final cleanup
selected_econ_vars_upd =
selected_econ_vars %>%
mutate(
  percent_non_institutionalized_public_cov = HC01_VC133 / HC01_VC130,
  percent_non_institutionalized_no_insurance = HC01_VC134 / HC01_VC130,
  STATEFP = str_extract(GEO.id, 'US[0-9]{2}') %>% str_replace('US', ''),
  cd_number = str_extract(GEO.display.label, 'District [0-9]+') %>% str_extract('[0-9]+') %>% as.numeric()
  ) %>%
left_join(state_fips) %>%
arrange(-percent_non_institutionalized_public_cov) %>%
data.table(key = c('state_short', 'cd_number'))

## merge health stats and shapefiles
cd_continental_us = data.table(cd_continental_us, key = c('state_short', 'cd_number'))

dist_polygon_info = select(cd_continental_us, state_short, cd_number, polygon_center_lat, polygon_center_lon) %>%
unique()

cd_shape_health_dat =
  selected_econ_vars_upd[cd_continental_us]

## plot the districts
ca_health_coverage_map =
  ggplot(cd_shape_health_dat %>% filter(state_short == 'CA'), aes(long, lat, group = group)) +
    # geom_polygon(data = us_map) +
  geom_polygon(data = us_state_map %>% filter(region == 'california')) +
  geom_polygon(aes(fill = percent_non_institutionalized_public_cov * 100), colour = 'black') +
  geom_text(data = dist_polygon_info %>% filter(state_short == 'CA'), aes(polygon_center_lon, polygon_center_lat, label = cd_number, group = NA), colour = 'white', size = 2) +
  coord_quickmap() +
  scale_fill_continuous(name = '% with public health coverage') +
  theme(
    legend.position = 'bottom',
    axis.text = element_blank(),
    axis.ticks = element_blank()
    ) +
  labs(
    title = 'Mapping Health Coverage by Congressional District',
    subtitle = 'Percent of Civilian Non-Institutionalized Population With Public Health Coverage',
    caption = 'Source: 2015 ACS 5 Year Estimates',
    x = '', y = ''
    )

setwd('~')
ggsave('california_public_health_coverage_map_by_cd.png', plot = ca_health_coverage_map, height = 7, width = 6, units = 'in', dpi = 500)

ca_health_coverage_map =
  ggplot(cd_shape_health_dat %>% filter(state_short == 'CA'), aes(long, lat, group = group)) +
    # geom_polygon(data = us_map) +
  geom_polygon(data = us_state_map %>% filter(region == 'california')) +
  geom_polygon(aes(fill = percent_non_institutionalized_no_insurance * 100), colour = 'black') +
  geom_text(data = dist_polygon_info %>% filter(state_short == 'CA'), aes(polygon_center_lon, polygon_center_lat, label = cd_number, group = NA), colour = 'white', size = 2) +
  coord_quickmap() +
  scale_fill_continuous(name = '% with no health coverage') +
  theme(
    legend.position = 'bottom',
    axis.text = element_blank(),
    axis.ticks = element_blank()
    ) +
  labs(
    title = 'Mapping Health Coverage by Congressional District',
    subtitle = 'Percent of Civilian Non-Institutionalized Population Without Health Coverage',
    caption = 'Source: 2015 ACS 5 Year Estimates',
    x = '', y = ''
    )

setwd('~')
ggsave('california_no_health_coverage_map_by_cd.png', plot = ca_health_coverage_map, height = 7, width = 6, units = 'in', dpi = 500)


library(networktools)

## Speech acts in Dutch parliamentary proceedings by two parties (VVD and CDA) from 2003 till 2005 (samples of 100 proceedings per year)

load('demo/parliamentary_proceedings.rdata')

dim(document.topic.matrix) # A sparse matrix of documents X topics (in this case a sample of the results from a topic model (LDA) over 73300 speech acts, with 200 topics)
dim(meta) # meta data for the documents in document.topic.matrix.

g = similarity.graph(document.topic.matrix,
                             vertex.grouping.vars=list(party=meta$party,
                                                       year=format(meta$date, '%Y')),
                             similarity.measure='correlation')

list.vertex.attributes(g)
list.edge.attributes(g)

g = graph.color.vertices(g, V(g)$party) # color vertices by party
V(g)$label = as.character(V(g)$year) # use year as vertex label

graph.plot(g)
graph.plot(g, min.edge=0.1)

#tkplot(g) # for interactive editing of network

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

## Abstracts in 10 communication sciences journals from Web of Science, with 'social network' as a topic, from 2001 till 2009

load('demo/abstracts_socialnet.rdata')

dim(document.topic.matrix) # A sparse matrix of documents X topics (in this case a sample of the results from a topic model (LDA) over 848 abstracts, with 25 topics)
dim(meta) # meta data for the documents in document.topic.matrix.

g = similarity.graph(document.topic.matrix, vertex.grouping.vars=list(journal=meta$journal, period=meta$period), similarity.measure='correlation', min.similarity=0)

g = graph.color.vertices(g, V(g)$journal) # color vertices by journal
V(g)$size = V(g)$n*2 # use number of abstracts per node (year X journal)
V(g)$label = as.character(V(g)$journal) # use journal as vertex name
V(g)$label.cex = 0.5

graph.plot(g, min.edge=0.3, select.vertices=V(g)$period == '2001/2003')
graph.plot(g, min.edge=0.3, select.vertices=V(g)$period == '2004/2006')
graph.plot(g, min.edge=0.3, select.vertices=V(g)$period == '2007/2009')


library(ggvis)

# Histogram, fully specified
mtcars %>% ggvis(x = ~wt) %>%
  compute_bin(~wt, width = 1, pad = FALSE) %>%
  layer_rects(x = ~xmin_, x2 = ~xmax_, y = ~count_, y2 = 0)

# Or using shorthand layer
mtcars %>% ggvis(x = ~wt) %>% layer_histograms()
mtcars %>% ggvis(x = ~wt) %>% layer_histograms(width = 1)

# Histogram, filled by cyl
mtcars %>% ggvis(x = ~wt, fill = ~factor(cyl)) %>%
  group_by(cyl) %>%
  layer_histograms(width = 1)

# Bigger dataset
data(diamonds, package = "ggplot2")
diamonds %>% ggvis(x = ~table) %>% layer_histograms()

# Stacked histogram
diamonds %>% ggvis(x = ~table, fill = ~cut) %>%
  group_by(cut) %>%
  layer_histograms(width = 1)

# Histogram of dates
set.seed(2934)
dat <- data.frame(times = as.POSIXct("2013-07-01", tz = "GMT") + rnorm(200) * 60 * 60 * 24 * 7)
dat %>% ggvis(x = ~times) %>% layer_histograms()


dir <- "~/workspace/dyn-urg/files/results/time-series-dynamism-experiment/"

nonhomogTS <- read.table(paste(dir,"non-homog-poisson-dynamism.csv",sep=""), quote="\"",as.is=T,colClasses=list("numeric"))
homogTS <- read.table(paste(dir,"homog-poisson-dynamism.csv",sep=""), quote="\"",as.is=T,colClasses=list("numeric"))
normalTS <- read.table(paste(dir,"normal-dynamism.csv",sep=""), quote="\"",as.is=T,colClasses=list("numeric"))
uniformTS <- read.table(paste(dir,"uniform-dynamism.csv",sep=""), quote="\"",as.is=T,colClasses=list("numeric"))

nonhomogTS["type"] <- "non-homogeneous-Poisson"
homogTS["type"] <- "homogeneous-Poisson"
normalTS["type"] <- "normal"
uniformTS["type"] <- "uniform"

res <- merge(nonhomogTS,homogTS, all=T)
res <- merge(res,normalTS,all=T)
res <- merge(res,uniformTS,all=T)

df <- data.frame(res)

library(ggplot2)

p <- ggplot(df, aes(x=V1,fill=type)) + geom_histogram(binwidth=.01, alpha=.5, position="identity") + xlab("dynamism") + scale_x_continuous(breaks=seq(0, 1, 0.05)) + scale_fill_brewer(palette="Set1")
show(p)


# get all O->D trips
od <- read.csv('/home/nate/scarbs_transit/trips/all_O->D.csv')
# convert some columns to factor
cols <- c('o','d','route_id','service_id','trip_id','h1','h2')
od[,cols] <- lapply(od[,cols],factor)
# identify and remove service days with wierd levels of service
# we should only have weekdays in this dataset
# get a frequency table of service_ids
freq = table(od$service_id)
# identify those further than 2 standard deviations from the mean trip count
wierd_days = as.numeric(
	row.names(
		freq[ freq < mean(freq) - 1.5*sd(freq)]
	)
)
# plot the frequency table
#plot(freq)
#abline(h=mean(freq) - 1.5*sd(freq))
wierd_trips = od[ od$service_id %in% wierd_days, ]
od = od[ ! od$service_id %in% wierd_days, ]
# travel time in minutes
od$travel_time = (od$d_etime - od$o_etime) / 60
# identify the peaks
od$ToD <- factor(
	ifelse(
		od$h1 %in% c(7,8,9),
		'morning',
		ifelse(
			od$h1 %in% c(12+4,12+5,12+6),
			'evening',
			'other'
		)
	)
)

# import sample times
sample_times <- read.csv('/home/nate/scarbs_transit/trips/sample-times.csv',stringsAsFactors=F)
sample_times$h = factor(sample_times$h)
sample_times$service_id = factor(sample_times$service_id)
# identify the peaks
sample_times$ToD <- factor(
	ifelse(
		sample_times$h %in% c(7,8,9),
		'morning',
		ifelse(
			sample_times$h %in% c(12+4,12+5,12+6),
			'evening',
			'other'
		)
	)
)
# subset to the peaks
sample_times = sample_times[sample_times$ToD %in% c('morning','evening'),]


################################################################
## maps for README                                            ##
## script may require running parts of export-seccion-stats.r ##
################################################################

cuts <- seq(0,50,5)
edon <- 2; edo <- "bc"

i <- 100
one.se <- subset(se.map, se.map@data$seccion==ses[i])

# state lum
pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
r <- raster(pth) # filenames 1992-2013
# projects to a different datum with long and lat
r <- projectRaster(r, crs=osm()) # project to osm native Mercator
# clip raster to state
r <- mask(r, ed.map)         # approximate poligon only
r[is.na(r)] <- 0 # make NAs zeroes
## # verify
png(file = "../pics/bc.png")
par(mar=c(.5,.5,2,1)) ## SETS B L U R MARGIN SIZES
plot(r, axes = FALSE, main = edo)
plot(ed.map, add = TRUE, lwd = .2)
plot(one.se, add = TRUE, lwd = .5, col = "red")
#plot(se.map, add = TRUE, lwd = .1)
dev.off()

# plot crop
        #plot(one.se, main=paste("sección", ses[i]))
        # clip raster to seccion
        r.se <- crop(r, extent(one.se)) # crop to plot area
        ## # verify
        png(file = "../pics/bc-100-crop.png")
        par(mar=c(.5,.5,2,4)) ## SETS B L U R MARGIN SIZES
        plot(one.se, main=paste("sección", ses[i], "(Mexicali)"))
        #plot(r.se, breaks=cuts, col = topo.colors(5), add = TRUE)
        plot(r.se, breaks=cuts, col = topo.colors(10), add = TRUE)
        plot(one.se, add = TRUE, lwd = 1)
        dev.off()

# plot mask
        # clip raster to seccion
        r.se <- crop(r, extent(one.se)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.se <- mask(r.se, one.se)         # approximate poligon
        #
        v <- unlist(extract(r, one.se)) # get values inside poligon
        tmp.mean   <- round(mean  (v),2)
        tmp.sd     <- round(sd    (v),2)
        tmp.median <- round(median(v),2)
        ## # verify
        png(file = "../pics/bc-100-mask.png")
        par(mar=c(.5,.5,2.5,4)) ## SETS B L U R MARGIN SIZES
        plot(one.se, main=paste("sección", ses[i], "\nmedian =", tmp.median, "mean=", tmp.mean, "sd =", tmp.sd))
        plot(r.se, breaks=cuts, col = topo.colors(10), add = TRUE)
        plot(one.se, add = TRUE, lwd = .5)
        dev.off()

# plot 1994-2018
png(file = "../pics/bc-100-mask-1994-2018.png")
par(mfrow=c(5,5))
for (i in 1994:2018){
    yr <- i
    pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
    r <- raster(pth) # filenames 1992-2013
    # projects to a different datum with long and lat
    r <- projectRaster(r, crs=osm()) # project to osm native Mercator
    # clip raster to state
    r <- mask(r, ed.map)         # approximate poligon only
    r[is.na(r)] <- 0 # make NAs zeroes
        # clip raster to seccion
        r.se <- crop(r, extent(one.se)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.se <- mask(r.se, one.se)         # approximate poligon
        #
        v <- unlist(extract(r, one.se)) # get values inside poligon
        tmp.mean   <- round(mean  (v),1)
        tmp.sd     <- round(sd    (v),1)
        tmp.median <- round(median(v),1)
        ## # verify
        par(mar=c(.5,.5,2.5,4)) ## SETS B L U R MARGIN SIZES
#        plot(one.se, main=paste(yr, "\nmedian =", tmp.median, "mean=", tmp.mean, "sd =", tmp.sd))
        plot(one.se, main=paste(yr, "\nmean=", tmp.mean))
        plot(r.se, breaks=cuts, col = topo.colors(10), add = TRUE)
        plot(one.se, add = TRUE, lwd = .5)
}
dev.off()

citation("raster")


#necessary library
library(data.table) #fread
library(lubridate)
library(reshape2)
library(dplyr)
library(scales)
library(stringr)
library(tidyr) # spread function

#memory.limit(size=900000) #Windows-specific #JO

YEARLIST =("19")
MONTHLIST = c("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
DISTANCE_FILEPATH = "../../data/tidy/vehicle-trajectory-computation/"
COMPUTATION_FILEPATH = "../../data/tidy/"

NUM_SAMPLE_DAYS = 10
NUM_SPEED_BINS = 6
NUM_ACCEL_BINS = 6

# aggregrate_trajectory_table
sample_day_trajectories = function(year, month, num_sample_days, seed_val){
    assign("dg",fread(paste0(DISTANCE_FILEPATH, paste(paste("green", "trajectory", year, month, sep = "-", collapse = ""), ".csv", sep=""))))
    assign("dh",fread(paste0(DISTANCE_FILEPATH, paste(paste("heavy", "trajectory", year, month, sep = "-", collapse = ""), ".csv", sep=""))))
    dg$lineid = 4
    dg = subset(dg, select = c(trxtime, year, month, day, lineid, lat, lon , speed_kph , accel_mps2 , interval_seconds , dist_meters , vehicleid))
    dh = subset(dh, select = c(trxtime, year, month, day, lineid, lat, lon , speed_kph , accel_mps2 , interval_seconds , dist_meters , vehicleid))
    # dg = dg[, c(trxtime, year, month, day, lineid, lat, lon , speed_kph , accel_mps2 , interval_seconds , dist_meters , vehicleid)]
    # dh = dh[, c(trxtime, year, month, day, lineid, lat, lon , speed_kph , accel_mps2 , interval_seconds , dist_meters , vehicleid)]
    DT = rbind(dg, dh)
    if (any(list("04", "06", "09", "11") %like% month)) { #for efficiency filter for months with 30 days
        num_days = 30
    } else if (month == "02") { # february
        num_days = 28
    } else {
        num_days = 31
    }
    DT <- DT[, day:=as.integer(day)]
    set.seed(seed_val)
    day_subset = sample(seq(num_days), num_sample_days)
    setkey(DT, day)
    DT = DT[day %in% day_subset]
    print(paste("Year:", year, "; Month:", month, "; Days sampled:"))
    print(unique(DT$day))
    remove(dg)
    remove(dh)
    return(DT)
}

# Unit conversion
convert_units = function(df){
    df$hour = hour(df$trxtime)
    df$speed_mph = df$speed_kph*0.621371 #kph to mph
    df$distance_mile = df$dist_meters*0.000621371 #convert from meters to mile
    df$time_hr = df$interval_seconds/3600.0 #convert from seconds to hour
    return(df)
}

# Calculate the speed bins
get_speed_cutpoints <- function (DT, num_bins, test = FALSE) {
    print("Computing speed cutpoints")
    probabilities = seq(0, 1, 1/num_bins)
    cutpoints <- quantile(DT$speed_mph, probabilities, na.rm=TRUE)
    df <- data.frame(cutpoints)
    print("Done")
    return(df)
}

# Calculate the acceleration quantiles
get_acceleration_cutpoints <- function (DT, num_bins, test = FALSE) {
    print("Computing acceleration cutpoints")
    probabilities = seq(0, 1, 1/num_bins)
    cutpoints <- quantile(DT$accel_mps2, probabilities, na.rm=TRUE) #read in the list from a saved file of cutpoints
    df <- data.frame(cutpoints)
    print("Done")
    return(df)
}

main <- function (num_speed_bins, num_accel_bins, num_days_to_sample, year_list, month_list, line_number) {
    DT = data.table()
    SEEDLIST = c(111, 222, 333, 444, 555, 666, 777, 888, 999, 101010, 111111, 121212) #different seed for each month
    seed_counter = 1
    for (y in year_list) {
        for (m in month_list) {
            interval_DT = sample_day_trajectories(y, m, num_days_to_sample, SEEDLIST[seed_counter])
            DT = rbindlist( list(DT, interval_DT) ) # obtain sampled df from all observations
            ##DT = DT(DT$lineid==line_number) - jimi/ Zhuo - complete
            seed_counter = seed_counter + 1
            remove(interval_DT)
        }
    }
    DT = convert_units(DT)
    speed_cutpoints = get_speed_cutpoints(DT, num_speed_bins)
    acceleration_cutpoints = get_acceleration_cutpoints(DT, num_accel_bins)
    ## ZHUO - update file names
    write.csv(speed_cutpoints, file.path(paste0(COMPUTATION_FILEPATH, paste0(paste("speed", y, "cutpoints", "bins" , num_speed_bins, sep = "-", collapse = ""), ".csv"))))
    write.csv(acceleration_cutpoints, file.path(paste0(COMPUTATION_FILEPATH, paste0(paste("acceleration", y, "cutpoints", "bins" , num_accel_bins, sep = "-", collapse = ""), ".csv"))))
    remove(DT)
}

for (LINE_NUMBER in c(1,2,3,4)) {
    main(NUM_SPEED_BINS, NUM_ACCEL_BINS, NUM_SAMPLE_DAYS, YEARLIST, MONTHLIST, LINE_NUMBER)
}


################################################################################
# Compare changes in particle size distributions over time between two
# two reactors, using data taken from image analysis as desribed in
# the paper "Measuring the shape and size of activated sludge particles
# immobilized in  agar with an open source software pipeline" submitted to
# [JOVE](https://www.jove.com/).
#
# Joseph E. Weaver
# jeweave4@ncsu.edu
# joe.e.weaver@gmail.com
# NC State University
#
################################################################################

# Include packages --------------------------------------------------------
library("here")      # portably manage directory locations relative to .Rproj
library("readr")     # For reading CSV files generated by SParMorIA
library("dplyr")     # For sensible management dataframes
library("tidyr")     # Bring in the entire tidyverse
library("purrr")     # Adds some functional programming
library("stringr")   # Text manipulation
library("lubridate") # datestring to date object conversion and manipulation
library("ggplot2")   # grammar of graphcs, greatly improves figure generation
library("Cairo")     # Antialiased graphics, particularly usefuon on windows

# Read in particle data from multiple csvs --------------------------------

# Use the here package to specify the location of the data directory
data_dir = here::here("data","two_reactor_time_series")

# Get a list of all CSV files in data dir
files <- dir(data_dir, pattern = "*.csv")

# Read each CSV file and combine all the particle data into one dataframe
# Inspired by the code listed at:
# http://serialmentor.com/blog/2016/6/13/reading-and-combining-many-tidy-data-files-in-R
data <- data_frame(filename = files) %>%
   mutate(file_contents = map(filename,
                              ~ read_csv(file.path(data_dir, .)))
   )
data <- unnest(data)

# Append metadata ---------------------------------------------------------

# There is probably experimental metadata we would like to incorporate. For
# example, things sampling date, the reactor from which the sample came, or
# even annotations like 'cloudy effluent'.
#
# There are two good ways to deal with this, including the metadata in
# the filename itself or by including it in a separate file.
#
# In the case of base metadata, like dates and reactor names, I prefer to
# store the information direclty in the filename.  These can be split out
# and added as new columns to our data frame.

# First, let's get the reactor number
data$reactor <-  stringr::str_match(data$filename, "reactor-(\\d+)_")[,2]

# Now, get the date and  convert it to a more useful format
data$sampleDate <- ymd_hm(stringr::str_match(
                          data$filename, "date-([\\d|-]+)_")[,2])

# In the case of external metadata, we can record observations in an external
# file, read it into a dataframe, then merge the result with our existing
# data.  For example, let's say that reactor 1 was 'yeasty' on 2017-12-19
# and reactor 2 was 'vinegary' on 2017-12-08.
#
# We could record that data in a csv (viewable in data/observations.csv)
# and then read and merge, like so:

# read and prepare metadata
# note, we're specifying 'reactor' should be read a string
# this matches the format of the reactor name in 'data'
smells <- read_csv(here::here("data", "observations.csv"),
                   col_types = cols(reactor = "c"))
smells$sampleDate <- ymd_hm(smells$date) # makes it easier to merge by date

# merge with existing data
data <- left_join(data,smells, by = c("sampleDate", "reactor"))

# Data processing ---------------------------------------------------------
#
# Often we will want to further process the data before plotting it.
# For example, we may want to plot particles by the log of their
# equivalent diameter, rather than as total area.

data$eqd_um <- sqrt(data$Area * 1e8 / 2) / pi
data$log_eqd_um <- log10(data$eqd_um)

# Let's also turn dates into experiment days

start_date <- ymd_hm("2017-12-08-1200")
data$Day <- round(as.duration(interval(
                  start_date, data$sampleDate)) / ddays(1))

# Figure generation ------------------

# While data importing, metadata attachment, and (to some extent) data
# processing will be similar between experiments, there is almost an infinite
# variety of figures which can be generated.  Here, we generate a simple
# violin plot to give an example of how the dataframe we've generated can
# be used in conjunction with the ggplot2 package.

# some defaults often used to improve base ggplot2
theme_classic()
theme_update(panel.background = element_blank(),
             legend.position = "none",
             axis.line.x = element_line(color = "black", size = 1),
             axis.line.y = element_line(color = "black", size = 1),
             axis.ticks.x = element_line(color = "black", size = 1),
             axis.ticks.y = element_line(color = "black", size = 1),
             text=element_text(size = 12),
             axis.text=element_text(size=12,color = "black"),
             strip.text=element_text(size = 12))

# Create a series of violin plots of the particles in each reactor
# and show how they change over time

smelly <- group_by(data, reactor, Day) %>%
   summarise(lab = unique(smell), max_val = max(log_eqd_um))

p <- ggplot(data, aes(reactor, log_eqd_um,group = reactor, fill = reactor)) +
  geom_violin() +
  facet_grid(. ~ Day, labeller = label_both) +
  geom_text(data = smelly, aes(y = max_val*1.15, label = lab), angle = 90) +
  xlab("Reactor") + ylab("log Diameter (μm)")

# View the plot on local device
# Note that on screen devices, line thicknesses and text sizes which are
# appropriate for output to vector and high dpi graphics may look comically
# large

# CairoWin()
# p

# Save as an SVG
CairoSVG(file = here::here("output", "two_reactor_time_series.svg"),
         width = 7, height = 3, onefile = TRUE, bg = "white",
         family = c("Calibri", "Helvitica", "sans"), pointsize = 12)
p
dev.off()

# Save as PDF
# wil have warnings about 'encoding' and 'pagecentre' options. These are
# ignored by CairoPDF.
CairoPDF(file = here::here("output", "two_reactor_time_series.pdf"),
         width = 7, height = 3, onefile = TRUE, bg = "white",
         family = c("Calibri", "Helvitica", "sans"), pointsize = 12)
p
dev.off()

# Save our session info ------------------

sink(here::here("output", "two_reactor_time_series.R.sessionInfo.txt"))
sessionInfo()
sink()


library(ComplexHeatmap)
library(circlize)
library(cluster)
library(svglite)

setwd('D:/1998c/Documents/Research/202002scRNA/package_release/scETM/scripts/heatmap_fig/AD')

# user defined set of topics

mat <- read.table('beta_top10genes_selected_topics.csv', row.names = 1,sep=',',check.names = F,
                  header = TRUE, stringsAsFactors = FALSE)
mat <- t(mat)

colorscheme=colorRamp2(c(min(mat),0,max(mat)), c( "blue","white", "red"))

hmap <- Heatmap(
  mat,
  col=colorscheme,
  name='Topic Intensity',
  column_dend_side = "bottom",
  show_row_names = TRUE,
  show_column_names = TRUE,
  cluster_rows = FALSE,
  cluster_columns = FALSE,
  column_names_gp = gpar(fontsize = 6),
  row_names_gp = gpar(fontsize = 7),
  rect_gp = gpar(col = "grey", lwd = 0.1))

pdf(file = "panel_a_beta.pdf",width=10,height=2.5)
draw(hmap, heatmap_legend_side="left", annotation_legend_side="right")
dev.off()

svglite("panel_a_beta.svg",width=8,height=3)
draw(hmap, heatmap_legend_side="left", annotation_legend_side="right")
dev.off()


# examine temperature profiles for Had EN4 data

##################
# Functions
##################
require(ncdf4)
require(data.table)

# round a single value (x) to nearest value in a vector (y)
roundto <- function(x, y){
	a <- abs(x - y)
	i <- which(a==min(a)) # can return 1 or 2 matches
	return(y[i])
}

###############
# Read in data
###############

dat <- fread('temp/warmingtolerance_byspecies.csv')

# trim to marine species
	nrow(dat)
dat <- dat[Realm=='Marine' & demers_pelag=='demersal', .(Genus, Species, demers_pelag, mobility, big, lat, lon)]
	nrow(dat) # 82

# adjust lon to 0-360
dat[,lon360 := lon]
dat[lon<0, lon360 := lon + 360]

# read in temperature profile files
fls <- list.files(path='data_dl/haden4', pattern='.nc', recursive=TRUE, full.names=TRUE)
	length(fls)

nc <- nc_open(grep('198608', fls, value=TRUE)) # August

prof <- ncvar_get(nc, 'temperature')
	dim(prof)
dimnames(prof) <- list(lon=ncvar_get(nc, 'lon'), lat=ncvar_get(nc, 'lat'), depth=ncvar_get(nc, 'depth'))

nc_close(nc)

##############
# Analysis
##############

# plot temperature profiles for locations where species were collected

plot(0, 0, xlab='temperature (°C)', ylab='depth (m)', ylim=c(100,0), xlim=c(-2,32), type='n')
for(i in 1:nrow(dat)){
	lines(prof[dat[i,as.character(round(lon360))], dat[i,as.character(round(lat))], ]-273.15, as.numeric(dimnames(prof)$depth))
}


load("~/Downloads/tmpdata")
rawdb <- rawdb[rawdb$a!=4,]

library(Rcpp)
source("R/TFR.r")
sourceCpp("src/TFR.cpp")

res <- TF(rawdb,"ss",beta  = 1,alpha1 = 1,burnin = 500,maxit = 5000,sample_step = 50)

xxx <- plyr::ddply(rawdb,"e",function(d){
    tmp <- table(d$a)
    d$mj <- as.integer(names(tmp)[which.max(tmp)])
    return(d)
},.progress = "text")

table(unique(xxx[,c("e","mj")])$mj)
res$pi

head(res$s_aa_n_claims,30)

xxx2 <- res$rawdb_original

xxx2 <- xxx2[order(xxx2$e),]
xxx <- xxx[order(xxx$e),]
tmp <- data.frame(t=xxx2$e_truth,m=xxx$mj)

## precision
tmp2 <- plyr::ddply(res$s_aa_n_claims,"s",function(d){
    data.frame(s=d$s[1],rate=sum(d$count[d$a_truth==d$a]) / sum(d$count),cnt=sum(d$count))
})

tmp2 <- tmp2[order(tmp2$cnt),]

plot(tmp2$cnt,tmp2$rate,type = "l")

table(res$rawdb_original$e_truth[res$rawdb_original$e_truth_prob<0.9])/length(res$rawdb_original$e_truth[res$rawdb_original$e_truth_prob<0.9])

table(res$rawdb_original$e_truth[res$rawdb_original$e_truth_prob>=0.9])/length(res$rawdb_original$e_truth[res$rawdb_original$e_truth_prob>=0.9])

93.7
97.5
75.0
78.0


library(rgdal)
library(alphahull)
library(igraph)
library(shapefiles)
filepath = "/Users/clintnewsom/projects/NYPL/map-vectorizer/test/"
layer = "test-traced"
myPolygons  = readOGR(filepath,layer=layer)
ogrInfo(filepath,layer)
plot(myPolygons)


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("datasets")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(datasets) # This package is specifically loaded for iris dataset shipped within it.

# Here we directly load the iris dataset installed with the "datasets" package.
data(iris)

# Replacing column names in iris dataset from datasets package
irisOriginal <- setNames(iris, c("Sepal_Length","Sepal_Width","Petal_Length","Petal_Width","Species"))

# Omit rows with missing values
irisOriginal <- na.omit(irisOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# iris<- read.csv("Iris.csv")

# Randomizing data
iris <-irisOriginal[sample(nrow(irisOriginal)),]

# Divide dataset for training and test
trainData <- iris[1:120, ]
testData  <- iris[121:150, ]

# Set predicted field in formula
formula = formula(Species ~ .)

# Create model for training set using naiveBayes
irisTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "Species" column for test data set
irisTestPrediction <- predict(irisTrainingModel, testData)
# Display predicted values
irisTestPrediction

# Create cross table to check on accuracy.
CrossTable(irisTestPrediction, testData$Species,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# PMML generation
saveXML(pmml(irisTrainingModel, predictedField = "Species"), "Iris.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original iris data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(irisTrainingModel, newdata = irisOriginal, threshold = 0, type = "class")
probabilities = predict(irisTrainingModel, newdata = irisOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file)
{
	result = NULL
	if(is.null(probabilities))
	{
		result = data.frame(classes)
		names(result) = c("Species")
	}
	else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("Predicted_Species", "SetosaSpeciesProbability", "VersicolorSpeciesProbability","VirginicaSpeciesProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")


library(devtools)
devtools::load_all()
library(parallel)
RNGkind("L'Ecuyer-CMRG")

s_seed <- 999983
s_k <- 5000
s_n <- 100
s_m <- 5

v_seed <- c(s_seed, s_seed + s_k)

sim_type1_1005 <- mclapply(v_seed, seed_loop <- function(seed) {
    type_1(seed, s_k / 2, s_n, s_m, L = 1000,
                fast.tn = T, semi.iter = F, center.bs = F)
}, mc.cores = 2)

save(sim_type1_1005, file = "sim_type1_1005.RData")


pal <- c("black", "red", "green", "blue", "magenta", "cyan", "yellow", "white")
par(mar = rep(0, 4))
image(matrix(1:8), col = pal, axes = FALSE)


# test_genMCMC_ANOVA.r

library(JerimalaiStoneArtefacts)
context("genMCMC_ANOVA")

test_that("genMCMC_ANOVA works", {

  library(JerimalaiStoneArtefacts)
  library(coda)

  # from Jags-Ymet-Xnom1fac-MnormalHom-Example.R

  myDataFrame = read.csv( file="data_for_tests/FruitflyDataReduced.csv" )
  # Specify the column names in the data file relevant to the analysis:
  yName="Longevity"
  xName="CompanionNumber"
  # Specify desired contrasts.
  # Each main-effect contrast is a list of 2 vectors of level names,
  # a comparison value (typically 0.0), and a ROPE (which could be NULL):
  contrasts = list(
    list( c("Pregnant1","Pregnant8") , c("None0") , compVal=0.0 , ROPE=c(-1.5,1.5) ) ,
    list( c("Pregnant1","Pregnant8","None0") , c("Virgin1","Virgin8") ,
          compVal=0.0 , ROPE=c(-1.5,1.5) ) ,
    list( c("Pregnant1","Pregnant8","None0") , c("Virgin1") ,
          compVal=0.0 , ROPE=c(-1.5,1.5) ) ,
    list( c("Virgin1") , c("Virgin8") , compVal=0.0 , ROPE=c(-1.5,1.5) )
  )
  # Specify filename root and graphical format for saving output.
  # Otherwise specify as NULL or leave saveName and saveType arguments
  # out of function calls.
  fileNameRoot = "FruitflyData-NormalHom-"
  graphFileType = "eps"

  #---------------------------------------------------------
  # Generate the MCMC chain:
  mcmcCoda_ANOVA = genMCMC_ANOVA(datFrm=myDataFrame , yName=yName , xName=xName ,
                      numSavedSteps=11000 , thinSteps=10 , saveName=fileNameRoot )
  #---------------------------------------------------------
#   # Display diagnostics of chain, for specified parameters:
#   parameterNames = varnames(mcmcCoda)
#   show( parameterNames ) # show all parameter names, for reference
#   for ( parName in c("ySigma","b0","b[1]","aSigma") ) {
#     diagMCMC( codaObject=mcmcCoda , parName=parName ,
#               saveName=fileNameRoot , saveType=graphFileType )
#   }
#   #---------------------------------------------------------
  # Get summary statistics of chain:
  summaryInfo_ANOVA = smryMCMC_ANOVA( mcmcCoda_ANOVA ,
                          datFrm=myDataFrame , xName=xName ,
                          contrasts=contrasts ,
                          saveName=fileNameRoot )

  # Display posterior information:
#   plotMCMC( mcmcCoda ,
#             datFrm=myDataFrame , yName=yName , xName=xName ,
#             contrasts=contrasts ,
#             saveName=fileNameRoot , saveType=graphFileType )
  #----------------------------------------------------------

  # clean up by removing files...
  do.call(file.remove,list(list.files(pattern = fileNameRoot)))
  file.remove("model.txt")

  # simply check that the output has the right number of rows and cols
  expect_equal(dim(summaryInfo_ANOVA), c(17,14))

})


# File: utils.r
# Description:
#    Functions to read and process QPE data: radar and station precipitation tag

# Read in radar data: fixed width format
read.radar <- function(f){
  tmp <- read.fwf(fname, c(8,8,8), header=F, col.names=c("lat","lon","dbz"))
  return(tmp)
}

# Plot radar data with ggmap: remove all 0s and interpolate on the map
plot.radar <- function(dbz){
  require(ggmap)
  map <- get_map(location='Taiwan', zoom=7)
  dbz <- dbz[which(dbz$dbz>0),]
  g <- ggmap(map) + stat_density2d(aes(x=lon, y=lat, fill=..level.., alpha=..level..),
                                   size=2, bins=4, data=dbz, geom="polygon")
  g
  return(g)
}

# Read in quantitative precipitations of CWB stations in Taipei area
# - return:
#   - dataframe of
#     - date: strings represent YYYYMMDDHH
#     - tXhr: accumulative precipitation in X hours (HH-1 ~ HH+X-1)
read.tpeqp <- function(fname, filter.year=NULL){
  # Read file
  tmp <- read.csv(fname, stringsAsFactors=F, na.strings=c("NA","-999", " "), fileEncoding="BIG-5")
  # Select columns
  tmp <- tmp[,c(3,4,9,14,19,24,29,34,39)]
  names(tmp) <- c("date","t1hr","t3hr","t6hr","t12hr","t24hr","t48hr","t72hr","t120hr")
  #
  tmp$date <- as.character(tmp$date)
  if(!is.null(filter.year)){
    tmp <- tmp[which(substr(tmp$date,1,4)==filter.year),]
  }
  row.names(tmp) <- NULL
  return(tmp)
}

# Aggregate output data object: a list of dataframes, named by the station
create.output <- function(datadir, filter.year=NULL){
  # Get all stations
  flist <- list.files(datadir)
  # Loop through all stations
  outputs <- NULL
  onames <- NULL
  for(f in flist){
    fname <- paste(datadir,f,sep="/")
    print(paste("Processing file:",fname))
    tmp <- read.tpeqp(fname, filter.year=filter.year)
    print(dim(tmp))
    if(nrow(tmp) %in% c(365*24, 366*24) ){
      outputs <- c(outputs, list(tmp))
      onames <- c(onames, f)
    } else {
      print(paste("Number of records incorrect:", nrow(tmp)))
    }
  }
  names(outputs) <- substr(onames,1,6)
  return(outputs)
}

#
dbz.flist <- function(srcdir){
  output <- NULL
  # Get all days
  daylist <- list.files(srcdir)
  # Loop through days
  for(d in daylist){
    ddir <- paste0(srcdir,d,"/")
    print(ddir)
    fltmp <- list.files(ddir)
    ftab <- data.frame(do.call(rbind, lapply(fltmp, function(x){unlist(strsplit(x,'.', fixed=T))})))
    tmp <- cbind("day"=rep(d, length(fltmp)), "fname"=fltmp, ftab)
    output <- rbind(output, tmp)
  }
  return(output)
}

# Read in preprocessed DBZ data:
read.dbzpcs <- function(fname, npc=20){
  tmp <- read.csv("dbz.ipca50.csv", stringsAsFactors = F, header=F, colClasses = c("character","character",rep("numeric", npc)))
  names(tmp) <- c("date","hhmm",paste("pc", 1:npc, sep="_"))
  return(tmp[,1:(npc+2)])
}

# Create input data for QPE:
# - Use given Y(precipitation) and it's time stamp(YYYYMMDDHH)
# - For the same YYYYMMDD, each HH of precipitation is corresponding to:
#   - 6 HHMM of DBZ data records (with 10min interval)
#   - HH-60min, HH-50min, HH-40min, HH-30min, HH-20min, and HH-10min
#   - impute NA for missing DBZ records
create.input.qpe <- function(y, x, filter.year=NULL){
  # Table for hour-minute correspondence
  hhlist <- c("00","01","02","03","04","05","06","07","08","09","10","11",
              "12","13","14","15","16","17","18","19","20","21","22","23")
  mmlist <- c("00","10","20","30","40","50")
  hhmm <- NULL
  for(h in hhlist){hhmm <- c(hhmm, paste0(h, mmlist))}
  hhmm <- matrix(hhmm, ncol=6, byrow=T)
  # Target hour
  thh <- c("01","02","03","04","05","06","07","08","09","10","11","12",
           "13","14","15","16","17","18","19","20","21","22","23","24")
  # target day-hour
  ydays <- sort(unique(substr(y$date,1,8)))
  newx <- NULL
  for(i in 1:nrow(y)){
    # Process date-hour string
    ydh <- y$date[i]                # YYYYMMDDHH string
    yday <- substr(ydh,1,8)         # YYYYMMDD
    yhh <- substr(ydh,9,10)         # HH
    idx.day <- which(ydays==yday)   # Index of YYYYMMDD
    idx.h <- which(thh==yhh)        # Index of HH
    # Find corresponding X
    ridx.x <- which((x[,1]==yday) & (x[,2] %in% hhmm[idx.h,]))
    # Concatenate all x as the new x
    print(ydh)
    #print(length(ridx.x))
    #print(x[ridx.x, 1:2])
    if(length(ridx.x)==6){
      rec <- as.vector(t(x[ridx.x, -(1:2)]))
      #print(length(rec))
    } else {
      print("missing data")
      rec <- rep(NA, 6*(ncol(x)-2))
    }
    newx <- rbind(newx, rec)
  }
  # Create colnames
  newx <- data.frame(newx)
  pcn <- names(x)[-(1:2)]
  ts <- paste0("m", seq(60,10,-10))
  names(newx) <- apply(expand.grid(pcn, ts), 1, paste, collapse="_")
  #
  return(cbind(y,newx))
}

# Run a loop to test QPF
test.qpf <- function(y, x, rseed=12345){
  # Number of tests of prediction
  ntest <- ncol(y) - 1
  ynames <- names(y)
  # Loop through
  results <- NULL
  for(i in 1:ntest){
    print(paste("Evaluating QPF:", ynames[i+1]))
    # Combine input/output data
    iodata <- cbind("y"=y[,i+1], x)
    row.names(iodata) <- y$date
    # Shift y for forecast
    iodata$y <- c(iodata$y[2:nrow(iodata)], NA)
    iodata <- iodata[complete.cases(iodata),]
    print(paste("    Number of valid records:", nrow(iodata)))
    # Setup train-control
    print("    Creating folds for cross validation...")
    set.seed(rseed)
    cvOut <- createFolds(iodata$y, k=10)
    cvIn <- cvOut
    for(i in 1:10){
      cvIn[[i]] <- (1:length(iodata$y))[-cvOut[[i]]]
    }
    trctrl <- trainControl("cv", index=cvIn, indexOut=cvOut, savePred=T)
    # Fit model
    print("    Training and cross validating...")
    fit.glm <- train(log(y+1)~., data=na.omit(iodata), method="glm", preProcess="scale", trControl=trctrl)
    rec <- fit.glm$results
    yhat <- fit.glm$finalModel$fitted.values
    rec$RMSE.insample <- RMSE(exp(yhat)-1, iodata$y)
    rec$CORR.log <- cor(yhat, log(iodata$y+1))
    rec$CORR.mm <- cor(exp(yhat)-1, iodata$y)
    results <- rbind(results, rec)
  }
  results <- cbind("test"=ynames[-1], data.frame(results))
  return(results)
}

generateCM <- function(pred, ref){
  return(table(pred, ref))
}

cmToMetrics <- function(cm, positive=1){
  # Decode the matrix
  if(positive==0){
    TP <- cm[1,1]/sum(cm)
    TN <- cm[2,2]/sum(cm)
    FP <- cm[1,2]/sum(cm)
    FN <- cm[2,1]/sum(cm)
  } else {
    TP <- cm[2,2]/sum(cm)
    TN <- cm[1,1]/sum(cm)
    FP <- cm[2,1]/sum(cm)
    FN <- cm[1,2]/sum(cm)
  }
  # Derive Metrics
  sensitivity <- TP/(TP+FN)
  specificity <- TN/(FP+TN)
  prevalence <- TP+FN/(FN+TP+FP+TN)
  ppv <- TP/(TP+FP)
  npv <- TN/(TN+FN)
  fpr <- FP/(FP+TN)
  fnr <- FN/(FN+TP)
  fdr <- FP/(FP+TP)
  FOR <- FN/(TN+FN)
  accuracy <- (TP+TN)/(FN+TP+FP+TN)
  F1 <- 2*TP/(2*TP+FP+FN)
  MCC <- (TP*TN-FP*FN)/sqrt((TP+FP)*(TP+FN)*(TN+FP)*(TN+FN))
  informedness <- sensitivity + specificity - 1
  markedness <- ppv + npv -1
  # Output
  output <- c("Accuracy"=accuracy,
              "True.Positive"=TP,
              "False.Negative"=FN,
              "False.Positive"=FP,
              "True.Negative"=TN,
              "Sensitivity"=sensitivity,
              "Specificity"=specificity,
              "Prevalence"=prevalence,
              "Positive.Predictive.Value"=ppv,
              "Negative.Predictive.Value"=npv,
              "False.Positive.Rate"=fpr,
              "False.Discovery.Rate"=fdr,
              "False.Negative.Rate"=fnr,
              "False.Omission.Rate"=FOR,
              "F1.Score"=F1,
              "Matthews.correlation.coefficient"=MCC,
              "Informedness"=informedness,
              "Markedness"=markedness)
  return(output)
}

# 2-step QPE
qpe.2step <- function(iodata, threshold=1){
  # Extract y and
  y <- iodata$y
  ybin <- (y>=threshold)*1
  #
  trctrl <- trainControl(method="cv", number=10, savePred=T)
  # Step 1: binary classification for y>=threshold
  fit.bin <- train(factor(y>=threshold)~., data=iodata, method="svmPoly", preProcess="scale", trControl=trctrl)
  # Step 2: regression model trained with y>=threshold
  fit.reg <- train(y~., data=iodata[which(iodata$y>=threshold),], method="svmPoly", preProcess="scale", trControl=trctrl)
  # Evaluation
  yhat.bin <- predict(fit.bin, newdata=iodata[,-1])
  yhat.bin <- as.numeric(yhat.bin)-1
  yhat.reg <- predict(fit.reg, newdata=iodata[,-1])
  yhat <- yhat.bin*yhat.reg
  rmse <- RMSE(iodata$y, yhat)
  r2 <- cor(iodata$y, yhat)
  print(paste("RMSE:", rmse, "    Rsquared:", r2))
  return(list(
    "model.bin" = fit.bin$finalModel,
    "model.reg" = fit.reg$finalModel,
    "pred" = data.frame("y_true"=iodata$y, "y_pred"=yhat)
    )
  )
}


context("clusterSamples and PCASamples checks")

file.list=list( system.file("extdata", "test1.myCpG.txt", package = "methylKit"),
                system.file("extdata", "test2.myCpG.txt", package = "methylKit"),
                system.file("extdata", "control1.myCpG.txt", package = "methylKit"),
                system.file("extdata", "control2.myCpG.txt", package = "methylKit") )

myobj=read( file.list,
                sample.id=list("test1","test2","ctrl1","ctrl2"),assembly="hg18",pipeline="amp",treatment=c(1,1,0,0))

# unite function
methidh=unite(myobj)

test_that("check if clusterSamples output is a hclust tree object", {
    expect_that(clusterSamples(methidh, dist="correlation", method="ward", plot=FALSE),
        is_a('hclust'))
})

test_that("check if PCASamples output is a summary of princomp", {
    expect_that(PCASamples(methidh,obj.return=TRUE),
        is_a('prcomp'))
})


# Poker winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)

# Roulette winnings from Monday to Friday
roulette_vector <- c(-24, -50, 100, -350, 10)

# Create the variable days_vector
days_vector <- c("Monday","Tuesday","Wednesday","Thursday","Friday")

# Assign the names of the day to 'roulette_vector' and 'poker_vector'
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

print(poker_vector)

print(roulette_vector)