library(matrixStats)
args <- commandArgs(trailingOnly = TRUE)
filename <- args[1]
forecast = 7
load(paste0("results/",filename))
print(sprintf("loading: %s",paste0("results/",filename)))
out = rstan::extract(fit)
prediction = out$prediction
estimated.deaths = out$E_deaths

df_pop= read.csv("data/popt_ifr.csv", stringsAsFactors = FALSE)
df_pop$country[df_pop$country == "United Kingdom"] = "United_Kingdom"

len_dates <- 0
for (date in dates){
  if (length(date) > len_dates){
      len_dates <- length(date)
      dates_all <- date
  }
}

date_till_percentage = date_iso <- as.character(Sys.Date())

cases <- vector("list", length = length(countries))
total_cases <- vector("list", length = length(countries))
total_cases_ui <- vector("list", length = length(countries))
total_cases_li <- vector("list", length = length(countries))
deaths <- vector("list", length = length(countries))
total_deaths <- vector("list", length = length(countries))
rt <- vector("list", length = length(countries))
fraction_infected <- vector("list", length = length(countries))
fraction_infected_li <- vector("list", length = length(countries))
fraction_infected_ui <- vector("list", length = length(countries))
fraction_obs_infected <- vector("list", length = length(countries))
fraction_total_obs_infected <- vector("list", length = length(countries))
y <- vector("list", length = length(countries))

for(i in 1:length(countries)) {
  Country = countries[i]
  x = dates[[i]]
  N = length(x)
  x  = c(x,x[length(x)]+1:forecast)
  padding <- len_dates - length(dates[[i]])
  y[[i]] = c(rep(0, padding),reported_cases[[i]], rep(NA, forecast))

  cases[[i]] = c(rep(0, padding), round(colMeans(prediction[,1:length(x),i])))

  total_cases[[i]] = c( round(cumsum(colMeans(prediction[,1:length(x),i]))))
  # chk = c(round((colMeans(rowCumsums(prediction[,1:length(x),i])))))

  total_cases_li[[i]] = c(
    round((colQuantiles(rowCumsums(prediction[,1:length(x),i]),probs=.025))))
  total_cases_ui[[i]] = c(
    round((colQuantiles(rowCumsums(prediction[,1:length(x),i]),probs=.975))))

  deaths[[i]] =  c(rep(0, padding), round(colMeans(estimated.deaths[,1:length(x),i])))
  total_deaths[[i]] =  c(rep(0, padding), round(cumsum(colMeans(estimated.deaths[,1:length(x),i]))))
  rt[[i]] = c(rep(NA, padding), colMeans(out$Rt[,1:length(x),i]))

  fraction_infected[[i]] = c(rep(0, padding), total_cases[[i]]/ df_pop[df_pop$country==Country,]$popt)
  fraction_infected_li[[i]] = c(rep(0, padding),
                                total_cases_li[[i]]/ df_pop[df_pop$country==Country,]$popt)
  fraction_infected_ui[[i]] = c(rep(0, padding),
                                total_cases_ui[[i]]/ df_pop[df_pop$country==Country,]$popt)
  fraction_obs_infected[[i]] = c(rep(0, padding), y[[i]] / cases[[i]])
  fraction_total_obs_infected[[i]] = c(rep(0, padding), cumsum(y[[i]]) / cases[[i]])

  total_cases[[i]]  = c(rep(0, padding),total_cases[[i]])
}

dates_all  = c(dates_all,dates_all[length(dates_all)]+1:forecast)
cases <- do.call(rbind, cases)
cases_df <- as.data.frame(cases)
names(cases_df) <- dates_all
cases_df$countries <- countries
# write.csv(cases_df, "figures/cases.csv")

total_cases <- do.call(rbind, total_cases)
total_cases_df <- as.data.frame(total_cases)
names(total_cases_df) <- dates_all
total_cases_df$countries <- countries
# write.csv(total_cases_df, "figures/total_cases.csv")

deaths <- do.call(rbind, deaths)
deaths_df <- as.data.frame(deaths)
names(deaths_df) <- dates_all
deaths_df$countries <- countries
# write.csv(deaths_df, "figures/deaths.csv")

total_deaths <- do.call(rbind, total_deaths)
total_deaths_df <- as.data.frame(total_deaths)
names(total_deaths_df) <- dates_all
total_deaths_df$countries <- countries
# write.csv(total_deaths_df, "figures/total_deaths.csv")

rt <- do.call(rbind, rt)
rt_df <- as.data.frame(rt)
names(rt_df) <- dates_all
rt_df$countries <- countries
# write.csv(rt_df, "figures/rt.csv")

fraction_infected <- do.call(rbind, fraction_infected)
fraction_infected_df <- as.data.frame(fraction_infected)
names(fraction_infected_df) <- dates_all
fraction_infected_df$countries <- countries
# write.csv(fraction_infected_df, "figures/fraction_infected.csv")

fraction_infected_li <- do.call(rbind, fraction_infected_li)
fraction_infected_li_df <- as.data.frame(fraction_infected_li)
names(fraction_infected_li_df) <- dates_all
fraction_infected_li_df$countries <- countries
# write.csv(fraction_infected_li_df, "figures/fraction_infected_li.csv")

fraction_infected_ui <- do.call(rbind, fraction_infected_ui)
fraction_infected_ui_df <- as.data.frame(fraction_infected_ui)
names(fraction_infected_ui_df) <- dates_all
fraction_infected_ui_df$countries <- countries
# write.csv(fraction_infected_ui_df, "figures/fraction_infected_ui.csv")

total_infected = data.frame(countries=countries,mean=fraction_infected[,dates_all == date_till_percentage],
                            li=fraction_infected_li[,dates_all == date_till_percentage],ui=fraction_infected_ui[,dates_all == date_till_percentage])
total_infected$value = sprintf("%.02f%% [%.02f%%-%.02f%%]",
                              total_infected$mean*100,total_infected$li*100,total_infected$ui*100)
total_infected[order(total_infected$countries),c("countries","value")]

total_infected <- total_infected[,c("countries","value")]
write.csv(total_infected,paste0("results/total_infected_",date_till_percentage,".csv"),row.names=F)

# Store copy for web output
dir.create("web/data/", showWarnings = FALSE, recursive = TRUE)
write.csv(total_infected,paste0("web/data/total_infected.csv"),row.names=F)

fraction_obs_infected <- do.call(rbind, fraction_obs_infected)
fraction_obs_infected_df <- as.data.frame(fraction_obs_infected)
names(fraction_obs_infected_df) <- dates_all
fraction_obs_infected_df$countries <- countries
# write.csv(fraction_obs_infected_df, "figures/fraction_obs_infected.csv")

fraction_total_obs_infected <- do.call(rbind, fraction_total_obs_infected)
fraction_total_obs_infected_df <- as.data.frame(fraction_total_obs_infected)
names(fraction_total_obs_infected_df) <- dates_all
fraction_total_obs_infected_df$countries <- countries
# write.csv(fraction_total_obs_infected_df, "figures/fraction_total_obs_infected.csv")


#' Method of RCTtoolbox: \code{lm()}
#'
#' When you create R6 object "RCTtoolbox"
#' via \code{\link{create_RCTtoolbox}}
#' and run its method \code{lm()},
#' the method internally implements a function
#' that fit linear model by least squares.
#' The method \code{lm()} provides some arguments.
#' See the section "Arguments."
#'
#' @param ctrl character. New control arm.
#' If NULL (default),
#' the first element of \code{treat_levels} is control arm.
#' @param subset subset condition.
#' If NULL (default),
#' full observations of \code{data} is used to estimate.
#' @param weights weight variable for weighted least squares.
#' If NULL (default), implement ordinary least squares.
#' @param cluster cluster variable for clustered standard error.
#' If NULL (default), standard error is not clustered.
#' @param only_dmod logical (default is TRUE).
#' Whether to estimate linear model without covariates?
#' @param \dots arguments passed to \code{\link[estimatr]{lm_robust}}.
#'
#' @return R6 object with "RCTtoolbox.balance.test" class.
#' The returned object has following field and methods:
#' \describe{
#'   \item{\code{result}}{Field.
#'     List of estimated result ("lm_robust" class).
#'     See \code{\link[estimatr]{lm_robust}} for each element of list.}
#'   \item{\code{print()}}{Method.
#'     Print information about the returned object.
#'     Run \code{$print()}.}
#'   \item{\code{summary()}}{Method.
#'     Print result in console.
#'     Run \code{$summary()}.}
#'   \item{\code{table()}}{Method.
#'     Create output table of estimation result.
#'     Run \code{$table()}.}
#' }
#'
#' @section Developer Note:
#' A method \code{lm()} provided by R6 object RCTtoolbox
#' implements \code{RCTtoolbox.lm$new()}
#' which generates R6 object with "RCTtoolbox.lm" class.
#' Initialization of R6 object "RCTtoolbox.lm" does two things.
#' First, the private field \code{dvec} of R6 object "RCTtoolbox" is
#' stored in the private field \code{dvar} of returned object.
#' Second, run \code{rct_lm(private$formula.yd, private$formula.x,
#' self$data, private$dvec.levels, private$dvec.labels, ...)}
#' where \code{...} accepts arguments explained in the section "Arguments."
#' The first five arguments passed to \code{rct_lm()} are
#' \describe{
#'   \item{\code{baseline}}{list of two-sided formula \code{outcome ~ treat}.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{formula.yd} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{covariate}}{list of one-sided formula \code{~ var1 + var2}
#'     The method \code{lm()} automatically
#'     passes the private field \code{formula.x} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{data}}{data.frame/tibble object that you want to use.
#'     The method \code{ttest()} automatically
#'     passes a public field \code{data} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_levels}}{character vector. Level of experimental arms.
#'     The first element is control arm.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.levels} of R6 object "RCTtoolbox"
#'     to this argument.}
#'   \item{\code{treat_labels}}{character vector. Label of experimental arms
#'     corresponding to \code{treat_levels}.
#'     The method \code{ttest()} automatically
#'     passes the private field \code{dvec.labels} of R6 object "RCTtoolbox"
#'     to this argument.}
#' }
#'
#' @examples
#' \dontrun{
#' data(RubellaNudge)
#' rct <- create_RCTtoolbox(
#'   atest + avacc ~ treat,
#'   ~ age + educ,
#'   RubellaNudge,
#'   LETTERS[1:7]
#' )
#'
#' # estimate linear model
#' rct$lm()$summary()
#' }
#'
#' @name lm
#'
NULL


#  James Rekow

DOCDensity_2d = function(doc, densLim = 10){

  #  ARGS: doc - input DOC
  #        densLim - maximum density displayed in plot. Regions with higher densities are plotted in
  #                  grey
  #
  #  RETURNS: docDens - ggplot object corresponding to the 2d density of the input DOC

  library(ggplot2)

  #  guarantee that input doc is a data frame (by default a doc is a named list)
  doc = data.frame(doc)

  #  create ggplot object
  docDens = ggplot(doc, aes(x = over, y = diss)) +
            stat_density_2d(geom = "raster", aes(fill = ..density..), contour = FALSE) +
            scale_fill_gradient2(limits = c(0, densLim)) +
            coord_cartesian(xlim = c(0.5, 1), ylim = c(0, 0.3), expand = c(0, 0))

  return(docDens)

} #  end DOCDens function


x <- rnorm(1000)
hx <- hist(x, breaks=100, plot=FALSE)
plot(hx, col=ifelse(abs(hx$breaks) < 1.669, 4, 2))


# Fast version of trigraf assuming that
#           ie(m) < je(m)
#           ie[is in ascending order
#           je is in ascending order within ie,
# that is, je(ie==i) is in ascending order for each fixed i.
# Code adapted from C code in trigraf.c, from the spatstat package
# by Adrian Baddeley.
#

subroutine trigraf(nv, ne, ie, je, nt, it, jt, kt)
#
# nv --- number of points being triangulated.
# ne --- number of triangle edges
# ie and je --- vectors of indices of ends of each edge
# nt --- number of triangles assumed to be at most ne
# it, jt, kt --- vectors of indices of vertices of triangles
#
integer firstedge, lastedge;
dimension ie(1), je(1), it(1), jt(1), kt(1)

# Initialise output.
nt = 1
lastedge = 0
while(lastedge < ne) {
# Consider next vertex i.
# The edges (i,j) with i < j appear contiguously in the edge list.
 firstedge = lastedge + 1
 i = ie(firstedge)
 do m = firstedge+1,ne {
  if ( ie(m) != i ) break
 }
  lastedge = m-1
# Consider each pair j, k of neighbours of i, where i < j < k.
# Scan entire edge list to determine whether j, k are joined by an edge.
# If so, save triangle (i,j,k)
  if(lastedge > firstedge) {
   do mj = firstedge,lastedge-1 {
    j = je(mj)
    do mk = firstedge+1,lastedge {
     k = je(mk)
# Run through edges to determine whether j, k are neighbours.
     do m = 1,ne {
      if(ie(m) >= j) break
     }
      while(m <= ne & ie(m) == j) {
       if(je(m) == k) {
# Add (i, j, k) to list of triangles.
        it(nt) = i;
        jt(nt) = j;
        kt(nt) = k;
        nt = nt+1
       }
      m = m+1
      }
     }
    }
   }
  }

return
end


#!/usr/bin/env Rscript --vanilla --slave

# get the input VCF tabular format, assert that sites must have AC > 0
vcf <- subset(read.table(pipe('cat /dev/stdin'), header=T), AC > 0)

tag <- commandArgs(TRUE)[1]

tag.genotypes_alternate_count <- paste(tag, '.genotypes.alternate_count', sep='')
tag.non_reference_discrepancy_count <- paste(tag, '.site.non_reference_discrepancy.count', sep='')
tag.non_reference_discrepancy_normalizer <- paste(tag, '.site.non_reference_discrepancy.normalizer', sep='')
tag.non_reference_sensitivity_count <- paste(tag, '.site.non_reference_sensitivity.count', sep='')
tag.non_reference_sensitivity_normalizer <- paste(tag, '.site.non_reference_sensitivity.normalizer', sep='')
tag.alternate_positive_discrepancy <- paste(tag, '.site.alternate_positive_discrepancy', sep='')
tag.alternate_negative_discrepancy <- paste(tag, '.site.alternate_negative_discrepancy', sep='')
tag.has_variant <- paste(tag, '.has_variant', sep='')

vcf.numberOfSites <- length(vcf[, tag.genotypes_alternate_count])
vcf.totalAltAlleles <- sum(vcf[, tag.genotypes_alternate_count])
vcf.positiveDiscrepancy <- sum(vcf[, tag.alternate_positive_discrepancy]) / sum(vcf[, tag.genotypes_alternate_count])
vcf.negativeDiscrepancy <- sum(vcf[, tag.alternate_negative_discrepancy]) / sum(vcf[, tag.genotypes_alternate_count])
vcf.sitesTruePositive <- sum(vcf[, tag.has_variant]) / nrow(vcf)

cat('number of sites', vcf.numberOfSites, '\n')
cat('total alternate alleles', vcf.totalAltAlleles, '\n')
cat('positive discrepancy', vcf.positiveDiscrepancy, '\n')
cat('negative discrepancy', vcf.negativeDiscrepancy, '\n')

x <- cbind(by(vcf, vcf$AC,
    function(x) {
        sum(x[, tag.alternate_positive_discrepancy]) / sum(x[, tag.genotypes_alternate_count])
    }))

byac <- data.frame(ac=as.numeric(rownames(x)), fdr=as.vector(x))

print(byac)


#' solve
#'
#' Solve a system of equations or invert a matrix.
#'
#' @param a,b
#' fmlmat matrices.
#' @param ...
#' Ignored.
#'
#' @name solve
#' @rdname solve
NULL

#' @rdname solve
#' @export
setMethod("solve", signature(a="fmlmat"),
  function(a)
  {
    ret = DATA(a)$dupe()
    linalg_invert(ret)

    wrapfml(ret)
  }
)

#' @rdname solve
#' @export
setMethod("solve", signature(a="fmlmat", b="fmlmat"),
  function(a, b, ...)
  {
    a_cp = DATA(a)$dupe()
    ret = DATA(b)$dupe()
    linalg_solve(a_cp, ret)

    wrapfml(ret)
  }
)


#!/usr/bin/Rscript
# This is a modified version of the code found here:
#   http://bioinf.wehi.edu.au/RNAseqCaseStudy/

# To run this case study, you should have R version of 3.0.2 or later
library(argparser)
library(edgeR)
library(Rsubread)

parse_argv <- function() {
    p <- argparser::arg_parser("Run a differential expression analysis.")

    # Add command line arguments
    p <- argparser::add_argument(p, "infile", type="character",
                                 help="sample data")
    p <- argparser::add_argument(p, "targets", type="character",
                                 help="sample information")
    p <- argparser::add_argument(p, "--outfile_dir", type="character",
                                 default="./", help="output file directory")
    p <- argparser::add_argument(p, "--names", type="character",
                                 help="output names")
    p <- argparser::add_argument(p, "--voom_off", flag=TRUE,
                                 help="toggle voom off")
    p <- argparser::add_argument(p, "--ebayes_off", flag=TRUE,
                                 help="toggle empirical bayes off")
    # Parse the command line arguments
    argv <- argparser::parse_args(p)

    # Do work based on the passed arguments
    return(argv)
}

write_args <- function(args, argpath) {
  if (!argv$voom_off) {do_voom <- "--voom_off"} else {do_voom <- ""}
  if (!argv$ebayes_off) {do_ebayes <- "--ebayes_off"} else {do_ebayes <- ""}
  args <- paste("Rscript differential_gene_expression.r \\ \n  ",
    args$infile, " \\ \n  ", args$targets, " \\ \n  -o", args$outfile_dir,
    " \\ \n  -n", args$names, " \\ \n  ", do_voom, " \\ \n  ", do_ebayes, "\n"
  )
  print(cat(args))
  write(args, sep="", file=argpath)
}

main <- function() {
  argv <- parse_argv()
  dir.create(file.path(argv$outfile_dir))
  write_args(argv,paste(argv$outfile_dir,"/",basename(argv$names),".r",sep=""))
  pdf(paste(argv$outfile_dir, "/", basename(argv$names), ".pdf", sep=""))
  targets <- limma::readTargets(argv$targets)

  # create a design matrix, first column must be treatment condition
  celltype <- factor(targets[[1]])
  design <- model.matrix(~targets[[1]])

  # count numbers of reads mapped to NCBI Refseq genes
  data <- read.table(argv$infile, sep="\t")

  # for now any NA values are assumed to have 0 coverage
  data[is.na(data)] = 0
  dge <- edgeR::DGEList(counts=data)

  # filter out low-count genes
  isexpr <- rowSums(cpm(dge) > 10) >= 2
  dge <- dge[isexpr,]

  if (!argv$voom_off) {
    # perform voom normalization
    voomed <- limma::voom(dge, design, plot=TRUE)
  } else {
    voomed <- dge
  }

  # cluster libraries
  limma::plotMDS(voomed, xlim=c(-2.5,2.5))

  if (!argv$ebayes_off) {
    # fit linear model and assess differential expression
    fit <- limma::eBayes(limma::lmFit(voomed, design))
  } else {
    fit <- limma::lmFit(voomed, design)
  }

  write.table(limma::topTable(fit, number=Inf, sort.by="P", coef=2), sep="\t",
    file=paste(argv$outfile_dir, "/", basename(argv$names), ".top.tsv", sep=""),
    quote=F
  )
  dev.off()
}

main()


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

# Raw Input Files: None
# Derived Input files:
#	'edit_times_unrounded.csv'
#   'eid_fsdt_regdate_table.csv'

NE = 44514
NT = 22126031

t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
te.lead = as.numeric(strptime("2010-09-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
te.train = as.numeric(strptime("2010-04-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tl5.lead = te.train
tl5.train = as.numeric(strptime("2009-11-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);

tm0.lead = as.numeric(strptime("2010-08-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm1.lead = as.numeric(strptime("2010-07-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm2.lead = as.numeric(strptime("2010-06-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm3.lead = as.numeric(strptime("2010-05-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm4.lead = tl5.lead

tm0.train = as.numeric(strptime("2010-03-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm1.train = as.numeric(strptime("2010-02-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm2.train = as.numeric(strptime("2010-01-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm3.train = as.numeric(strptime("2009-12-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tm4.train = tl5.train

# First read EID | FSDT | RegDate Table
EFR = read.csv(paste(RESDIR,'eid_fsdt_regdate_table.csv',sep=''),header=T)

# Now create another subset of users whose first edit date (FSDT) was before te.train
# There are 33839 users in this set
uids.train = EFR$user_id[which(EFR$FSDTnum < te.train)]
uids.lead = EFR$user_id

cname.lead = c("user_id","FSDT","LSDT","registration_date","sum_edits","sum_edit_days","sum_edit_ns0","sum_edit_ns1","sum_edit_ns2","sum_edit_ns3","sum_edit_ns4","sum_edit_ns5","sum_reverts","sum_reverts_ns0","sum_reverts_ns1","sum_reverts_ns2","sum_reverts_ns3","sum_reverts_ns4","sum_reverts_ns5","sum_reverts_self","sum_articles","sum_delta","sum_edits_l5","sum_edit_days_l5","sum_edit_ns0_l5","sum_edit_ns1_l5","sum_edit_ns2_l5","sum_edit_ns3_l5","sum_edit_ns4_l5","sum_edit_ns5_l5","sum_reverts_l5","sum_reverts_ns0_l5","sum_reverts_ns1_l5","sum_reverts_ns2_l5","sum_reverts_ns3_l5","sum_reverts_ns4_l5","sum_reverts_ns5_l5","sum_reverts_self_l5","sum_new_articles_l5","sum_delta_l5","Edits_mth_cutoff_minus_4","Edits_mth_cutoff_minus_3","Edits_mth_cutoff_minus_2","Edits_mth_cutoff_minus_1","Edits_mth_cutoff_minus_0")

cname.train = c("user_id","FSDT","LSDT","registration_date","sum_edits","sum_edit_days","sum_edit_ns0","sum_edit_ns1","sum_edit_ns2","sum_edit_ns3","sum_edit_ns4","sum_edit_ns5","sum_reverts","sum_reverts_ns0","sum_reverts_ns1","sum_reverts_ns2","sum_reverts_ns3","sum_reverts_ns4","sum_reverts_ns5","sum_reverts_self","sum_articles","sum_delta","sum_edits_l5","sum_edit_days_l5","sum_edit_ns0_l5","sum_edit_ns1_l5","sum_edit_ns2_l5","sum_edit_ns3_l5","sum_edit_ns4_l5","sum_edit_ns5_l5","sum_reverts_l5","sum_reverts_ns0_l5","sum_reverts_ns1_l5","sum_reverts_ns2_l5","sum_reverts_ns3_l5","sum_reverts_ns4_l5","sum_reverts_ns5_l5","sum_reverts_self_l5","sum_new_articles_l5","sum_delta_l5","Edits_mth_cutoff_minus_4","Edits_mth_cutoff_minus_3","Edits_mth_cutoff_minus_2","Edits_mth_cutoff_minus_1","Edits_mth_cutoff_minus_0","y_next5_edits")

ResMatLead = matrix(-1,NE,45)
colnames(ResMatLead) = cname.lead
ResMatTrain = matrix(-1,length(uids.train),46)
colnames(ResMatTrain) = cname.train
ResMatLead = data.frame(ResMatLead); ResMatTrain = data.frame(ResMatTrain);

ResMatLead$user_id = EFR[,1]
ResMatLead$FSDT = EFR[,2]
ResMatLead$registration_date = EFR[,3]

itrain = which(EFR$FSDTnum < te.train)
ResMatTrain$user_id = EFR[itrain,1]
ResMatTrain$FSDT = EFR[itrain,2]
ResMatTrain$registration_date = EFR[itrain,3]

rm(list=c("EFR","itrain",'cname.lead','cname.train'))

######## First read-off as many features as we can from the already created eid-time file
ET = scan(paste(RESDIR,'edit_times_unrounded.csv',sep=''),what='character');
# to.export = setdiff(ls(),c('ResMatTrain','ResMatLead'))
# require('snowfall')
# sfInit(parallel=T,12)
# sfExport(list=to.export,local=F)

parWrapper <- function( i )
{
	if (i%%2000 == 0) {cat(sprintf("Parsed %i of %i editors",i,NE),"\n"); flush.console();}
	splita <- as.numeric(strsplit(ET[i],",",fixed=T)[[1]])
	fsa <- floor(splita)

	iwithin = which((splita >= tl5.lead) & (splita < te.lead))
	resLead = rep(0,10);
	resTrain = rep(0,10);

	resLead[1] = length(splita)
	resLead[2]  = length(unique(fsa))
	resLead[3] = length(iwithin)
	resLead[4] = length(unique(fsa[iwithin]))
	resLead[5] = max(splita)

	resLead[6] = sum((splita >= tm4.lead) & (splita < tm3.lead))
	resLead[7] = sum((splita >= tm3.lead) & (splita < tm2.lead))
	resLead[8] = sum((splita >= tm2.lead) & (splita < tm1.lead))
	resLead[9] = sum((splita >= tm1.lead) & (splita < tm0.lead))
	resLead[10] = sum((splita >= tm0.lead) & (splita < te.lead))

	it = which(uids.train == uids.lead[i])
	if (length(it) > 0){
		iexist =  which(splita < te.train)
		iwithin = which((splita >= tl5.train) & (splita < te.train))

		resTrain[1] = length(iexist)
		resTrain[2]  = length(unique(fsa[iexist]))
		resTrain[3] = length(iwithin)
		resTrain[4] = length(unique(fsa[iwithin]))
		resTrain[5] = max(splita[iexist])

		resTrain[6] = sum((splita >= tm4.train) & (splita < tm3.train))
		resTrain[7] = sum((splita >= tm3.train) & (splita < tm2.train))
		resTrain[8] = sum((splita >= tm2.train) & (splita < tm1.train))
		resTrain[9] = sum((splita >= tm1.train) & (splita < tm0.train))
		resTrain[10] = sum((splita >= tm0.train) & (splita < te.train))
	}
	return(list(ilead = i, itrain=it,reslead = resLead, restrain = resTrain))
}
#result = sfLapply(1:NE,parWrapper); sfStop();
result = lapply(1:NE,parWrapper);
varorder = c('sum_edits','sum_edit_days','sum_edits_l5','sum_edit_days_l5','LSDT','Edits_mth_cutoff_minus_4','Edits_mth_cutoff_minus_3','Edits_mth_cutoff_minus_2','Edits_mth_cutoff_minus_1','Edits_mth_cutoff_minus_0');

for (ir in 1:length(result)){
	if (ir%%1000 == 0) {cat(sprintf("Aggregated %i of %i editors",ir,NE),"\n"); flush.console();}
	il = result[[ir]]$ilead
	ResMatLead[il,varorder] = result[[ir]]$reslead
	it = result[[ir]]$itrain
	if (length(it) > 0){
		ResMatTrain[it,varorder] = result[[ir]]$restrain
	}
}

write.csv(ResMatLead, file = paste(RESDIR,"OrigSubset1_Lead.csv",sep=''), row.names = FALSE);
write.csv(ResMatTrain, file = paste(RESDIR,"OrigSubset1_Train.csv",sep=''), row.names = FALSE);


setwd("C:\\Users\\mmtobias\\Documents\\Presentations\\FOSS4G 2017\\Data")

library(geosphere)
library(sp)
library(rgdal)
library(geojsonio)

datafile<-"FOSS4G_Locations.txt"

fg<-read.delim(datafile)

from.pts<-data.frame(fg$Longitude[1:16], fg$Latitude[1:16])
to.pts<-data.frame(fg$Longitude[2:17], fg$Latitude[2:17])

all.lines<-c()

for (i in 1:16){
  #print(i)
  one.line<-gcIntermediate(from.pts, to.pts, n=100, addStartEnd=TRUE, sp= TRUE)
  #one.line<-Line(one.line)
  #stuff<-c(from.pts[,2], from.pts[,1], to.pts[,2], to.pts[,1])
  #all.lines<-SpatialLines(list(all.lines, one.line))
  }

geojson_write(one.line, file="FOSS4G_GreatCircles.geojson", overwrite=TRUE, convert_wgs84 = TRUE)


install.packages("viridis")

library(viridis)

source("../utility_scripts/data_prep.r")
source("../utility_scripts/annotation_defaults.r")

# Top 10 popular names from all of time
all_time_top_names_data <- scent_data %>%
  select(dog_name, team) %>%
  distinct(team, .keep_all=TRUE) %>%
  group_by(dog_name) %>%
  summarize(number_of_dogs = n()) %>%
  ungroup() %>%
  slice_max(number_of_dogs, n=10)

plot1 <- ggplot(data=all_time_top_names_data) +
  geom_col(mapping = aes(y = fct_reorder(dog_name, number_of_dogs), x = number_of_dogs, fill = number_of_dogs)) +
  scale_fill_viridis(option="turbo") +
  scale_x_continuous(
    labels=c("", "20 dogs", "40 dogs", "50 dogs", "60 dogs", "75 dogs"),
    breaks = c(0, 20, 40, 50, 60, 75)) +
  ggtitle('All Time Popular Names') +
  theme_minimal()  +
  theme(
    legend.position = 'none',
    axis.title = element_blank()
  )

year_wise_top_names_data <- scent_data %>%
  select(year, dog_name, team) %>%
  group_by(year, dog_name) %>%
  distinct(team, .keep_all=TRUE) %>%
  summarize(number_of_dogs_this_name = n()) %>%
  slice_max(number_of_dogs_this_name, n=1) %>%
  ungroup() %>%
  arrange(year, desc(number_of_dogs_this_name))

all_time_top_names <- all_time_top_names_data$dog_name
year_wise_top_names <- unique(year_wise_top_names_data$dog_name)
popular_names <- unique(c(all_time_top_names, year_wise_top_names))

name_trends_data <- scent_data %>%
  filter(dog_name %in% popular_names) %>%
  group_by(year, dog_name) %>%
  distinct(team, .keep_all=TRUE) %>%
  summarize(number_of_dogs = n()) %>%
  ungroup()

plot2 <- ggplot(data = name_trends_data, mapping = aes(x = year, y = number_of_dogs)) +
  geom_line() +
  scale_x_continuous(breaks = seq(2009, 2021, 2)) +
  scale_y_continuous(breaks = seq(0, 40, 20)) +
  #scale_color_viridis(option="cividis", discrete = TRUE) +
  facet_wrap(~dog_name) +
  ggtitle("Trends In Popular Names") +
  theme_minimal()  +
  theme(
    legend.position = 'none',
    axis.title = element_blank()
  )

annotated_plot <- getAnnotatedPlot(
  plot1 / plot2,
  title="Popular Dog Names",
  subtitle="")
annotated_plot

ggsave("popular_names.png", plot=annotated_plot, path=".", width=4194, height=3226, units="px", bg="white")


cat(sapply(lapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), as.integer), function(s) {
  j <- TRUE
  if (s[1] > 1) {
    u <- c()
    for (i in 3:length(s)) {
      x <- abs(s[i] - s[i-1])
      if (x >= s[1] || x == 0 || (x-1) %in% u) {
        j <- FALSE
        break
      }
      u <- append(u, x-1)
    }
  }
  if (j == TRUE) {
    "Jolly"
  } else {
    "Not jolly"
  }
}), sep="\n")


## From Sam.Zhao@agriculture.gov.au

require(Hmisc)
# create a 9 by 9 table
my.table <- matrix(1:81, nrow=9)
colnames(my.table) <- paste("c",1:9,sep='')

n.col <- 9
n.row <- 9

# cell format
cell.format <- matrix(rep("", n.col*n.row), nrow=n.row,  ncol = n.col)
#color the rows 1,4,7 blue
cell.format[c(1,4,7),] <- "color{blue}"
my.table[c(1,4,7),] <- 'blue'
# color the column ‘c6’ blue
cell.format[,6] <- "color{blue}"
my.table[,6] <- 'blue'
#color the cells (2,9), (3,9), (5,9), (6,9), (8,9) and (9,9) red
cell.format[c(2,3,5,6,8,9),9] <- "color{red}"
my.table[c(2,3,5,6,8,9),9] <- 'red'

w <- latex(my.table,
     file="/tmp/z.tex",
     numeric.dollar = TRUE,
      title = "",
      where="h",
      rowname = " ",
      ctable=TRUE,
      cellTexCmds = cell.format,
      rgroup = c("RGroup1", "RGroup2","RGroup3"),
      n.rgroup = c(3,3,3),
      cgroup = c("", "CGroup1","CGroup2","CGroup3"),
      n.cgroup = c(1,2,4,2),
      caption = "The Example Table Using Hmisc on R 2.14.",
      label = "tab:comp-csp-results-large-small-imp"
     )


isOutOfTime = function(testTimeLimit, testTimeStarted, itemTimeLimit, itemTimeFullRequired) {
  startedAgo = as.numeric(Sys.time()) - testTimeStarted
  testTimeLeft = testTimeLimit - startedAgo
  if(testTimeLimit > 0) {
    if(testTimeLeft <= 0) { return(T) }
    if(testTimeLeft < itemTimeLimit && itemTimeFullRequired) { return(T) }
  }
  return(F)
}

getBranch = function(testTimeLimit, testTimeStarted, itemTimeLimit, itemTimeFullRequired, itemNumLimit, minAccuracy, itemsAdministered, itemsNum, sem) {
  if(isOutOfTime(testTimeLimit, testTimeStarted, itemTimeLimit, itemTimeFullRequired)) {
    concerto.log("time out", "test status")
    return("stop")
  }

  if(itemNumLimit > 0 && length(itemsAdministered) >= itemNumLimit || length(itemsAdministered) >= itemsNum) {
    concerto.log("maximum items reached", "test status")
    return("stop")
  }

  if(minAccuracy != 0 && minAccuracy >= sem) {
    concerto.log("minimum accuracy", "test status")
    return("stop")
  }
  concerto.log("continue", "test status")
  return("continue")
}

.branch = getBranch(
  as.numeric(settings$testTimeLimit),
  testTimeStarted,
  as.numeric(settings$itemTimeLimit),
  settings$itemTimeFullRequired == "1",
  as.numeric(settings$itemNumLimit),
  as.numeric(settings$minAccuracy),
  itemsAdministered,
  dim(items)[1],
  sem
)


# pull out the necessary internal functions from greta
op <- .internals$nodes$constructors$op

#' @import greta
#'
#' @title Posterior Predictive Checks for \code{greta_mcmc_list} object
#'
#' @aliases pp_check
#'
#' @description Perform posterior predictive checks with the help of the package \code{bayesplot}
#'
#'
#' @param object A greta_mcmc_list object obtained from the greta::mcmc function
#' @param y A greta array of the response variable, see example
#' @param nsim A numeric, the number of posterior simulation to draw, default is 10
#' @param type A character string, the type of posterior predictive plot to draw. See \code{\link[bayesplot:PPC-overview]{PPC-overview}} for some options, or check the example below.
#' @param ... Further arguments passed to ppc_* functions, check the possibilities there.
#'
#' @return A ggplot object that can be further modified using the \pkg{ggplot2} package.
#'
#' @details For a detailed explanation of each of the implemented ppc functions, see \code{\link[bayesplot:PPC-overview]{PPC-overview}}.
#' Note that LOO and Discrete ppc_* function are not yet available for greta models.
#'
#' @examples
#' \dontrun{
#' x <- runif(100, -2, 2)
#' y <- rnorm(100, 1 + 2 * x, 1)
#' # need the pass the response vector as greta array
#' y <- as_data(y)
#'
#' intercept <- normal(0, 2)
#' slope <- normal(0, 1)
#' linpred <- intercept + slope * x
#' sd_res <- cauchy(0, 2, truncation = c(0, Inf))
#'
#' distribution(y) <- normal(linpred, sd_res)
#' m <- model(intercept, slope, sd_res)
#' d <- mcmc(m, warmup = 10, n_samples = 10)
#'
#' # default use
#' pp_check(d, y)
#' # check some options
#' pp_check(d, y, nsim = 4, type = "scatter_avg")
#' pp_check(d, y, type = "hist")
#' pp_check(d, y, type = "error_scatter")
#' }
#'
#' @importFrom bayesplot pp_check
#' @export pp_check
#' @export

pp_check.greta_mcmc_list <- function(object, y, nsim = 10, type = "dens_overlay", ...){
  # compute posterior predictive values
  yrep <- calculate(y, values = object, nsim = nsim)[[1]][,,1]
  # turn response into a vector
  y_vec <- as.numeric(y)

  # remove some type of pp plots that are currently not making sense
  if(type %in% c("bars", "bars_grouped", "rootgram")){
    stop("Discrete ppc function not supported")
  }

  if(length(grep("loo", type)) != 0){
    stop("LOO ppc function are not supported")
  }

  # the ppc function to apply
  ppc_fun <- get(paste0("ppc_", type), asNamespace("bayesplot"))

  # call the function
  ppc_fun(y_vec, yrep, ...)
}


#check fits, convergence plots and prsf scores for calibration models

rm(list=ls())
source('paths.r')
source('paths_fall2019.r')
library(runjags)
library(betareg)
library(coda)
library(ddpcr) # for quiet() function
source('NEFI_functions/crib_fun.r')

allfits <- readRDS(prior_delgado_ddirch_16S.path)

# has everything converged? print any high prsf scores.
for (i in 1:length(allfits)) {
  print(names(allfits)[[i]])
  fit <- allfits[[i]]
  summary(fit$jags_model)
  quiet(s <- summary(fit$jags_model))
  print(s[which(s[,11] > 1.1),])
}
fit$species_parameter_output

# save plots.
#pdf("/fs/data3/caverill/NEFI_data/16S/pecan_gen/figures/prior_fit_ddirch_all_groups.pdf")

#check the plots.
#allfits <- output.list
r2_all <- list()
par(mfrow = c(3,3))

for (p in 1:length(allfits)) {
fit <- allfits[[p]]
r2_lev <- list()
for(i in 1:ncol(fit$predicted)) {
  if (colnames(fit$predicted)[i]=="other") next()
  plot(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i],
       pch = 16, xlab="predicted abundance", ylab="observed abundance")
  Axis(x="predicted", side=2)
  abline(0,1,lwd = 2)
  abline(lm(fit$observed[,i]/rowSums(fit$observed) ~ fit$predicted[,i]), lty = 2, col = 'purple')

  #mod <- betareg::betareg(crib_fun(fit$observed[,i]/rowSums(fit$observed)) ~ crib_fun(fit$predicted[,i]))
  #rsq <-round(summary(mod)$pseudo.r.squared, 3)

  mod <- lm(fit$observed[,i] ~ fit$predicted[,i])
  rsq <- round(summary(mod)$r.squared, 2)
  #r2_out[[p]] <- rsq

  mtext(colnames(fit$predicted)[i], side = 3)
  mtext(paste0('R2=',rsq), side = 3, line = -1.5, adj = 0.05)
  r2_lev[[i]] <- rsq
}
r2_all[[p]] <- r2_lev
}
dev.off()
names(r2_all) <- names(allfits)

# view summary by rank
lev.mu <- lapply(r2_all[1:5], unlist)
lev.mu <- lapply(lev.mu, mean)
tax.mu <- mean(unlist(r2_all[1:5]))
fg.mu <- mean(unlist(r2_all[6:18]))
n.mu <- mean(unlist(r2_all[7:13]))
c.mu <- mean(unlist(r2_all[c(6,14:16)]))
co.mu <- mean(unlist(r2_all[c(17:18)]))
lev.mu <- c(fg.mu, lev.mu)

names(lev.mu)[[1]] <- "functional"

lev.mu <- unlist(lev.mu)
xx <- seq(1,length(lev.mu))
ylim <- c(0,.7)
plot(lev.mu ~ xx, cex = 2.5, ylim = ylim, pch = 16, ylab = NA, xlab = NA, bty='n', xaxt = 'n', col="grey")
points(lev.mu ~ xx, cex = 2.5, pch = 16)
lines(xx, lev.mu, lty = 2, col="grey")
mtext(expression(paste("Calibration site-level R"^"2")), side = 2, line = 2.2, cex = o.cex)
axis(1, labels = F)
text(x=xx, y = -0.05, labels= names(lev.mu), srt=45, adj=1, xpd=TRUE, cex = 1.6)
text(x=xx, y = .17, labels= names(lev.mu), srt=45, adj=1, xpd=TRUE, cex = 1.8)


# csv is generated from Postgresql via
# copy (select etag,date_modified from idb_object_keys where user_uuid = '285a4be0-...' order by date_modified ASC) to '/tmp/uploads20140902.csv' with CSV;

#
png(filename="output_uploads_per_day.png",width=800)
uploads <- read.csv('uploads20140917.csv', header=FALSE)

# change margins
par(mai=c(.75,.1,.5,.5))

uploadstamps <- c(as.POSIXlt (strftime(uploads$V2)) )

myhist <- hist(uploadstamps,breaks="days",main="Upload events per day",xlab="",ylab="",las=2,xaxt="n",yaxt="n",col="darkgrey",freq=TRUE)

axis.POSIXct(1, at=seq((uploadstamps[1]-86400), as.POSIXlt(Sys.time()), by="day"), format="%b %d", srt=45, las=2,cex.axis=0.7)

axis(4, at=myhist$freq)
box()
dev.off()


library(igraph)
library(ggplot2)
year<-1994
pattern <- paste(year,'-*-*', sep = "")
group <- grep(pattern, Cit.HepPh.WithDates.WellCited[,2],
              ignore.case = FALSE, perl = FALSE, value = FALSE,
              fixed = FALSE, useBytes = FALSE, invert = FALSE)
graphDY<-Cit.HepPh.WithDates.WellCited[group,c(1,3)]
#graphDY<-rbind(graphD,Cit.HepPh.WithDates.WellCited[Cit.HepPh.WithDates.WellCited$V3==wellcited[1],c(1,3)])
gg <- graph.data.frame(d = graphDY, directed = T)
is.simple(gg)
gg <- simplify(gg)
par(mar = c(0, 0, 0, 0))
set.seed(23)
# plot(gg, layout = layout.fruchterman.reingold,
#      vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
#      edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)

is.connected(gg, mode=c("weak"))
gc<-clusters(gg, mode=c("weak"))
V(gg)$sg = gc$membership
V(gg)$color = rainbow(max(V(gg)$sg))[V(gg)$sg]
plot(gg, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)

comps <- decompose.graph(gg,max.comps=1,min.vertices=max(gc$csize))
g<-comps[[1]]
plot(g, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)


# A heatmap of thresholds over the past 30 days
library(ggplot2)
library(jsonlite)
library(lubridate)
library(tibble)
library(dplyr)
library(tidyr)
library(readr)
library(RJSONIO)
library(xml2)
library(purrr)
library(plot3D)
select = dplyr::select
filter = dplyr::filter

###################################
# USER INPUT
# Date from which records-tidy.r
# is to be run.
# Format: yyyymmdd
# Note that end date will be either current date -1
# or the end of the year. To run the next year,
# change start_date to the first of the next year
# and rerun records-tidy.py
start_date <- ymd("20210101")
###################################

# set base path depending on whether this is run on the server
# (the here package would be a better idea for this!)
fullpath <- if_else(Sys.info()["user"] == "ubuntu",
  "/srv/isithotrightnow/", "./")

current_date <- with_tz(Sys.Date(), tzone = "Australia/Sydney") - 1
current_year <- year(start_date)
end_date <- if_else(year(current_date) != current_year,
                   ymd(paste0(current_year,"1231")),
                   current_date)
dates <- paste0(
  format(seq(start_date, end_date, by = 1), "%y%m%d"),
  "-all.csv")

# load functions from app_functions.R
source(paste0(fullpath, "app_functions_static.R"))

# function for creating an array of categories based on an array of percentiles for a particular year
get_category_array <- function(heatmap_array) {
  if (!all.equal(dim(heatmap_array), c(31,12))) {
    stop("heatmap_array does not have the right dimensions (31,12)")
  }
  category_array <- array(dim = dim(heatmap_array))
  for (i in 1:31) {
    for (j in 1:12) {
      category_array[i, j] <-
        as.character(cut(heatmap_array[i, j],
                         breaks = c(-100, 5, 10, 40, 60, 90, 95, 100),
                         labels = c("bc","rc","c","a","h","rh","bh"),
                         include.lowest = T, right = F))
    }
  }
  return(category_array)
}

# get list of station ids to process from locations.json
station_set <- fromJSON(paste0(fullpath, "www/locations.json"))
for (i in 1:length(station_set)) {
  if (file.exists(paste0(fullpath,"databackup/", station_set[[i]]["id"],"-", current_year, ".csv"))) {
    station_set[[i]]$percentileHeatmap_array <- array(data = read_csv(paste0(fullpath,"databackup/", station_set[[i]]["id"],
                                                                           "-", current_year, ".csv"))[["percentile"]],
                                                    dim = c(31,12))
    station_set[[i]]$categoryHeatmap_array <- get_category_array(heatmap_array = station_set[[i]]$percentileHeatmap_array)
  } else {
    station_set[[i]]$percentileHeatmap_array <- array(dim = c(31,12))
    station_set[[i]]$categoryHeatmap_array <- array(dim = c(31,12))
  }
}

# run this loop to calculate historical percentiles since the start of the year
# In the future this loop will be replaced by calculation only for the previous
# day and the data will be saved in an R dataframe
for (d in 1:length(dates)) {
  file <- dates[d]
  date <- ymd(substr(file, 1, 6))
  print(file)
  daydata <- read_csv(paste0(fullpath,"databackup/", file))
  daydata <- daydata %>% mutate(tavg = (tmax + tmin) / 2)

  for (i in 1:length(station_set))
  {

    # Calculate percentiles of historical data
    HistObs <- getHistoricalObs(station_set[[i]]$id, date = date, window = 7)
    histPercentiles <- calcHistPercentiles(Obs = HistObs)

    Tavg.now <- daydata[which(as.numeric(daydata$station_id) == as.numeric(station_set[[i]]$id)), ]$tavg

    # don't include the median when binning obs against the climate!
    # (the -100 and 100 allow us to have the lowest and highest bins)
    station_set[[i]]$categoryHeatmap_array[day(date), month(date)] <-
      as.character(cut(Tavg.now,
        breaks = c(
          -100,
          histPercentiles[!rownames(histPercentiles) %in% "50%", "Tavg"],
          100),
        labels = c("bc","rc","c","a","h","rh","bh"),
        include.lowest = T, right = F))

    station_set[[i]]$percentileHeatmap_array[day(date), month(date)] <-
      100 * round(ecdf(HistObs$Tavg)(Tavg.now), digits = 2)
  }
}

message("Percentiles calculated; tidying up")

# get the nested list structure into a nested data frame
# (previously in heatmap-tidy.r)
tidy_data =
  station_set %>%
  {
    data_frame(
    id   = map_chr(., pluck, 'id'),
    # name = map_chr(., pluck, 'name'),
    percentiles =
      map(., pluck, 'percentileHeatmap_array') %>%
      map(as_tibble) %>%
      map(set_names, 1:12) %>%
      map(rownames_to_column, 'day') %>%
      map(gather, key = 'month', value = 'percentile', -day),
    categories =
      map(., pluck, 'categoryHeatmap_array') %>%
      map(as_tibble) %>%
      map(set_names, 1:12) %>%
      map(rownames_to_column, 'day') %>%
      map(gather, key = 'month', value = 'category', -day))
  } %>%
  # now unnest, drop the duplicated columns and then nest by station
  unnest() %>%
  mutate(date = as.Date(paste(current_year, month, day, sep = '-'))) %>%
  select(id, date, percentile) %>%
  mutate(percentile = as.integer(percentile)) %>%
  nest(-id)

message("And finally, writing out!")

# write 'em out to disk
walk2(tidy_data$data, tidy_data$id,
  ~ write_csv(.x, paste0(fullpath, "databackup/", .y, '-', current_year, '.csv')))


#################################################################################
# Monte Carlo method to calculate Multi-Species Indices (MSI)
# CBS (Statistics Netherlands), july 2016
# 	- generate MSIs with confidence interval, accounting for sampling error
#   - baseyear for simulated MSIs is flexible
#   - baseyear for plots can be set to 100 for index or for smoothed trend value
#	  - linear trend classification
#   - smoothed trend classification
#   - compare linear trends before and after changepoint
#   - assess overall change and change in last years
#   - truncation of low indices (and their SE set to 0)
#################################################################################

#################################################################################
# Input file has at least these 4 columns:
#   - species (species code)
#   - year
#   - index (base year has index 100; anny year can be the base year)
#   - se (standard error of index; base year has SE zero)
#################################################################################

# Data import and specificatons
setwd("E:/MSI/data") # the path for input and output files.
rdata <- read.table("farmland.txt", header=TRUE) # name of input file.
jobname <- as.character ("farmland") # generic name for output files.
nsim <- 1000		    # number of Monte Carlo simulations.
SEbaseyear <- 1990 # desired year to set MSI to 1000 and SE to 0; usually the first year of the time series.
plotbaseyear <- 1990 # desired year to set to 100 in plots.
index_smooth <- "SMOOTH" # INDEX / SMOOTH: "INDEX" will cause the index in plotbaseyear set to 100; "SMOOTH" will set the smoothed trend value in the plotbaseyear to 100.
lastyears <- 10		# last X years of time series for which separate trend (short-term trends) should be calculated.
maxCV <- 3       # maximum allowed mean Coefficient of Variation (CV) of species indices (0.5 = 50%). Species with higher mean CV are excluded.
changepoint <- 2000 # compare trends before and after this year.
truncfac <- 10    # truncation factor (=max year-to-year index ratio). Default for Living Planet Index = 10.
TRUNC <- 1 # set all indices below TRUNC to this value and their SE to 0. TRUNC <- 0 means no truncation.

# set names of output files
jobnameRESULTS <- paste (jobname, "_RESULTS.csv", sep = "")
jobnameTRENDS <- paste (jobname, "_TRENDS.csv", sep = "")
jobnameSIMTRENDS <- paste (jobname, "_SIMTRENDS.csv", sep = "")
jobnameGRAPH <- paste (jobname, "_GRAPH.jpg", sep = "")

# Define and calculate model parameters
species <- rdata[,"species"]
year <- rdata[,"year"]
index <- rdata[,"index"]
se <- rdata[,"se"]
uspecies <- sort(unique(species))
nspecies <- length(uspecies)
uyear <- sort(unique(year))
nyear <- length(unique(year))
meanindex <- tapply(index, species, mean, na.rm=TRUE)/100
mnindex1 <- as.data.frame(rep(meanindex,each=nyear))
minyear <- min(year)
maxyear <- max(year)
plotbaseyear <- plotbaseyear-minyear+1
baseyear <- max(1,SEbaseyear-minyear+1)
lastyears <- min(lastyears,nyear)
INP <- data.frame(cbind(species, year, index, se))
SPEC <- as.matrix(species)
species <- sort(rep(uspecies,each=nyear))
year <- rep(uyear,nspecies)
INP1 <- data.frame(cbind(species,year))
INP2 <- merge(INP, INP1, by=c("species","year"), sort=TRUE, all=TRUE)

# Calculate and plot mean CV for indices per species
CVtemp <- INP2[INP2$index >= 10, ] # select records with index >= 10 for CV calculation
CVtemp <- CVtemp[!is.na(CVtemp$index), ] # reject missing values
CV1 <- CVtemp$se/CVtemp$index
CV1[CV1== 0] <- NA
CV1[CV1== Inf] <- NA
species2 <- CVtemp$species
mnCV <- tapply(CV1, species2, mean, na.rm=TRUE)
plot(uspecies, mnCV, type="p", pch=19, col="black", main=jobname, xlab="species code", ylab="meanCV")
CV <- as.data.frame(rep(mnCV, each=nyear))

# replace small indices by TRUNC and their SE by zero
INP3 <- data.frame(cbind(species, year, CV, mnindex1))
colnames(INP3) <- c("species","year", "CV", "mnindex1")
INP4 <- merge(INP2, INP3, by=c("species","year"), sort=FALSE, all=TRUE)
INP5 <- subset(INP4, CV < maxCV, select = c(species, year, index, se, mnindex1))
INP5$index[INP5$index < TRUNC & !is.na(INP5$index)] <- TRUNC
INP5$se[INP5$index == TRUNC & !is.na(INP5$index)] <- 0

# reset parameters
index <- as.vector(INP5["index"])
se <- as.vector(INP5["se"])
nobs <- NROW(INP5)
uspecies <- sort(unique(INP5$species))
nspecies <- length(uspecies)
year <- rep(uyear, nspecies)

# Transform indices and standard deviations to log scale (Delta method)
LNindex <- as.vector(log(index))
LNse <- as.vector(se/index)

# Monte Carlo simulations of species indices
MC <- matrix(NA, nobs, nsim)
for (s in 1:nsim) {
       for (o in 1:nobs) {
       MC[o,s] <- rnorm(1, LNindex[o,1], LNse[o,1])
       }
       }
MC[MC < log(TRUNC)] <- log(TRUNC)

# impute missing values using chain method
CHAIN <- matrix(NA, nobs, nsim)
for (s in 1:nsim ){
  for (o in 1:nobs-1) {
    CHAIN[o,s] <- MC[o+1,s]-MC[o,s]
  }
  for (sp in 1:nspecies) {
    CHAIN[sp*nyear,s] <- NA
  }
}

CHAIN[CHAIN > log(truncfac)] <- log(truncfac)
CHAIN[CHAIN < log(1/truncfac)] <- log(1/truncfac)

mnCHAIN <- matrix(NA, nyear, nsim)
for (s in 1:nsim) {
  mnCHAIN[,s] <- tapply(CHAIN[,s], year, mean, na.rm=TRUE)
}

simMSI <- matrix(NA, nyear, nsim)
bmin <- baseyear-1
bplus <- baseyear+1
for (s in 1:nsim){
simMSI[baseyear,s] <- log(100)
  for (y in bmin:min(bmin,1)){
    simMSI[y,s] <- simMSI[y+1,s] - mnCHAIN[y,s]
  }
  for (y in min(bplus,nyear):nyear){
    simMSI[y,s] <- simMSI[y-1,s] + mnCHAIN[y-1,s]
  }
}

# calculate MSI and SE
meanMSI <- array(NA, dim=c(1, nyear))
stdevMSI <- array(NA, dim=c(1, nyear))
for (y in 1:nyear) {
  meanMSI[y] <- mean(simMSI[y,])
  stdevMSI[y] <- sd(simMSI[y,])
}

# Monte Carlo simulations of MSI (for trend calculation)
simMSI <- matrix(NA, nyear, nsim)
for (s in 1:nsim) {
  for (y in 1:nyear) {
    simMSI[y,s] <- rnorm(1, meanMSI[y], stdevMSI[y])
  }
}

# Back-transformation of MSI to index scale (Delta method)
meanMSI <- array(NA, dim=c(1, nyear))
stdevMSI <- array(NA, dim=c(1, nyear))
for (y in 1:nyear) {
  meanMSI[y] <- round(exp(mean(simMSI[y,])), digits=2)
  stdevMSI[y] <- round(sd(simMSI[y,])*meanMSI[y], digits=2)
}

# Confidence interval of MSI on index-scale
CI <- array(NA, dim=c(nyear, 2))
for (y in 1:nyear){
  CI[y,1] <- exp(mean(simMSI[y,])-1.96*sd(simMSI[y,]))
  CI[y,2] <- exp(mean(simMSI[y,])+1.96*sd(simMSI[y,]))
}

# Overall linear trend per simulation
lrMSI <- array(NA, dim=c(2, nsim))
for (s in 1:nsim) {
  summ <- summary(lm(simMSI[,s] ~ uyear, na.action=na.exclude))
  lrMSI[1,s] <- round(summ$coefficients[2], digits=4)	# coeff[2] = slope
  lrMSI[2,s] <- round(summ$coefficients[2,2], digits=4) 	# coeff[2,2] = se of slope
}

SLOPE <- mean(lrMSI[1,])
sdSLOPE <- sd(as.vector(lrMSI[1,]))

# Back transform trends to index scale:
SLOPE_mult <- round(exp(SLOPE), digits=4)
sdSLOPE_mult <- round(sdSLOPE*SLOPE_mult, digits=4)

SLOPE
sdSLOPE
SLOPE_mult
sdSLOPE_mult

# Overall trend classification (see Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
TrendClass <- "X"
if (SLOPE_mult - 1.96*sdSLOPE_mult > 1.05) {TrendClass <- "strong increase" } else
  if (SLOPE_mult + 1.96*sdSLOPE_mult < 0.95) { TrendClass <- "steep decline" } else
    if (SLOPE_mult - 1.96*sdSLOPE_mult > 1.00) { TrendClass <- "moderate increase"} else
      if (SLOPE_mult + 1.96*sdSLOPE_mult < 1.00) { TrendClass <- "moderate decline" } else
        if ((SLOPE_mult - 1.96*sdSLOPE_mult - 0.95)*(1.05 - SLOPE_mult + 1.96*sdSLOPE_mult) < 0.00) { TrendClass <- "uncertain"} else
          if ((SLOPE_mult + 1.96*sdSLOPE_mult) - (SLOPE_mult - 1.96*sdSLOPE_mult) > 0.10) { TrendClass <- "uncertain" } else
          {TrendClass <- "stable"}
TrendClass

# Short term linear trend per simulation
lrMSI_short <- array(NA, dim=c(2, nsim))
lyear <- c((maxyear-lastyears+1):maxyear)
simMSI_short <- array(NA, dim=c(lastyears, nsim))
for (s in 1:nsim) {
  for (y in 1:lastyears) {
    simMSI_short[y, s] <- simMSI[(nyear-lastyears+y),s]
  }
}
for (s in 1:nsim) {
  summ <- summary(lm(simMSI_short[,s] ~ lyear, na.action=na.exclude))
  lrMSI_short[1,s] <- round(summ$coefficients[2], digits=4)	# coeff[2] = slope
  lrMSI_short[2,s] <- round(summ$coefficients[2,2], digits=4) 	# coeff[2,2] = sd of slope
}

SLOPE_short <- mean(lrMSI_short[1,])
sdSLOPE_short <- sd(as.vector(lrMSI_short[1,]))

# Back-transform short-term trends to index scale
SLOPE_short_mult <- round(exp(SLOPE_short), digits=4)
sdSLOPE_short_mult <- round(sdSLOPE_short*SLOPE_short_mult, digits=4)

SLOPE_short
sdSLOPE_short
SLOPE_short_mult
sdSLOPE_short_mult

# Short term trend classification (Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
TrendClass_short <- "X"
if (SLOPE_short_mult - 1.96*sdSLOPE_short_mult > 1.05) {TrendClass_short <- "strong increase" } else
  if (SLOPE_short_mult + 1.96*sdSLOPE_short_mult < 0.95) { TrendClass_short <- "steep decline" } else
    if (SLOPE_short_mult - 1.96*sdSLOPE_short_mult > 1.00) { TrendClass_short <- "moderate increase"} else
      if (SLOPE_short_mult + 1.96*sdSLOPE_short_mult < 1.00) { TrendClass_short <- "moderate decline" } else
        if ((SLOPE_short_mult - 1.96*sdSLOPE_short_mult - 0.95)*(1.05 - SLOPE_short_mult + 1.96*sdSLOPE_short_mult) < 0.00) { TrendClass_short <- "uncertain"} else
          if ((SLOPE_short_mult + 1.96*sdSLOPE_short_mult) - (SLOPE_short_mult - 1.96*sdSLOPE_short_mult) > 0.10) { TrendClass_short <- "uncertain" } else
          {TrendClass_short <- "stable"}
TrendClass_short

# linear trend before changepoint per simulation
lrMSI_before <- array(NA, dim=c(2, nsim))
byear <- c(minyear:changepoint)
byears <- length(byear)
simMSI_before <- array(NA, dim=c(byears, nsim))
for (s in 1:nsim) {
  for (y in 1:byears) {
    simMSI_before[y, s] <- simMSI[y,s]
  }
}
for (s in 1:nsim) {
  summb <- summary(lm(simMSI_before[,s] ~ byear, na.action=na.exclude))
  lrMSI_before[1,s] <- round(summb$coefficients[2], digits=4)  # coeff[2] = slope
  lrMSI_before[2,s] <- round(summb$coefficients[2,2], digits=4) 	# coeff[2,2] = sd of slope
}
SLOPE_before <- round(mean(lrMSI_before[1,]), digits=5)
sdSLOPE_before <- round(sd(as.vector(lrMSI_before[1,])), digits=5)

# Back-transform trends before changepoint to index scale
SLOPE_before_mult <- round(exp(SLOPE_before), digits=4)
sdSLOPE_before_mult <- round(sdSLOPE_before*SLOPE_before_mult, digits=4)

SLOPE_before
sdSLOPE_before
SLOPE_before_mult
sdSLOPE_before_mult

# Trend classification before changepoint
TrendClass_before <- "X"
if (SLOPE_before_mult - 1.96*sdSLOPE_before_mult > 1.05) {TrendClass_before <- "strong increase" } else
  if (SLOPE_before_mult + 1.96*sdSLOPE_before_mult < 0.95) { TrendClass_before <- "steep decline" } else
    if (SLOPE_before_mult - 1.96*sdSLOPE_before_mult > 1.00) { TrendClass_before <- "moderate increase"} else
      if (SLOPE_before_mult + 1.96*sdSLOPE_before_mult < 1.00) { TrendClass_before <- "moderate decline" } else
        if ((SLOPE_before_mult - 1.96*sdSLOPE_before_mult - 0.95)*(1.05 - SLOPE_before_mult + 1.96*sdSLOPE_before_mult) < 0.00) { TrendClass_before <- "uncertain"} else
          if ((SLOPE_before_mult + 1.96*sdSLOPE_before_mult) - (SLOPE_before_mult - 1.96*sdSLOPE_before_mult) > 0.10) { TrendClass_before <- "uncertain" } else
          {TrendClass_before <- "stable"}
TrendClass_before

# linear trend after changepoint per simulation
lrMSI_after <- array(NA, dim=c(2, nsim))
ayear <- c(changepoint:maxyear)
ayears <- length(ayear)
simMSI_after <- array(NA, dim=c(ayears, nsim))
for (s in 1:nsim) {
  for (y in 1:ayears) {
    simMSI_after[y, s] <- simMSI[(byears-1+y),s]
  }
}
for (s in 1:nsim) {
  summa <- summary(lm(simMSI_after[,s] ~ ayear, na.action=na.exclude))
  lrMSI_after[1,s] <- round(summa$coefficients[2], digits=4)  # coeff[2] = slope
  lrMSI_after[2,s] <- round(summa$coefficients[2,2], digits=4)   # coeff[2,2] = sd of slope
}
SLOPE_after <- round(mean(lrMSI_after[1,]), digits=5)
sdSLOPE_after <- round(sd(as.vector(lrMSI_after[1,])),digits=5)

# Trend classification before changepoint
SLOPE_after_mult <- round(exp(SLOPE_after), digits=4)
sdSLOPE_after_mult <- round(sdSLOPE_after*SLOPE_after_mult, digits=4)

SLOPE_after
sdSLOPE_after
SLOPE_after_mult
sdSLOPE_after_mult

# Trend classification after changepoint
TrendClass_after <- "X"
if (SLOPE_after_mult - 1.96*sdSLOPE_after_mult > 1.05) {TrendClass_after <- "strong increase" } else
  if (SLOPE_after_mult + 1.96*sdSLOPE_after_mult < 0.95) { TrendClass_after <- "steep decline" } else
    if (SLOPE_after_mult - 1.96*sdSLOPE_after_mult > 1.00) { TrendClass_after <- "moderate increase"} else
      if (SLOPE_after_mult + 1.96*sdSLOPE_after_mult < 1.00) { TrendClass_after <- "moderate decline" } else
        if ((SLOPE_after_mult - 1.96*sdSLOPE_after_mult - 0.95)*(1.05 - SLOPE_after_mult + 1.96*sdSLOPE_after_mult) < 0.00) { TrendClass_after <- "uncertain"} else
          if ((SLOPE_after_mult + 1.96*sdSLOPE_after_mult) - (SLOPE_after_mult - 1.96*sdSLOPE_after_mult) > 0.10) { TrendClass_after <- "uncertain" } else
          {TrendClass_after <- "stable"}
TrendClass_after

# compare linear trends before and after changepoint
compare <- array(NA, dim=c(nsim, 1))
for (s in 1:nsim){
  compare[s,1] <- lrMSI_after[1,s]-lrMSI_before[1,s]
}
meanTrendDiff <- mean(compare)
seTrendDiff <- sd(as.vector(compare))
significance <- NA
if (abs(meanTrendDiff)-2.58*seTrendDiff > 0) { significance <- "p<0.01" } else
  if (abs(meanTrendDiff)-1.96*seTrendDiff > 0) { significance <- "p<0.05" } else
    {significance <- "n.s."}

# Smoothing
# span = 0.75 is default in R and usually fits well. But trying other values may give better results, depending on your data
loessMSI <- array(NA, dim=c(nyear, nsim))
Diff <- array(NA, dim=c(nyear, nsim))
for (s in 1:nsim) {
  smooth <- predict(loess(simMSI[,s]~uyear, span=0.75, degree=2, na.action=na.exclude),
                    data.frame(uyear), se=TRUE)
  loessMSI[,s] <- round(smooth$fit, digits=4)

  for (y in 1:nyear) {
    Diff[y,s] <- loessMSI[nyear,s] - loessMSI[y,s]
  }
}

# calculate overall change (first year set to 100) and change in last years
pct_CHANGE <- array(NA, dim=c(nsim, 2))
for (s in 1:nsim) {
pct_CHANGE[s,1] <- exp(loessMSI[nyear,s])*100/exp(loessMSI[1,s])-100
pct_CHANGE[s,2] <- exp(loessMSI[nyear,s])*100/exp(loessMSI[1,s])-exp(loessMSI[(nyear-lastyears+1),s])*100/exp(loessMSI[1,s])
}
pct_CHANGE_long <- round(mean(pct_CHANGE[,1]),digits=3)
sd_pct_CHANGE_long <- round(sd(pct_CHANGE[,1]), digits=3)
pct_CHANGE_long
sd_pct_CHANGE_long
pct_CHANGE_short <- round(mean(pct_CHANGE[,2]),digits=3)
sd_pct_CHANGE_short <- round(sd(pct_CHANGE[,2]), digits=3)
pct_CHANGE_short
sd_pct_CHANGE_short

# significance of percentage change
significance_PCT_long <- NA
if (abs(pct_CHANGE_long)-2.58*sd_pct_CHANGE_long > 0) { significance_PCT_long <- "p<0.01" } else
  if (abs(pct_CHANGE_long)-1.96*sd_pct_CHANGE_long > 0) { significance_PCT_long <- "p<0.05" } else
  {significance_PCT_long <- "n.s."}

significance_PCT_short <- NA
if (abs(pct_CHANGE_short)-2.58*sd_pct_CHANGE_short > 0) { significance_PCT_short <- "p<0.01" } else
  if (abs(pct_CHANGE_short)-1.96*sd_pct_CHANGE_short > 0) { significance_PCT_short <- "p<0.05" } else
  {significance_PCT_short <- "n.s."}

# create output for flexible trend estimates
smoothMSI <- array(NA, dim=c(nyear, 13))
for (y in 1:nyear) {
  smoothMSI[y,1] <- round(mean(loessMSI[y,]), digits=4) # smooth MSI on log scale
  smoothMSI[y,2] <- round(sd(loessMSI[y,]), digits=4) # SE of smooth MSI on log scale
  smoothMSI[y,3] <- round(mean(Diff[y,]), digits=4) # Difference smooth MSI with last year on log scale
  smoothMSI[y,4] <- round(sd(Diff[y,]), digits=4) # SE of difference with ast year
  smoothMSI[y,12] <- round(smoothMSI[y,1]-1.96*smoothMSI[y,2], digits=2) # lower CI of smooth MSI on log scale
  smoothMSI[y,13] <- round(smoothMSI[y,1]+1.96*smoothMSI[y,2], digits=2) # upper CI of smooth MSI on log scale
}

# Trendclassification, based on smoothed trends (Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
for (y in 1:nyear) {
  smoothMSI[y,5] <- round(smoothMSI[nyear,1]/smoothMSI[y,1], digits=4)		# = TCR
  smoothMSI[y,6] <- round(smoothMSI[y,5]-1.96*(smoothMSI[y,4]/smoothMSI[y,1]), digits=4)	# = CI- TCR
  smoothMSI[y,7] <- round(smoothMSI[y,5]+1.96*(smoothMSI[y,4]/smoothMSI[y,1]), digits=4)	# = CI+ TCR
  smoothMSI[y,8] <- round(exp(log(smoothMSI[y,5])/(nyear-y)), digits=4)		# = YCR
  smoothMSI[y,9] <- round(exp(log(smoothMSI[y,6])/(nyear-y)), digits=4)		# = CI- YCR
  smoothMSI[y,10] <- round(exp(log(smoothMSI[y,7])/(nyear-y)), digits=4)		# = CI+ YCR
}

for (y in 1:(nyear-1)) {
  if (smoothMSI[y,9] > 1.05) {smoothMSI[y,11] <- 1} else
    if (smoothMSI[y,10] < 0.95) {smoothMSI[y,11] <- 6} else
      if (smoothMSI[y,9] > 1.00) {smoothMSI[y,11] <- 2} else
        if (smoothMSI[y,10] < 1.00) {smoothMSI[y,11] <- 5} else
          if ((smoothMSI[y,9] - 0.95)*(1.05 - smoothMSI[y,10]) < 0.00) {smoothMSI[y,11] <- 3} else
            if ((smoothMSI[y,10]) - (smoothMSI[y,9]) > 0.10) {smoothMSI[y,11] <- 3} else
            {smoothMSI[y,11] <- 4}
}

TrendClass_flex <- matrix(NA, nrow= nyear, ncol=1)
for (y in 1:(nyear-1)) {
  if (smoothMSI[y,9] > 1.05) {TrendClass_flex[y] <- "strong_increase" } else
    if (smoothMSI[y,10] < 0.95) { TrendClass_flex[y] <- "steep_decline" } else
      if (smoothMSI[y,9] > 1.00) { TrendClass_flex[y] <- "moderate_increase"} else
        if (smoothMSI[y,10] < 1.00) { TrendClass_flex[y] <- "moderate_decline" } else
          if ((smoothMSI[y,9] - 0.95)*(1.05 - smoothMSI[y,10]) < 0.00) { TrendClass_flex[y] <- "uncertain"} else
            if ((smoothMSI[y,10]) - (smoothMSI[y,9]) > 0.10) { TrendClass_flex[y] <- "uncertain" } else
            {TrendClass_flex[y] <- "stable"}
}

# rescaling (for presentation of plot)
rescale <- NA
 if (index_smooth =="INDEX") {rescale <- 100/meanMSI[plotbaseyear]} else
  if (index_smooth =="SMOOTH") {rescale <- 100/exp(smoothMSI[plotbaseyear,1])} else
   {rescale <- NA}
simMSImean <- round(as.vector(rescale*meanMSI), digits=2)
simMSIsd <- round(as.vector(rescale*stdevMSI), digits=2)
uppCI_MSI <- round(rescale*CI[,2], digits=2)
lowCI_MSI <- round(rescale*CI[,1], digits=2)
trend_flex <- round(rescale*exp(smoothMSI[,1]), digits=2)
lowCI_trend_flex <- round(rescale*exp(smoothMSI[,12]), digits=2)
uppCI_trend_flex <- round(rescale* exp(smoothMSI[,13]), digits=2)

# create output file for MSI + smoothed trend
RES <- as.data.frame(cbind(uyear, simMSImean, simMSIsd, lowCI_MSI, uppCI_MSI, trend_flex, lowCI_trend_flex, uppCI_trend_flex))
RES$trend_class <- TrendClass_flex
names(RES) <- c("year", "MSI", "sd_MSI", "lower_CL_MSI", "upper_CL_MSI", "Trend", "lower_CL_trend", "upper_CL_trend", "trend_class")
write.csv2(RES, file=jobnameRESULTS, row.names=FALSE, quote=FALSE)

# create output file with all linear trends
SIMTRENDS <- t(rbind(lrMSI[1,],lrMSI_short[1,]))
write.csv2(SIMTRENDS, file=jobnameSIMTRENDS, row.names=FALSE)

# create output for linear trend estimates and % change
rownames <- rbind("overall trend","SE overall trend", "trend last years", "SE trend last years", "changepoint",
                  "trend before changepoint", "SE trend before changepoint", "trend after changepoint", "SE trend after changepoint",
                  "% change", "SE % change", "% change last years", "SE % change last years")
output <- cbind(SLOPE_mult, sdSLOPE_mult, SLOPE_short_mult, sdSLOPE_short_mult,
                changepoint, SLOPE_before_mult, sdSLOPE_before_mult, SLOPE_after_mult, sdSLOPE_after_mult,
                pct_CHANGE_long, sd_pct_CHANGE_long, pct_CHANGE_short, sd_pct_CHANGE_short)
TRENDS <- as.data.frame(t(output), row.names=rownames)
TRENDS$significance <- ""
TRENDS["changepoint", "significance"] <- significance
TRENDS[1, "significance"] <- TrendClass
TRENDS[3, "significance"] <- TrendClass_short
TRENDS[6, "significance"] <- TrendClass_before
TRENDS[8, "significance"] <- TrendClass_after
TRENDS[10, "significance"] <- significance_PCT_long
TRENDS[12, "significance"] <- significance_PCT_short
names(TRENDS) <- c("value", "significance")
write.csv2(TRENDS, file=jobnameTRENDS)

# create output file with plot
maxy <- max(uppCI_MSI) + 10
jpeg(filename = jobnameGRAPH, width = 480, height = 480,units = "px", pointsize = 12, bg = "white", res = NA, restoreConsole = TRUE)
legend1 <- paste(nspecies, "species")
legend2 <- paste(TrendClass)
legend3 <- paste("last", lastyears, "years:", TrendClass_short)
plot(uyear, simMSImean, type="p", pch=19, col="black", main=jobname, xlab="", ylab="Index", xlim = c(minyear, maxyear), ylim = c(0,maxy))
text(minyear, 40, legend1, adj=0, cex=0.8)
text(minyear, 25, legend2, adj=0, cex=0.8)
text(minyear, 10, legend3, adj=0, cex=0.8)
lines(uyear, rescale*exp(smoothMSI[,1]), lty=1, col="black")
lines(uyear, rescale*exp(smoothMSI[,12]), lty=3, col="black")
lines(uyear, rescale*exp(smoothMSI[,13]), lty=3, col="black")
#arrows(uyear, simMSImean, uyear, (simMSImean-simMSIsd), angle = 90, code = 3, length=0)
#arrows(uyear, simMSImean, uyear, (simMSImean+simMSIsd), angle = 90, code = 3, length=0)
dev.off()

# plot to screen
maxy <- max(uppCI_MSI) + 10
plot(uyear, simMSImean, type="p", pch=19, col="black", main=jobname, xlab="", ylab="Index", xlim = c(minyear, maxyear), ylim = c(0,maxy))
text(minyear, 40, legend1, adj=0, cex=0.8)
text(minyear, 25, legend2, adj=0, cex=0.8)
text(minyear, 10, legend3, adj=0, cex=0.8)
lines(uyear, rescale*exp(smoothMSI[,1]), lty=1, col="black")
lines(uyear, rescale*exp(smoothMSI[,12]), lty=3, col="black")
lines(uyear, rescale*exp(smoothMSI[,13]), lty=3, col="black")
arrows(uyear, simMSImean, uyear, (simMSImean-simMSIsd), angle = 90, code = 3, length=0)
arrows(uyear, simMSImean, uyear, (simMSImean+simMSIsd), angle = 90, code = 3, length=0)


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

df <- data.frame(read.csv(args[1]))
colnames(df) <- c("arb_ord", "time", "incidence", "time")

print(nrow(df))
print(summary(df))
print(apply(df, 2 , sd))

par(mfrow=c(1,2))
hist(df$arb_ord, freq = FALSE)
hist(df$incidence, freq = FALSE)


# Build a data frame of subjects and fruit preferences based on a random
# sampling of a random amount of fruit from a vector of possible fruit
subjects <- seq(1,10,1)
all_fruit <- c("apple","banana","cantalope","drurian","date","lychee","carambola","kumquat","loquat","grape","orange","mango")

sample_a_vector <- function(x) {
  paste(sample(x,floor(runif(1,0,length(x)/4))),  collapse=",")
}

df <- data.frame(subjects)
df$favorite_fruit <- replicate(length(subjects), sample_a_vector(all_fruit))
df

# Make a new data frame of one column per fruit listed in favorite_fruit column
# For this exercise assume we do not know the list of all_fruit.
# We must derive our list of fruit from our sample of fruit in the favorite_fruit column
library(dplyr)
library(tidyr)
df.tall <- df %>% mutate(favorite_fruit = strsplit(favorite_fruit, ",")) %>% unnest(favorite_fruit)
df.tall$likes_fruit <- rep(1,nrow(df.tall))
df.wide <- spread(df.tall, favorite_fruit,likes_fruit)
df.wide.combined <- merge(df,df.wide, by="subjects", all.x=TRUE)
df.wide.combined

# If you hate NAs in the fruit columns...
df.wide.combined[is.na(df.wide.combined)] <- 0
df.wide.combined


args <- commandArgs(trailingOnly = TRUE)
input_file = args[1]
output_file = args[2]

d = read.table(input_file, head=T)
attach(d)
d[1,]
var = alpha1_se^2
var_post = (1+1/var)^{-1}
alpha1_post = alpha1/(1+var)
summary(alpha1_post)
summary(var_post)
outd  = cbind(d, alpha1_post, sqrt(var_post))
dim(outd)
write(file=output_file, ncol=8, t(outd))


# Loading in results and generating plots

library(data.table)
library(tidyverse)
library(git2r)
library(tictoc)
library(ggplot2)
library(patchwork)
library(cowplot)
library(latex2exp)
library(furrr)
library(sn)
library(ggrepel)
library(testthat)
library(svglite)
library(lemon)

#########################
# Figures S1, 1, 2 and 3

rm(list = ls())
devtools::load_all()
no.samples <- 5000
cap_cases <- 2000
max_days <- 300

# Load in pre-saved results
sweep_results <- readRDS("data-raw/res_Jan_complete_fix.rds")

# A colour-blind-friendly palette
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")

sweep_results <- sweep_results %>%
  dplyr::group_by(scenario) %>%
  dplyr::mutate(pext = extinct_prob(sims[[1]], cap_cases = cap_cases, week_range = 40:42)) %>%
  dplyr::ungroup(scenario)

sweep_results <- sweep_results %>%
  dplyr::group_by(scenario) %>%
  dplyr::mutate(mean_Re = calc_R(sims[[1]])) %>%
  dplyr::ungroup(scenario)

sweep_results <- sweep_results %>%
  dplyr::group_by(scenario) %>%
  dplyr::mutate(sd_Re = calc_R_sd(sims[[1]])) %>%
  dplyr::ungroup(scenario)

sweep_results <- sweep_results %>%
  dplyr::group_by(index_R0, sensitivity, test_asym, test_delay, iso_adhere) %>%
  dplyr::mutate(rel_Re = (mean_Re[which(control_effectiveness==0)]-mean_Re)/mean_Re[which(control_effectiveness==0)]) %>%
  dplyr::ungroup()

# Figure S1: Parameter distributions (incubation, generation interval etc.)
ringbp::make_figure_S1()

# Figs 1 and 2
res <- sweep_results

lower <- rep(NA,nrow(res))
upper <- rep(NA,nrow(res))

for(i in 1:nrow(res)){
  out <- prop.test(res$pext[i]*no.samples,no.samples,correct=TRUE)
  CIs <- as.numeric(unlist(out[6]))
  lower[i] <- CIs[1]
  upper[i] <- CIs[2]
}

res <- res %>% mutate(lower = lower,
                      upper = upper)
lower <- c()
upper <- c()

saveRDS(res,'data-raw/Fig1.rds')
res <- readRDS('data-raw/Fig1.rds')

Fig1 <- res %>%
  filter(test_delay != 0.5) %>%
  filter(test_asym == FALSE) %>%
  filter(sensitivity == 0.95) %>%
  mutate(test_delay = factor(test_delay, labels = c('instant tracing','2 day delay'))) %>%
  mutate(iso_adhere = factor(iso_adhere, labels = c('poor reporting & adherence', 'good reporting & adherence','high adherence'))) %>%
  mutate(index_R0 = factor(index_R0, labels = c("Rs = 1.3","1.5"))) %>%
  ggplot(aes(control_effectiveness, 1 - pext, colour = test_delay, linetype = test_delay)) +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2)],name="TTI delay:") +
  ggplot2::scale_linetype_manual(values = c(2,1),name="TTI delay:") +
  geom_line(lwd=1.1) +
  geom_point() +
  geom_linerange(aes(control_effectiveness,ymax=1-lower,ymin=1-upper),show.legend=FALSE) +
  facet_rep_grid(iso_adhere~index_R0,scales='free', repeat.tick.labels = 'all') +
  coord_capped_cart(bottom='both', left='both') +
  theme_cowplot(font_size = 16) +
  background_grid() +
  theme(panel.spacing = unit(2, "lines")) +
  theme(strip.background =element_rect(fill="white"), axis.line=element_line()) +
  ggplot2::theme(legend.position = c(0.24,-0.1),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,3,0.1), 'lines'),legend.key.size = grid::unit(2.5, "lines")) +
  #ggplot2::theme(legend.position = c(0.24,-0.1),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,2.5,0.1), 'lines')) +
  labs(x='Contact tracing coverage',y="Prob. large outbreak") +
  ylim(c(0,0.6))

Fig2 <- res %>%
  filter(test_delay != 0.5) %>%
  filter(test_asym == FALSE) %>%
  filter(sensitivity == 0.95) %>%
  mutate(test_delay = factor(test_delay, labels = c('instant tracing','2 day delay'))) %>%
  mutate(iso_adhere = factor(iso_adhere, labels = c('poor reporting & adherence', 'good reporting & adherence','high adherence'))) %>%
  mutate(index_R0 = factor(index_R0, labels = c("Rs = 1.3","1.5"))) %>%
  ggplot(aes(control_effectiveness, 100*rel_Re, colour = test_delay, fill = test_delay)) +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2)],name="TTI delay:") +
  ggplot2::scale_fill_manual(values = cbPalette[c(4,2)],name="TTI delay:") +
  geom_col(aes(y=100*rel_Re),position=position_dodge()) +
  facet_rep_grid(iso_adhere ~ index_R0,scales='free', repeat.tick.labels = 'all') +
  coord_capped_cart(bottom='both', left='both') +
  theme_cowplot(font_size = 16) +
  background_grid() +
  theme(panel.spacing = unit(2, "lines")) +
  theme(strip.background =element_rect(fill="white"), axis.line=element_line()) +
  ggplot2::theme(legend.position = c(0.25,-0.1),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,3,0.1), 'lines'),legend.key.size = grid::unit(1.5, "lines")) +
  #ggplot2::theme(legend.position = c(0.24,-0.1),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,2.5,0.1), 'lines')) +
  labs(x='Contact tracing coverage',y="% reduction in R") +
  ylim(c(-2,15)) +
  scale_x_continuous(breaks=c(-0.2,0,0.2,0.4,0.6,0.8,1),labels=c("",0,0.2,0.4,0.6,0.8,""), limits = c(-0.2,1))

Fig3 <- res %>%
  filter(test_asym == FALSE) %>%
  filter(iso_adhere == 0.65) %>%
  mutate(test_delay = factor(test_delay, labels = c('instant tracing','1 day delay', '2 day delay'))) %>%
  mutate(index_R0 = factor(index_R0, labels = c("Rs = 1.3","1.5"))) %>%
  mutate(sensitivity = factor(sensitivity)) %>%
  mutate(iso_adhere = factor(iso_adhere,labels=c(""))) %>%
  ggplot(aes(control_effectiveness, 1 - pext, colour = test_delay, linetype = sensitivity)) +
  ggplot2::scale_colour_manual(values = cbPalette[c(4,2,7)],name="TTI delay:") +
  ggplot2::scale_linetype_manual(values = c(2,1),name="Test sensitivity:") +
  geom_line(lwd=1.1) +
  geom_point() +
  geom_linerange(aes(control_effectiveness,ymax=1-lower,ymin=1-upper),show.legend=FALSE) +
  facet_rep_grid(iso_adhere ~ index_R0,scales='free', repeat.tick.labels = 'all') +
  coord_capped_cart(bottom='both', left='both') +
  theme_cowplot(font_size = 16) +
  background_grid() +
  theme(panel.spacing = unit(2, "lines")) +
  theme(strip.background =element_rect(fill="white"), axis.line=element_line()) +
  ggplot2::theme(legend.position = c(0.05,-0.17),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,3,0.1), 'lines'),legend.key.size = grid::unit(2.5, "lines")) +
  #ggplot2::theme(legend.position = c(0.24,-0.1),legend.title=element_text(size=14),legend.direction = "horizontal",legend.box = "horizontal",plot.margin= grid::unit(c(0.1,0.1,2.5,0.1), 'lines')) +
  labs(x='Contact tracing coverage',y="Prob. large outbreak") +
  ylim(c(0,0.4))

################################
# Manipulate data for Fig 4

res2 <- list()
week_range <- 40:42

res <- sweep_results

for(i in seq_len(nrow(res))){
  #print(i)
  tmp <- res$sims[i][[1]]
  tmp <-
    tmp %>%
    dplyr::group_by(sim) %>% # group by simulation run
    mutate(max_weekly = max(weekly_cases),
           time_to_size = which(cumulative>=500)[1], #time to reach 500 cases (weeks)
           total = max(cumulative)) %>%
    dplyr::filter(week %in% week_range) %>%
    dplyr::summarise(extinct =
                       ifelse(all(weekly_cases == 0 &
                                    cumulative < cap_cases),
                              1, 0),
                     max_weekly = max(max_weekly),
                     time_to_size = min(time_to_size),
                     total = max(total)) %>%
    dplyr::ungroup()
  tmp <-
    tmp %>%
    mutate(index_R0 = res$index_R0[i],
           control_effectiveness = res$control_effectiveness[i],
           max_quar_delay = res$max_quar_delay[i],
           iso_adhere = res$iso_adhere[i],
           sensitivity = res$sensitivity[i])

  res2[[i]] <- tmp
}
res2 <- do.call(rbind, res2)

# we want:
# total outbreaks / n
total_cumulative_distr <-
  res2 %>%
  mutate(total = ifelse(total > 2000, 2000, total)) %>%
  group_by(index_R0, control_effectiveness, max_quar_delay, iso_adhere, sensitivity) %>%
  do(res = tibble(cumdistr = nrow(.) * ecdf(.$total)(4:2000),
                  total = 4:2000,
                  outbreaks = nrow(.) - sum(.$extinct),
                  runs = nrow(.),
                  max_quar_delay = .$max_quar_delay[1],
                  index_R0 = .$index_R0[1],
                  iso_adhere = .$iso_adhere[1],
                  sensitivity = .$sensitivity[1],
                  control_effectiveness = .$control_effectiveness[1],
                  poutbreak = pmin(1,(outbreaks) / (runs - cumdistr))))

total_cumulative_distr <- do.call(rbind, total_cumulative_distr$res) %>%
  mutate(index_R0 = factor(index_R0, labels = c('Rs = 1.3','1.5'))) %>%
  mutate(iso_adhere = factor(iso_adhere)) %>%
  mutate(sensitivity = factor(sensitivity, labels = c('65% sensitive','95%'))) %>%
  mutate(max_quar_delay = factor(max_quar_delay, labels = c('instant tracing', '1 day delay', '2 day delay'))) %>%
  filter(outbreaks != 0)

# Fig 4
T1 <- total_cumulative_distr

lower <- rep(NA,nrow(T1))
upper <- rep(NA,nrow(T1))

for(i in 1:nrow(T1)){

  out <- prop.test(T1$outbreaks[i],max(T1$runs[i]-T1$cumdistr[i],T1$outbreaks[i]),correct=FALSE)
  CIs <- as.numeric(unlist(out[6]))
  lower[i] <- CIs[1]
  upper[i] <- CIs[2]
}

T1 <- T1 %>% mutate(lower = lower,
                    upper = upper)
lower <- c()
upper <- c()

saveRDS(T1,'data-raw/Fig4.rds')
T1 <- readRDS('data-raw/Fig4.rds')

T1 <- T1 %>% mutate(control_effectiveness=factor(control_effectiveness,labels=c("no tracing","20%","40%","60%","80%")))
T1 <- T1 %>% mutate(iso_adhere = factor(iso_adhere, labels = c('poor reporting & adherence', 'average reporting & adherence','average reporting & high adherence')))

Fig4 <- T1 %>%
  filter(sensitivity=="95%") %>%
  filter(max_quar_delay != "1 day delay") %>%
  filter(index_R0=="Rs = 1.3") %>%
  ggplot(aes(total, poutbreak, colour = control_effectiveness)) +
  geom_line(size=1.1,aes(linetype=control_effectiveness)) +
  geom_linerange(alpha=0.1,aes(total,ymax=upper,ymin=lower),show.legend=FALSE) +
  facet_grid(max_quar_delay ~ iso_adhere) +
  scale_colour_manual(values = cbPalette[c(3,8,7,2,4)],name="TTI coverage:") +
  scale_linetype_manual(values = c(1,5,2,4,3),name="TTI coverage:") +
  ylab('Prob. large outbreak') +
  guides(linetype=guide_legend(title="TTI coverage:")) +
  theme_cowplot(font_size = 16) +
  theme(strip.background =element_rect(fill="white")) +
  background_grid() +
  ggplot2::theme(legend.position = c(0.08,0.2), legend.title=element_text(size=14), legend.key.width = unit(2,"cm")) +
  labs(x='Total cases so far',y="Prob. large outbreak") +
  xlim(c(0,1000)) +
  ylim(c(0,1))

save(file="data-raw/outbreakSize_plot.Rdata",Fig4)


# R code to generate simple generation plots from *.p files generated by mrbayes
# Pablo Vinuesa  @pvinmex
# CCG-UNAM, Morelos, Mexico
# https://www.ccg.unam.mx/~vinuesa/
# Diplomado en Bioinformática, UAS, october 2021
# https://github.com/vinuesa/intro-filoinfo_UAS

# execute the following lines from an R console or from within an RStudio session

f1r1<-read.table("primates4bayes.nex.run1.p", skip=1, header=T)
f1r2<-read.table("primates4bayes.nex.run2.p", skip=1, header=T)

pdf(file="primates4bayes_generation_plots.pdf")
plot(f1r1[,2], type="l", col="blue", xlab="No. of generations", ylab="lnL", main="Pre-burnin generation plots for runs 1 & 2")
points(f1r2[,2], type="l", col="red")
legend("bottomright", lty=c(1,1), col=c("blue", "red"), c("run1", "run2"))

plot(f1r1[50:500,2], type="l", col="blue", xlab="No. of generations", ylab="lnL", main="Post-burnin generation plots for runs 1 & 2")
points(f1r2[50:500,2], type="l", col="red")
legend("bottomleft", lty=c(1,1), col=c("blue", "red"), c("run1", "run2"))
dev.off()
quit()


\docType{data}
\name{diamantes}
\alias{diamantes}
\title{Precio de 50.000 diamantes}
\format{Un data.frame con 53.940 filas y 10 columnas
\describe{
\item{precio}{Precio en dólares americanos (\$326-\$18,823)}
\item{quilate}{Peso del diamante (0.2-5.01)}
\item{corte}{Calidad del corte (Regular, Bueno, Muy bueno, Premium, Ideal)}
\item{color}{Color del diamante, de J (peor) a D (mejor)}
\item{claridad}{Medida de que tan claro es el diamante (I1 (peor), SI1, SI2, VS1, VS2, VVS1, VVS2, IF (mejor))}
\item{profundidad}{Porcentaje de la profundidad total = z / mean(x, y) = 2 * z / (x + y) (43-79)}
\item{tabla}{Ancho de la parte superior del diamante con relación a su punto más ancho (43-95)}
\item{x}{Largo en milimetros}
\item{y}{Ancho en milimetros}
\item{z}{Profundidad en milimetros}
}}
\usage{diamantes}
\description{Un conjunto de datos que contiene los precios de casi 54.000 diamantes.}
\keyword{datasets}


orderedData <- data_testing[order(-data_testing$bug),];

write.csv(orderedData,"E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\testdata_orderedByActualBugs.csv",row.names=FALSE);

cumulativeLOC <- cumsum(orderedData$loc);
cumulativeBugs <- cumsum(orderedData$bug);

totalLOC <- cumulativeLOC[NROW(cumulativeLOC)];
totalBugs <- cumulativeBugs[NROW(cumulativeBugs)];

percentLOC <- cumulativeLOC/totalLOC;
percentLOC <- percentLOC*100;

percentBugs <- cumulativeBugs/totalBugs;
percentBugs <- percentBugs*100;

plot(percentLOC,percentBugs,type = "n");
legend("bottomright",c("Actual","Predicted","PredictedPerLOC","PredictedPerCC"),
       lty = c(1,1,1,1),lwd = c(1.5,1.5,1.5,1.5),col = c("black","red","blue","dark green"),cex=0.7)

lines(percentLOC,percentBugs,type="o",col="black",lwd = 1.5,pch=".",cex=0.8)


# Not use, but standard method
tsoutliers <- function(x)
{
  # Standard method based on IQR
  # http://stats.stackexchange.com/questions/1142/simple-algorithm-for-online-outlier-detection-of-a-generic-time-series
  x <- as.ts(x)
  tt <- 1:length(x)
  resid <- residuals(loess(x ~ tt))
  resid.q <- quantile(resid,prob=c(0.25,0.75))
  iqr <- diff(resid.q)
  limits <- resid.q + 1.5*iqr*c(-1,1)
  score <- abs(pmin((resid-limits[1])/iqr,0) + pmax((resid - limits[2])/iqr,0))
  return(score)
}

outliers.iqr <- function(x){
  #deltas <- c(1,1,1,1,1,1,10,1,1,1,1,10,1,1,1)
  # ok

  #deltas <- c(27175,  1613,  2075,  9607,  1037,  497)
  # only detects the first one :(

  sequence <- deltas
  q.25.75 <- quantile(sequence, c(0.25, 0.75))
  iqr <- diff(q.25.75)
  limits <- q.25.75 + 1.5*iqr*c(-1,1)
  score.outlier.sup <- pmax((sequence - limits[2])/iqr,0)
  return(score.outlier.sup)
}

outliers.bertrand.seq <- function(x){
  # Outlier if it is 1.5 times higher than the maximum previous value
  # in the window from the last outlier until now
  x <- c(1,1,1,1,1,1,10,1,1,1,1,10,1,1,1)
  x <- c(27175,  1613,  2075,  9607,  1037,  497)
  # does not detect the first and therefore sets the maximum too high :(

  outliers <- c()
  scores<- rep(NA, length(x))
  window.init <- 1
  pos <- 2
  while(pos<length(x)){
    sequence <- x[window.init:(pos-1)]
    score <- x[pos]/(1.5*max(sequence))
    scores[pos] <- score

    cat("\ninit position:", window.init)
    cat("\nlast position: ", pos-1)
    cat("\nposition:", pos)
    cat("\nin-window sequence: ", sequence)
    cat("\nnew sample:", x[pos])
    cat("\nmax delta:", 1.5*max(sequence))
    cat("\nscore: ", score)
    if(score>1){
      cat('\n*******outlier')
      outliers <- c(outliers, pos)
      window.init <- pos+1
      pos <- window.init + 1
    }
    else{
      pos <- pos+1
    }
    readline("next...")

  }
  par(mfrow=c(2,1))
  plot(x)
  plot(scores)
  return(scores)
}

outliers.bertrand <- function(x){
  # Outlier if it is 1.5 times higher than the maximum previous value
  # in the window from the last outlier until now
  x <- c(1,1,1,1,1,1,10,1,1,1,1,10,1,1,1)

  x <- c(1,1,1,1,1,1,10,1,1,1,1,100,1,1,1)
  # :( 100 makes the 10 to look like normal
  x <- c(27175,  1613,  2075,  9607,  1037,  497)

  outliers <- c()

  score <- x/max(x)
  scores[pos] <- score

  cat("\ninit position:", window.init)
  cat("\nlast position: ", pos-1)
  cat("\nposition:", pos)
  cat("\nin-window sequence: ", sequence)
  cat("\nnew sample:", x[pos])
  cat("\nmax delta:", 1.5*max(sequence))
  cat("\nscore: ", score)

  par(mfrow=c(2,1))
  plot(x)
  plot(scores)
  return(scores)
}

############################################
# Miercoles. Con bayes factor
#############################################
outlier.bayes <- function(deltas){

  deltas <- c(1,1,1,1,1,1,10,1,1,1,1,10,1,1,1)
  deltas <- c(27175,  1613,  2075,  9607,  1037,  497)
  deltas <- c(0,  0,  2075,  0,  0,  0)
  deltas <- c(26678,  1116,  1578,  9110,   540,     0)
  deltas <- c(0, 0.041832, 0.0591, 0.3414, 0.0202, 0)

  outliers <- c()
  bayes.factors <- rep(NA, length(deltas))
  alpha <- 1/mean(deltas)
  beta <- 1

  window.init <- 1
  pos <- 2
  while(pos<length(deltas)){
    sequence <- deltas[window.init:(pos-1)]
    delta.new <- deltas[pos]
    cat("\ninit position:", window.init)
    cat("\nlast position: ", pos-1)
    cat("\nposition:", pos)
    cat("\nin-window sequence: ", sequence)
    cat("\nnew sample:", delta.new)
    m <- mean(sequence)
    n <- length(sequence)
    p <- log(alpha+n) +
      (alpha+n)*log(beta + n*m) -
      (alpha+n+1)*log(beta + n*m + delta.new)
    p.prior <- log(alpha) +
      (alpha)*log(beta) -
      (alpha+1)*log(beta + delta.new)

    # if outlier, store it and re-start the sequence in the next point
    bayes.factors[pos] <- exp(p.prior-p)
    cat("\nprobability from prior: ", p.prior)
    cat("\nprobability from window: ", p)
    cat("\nbayes factor ", exp(p.prior-p))
    if(exp(p.prior-p)>2){
      cat("\noutlier, better explained by the base prior")
      outliers <- c(outliers, i)
      window.init <- pos+1
      pos <- window.init + 1
    }
    else{
      pos <- pos+1
    }
    #readline("next...")
  }
  par(mfrow=c(2,1))
  plot(deltas)
  plot(bayes.factors)
}

dates <- c(1408917425, 1408944600, 1408946213, 1408948288, 1408957895, 1408958932, 1408959429)
deltas <- diff(dates)

#deltas/median(deltas)

scores <- tsoutliers(dates)

outlier.bayes(deltas)

outliers.iqr
outliers.bertrand.seq
outliers.bertrand
outlier.bayes