#                            mantel
#--------------------------------------------------------------------------
print("summary")

rm(list = ls())

library(vegan)
library(pbdMPI, quiet = TRUE)

# Initial Parameters given by the user
args <- commandArgs(trailingOnly = TRUE)
dist1 <- args[1] # The name of the first (community) csv file. Not transposed
dist2 <- args[2] # The name of the second (community) csv file. Not transposed
datasetPath <- args[3] # The directory (path) where the datasets are stored
method <- args[4] # by default is "pearson"
permutations <- as.numeric(args[5])
na.rm <- args[6]

#setwd("/home/varsos/R-3.1.1/Datasets/Christina_dataset")
setwd(datasetPath)

#xdis <- dist1;#vegdist(t(read.csv(dist1, header = TRUE, row.names = 1 ,sep = ",")))
#ydis <- dist2;#vegdist(t(read.csv(dist2, header = TRUE, row.names = 1 ,sep = ",")))

xdis <- get(load(dist1));
ydis <- get(load(dist2));

init()

processors <- comm.size()
myrank <- comm.rank()

#xdis <- as.dist(xdis)
#ydis <- as.vector(as.dist(ydis))
if (na.rm) {
  use <- "complete.obs"
} else use <- "all.obs"
statistic <- cor(as.vector(xdis), ydis, method = method,
                 use = use)
variant <- match.arg(method, eval(formals(cor)$method))
variant <- switch(variant, pearson = "Pearson's product-moment correlation",
                  kendall = "Kendall's rank correlation tau", spearman = "Spearman's rank correlation rho",
                  variant)
N <- attr(xdis, "Size")
#!#!#!#!#!#!#!#!#!#!#!#!#
if (length(permutations) == 1) {
  if (permutations > 0) {
#    arg <- if (missing(strata))
#      NULL
#    else strata
    arg <- NULL
    if(myrank != (processors - 1)){
      permat <- t(replicate((permutations/processors), permute::shuffle(N)))
    } else permat <- t(replicate(permutations - ((processors - 1)*ceiling(permutations/processors))
                                 , permute::shuffle(N)))
  }
} else {
  if(myrank != (processors - 1)){
    permat <- as.matrix((permutations/processors))
    if (ncol(permat) != N)
      stop(gettextf("'permutations' have %d columns, but data have %d observations",
                    ncol(permat), N))
    permutations <- nrow((permutations/processors))
  } else {
    Asd <- permutations - ((processors - 1)*ceiling(permutations/processors))
    permat <- as.matrix(Asd)
    if (ncol(permat) != N)
      stop(gettextf("'permutations' have %d columns, but data have %d observations",
                    ncol(permat), N))
    permutations <- nrow(Asd)
  }
}

if (permutations) {
  if(myrank != (processors - 1)) {
    perm <- numeric((permutations/processors))
    xmat <- as.matrix(xdis)
    asdist <- row(xmat) > col(xmat)
    ptest <- function(take, ...) {
      permvec <- (xmat[take, take])[asdist]
      drop(cor(permvec, ydis, method = method, use = use))
    }
    perm <- sapply(1:(permutations/processors), function(i, ...) ptest(permat[i,
                                                                              ], ...))
    signif <- (sum(perm >= statistic) + 1)/((permutations/processors) +
                                              1)
  } else {
    Asd <- permutations - ((processors - 1)*ceiling(permutations/processors))
    perm <- numeric(Asd)
    xmat <- as.matrix(xdis)
    asdist <- row(xmat) > col(xmat)
    ptest <- function(take, ...) {
      permvec <- (xmat[take, take])[asdist]
      drop(cor(permvec, ydis, method = method, use = use))
    }
    perm <- sapply(1:Asd, function(i, ...) ptest(permat[i,
                                                        ], ...))
    signif <- (sum(perm >= statistic) + 1)/(Asd + 1)
  }
} else {
  signif <- NA
  perm <- NULL
}
# finalize()
#!#!#!#!#!#!#!#!#!#!#!#
# res <- list(call = as.call(list(quote(mantel), quote(dist1), quote(dist2), method = method,
#                                permutations = permutations)), method = variant, statistic = statistic,
#            signif = signif, perm = perm, permutations = permutations)

res <- list(call = match.call(definition = function(xdis, ydis, method, permutations)NULL,
          quote(mantel(xdis, ydis, method, permutations))), method = variant,
		  statistic = statistic, signif = signif, perm = perm, permutations = permutations)
# if (!missing(strata)) {
#  res$strata <- deparse(substitute(strata))
#  res$stratum.values <- strata
# }

class(res) <- "mantel"
comm.print(res)

# Stop the clock
# comm.print("Full program execution time for each processor",rank.source = 0)
# comm.print(proc.time() - fullProgramTimer, all.rank=T)
finalize()
#}


library(raster)
library(watershed)
library(sf)
library(units)

data("kamp_dem")
kamp = delineate(kamp_dem)

kv = vectorise_stream(kamp[["stream"]])
par(mar=c(4,4,4,4))

xl = c(4679000, 4689000) + 5000 * c(-1, 1)
yl = c(2835000, 2846000) + 5000 * c(-1, 1)
plot(kamp_dem, col=terrain.colors(20), axes = TRUE, xlim=xl, ylim=yl)
plot(st_geometry(kv), col='blue', add = TRUE)
rect(4675000, 2835000, 4689700, 2846300, border='red')

kamp_dem_sm = crop(kamp_dem, raster::extent(c(4675000, 4689700, 2835000, 2846300)))
saveRDS(kamp_dem_sm, "inst/testdata/kamp_dem_sm.rds")

kamp_sm = delineate(kamp_dem_sm)
## warning - a topological error. we can kill this
Tp = pixel_topology(kamp_sm)

kv_sm = vectorise_stream(kamp_sm[["stream"]])

plot(kamp_dem_sm, col=terrain.colors(20), axes = FALSE)
plot(st_geometry(kv_sm), col='blue', add = TRUE)

## prep some data for hydrology test
ca = catchment(kamp_sm, type='reach')
kv_sm$ca = ca[kv_sm$reach_id]

data(kamp_q)
kamp_q2 = st_snap(kamp_q, kv, tolerance=100)
plot(kamp_dem_sm, col=terrain.colors(20), axes = FALSE)
plot(st_geometry(kv_sm), col='blue', add = TRUE)
plot(kamp_q, col='cyan', add=TRUE)
plot(kamp_q2, col='red', add=TRUE)

## save the other intermediate calculations
kamp_sm = readAll(kamp_sm)
saveRDS(kamp_sm, "inst/testdata/kamp_sm.rds")
saveRDS(kv_sm, "inst/testdata/kv_sm.rds")

## some points get duplicated, add a point ID to eliminate them
kamp_q2$id = 1:nrow(kamp_q2)
kamp_q2 = st_intersection(kamp_q2, kv_sm)
kamp_q2$id
kamp_q2 = kamp_q2[!duplicated(kamp_q2$id),]
units(kamp_q2$ca) = "m^2"
saveRDS(kamp_q2, "inst/testdata/kamp_q_sm.rds")


#getting hierarchical means c/p/s
rm(list=ls())
library(runjags)

#### pseudo-data generation ####
#4 sites with their own means and standard deviations.
site_mu <- c(20,30,19,12)
site_sd <- c(2,4,2,1)
siteID <- c(LETTERS[1:4])

#specify number of plots per site and number of cores per plot.
n.plot <- 20
n.core <- 30

plots <- list()
for(i in 1:length(site_mu)){
  plot_mu <- rnorm(n.plot,site_mu[i],site_sd[i])
  plots[[i]]  <- plot_mu
}
plot_mu <- unlist(plots)
plotID <- list()
for(i in 1:length(siteID)){
    plots <- vector(length = n.plot)
    for(k in 1:n.plot){
      plots[k] <- paste0(siteID[i],'_',k)
    }
  plotID[[i]] <- plots
}
plotID <- unlist(plotID)
siteID <- substring(plotID,1,1)
dat <- data.frame(siteID,plotID,plot_mu)

core_sd <- 1
cores <- list()
for(i in 1:length(plot_mu)){
  core_mu <- rnorm(n.core,plot_mu[i],core_sd)
  cores[[i]] <- core_mu
}
core_mu <- unlist(cores)
coreID <- list()
for(i in 1:length(plotID)){
  cores <- vector(length=n.core)
  for(k in 1:n.core){
    cores[k] <- paste0(plotID[i],"_",k)
  }
  coreID[[i]] <- cores
}
coreID <- unlist(coreID)
plotID <- sub('_([^_]*)$', '', coreID)
siteID <- substring(plotID,1,1)
dat <- data.frame(core_mu,coreID,plotID,siteID)

#### specify JAGS model ####
jags.model = "
model {
  #get plot level means
  for(i in 1:N.core){
    core_mu[i] ~ dnorm(plot_mu[core_plot[i]], tau.plot[core_plot[i]])
  }

  #get site level means.
  for(i in 1:N.plot) {
    plot_mu[i] ~ dnorm(site_mu[plot_site[i]], tau.site[plot_site[i]])
  }

  #get global mean and uncertainty.
  for(i in 1:N.site){
    site_mu[i] ~ dnorm(global_mu, tau.glob)
  }

  #Plot level priors
  for(i in 1:N.plot){
    sigma.plot[i] ~ dunif(0, 100)
      tau.plot[i] <- pow(sigma.plot[i], -2)
  }
  #Site level priors
  for(i in 1:N.site) {
    sigma.site[i] ~ dunif(0, 100)
      tau.site[i] <- pow(sigma.site[i], -2)
  }
  #Global level priors
   global_mu ~ dnorm(0,1E-3)
  sigma.glob ~ dunif(0,100)
    tau.glob <- pow(sigma.glob, -2)

}"

#### setup JAGS data object. ####
jags.data <- list(N.core = nrow(dat), N.plot = length(unique(dat$plotID)), N.site = length(unique(dat$siteID)),
                  core_mu = dat$core_mu, core_plot = droplevels(as.factor(dat$plotID)), plot_site = droplevels(as.factor(substring(unique(dat$plotID), 1,1)))
                  )

#### fit JAGS model ####
test <- run.jags(model = jags.model,
                  data = jags.data,
              n.chains = 3,
               monitor = c('site_mu','global_mu'),
                 adapt = 200,
                burnin = 1000,
                sample = 1000)
out <- summary(test)


library(statnet)
library(ergm)
library(sna)
library(coda)
library(network)
#library(VCERGM)
sessionInfo()

set.seed(0)

Ntrems = 2
#create an empty network, the formula defining ergm, sample the ensemble and store in R

load('~/Dropbox/Dynamic_Networks/data/congress_covoting_US/Rollcall_VCERGM.RData')
obsMat_T_R =     list()
estParSS_T_R =    list()
changeStats_T_R = list()
stats_T_R = list()
networks = Rollcall$networks # Networks
attr = Rollcall$attr # Political affiliation
T<-length(Rollcall$networks)
net <- network.initialize(5)

for(t in 1:T){
estParSS_t_R =    list()
changeStats_t_R = list()

net <-network(networks[[t]] , directed = FALSE)
#set.network.attribute(net, 'attr1', attr[[t]])
net %v% 'attr1' <-attr[[t]]
formula_ergm = net ~  edges +  gwesp(alpha = 0.5,fixed = TRUE)  + nodematch('attr1')#  #
#formula_ergm = net ~  triangle + kstar(2)  +   nodematch('attr1')# # edges +  triangle +  kstar(2) +   nodematch('attr1') #  gwesp(decay = 0.5,fixed = TRUE) + gwnsp(decay = 0.5,fixed = TRUE)  # triangle + kstar(2)  +   nodematch('attr1')# + nodematch('attr1') #  gwesp(decay = 0.5,fixed = TRUE) gwdegree(decay = 0.5,fixed = TRUE)# edges  +   kstar(2) #  + nodematch('attr1')  #
obsMat_T_R[[t]] <- as.matrix(net)
tmp <- ergm(formula_ergm,control = control.ergm(init=c(-6,1.5,2.5)))
estParSS_T_R[[t]] <- tmp[[1]]
print(t)
print(estParSS_T_R[[t]])
chStat_t <- ergmMPLE(formula_ergm)
changeStats_T_R[[t]] <- cbind(chStat_t$response, chStat_t$predictor,chStat_t$weights)
stats_T_R[[t]] <- summary(formula_ergm)
}


#!/usr/bin/env Rscript

# Command line argument processing
args <- commandArgs(trailingOnly=TRUE)

if (!require("stringr")){
    install.packages("stringr", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("stringr")
}
if (!require("dplyr")){
    install.packages("dplyr", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("dplyr")
}
if (!require("ggplot2")){
    install.packages("ggplot2", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("ggplot2")
}

### function ###
shannon.entropy <- function(p)
{
  if (min(p) < 0 || sum(p) <= 0)
    return(NA)
  p.norm <- p[p>0]/sum(p)
  -sum(log2(p.norm)*p.norm)
}

input_tpm <- args[1]

### create sirv counts
sirv_tpm = read.table(input_tpm, sep="", comment.char = "", header=T, check.names=FALSE, stringsAsFactors=F)

colnames(sirv_tpm) = str_split_fixed(colnames(sirv_tpm), ".sirv", 2)[,1]
sirv_tpm = as.data.frame(sirv_tpm)
sirv_tpm = subset(sirv_tpm, !grepl("ERCC", gene_id))

rownames(sirv_tpm) = sirv_tpm$transcript_id
sirv_tpm = sirv_tpm[,-c(1,2)]

### calc entropy
samplenum = ncol(sirv_tpm)
sirvnum = nrow(sirv_tpm)
sirv_entropies = c()
for(j in 1:samplenum){
  p <- sirv_tpm[1:sirvnum,j]/sum(sirv_tpm[1:sirvnum,j])
  sirv_entropies[j] <- ifelse(!any(is.na(p)), shannon.entropy(p), -1)
}

plotdata = data.frame(samplename = colnames(sirv_tpm), entropy = sirv_entropies)

### draw barplot

ymax = shannon.entropy(rep(1/sirvnum, sirvnum))

g = ggplot(plotdata, aes(x=samplename,y=entropy)) +
    geom_bar(alpha=0.7, stat="identity") +
    ylim(0, ymax) +
    xlab("Sample")+ylab("Entropy of sirv") +
    #scale_x_discrete(labels=plotdata$x) +
    theme(axis.text.x=element_text(size=6, angle=90, hjust=1), legend.text=element_text(size=8)) +
    ggtitle("Entropy of sirv isoforms")

ggsave(file = "barplot_entropy_of_sirv.pdf", plot=g, dpi=100, width=12, height=5)

# Write rate values to file
outputdata = data.frame(name = plotdata$samplename, entropy=plotdata$entropy)
rownames(outputdata) = outputdata$name
write.csv(outputdata, 'barplot_entropy_of_sirv.csv', quote=FALSE, append=TRUE)

# Printing sessioninfo to standard out
print("Draw plot info:")
sessionInfo()


#Series temporais e analises preditivas - Fernando Amaral

library(forecast)
library(ggplot2)

autoplot(AirPassengers)
previ = stlf(AirPassengers, h=48)
print(previ)
autoplot(previ)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/7.1.Previsao com Decomposicao.r


#movielens data preparation
#laod data
raw_data = read.csv("udata.csv")

ratings = raw_data[,1:3]
movies = read.csv("u.item",sep="|",header=F)
colnames(movies) = c("MovieId","MovieTitle","ReleaseDate","VideoReleaseDate","IMDbURL","Unknown","Action","Adventure","Animation","Children","Comedy","Crime","Documentary","Drama","Fantasy","FilmNoir","Horror","Musical","Mystery","Romance","SciFi","Thriller","War","Western")
movies = movies[,-c(2:5)]

users = read.csv("u.user",sep="|",header=F)
colnames(users) = c("UserId","Age","Gender","Occupation","ZipCode")
users = users[,-c(4,5)]
#basic stats of data
dim(movies)
#[1] 1682   24
dim(users)
#[1] 943   5

#merging user item rating with user profile
ratings = merge(x = ratings, y = users, by = "UserId", all.x = TRUE)
ratings = merge(x = ratings, y = movies, by = "MovieId", all.x = TRUE)

names(ratings)

#remove unwanted columns
#ratings = ratings[,-c(4,8:12)]

#conversion to categorical
nrat = unlist(lapply(ratings$Rating,function(x)
{
  if(x>3) {return(1)}
  else {return(0)}
}))
ratings = cbind(ratings,nrat)
#apply(ratings[,-c(1:3,23)],2,function(x)table(x))
scaled_ratings = ratings[,c(8:NCOL(ratings)-1)]
#ratings$Rating = as.factor(ratings$Rating)
ratings$Gender = factor(ratings$Gender,levels=c("0","1"))
ratings$NAge = scale(ratings$Age)
#ratings = ratings[,-4]
names(scaled_ratings)
#scaled_ratings = scale(ratings[,-c(1,2)])

#build models
'library(caret)
control <- trainControl(method="repeatedcv", number=10, repeats=1)
set.seed(7)
modelKNN <- train(Rating~., data=ratings[,-c(1,2)], method="knn",metric="Accuracy", trControl=control)
'
'k-Nearest Neighbors

100000 samples
22 predictor
5 classes: "1", "2", "3", "4", "5"

No pre-processing
Resampling: Cross-Validated (5 fold)
Summary of sample sizes: 80000, 80000, 80000, 80000, 80000
Resampling results across tuning parameters:

k  Accuracy  Kappa      Accuracy SD  Kappa SD
5  0.35001   0.1001631  0.003126380  0.003737368
7  0.35419   0.1022643  0.001690192  0.001714554
9  0.35468   0.1001364  0.003435586  0.004281009

Accuracy was used to select the optimal model using  the largest value.
The final value used for the model was k = 9.
'
#scaled_ratings=scale(scaled_ratings[,-c(1,2,21)])
scaled_ratings = scale(scaled_ratings)
scaled_ratings = cbind(scaled_ratings, ratings[,c('MovieId','UserId','nrat')])
#scaled_ratings = cbind(scaled_ratings,ratings[,c(1,2,23)])
#train test samples
set.seed(7)
which_train <- sample(x = c(TRUE, FALSE), size = nrow(scaled_ratings),
                      replace = TRUE, prob = c(0.8, 0.2))
model_data_train <- scaled_ratings[which_train, ]
model_data_test <- scaled_ratings[!which_train, ]
library(randomForest)
#removes userId and MovieId before fit
fit = randomForest(as.factor(nrat)~., data = model_data_train[,-c(19,20)])
#remove userId and MovieId and actual rating
predictions <- predict(fit, model_data_test[,-c(19,20,21)], type="class")
#predictions <-  predict(fit, model_data_test[,-c(19,20,21)], type="prob")[,2]
cm = table(predictions,model_data_test$nrat)
(accuracy <- sum(diag(cm)) / sum(cm))
(precision <- diag(cm) / rowSums(cm))
recall <- (diag(cm) / colSums(cm))

table(predictions, model_data_test$Rating)

library(pROC)
plot.roc(as.numeric(model_data_test$nrat),as.numeric(predictions))
#create a movie rating matrix

totalMovieIds = unique(movies$MovieId)
nonratedmoviedf = function(userid){
  ratedmovies = raw_data[raw_data$UserId==userid,]$MovieId
  non_ratedmovies = totalMovieIds[!totalMovieIds %in% ratedmovies]
  df = data.frame(cbind(rep(userid),non_ratedmovies,0))
  names(df) = c("UserId","MovieId","Rating")
  return(df)
}
activeusernonratedmoviedf  = nonratedmoviedf(943)
#oneratings = merge(x = onenonratedmoviedf, y = users, by = "UserId", all.x = TRUE)
activeuserratings = merge(x = activeusernonratedmoviedf, y = movies, by = "MovieId", all.x = TRUE)

predictions <- predict(fit, activeuserratings[,-c(1:4)], type="class")
recommend = data.frame(MovieId = activeuserratings$MovieId,predictions)
recommend = recommend[which(recommend$predictions == 1),]
#predList = apply(predictions,1,function(x) if(x[1] > x[2]) return(x[1]) else return(x[2]))

################################################################################
#convert timestamp to local time
ratings_ctx = merge(x = raw_data, y = movies, by = "MovieId", all.x = TRUE)
ts = ratings_ctx$Timestamp
hours <- as.POSIXlt(ts,origin="1960-10-01")$hour
ratings_ctx = data.frame(cbind(ratings_ctx,hours))
UCP  = ratings_ctx[(ratings_ctx$UserId == 943),][,-c(2,3,4,5)]
UCP_pref = aggregate(.~hours,UCP[,-1],sum)
UCP_pref_sc = cbind(context = UCP_pref[,1],t(apply(UCP_pref[,-1], 1, function(x)(x-min(x))/(max(x)-min(x)))))
UCP_pref_content = merge(x = recommend, y = movies, by = "MovieId", all.x = TRUE)

dim(UCP_pref_content)
dim(UCP_pref_sc)

#first recommend movies based on content.
#Take an aggregated weighted matrix per user per time. These will be used as weights
#take recommended movies features (which are binary). Do dot product (sumproduct) for each predictions features * context weights and sum
#sort based on these values to recommend per context
active_user =cbind(UCP_pref_content$MovieId,(as.matrix(UCP_pref_content[,-c(1,2,3)]) %*% as.matrix(UCP_pref_sc[4,2:19])))
active_user_df = as.data.frame(active_user)
names(active_user_df) = c('MovieId','SimVal')
FinalPredicitons_943 = active_user_df[order(-active_user_df$SimVal),]

names(context_df) = c('UserId','hourOfDay')
context_matrix = table(context_df)
context_matrix_sc = t(apply(context_matrix, 1, function(x)(x-min(x))/(max(x)-min(x))))

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


# Explore the difference between the cheapest and most expensive houses

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

# Calculate monthly deciles
midmonth <- function(date) {
  mday(date) <- 15
  date
}
deciles <- ddply(geo, .(date = midmonth(date)), summarise,
  decile = seq_len(9),
  value = quantile(price, seq(0.1, 0.9, by = 0.1), na.rm = T),
  med = median(price),
  .progress = "text")

ggplot(deciles, aes(date, value / 1e6)) +
  geom_line(aes(group = decile, colour = decile)) +
  scale_colour_gradient(low="grey70", high = "grey20") +
  opts(legend.position = "none") +
  xlab(NULL) +
  ylab("Price (millions)")
ggsave(file = "beautiful-data/graphics/decile-raw.pdf", width = 8, height = 4)

# Index
deciles <- ddply(deciles, .(decile), transform, index = value / value[1])
subset(deciles, as.Date(date) == as.Date("2008-11-15"))

# It looks like the most expensive houses have been least affected.  The
# cheapest houses have been most affected.
ggplot(deciles, aes(date, index)) +
  geom_hline(yintercept = 1, colour="grey50") +
  geom_line(aes(group = decile, colour = decile)) +
  scale_colour_gradient(low="grey70", high = "grey20") +
  opts(legend.position = "none") +
  xlab(NULL) +
  ylab("Proportional change in value")
ggsave(file = "beautiful-data/graphics/decile-ind.pdf", width = 8, height = 4)

# Relative to median house price, expensive houses have become more expensive
# and cheaper houses cheaper:  the variation in prices has increased as a
# result of the housing crisis
ggplot(deciles, aes(date, value / med)) +
  geom_line(aes(group = decile, colour = decile)) +
  scale_colour_gradient(low="grey70", high = "grey20") +
  opts(legend.position = "none") +
  xlab(NULL) +
  ylab("Value relative to median house price")

ggsave(file = "beautiful-data/graphics/decile-rel.pdf", width = 8, height = 4)


#' Dual axis plot
#'
#' @description Rescale data with linear scaling, non-linear relationship between variables may cause wrong interpretations
#'
#' @param df data.frame
#'
#' @param x_axis name of the x axis variable
#'
#' @param y_left name of the y axis variable for the left side
#'
#' @param y_right name of the y axis variable for the right side
#'
#' @param y_breaks numeric vector of the y axis left breaks
#'
#' @param col_left name of the color for the left side
#'
#' @param col_right name of the color for the right side
#'
#' @param legend_pos legend position
#'
#' @return ggplot2 object
#'
#' @export
#'
#' @examples
#'
#' x <- seq(0,1,l = 100)
#'
#' y <- cumsum(rnorm(100))
#'
#' z <- y^3 + rnorm(100)
#'
#' data <- tibble(x,y,z)
#'
#' dual_plot(data,"x","y","z")
#'

dual_plot <- function(df,
                      x_axis,
                      y_left,
                      y_right,
                      y_breaks = NULL,
                      col_left = "forestgreen",
                      col_right = "chocolate2",
                      legend_pos = "top",...){

  if(sum(stringr::str_detect(class(df),
                             paste(c("tbl_df","tbl","data.frame","tabyl","grouped_df","data.table"),
                                   collapse = "|"))) ==  0){
    stop("tbl must be a data.frame/tibble")
  }

  if(is.numeric(y_breaks) == F & is.null(y_breaks) == F){
    stop("y_breaks must be numeric")
  }

  df <- na.omit(df[,c(x_axis,y_left,y_right)])

  x <- do.call("c",df[,x_axis])

  y <- unlist(df[,y_left])

  z <- unlist(df[,y_right])

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

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

  max_y <- max(y,na.rm = T)

  min_y <- min(y,na.rm = T)

  if(max(y_breaks) > max_y ){
    stop("max of y_breaks must be <= max of y_left")
  }

  if(min(y_breaks) < min_y ){
    stop("min of y_breaks must be >= min of y_left")
  }

  mult_max <- (max_y-min_y)/5

  if(mult_max < 1){

    max_seq <-  signif(mult_max,digits = 2)

  }else{

    max_seq <-  round(mult_max)

  }

  y2 <- relper::scale01(z,min_y,max_y)

  if(is.null(y_breaks)){

    y1_seq <- relper::mult_seq(y,max_seq)

  }else{

    y1_seq <- y_breaks

  }

  y2_lbl <- relper::num_format(relper::scale01(c(y1_seq,min_y,max_y), min(z), max(z)),2)

  y2_lbl <- y2_lbl[1:length(y1_seq)]

  warning("non-linear relationship between variables may cause misleading rescaling")

  dplyr::tibble(x,y,y2) %>%
    tidyr::gather(var,value,-x) %>%
    dplyr::mutate(var = ifelse(var == "y",y_left,y_right)) %>%
    dplyr::mutate(var = forcats::fct_relevel(var,y_left)) %>%
    ggplot2::ggplot(aes(x,value,col = var))+
    ggplot2::geom_line(size = .8)+
    relper::theme_y()+
    ggplot2::scale_y_continuous(breaks = y1_seq,
                                sec.axis = ggplot2::sec_axis(~., breaks = y1_seq, labels = y2_lbl))+
    ggplot2::theme(axis.text.y.left    = ggplot2::element_text(colour = col_left,  face = "bold"))+
    ggplot2::theme(axis.text.y.right   = ggplot2::element_text(colour = col_right, face = "bold"))+
    ggplot2::scale_color_manual(values = c(col_left,col_right))+
    ggplot2::theme(legend.position = legend_pos)+
    ggplot2::labs(
      y = "",
      col = ""
      )

}


pdf_file<-"pdf/scatterplots_quadrants.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=9)

par(mar=c(4,4,0.5,2),omi=c(0.5,0.5,1,0),family="Lato Light",las=1)
library(RColorBrewer)

# Import data and prepare chart

mydata<-read.csv(file="myData/BetterLifeIndex_Data_2011V6.csv",head=F,
	sep=";",dec=",",skip=6)
mydata<-mydata[2:36,]
attach(mydata)

myX<-as.numeric(V16)
myY<-as.numeric(V15)
myX_des<-"Self-reported Health (Scale from 0 to 100)"
myY_des<-"Life Expectancy"

# Define chart and other elements

plot(type="n",xlab=myX_des,ylab=myY_des,myX, myY,xlim=c(30,90),ylim=c(72,83),axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

myC1<-brewer.pal(5,"PiYG")[5]
myC2<-brewer.pal(5,"PiYG")[4]
myC3<-brewer.pal(5,"PiYG")[1]
myC4<-brewer.pal(5,"PiYG")[2]

myP1<-subset(mydata[c("V2","V16","V15")],myX > mean(myX) & myY > mean(myY))
myP2<-subset(mydata[c("V2","V16","V15")],myX < mean(myX) & myY > mean(myY))
myP3<-subset(mydata[c("V2","V16","V15")],myX < mean(myX) & myY < mean(myY))
myP4<-subset(mydata[c("V2","V16","V15")],myX > mean(myX) & myY < mean(myY))

myN1<-nrow(myP1)
myN2<-nrow(myP2)
myN3<-nrow(myP3)
myN4<-nrow(myP4)

symbols(myP1[,2:3],bg=myC1,circles=rep(1,myN1),inches=0.3,add=T,xpd=T,fg="white")
symbols(myP2[,2:3],bg=myC2,circles=rep(1,myN2),inches=0.3,add=T,xpd=T,fg="white")
symbols(myP3[,2:3],bg=myC3,circles=rep(1,myN3),inches=0.3,add=T,xpd=T,fg="white")
symbols(myP4[,2:3],bg=myC4,circles=rep(1,myN4),inches=0.3,add=T,xpd=T,fg="white")

text(myP2[,2:3],as.matrix(myP2$V2),cex=0.9,pos=1,offset=1.75)
text(myP4[,2:3],as.matrix(myP4$V2),cex=0.9,pos=1,offset=1.75)

abline(v=mean(myX,na.rm=T),col="black",lty=3)
abline(h=mean(myY,na.rm=T),col="black",lty=3)

text(min(V16),mean(V15)+0.005*mean(V15),"high",family="Lato Black",adj=0)
text(min(V16),mean(V15)-0.005*mean(V15),"low",family="Lato Black",adj=0)
text(mean(V16)-0.001*mean(V16),72,"high",family="Lato Black",pos=4)
text(mean(V16)+0.001*mean(V16),72,"low",family="Lato Black",pos=2)

# Titling

mtext("Life Expectancy and Self-reported Health (OECD)",3,adj=0,line=2.5,cex=2.0,family="Lato Black")
mtext("Self-reported Health (scale from 0-100)",3,adj=0,line=0,cex=1.0,font=3)
mtext("Source: oecdbetterlifeindex.org",1,line=4,adj=1,cex=0.95,font=3)
dev.off()


\title{Miscellaneous Mathematical Functions}\name{MathFun}\alias{abs}\alias{sqrt}\keyword{math}\description{
  \code{abs(x)} computes the absolute value of x, \code{sqrt(x)} computes the
  (principal) square root of x, \eqn{\sqrt{x}}.% Details for complex x are below

  The naming follows the standard for computer languages such as C or Fortran.
}\usage{
abs(x)
sqrt(x)
}\arguments{
  \item{x}{a numeric or \code{\link{complex}} vector or array.}
}\details{
  These are \link{internal generic} \link{primitive} functions: methods
  can be defined for them individually or via the
  \code{\link[=S3groupGeneric]{Math}} group generic.  For complex
  arguments (and the default method), \code{z}, \code{abs(z) ==
  \link{Mod}(z)} and \code{sqrt(z) == z^0.5}.

  \code{abs(x)} returns an \code{\link{integer}} vector when \code{x} is
  \code{integer} or \code{\link{logical}}.
}\section{S4 methods}{
  Both are S4 generic and members of the
  \code{\link[=S4groupGeneric]{Math}} group generic.
}\references{
  Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988)
  \emph{The New S Language}.
  Wadsworth & Brooks/Cole.
}\seealso{
  \code{\link{Arithmetic}} for simple, \code{\link{log}} for logarithmic,
  \code{\link{sin}} for trigonometric, and \code{\link{Special}} for
  special mathematical functions.

  \sQuote{\link{plotmath}} for the use of \code{sqrt} in plot annotation.
}\examples{
require(stats) # for spline
require(graphics)
xx <- -9:9
plot(xx, sqrt(abs(xx)),  col = "red")
lines(spline(xx, sqrt(abs(xx)), n=101), col = "pink")


###
# produces intergenerational transition matrices
# of (M,B,C) language repertoires
# across various relationships: mother-child, etc.
# calculates conditional probabilities both ways
# and saves counts and probabilities
# as 3x3 tables
###

rm(list=ls())

source("inread.r")
library(dplyr)
library(tidyr)

# function to produce and write 3x3 matrices
threesquare <- function(biao, outname){
	# assign the proper order to M, B and C
	# add generation labels to lg data
	biao$lxSelf <-
	  factor(biao$lxSelf, levels=c("M", "B", "C"),
		labels=c("M.self", "B.self", "C.self"), ordered=TRUE)
	biao$lxElder <-
	  factor(biao$lxElder, levels=c("M", "B", "C"),
		labels=c("M.elder", "B.elder", "C.elder"), ordered=TRUE)

	# drop rows with missing observations
	biao <- biao[!is.na(biao$lxSelf),]
	biao <- biao[!is.na(biao$lxElder),]

	# count up the cases of each elder-to-kid transition
	# arrange in 3x3 matrix
	transmat1 <-
	  spread(as.data.frame(tally(
	  biao %>% group_by(lxSelf, lxElder))), lxElder, n)
	rownames(transmat1) <- as.character(transmat1$lxSelf)
	transmat1$lxSelf <- NULL
	transmat1[is.na(transmat1)] <- 0

	# row and column totals
	total.elder <- rowSums(transmat1)
	total.self <- c(colSums(transmat1), sum(total.elder))
	transmat1b <-
	rbind(cbind(transmat1, total.elder), total.self)
	rownames(transmat1b) <- c(rownames(transmat1), "total.self")

	# transition probabilities for child, conditioned on elder
	transmat2 <-
	as.data.frame(prop.table(as.matrix(transmat1),margin=2))

	# transition probabilities for elder, conditioned on child
	transmat3 <-
	as.data.frame(prop.table(as.matrix(transmat1),margin=1))

	write.csv(transmat1b,
		file = paste0("analysis/3x3_ct_", outname, ".csv"),
		fileEncoding = "UTF-8")
	write.csv(transmat2,
		file = paste0("analysis/3x3_p_", outname, ".csv"),
		fileEncoding = "UTF-8")
	write.csv(transmat3,
		file = paste0("analysis/3x3_revp_", outname, ".csv"),
		fileEncoding = "UTF-8")
	}

# read in data and rename variables:
# inputs to threesquare() must have
# a column 'lxSelf' and a 'lxElder'
# containing MBC values
mothers <- inread("data/mbc_kid_mom.csv")
fathers <- inread("data/mbc_kid_dad.csv")
grandparents <- inread("data/mbc_kid_gp.csv")
centralparent <- inread("data/mbc_kid_cp.csv") %>%
    select(Subject_Code, self.MBC, avg.elder.MBC) %>%
    rename(lxSelf = self.MBC, lxElder = avg.elder.MBC)

# apply function to each dataset
threesquare(mothers, "mom")
threesquare(fathers, "dad")
threesquare(grandparents, "gp")
threesquare(centralparent, "cp")


source("data_cure_rate_real.r")

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

############
### Unnormalised posterior

compiled.model.unnorm.posterior <- stan_model("stan/cure_rate_posterior_unnormalised.stan")

cr.data.forposterior <- list(
  N0 = N_0,
  P = ncol(X_0),
  X0 = X_0,
  y0 = Y_0_cens,
  Delta0 = Delta_0,
  N = N,
  X = X,
  y = Y_cens,
  Delta = Delta,
  mu_0 = mu0,
  sigma_0 = s0,
  delta_0 = d0,
  tau_0 = tau0,
  sigma_beta = 10,
  eta = eta,
  nu = nu
)

unnorm.posterior.cr <- sampling(compiled.model.unnorm.posterior, data = cr.data.forposterior)
unnorm.posterior.cr
pairs(unnorm.posterior.cr, pars = c("a_0", "beta"))
pairs(unnorm.posterior.cr, pars = c("a_0", "alpha", "lambda"))

### The approximately normalised prior
 J <- 20

constant_data <- read.csv("../data/constant_data/CureRateRealData_logCA0_adaptive.csv")
library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = constant_data)

approx.normalised.model <- stan_model("stan/cure_rate_posterior_normalised_approximate.stan")

Ks <- c(100, 1000, 10000, 20000)

get_posterior_K <- function(K){
  cat("Doing k=", K, "\n")
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  cr.data.forposterior$pred_grid_x <- a0_grid$a0
  cr.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.cr <- sampling(approx.normalised.model,
                                          data = cr.data.forposterior,
                                       control = list(adapt_delta = .95, max_treedepth = 15),
                                       refresh = 0)
  return(approx.norm.posterior.cr)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

all.approximates[[4]]

pairs(all.approximates[[4]], pars = c("a_0", "beta"))
pairs(all.approximates[[4]], pars = c("a_0", "alpha", "lambda"))

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.cr, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.dt <-
  rbind(
    data.frame(a0 = a0.unnorm,
               normalisation = rep("unnormalised", length(a0.unnorm))
    ),
    do.call(rbind, a0.approx.list)
  )

library(ggplot2)

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, eta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Logistic regression") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist

ggsave("../figures/a0_posterior_CureRate_prior2.pdf", a0_dist)

# subset(a0.dt, normalisation != "unnormalised")
a0_dist_norm <- ggplot(a0.dt,
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Logistic regression") +
  scale_y_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist_norm

ggsave("../figures/a0_posterior_CureRate_normalisation_comparison_prior2.pdf", a0_dist_norm)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.cr, 'alpha')$alpha,
        extract(unnorm.posterior.cr, 'lambda')$lambda,
  extract(unnorm.posterior.cr, 'beta')$beta)
)
names(unnorm.pars) <- c("alpha", "lambda", paste("beta[", 1:4, "]", sep = ""))

##

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'alpha')$alpha,
          extract(x, 'lambda')$lambda,
          extract(x, 'beta')$beta
          )
  )
  names(pars) <- c("alpha", "lambda", paste("beta[", 1:4, "]", sep = ""))
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

##

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "unnormalised"

posterior.dt <- rbind(unnorm.dt, do.call(rbind, app.norm.pars.df.list))
posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("unnormalised", paste("K=", Ks, sep = "")) )

###
parameter_posteriors <- ggplot(data = posterior.dt, aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free", labeller = label_parsed) +
  theme_bw(base_size = 16)

parameter_posteriors

ggsave("../figures/parameter_posterior_CureRate_prior2.pdf", parameter_posteriors)


##
## A mechanistic combined toxicokinetic–toxicodynamic (TK/TD) and growth
## model for the aquatic macrophytes Lemna spp. as published by
## Schmitt et al. (2013), DOI: 10.1016/j.ecolmodel.2013.01.017
##
## Parts of the implementation were commented out for reasons of brevity.
##

#library(deSolve)       # Library with ODE-solver
#library(FME)

# This script contains the following functions:

#   calcgrowth(timepoints, vars, param, filenames, graph)   -  To be called for simulation run
#   growthmodel(timepoints, vars, param)                    -  Calls ODE-solver (Called by calcgrowth)

#   growth_ode(t,vars,param)                                -  M O D E L - E Q U A T I O N S !!!!!
#     Supporting functions:
#     P_T(P_up,MolWeight, actTemp)     Temperature dependence of permeability
#     f_R(Rad,k_0,a_k)                 -|
#     f_T(Temp,Topt,Tmax,Tmin)         -|
#     f_T_resp(Temp,t_ref,Q10)         -|
#     f_P(C_P, CP50, a_P, KiP)         -|--  Functions to calculate dependence factors for growth rate
#     f_N(C_N, CN50, a_N, KiN)         -|
#     f_BM(BM, BM50)                   -|
#     f_E(b,EC50,Emax,C_active)        -|
#
#   prepare_param(param,filenames)                           - Loads tables from filenames and includes them in parameter list
#   modeval(result,eff_frac,t_recov)                         -  Calculates endpoint on population level from results

#  For Calculation:     calcgrowth(timepoints, vars, param, filenames,graph=T)

#------- Main function for simulation run --------------------------------------
calcgrowth <- function(timepoints, vars, param, filenames,graph,...)
# !!! CALCGROWTH allways calculates control and treated population !!!
#
# Input:
#  - timepoints: vector with timepoints for output
#  - vars      : named vector with variables of the model
#  - param     : list with parameter values
#  - filenames : vector with names (incl. path) to fiels to be loaded
#  - graph     : logical T/F with/without graphical output
#
# Output:
#  - Dataframe with columes: Time, Dry Biomass Control, Dry Biomass treated, Effect(%),
#                           FrondNo Contro, FrondNo treated, int. Concentration, int. Effect
#
{
# Are data provided as tables? If yes read files and replace parameter value by table
#filenames<-filenames[filenames!='']
#if (length(filenames)!=0) {
#   param <- prepare_param(param, filenames)
#   }

# simulate with effect
result <- growthmodel(timepoints=timepoints, vars=vars,param=param,...)
result$E <- NULL
result$FrondNo <- result[,"BM"]/param$mass_per_frond
# control simulation
#param_cont <- param
#param_cont$Conc <- 0    # Prepare control simulation
#result_cont <- growthmodel(timepoints=timepoints, vars=vars,param=param_cont)

#out<-cbind(   Time          =result[,"time"],
#              Control       =result_cont[,"BM"],
#              Treated       =result[,"BM"],
#              Effect        =(result_cont[,"BM"]-result[,"BM"])/result_cont[,"BM"]*100,
#              FrondNo_Cont  =result_cont[,"BM"]/param$mass_per_frond,
#              FrondNo_Treat =result[,"BM"]/param$mass_per_frond,
#              M_int         =result[,"M_int"],
#              C_int         =result[,"C_int"],
#              Eff_int       =result[,"E"]
#              )

# prepare plot if wanted
#if(graph){
#  windows()
#  plot(out[,'Time'],out[,'Control'],type = "l",xlab='Time [d]',ylab='Biomass [g_dw/m?')
#  lines(out[,'Time'],out[,'Treated'],type = "l",col="red")
#  if (!is.null(param$obsdat)) {points(param$obsdat)}
#  }

return(result)
}

#------ Function that calls ODE-solver -----------------------------------------
growthmodel <- function(timepoints, vars, param, hmax=.1) {
with(as.list(c(vars,param)),{

#plot(0,0,xlim=c(0,max(timepoints)),ylim=c(0,200))

# Solve ODE
out <- as.data.frame(deSolve::ode(y = vars, times = timepoints, func = growth_ode, parms = param, hmax=hmax))
#colnames(out)[4] <- 'C_int'

# Conversion: internal mass -> internal concentration
out[,'C_int'] <- out[,'M_int']/(out[,'BM']*param$BMw2BMd)

return(out)
})
}

# ************  M O D E L - E Q U A T I O N S **********************************
# ODE System and related equations
growth_ode <- function(t,vars,param){
# vars (= Variables of the model) contains:
# BM        [g/m?]      Biomass (is converted into No of individuals at the end
# E         (Toxic)     Effect = Factor on growth rate  (Range: 0 - 1)
# M_int     [?g]        Mass of toxicant in biomass

# Parameters and their units:

#      - Fate of biomass -
#k_phot_fix  T/F         If True k_phot_max is not changed by environmental factors
#k_phot_max  [1/d]       Photosynthesis rate
#k_resp   [1/d]       Respiration rate
#k_loss   [1/d]       Some rate of loss (e.g. Flow rate)
#
#      - Effect -
#Conc     [any]      Concentration of toxicant (may also be a table)
#TDMod    ['direct' or 'delayed'] Kind of model to be used
#Emax     [-]         maximum Effect
#EC50     [same as conc. data]      Midpoint of effect curve
#b        [-]         Slope of effect curve
#k_E_in   [1/d]       Rate of effect effect increase (delayed TD model)
#k_E_out  [1/d]       Rate of effect effect decline
#
#       - Toxicokinetics -
#P_up     [cm/d]      Permeability for uptake
#AperBM   [cm?/g_dw]  A_leaf / d_leaf = 1/d_leaf (for circular disc, d=0.05 cm)
#Kbm      []          Biomass(fw):water partition coefficient
#P_Temp   T/F         Switch for temperature dependence of cuticle permeability
#MolWeight [g/mol]    Molmass of molecule (determines Q10_permeability)
#
#      - Others -
#mass_per_frond     [g_dw/frond]  Dryweight per frond
#BMw2BMd            [g_fresh/g_dry]  Fresh- / dryweight
#
#      - Temperatur dependence -
# k_photrowth  (!!values depend on temp. dependence of k_resp!!)
#Temp     [?C]        Current temperature (may also be a table)
#Tmin     [?C]        Minimum growth temperature
#Tmax     [?C]        Maximum growth temperature
#Topt     [?C]        Optimum growth temperature
#
# k_resp
#t_ref     Temperature at which k_resp is effective
#Q10
#
#
#      - Light dependence (linear dependence on global radiation (see Hodgeson 1969)
#Rad 	    [kJ/m?/d]  Radiation  (may also be given as table)
#k_0     	[1/d]      Intercept of linear part
#a_k     	[(1/d)/(kJ/m?/d)]        Slope of linear part
#
#
#      - Phosphorus dependence (Hill like dependence) -
#C_P      [mg/L]       Phosporus concentration in water
#CP50     [mg/L]       P-conc. where growth rate is halfened   [Ref. F 0191, data re-evaluated with Hill-Model]
#a_P      []            Hill coefficient                       [Ref. F 0191, data re-evaluated with Hill-Model]
#KiP      [mg/L]       P-inhibition constant for very high P-conc.   [Ref. F 0191]
#
#      - Nitrogen dependence (Hill like dependence) -
#C_N      [mg/L]       Nitrogen concentration in water
#CN50     [mg/L]       N-conc. where growth rate is halfened   [Ref. F 0191, data re-evaluated with Hill-Model]
#a_N      []            Hill coefficient                       [Ref. F 0191, data re-evaluated with Hill-Model]
#KiN      [mg/L]       n-inhibition constant for very high P-conc.   [Ref. F 0191]
#
#      - Density dependence -
#BM50     [g_dw/m?]             Cut off BM   [Ref. F 0191]
#

# Default values
TDMod = 'direct'
k_E_in=100
k_E_out=100

with(as.list(c(vars,param)),{
# Determine actual values at timepoints t from tables
if(!is.null(dim(Conc))) {
  actConc <- approx(Conc,y=NULL,t,rule=2)     # Linear interpolation if is table
  actConc <- actConc$y
}
else
  {actConc <- Conc}

if(!is.null(dim(Temp))) {
  actTemp <- approx(Temp,y=NULL,t,rule=2)     # Linear interpolation if is table
  actTemp <- actTemp$y }
else
  {actTemp <- Temp}

if(!is.null(dim(Rad))) {
  actRad <- approx(Rad,y=NULL,t,rule=2)     # Linear interpolation if is table
  actRad <- actRad$y }
else {
  if(Rad>0){actRad <- Rad}
  else{actRad <- calcRad(t,Lat)}
  }

#points(t,BM)

# Calculate internal toxicant concentrations from amount in biomass
BM_fresh <- BM*BMw2BMd
C_int <- M_int/BM_fresh
C_int_u <- abs(C_int/Kbm)   # Unbound internal concentration

# Calculate effective growth rate
if(!k_phot_fix){
  k_phot_eff <- k_phot_max * f_R(actRad, k_0, a_k)
  k_phot_eff <- k_phot_eff * f_T(actTemp,Topt,Tmax,Tmin)
  k_phot_eff <- k_phot_eff * f_P(C_P, CP50, a_P, KiP) * f_N(C_N, CN50, a_N, KiN)
  k_phot_eff <- k_phot_eff * f_BM(BM, BM50)
  k_resp_eff <- k_resp*f_T_resp(actTemp,t_ref,Q10)
}else{
  k_phot_eff <- k_phot_max
  k_resp_eff <- k_resp
}

# Consider toxic effect
f_Eff <- f_E(b,EC50,Emax,C_int_u)
if(TDMod=='delayed'){f_Eff <- E}  # delayed effects could be considered
k_phot_eff <- k_phot_eff*f_Eff

# Biomass
dBMdt <- BM*(k_phot_eff-k_resp_eff-k_loss)
# let population extinct if less than one frond/m?
if(BM<5*mass_per_frond){dBMdt <- 0}

# Effect  (this is the delayed TD model)
dEdt <- k_E_in*f_E(b,EC50,Emax,C_int_u) - k_E_out * E

# TK part: Internal amount of toxicant
P_up_eff = P_up
if(P_Temp){P_up_eff = P_T(P_up,MolWeight, actTemp)}   # Temperature dependence of permeability
dM_intdt <- P_up_eff*AperBM*BM*(actConc-C_int_u) - C_int*BM_fresh*(k_resp_eff+k_loss)

return(list(c(dBMdt, dEdt, dM_intdt)))
})
}

# Calculation of temperature dependent permeability
P_T <- function(P_up,MolWeight, actTemp)
{
Eact <- 0.307*MolWeight/1.4+95          # Activation energy
Q10perm <- exp(10*Eact/0.008314/300^2)   # see Baur Publication 7
return(P_up * Q10perm^((actTemp-20)/10))
}

# Functions for calculating reduction factors for growth rate

# Light
f_R <- function(actRad, k_0, a_k)
{
photfac <- a_k*actRad + k_0
if(photfac >1){photfac=1}
return(photfac)
}

# Temperature
# effect on k_phot
f_T <- function(actTemp,Topt,Tmax,Tmin)
{
Tx<-Tmax
if(actTemp<=Topt){Tx<-Tmin}
return(exp(-2.3*((actTemp-Topt)/(Tx-Topt))^2))
}
# effect on k_resp
f_T_resp <- function(actTemp,t_ref,Q10)
{
Q10^((actTemp-t_ref)/10)
}

# Phosphorus
f_P <- function(C_P, CP50, a_P, KiP)
{
C_P^a_P/(C_P^a_P + CP50^a_P) * KiP/(KiP + C_P)
}

# Nitrogen
f_N <- function(C_N, CN50, a_N, KiN)
{
C_N^a_N/(C_N^a_N + CN50^a_N)* KiN/(KiN + C_N)
}

# Biomass (crowding)
f_BM <- function(BM, BM50)
{
fact<-(BM50 - BM)/BM50
return(fact)
}

# Effect
f_E <- function(b,EC50,Emax,C_active)
{
1-Emax*C_active^b/(EC50^b+C_active^b)
}

#******************************************************************************

#------- Function for reading input files --------------------------------------
# prepare_param <- function(param,filenames)
# # Reads files with input information and add respective tables to parameters
# {
# nam <- names(filenames)
# for (i in (1:NROW(nam))) {
#   nam_i <- nam[i]
#   content <- read.delim(filenames[i], header=T)
#   if(sum(nam_i=='Data_file')>0) {param$obsdat <- content}
#     else {param$obsdat = NULL}
#   if(sum(nam_i=='Conc_file')>0) {param$Conc <- content}
#   if(sum(nam_i=='Temperature_file')>0) {param$Temp <- content}
#   if(sum(nam_i=='Irradiation_file')>0) {param$Rad <- content}
#   }
# return(param)
# }

#------- Evaluation of simulation results --------------------------------------
#modeval <- function(result,control,eff_frac,t_recov){
# Calculates: Maximum Effect, Period of Effect (Time to Recovery) and Effect remaining after t_recov
# Input:
#   result:   Biomass treated
#   control:  Biomass control
#   eff_frac: Maximum relativ deviation from control that is NO effect
#   t_recov:  Time after onset of effect at which remaining effect is determined
#
# Output:
#   MaxEff:     Maximum Effect (%control)
#   E_trecov:   Effect remaining at t_recov after onset
#   t_recov:    Period of Effect (time between onset and disappearence)
#   AuEffCurve: Area under effect curve
#
#
# n_times <- NROW(result)
#
# calcEff <- (control[,'BM']-result[,'BM'])/control[,'BM'] # effect as fraction
#
# # Initialisation of variables
# maxeff_tot<-0
# maxeff_rec<-0
# maxeff<-0
# maxeff_tot_r<-0
# maxeff_rec_r<-0
# maxeff_r<-0
# teff_max<-0
# teff_max_tot<-0
# teff_max_r<-0
# teff_max_tot_r<-0
# AuEC <- 0
# AuEC_tot <- 0
#
# # Evaluation on basis of accumulated values
# t1<-0
# t2<-0
# t1_r<-0
# t2_r<-0
# for (i in (1:n_times)) {
# # do evaluation for biomass
#    if(calcEff[i]>eff_frac){
#       if(t1==0){t1<-result[i,'time']}
#       t2<-result[i,'time']
#       if(calcEff[i]>maxeff){maxeff<-calcEff[i]}    # determin Max. Effect
#       if((t2-t1)>t_recov && calcEff[i]>maxeff_rec){maxeff_rec<-calcEff[i]}
#       if((t2-t1)>teff_max){teff_max<-(t2-t1)}    # determin period of effect
#       AuEC <- AuEC+(calcEff[i]+calcEff[i-1])/(2*(result[i,'time']-result[i-1,'time']))  # determine area under effect curve
#       }
#    else{
#       if(maxeff>maxeff_tot){maxeff_tot<-maxeff}
#       if(teff_max>teff_max_tot){teff_max_tot<-teff_max}
#       if(AuEC>AuEC_tot){AuEC_tot<-AuEC}
#       maxeff<-0
#       teff_max<-0
#       t1<-0
#       t2<-0
#       }
#   }
#
# # repeat this in order to capture effects at end of calculation period
# if(t2>0 && calcEff[i]>maxeff_rec){maxeff_rec<-calcEff[i]}
# if(maxeff>maxeff_tot){maxeff_tot<-maxeff}
#
#
# result <- c(
# MaxEff        =  maxeff_tot*100, # Maximum Effect (%control)
# E_trecov      =  maxeff_rec,     # Effect remaining at t_recov after onset
# t_recov       =  teff_max_tot,   # Period of Effect (time between onset and disappearence)
# AuEffCurve    =  AuEC_tot)       # Area under effect curve
#
# return(result)
# }


# Script for filtering temporal outliers and extracting harmonic metrics

library(probaV)
library(pbapply)
#library(foreach)
library(sf)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/ProbaVDataDirs.r")

HarmonicsOutputDB = "../data/pixel-based/timeseries/harmonics.gpkg"
InputDB = "../data/pixel-based/timeseries/timeseries-cloudfree.gpkg"

#TileList = GetTileList(LoadGlobalRasterPoints())
Dates = LoadRawDataDirs()$date
ColDates = paste0("X", gsub("-", "", Dates))

# TODO: move to utils
phaser = function(co, si)
{
    tau = 2*pi
    return(atan2(si, co) %% tau)
}
amplituder = function(co, si)
{
    return(sqrt(co^2 + si^2))
}

NDVISF = st_read(InputDB, "NDVI")

GetHarmonics = function(TS)
{
    if (all(is.na(TS)))
    {
        c(min=NA, max=NA, intercept=NA, co=NA, si=NA, co2=NA, si2=NA, trend=NA,
                    phase1=NA, amplitude1=NA, phase2=NA, amplitude2=NA)
    } else {
        HarmCoefs = getHarmMetrics(TS, dates=Dates, order=2)
        p1 = phaser(HarmCoefs["co"], HarmCoefs["si"])
        p2 = phaser(HarmCoefs["co2"], HarmCoefs["si2"])
        a1 = amplituder(HarmCoefs["co"], HarmCoefs["si"])
        a2 = amplituder(HarmCoefs["co2"], HarmCoefs["si2"])
        c(HarmCoefs, phase1=p1, amplitude1=a1, phase2=p2, amplitude2=a2)
    }
}

HarmMetrics = t(pbapply(as.matrix(as.data.frame(NDVISF)[,ColDates]), 1, GetHarmonics))
HarmMetrics = cbind(NDVISF[, c("X", "Y")], HarmMetrics)
names(HarmMetrics)[3:(length(HarmMetrics)-1)] = c(
    "min", "max", "intercept", "co", "si", "co2", "si2", "trend", "phase1", "amplitude1", "phase2", "amplitude2")

st_write(HarmMetrics, HarmonicsOutputDB)


# --- Day 1: Report Repair ---
# After saving Christmas five years in a row, you've decided to take a vacation
# at a nice resort on a tropical island. Surely, Christmas will go on without
# you.
#
# The tropical island has its own currency and is entirely cash-only. The gold
# coins used there have a little picture of a starfish; the locals just call
# them stars. None of the currency exchanges seem to have heard of them, but
# somehow, you'll need to find fifty of these coins by the time you arrive so
# you can pay the deposit on your room.
#
# To save your vacation, you need to get all fifty stars by December 25th.
#
# Collect stars by solving puzzles. Two puzzles will be made available on each
# day in the Advent calendar; the second puzzle is unlocked when you complete
# the first. Each puzzle grants one star. Good luck!
#
# Before you leave, the Elves in accounting just need you to fix your expense
# report (your puzzle input); apparently, something isn't quite adding up.
#
# Specifically, they need you to find the two entries that sum to 2020 and then
# multiply those two numbers together.
#
# For example, suppose your expense report contained the following:
#
# 1721
# 979
# 366
# 299
# 675
# 1456
#
# In this list, the two entries that sum to 2020 are 1721 and 299. Multiplying
# them together produces 1721 * 299 = 514579, so the correct answer is 514579.
#
# Of course, your expense report is much larger. Find the two entries that sum
# to 2020; what do you get if you multiply them together?

x <- scan("input.txt", 0)
for (i in seq(along = x)) {
  j <- which(x[i] + x == 2020)
  if (length(j) > 0) {
    print(x[i] * x[j])
    quit()
  }
}


## Pacman Residual Plot
plots5 	<- function(..., overcast=args$overcast){
    if(!overcast){
        exp_reg 	<- exp_regression(atemp_am, avg)
        title 		<- "Pac-Man Residual of the Mean PW and Temperature Model\nCondition: Clear Sky"
    }else{
        exp_reg 	<- exp_regression(atemp_amo, avgo)
        title 		<- "Pac-Man Residual of the Mean PW and Temperature Model\nCondition: Overcast"
    }
    # residual quantities from the regression model
    residual 	<- abs(resid(exp_reg$model))
    # sequence used for angular position
    t 			<- seq(40, 320, len=length(residual))
    # Maximum radial distance
    rmax 		<- max((residual), na.rm=TRUE)
    # 6 equal divisions
    divs 		<- seq(round(min(residual)), round(max(residual)), len=6)
    # Plots the residual against an angular position
    polar.plot(0, rp.type="s",labels="",
    radial.lim=c(0, round(rmax, 0)),show.grid=TRUE, show.grid.labels=FALSE,
    main= title, show.radial.grid=FALSE, grid.col="black")

    # Color Scheme for the rings
    color1 <- "Yellow"; color2 <- "White"
    draw.circle(0, 0, radius=divs[6], col=color1)
    draw.circle(0, 0, radius=divs[5], col=color2)
    draw.circle(0, 0, radius=divs[4], col=color1)
    draw.circle(0, 0, radius=divs[3], col=color2)
    draw.circle(0, 0, radius=divs[2], col=color1)

    polar.plot(residual, t, rp.type="s",point.col="blue",point.symbols=16, add=TRUE)

    text(divs[2] - 0.08, 0, labels=bquote(.(divs[2])*sigma))
    text(divs[3] - 0.1, 0,  labels=bquote(.(divs[3])*sigma))
    text(divs[4] - 0.1, 0,  labels=bquote(.(divs[4])*sigma))
    text(divs[5] - 0.1, 0,  labels=bquote(.(divs[5])*sigma))
    text(divs[6] - 0.1, 0,  labels=bquote(.(divs[6])*sigma))

    polar.plot(c(0, round(rmax, 0)), c(min(t) - 10, min(t) - 10), lwd=1, rp.type="p",line.col="black", add=TRUE)
    polar.plot(c(0, round(rmax, 0)), c(max(t) + 10, max(t) + 10), lwd=1, rp.type="p",line.col="black", add=TRUE)
}


# Background correction
#
# Background correct Cy5/Cy3 signal of a Infinium HumanMethylation450 BeadChip.
#
# @param rg Cy5/Cy3 signal generated by \code{\link{read.rg}()}.
# @param offset Number to add to background corrected signal (Default: 15).
# @param verbose If \code{TRUE}, then status messages are printed during execution (Default: \code{FALSE}).
# @return Background corrected Cy5/Cy3 signal by \code{\link[limma]{normexp.signal}}.
background.correct <- function(rg, probes, offset=15, verbose=F) {
    stopifnot(is.rg(rg))

    for (dye in c("R","G")) {
        msg("background correction for dye =", dye, verbose=verbose)
        addresses <- probes$address[which(probes$target %in% c("M","U") & probes$dye == dye)]
        addresses <- intersect(addresses, rownames(rg[[dye]]))
        if(length(addresses) == 0)
            stop("It seems like the supplied chip annotation does not match the IDAT files.")
        xf <- rg[[dye]][addresses,"Mean"]
        xf[which(xf <= 0)] <- 1

        addresses <- probes$address[which(probes$type == "control" & probes$dye == dye)]
        addresses <- intersect(addresses, rownames(rg[[dye]]))
        if(length(addresses) == 0)
            stop("It seems like the supplied chip annotation does not match the IDAT files.")
        xc <- rg[[dye]][addresses,"Mean"]
        xc[which(xc <= 0)] <- 1

        addresses <- probes$address[which(probes$target == "OOB" & probes$dye == dye)]
        addresses <- intersect(addresses, rownames(rg[[dye]]))
        if(length(addresses) == 0)
            stop("It seems like the supplied chip annotation does not match the IDAT files.")
        oob <- rg[[dye]][addresses,"Mean"]

        bg <- rep(NA, length(xf) + length(xc))
        try({
            ests <- huber.2(oob)
            mu <- ests$mu
            sigma <- log(ests$s)
            alpha <- log(max(huber.2(xf)$mu - mu, 10))
            ## mu = robust median of the oob probes
            ## sigma = log(mad of the oob probes)
            ## alpha = log(robust median of meth/unmeth probes  -  robust median of oob probes)
            ## c(xf,xc) = c(meth/unmeth probes, control probes)
            ## bg <- c(xf,xc) background corrected
            bg <- limma::normexp.signal(as.numeric(c(mu,sigma,alpha)), c(xf,xc)) + offset
        })
        rg[[dye]][c(names(xf), names(xc)), "Mean"] <- bg

    }
    rg
}

huber.2 <- function(x) {
    ret <- tryCatch(MASS::huber(x), error=function(e) e)
    if ("error" %in% class(ret))
        ret <- MASS::huber(x[which(x > min(x,na.rm=T))])
    ret
}


# run: Rscript solution.r

sum = 0;
for(i in 1:1000 - 1) {
    if(i %% 3 == 0 || i %% 5 == 0) {
        sum = sum + i;
    }
}

print(sum);


# plot_ncrf_event_matrix--
#   Plot, one dot per alignment, error events vs alignment length.
#
# The input file is the output of "ncrf_extract_event_matrix --withheader".
# It has a header line and (usually) one row for each alignment;  9 columns
# per row.
#
# typical input:
#   line motif mRatio m    mm  io  ix do  dx
#   1    GGAAT 0.817  873  119 38  0  36  3
#   5    GGAAT 0.815  1665 207 68  0  92  10
#   9    GGAAT 0.816  2776 334 114 0  161 17
#   13   GGAAT 0.82   545  72  17  0  27  4
#   17   GGAAT 0.826  881  97  30  0  50  8
#    ...

plot_ncrf_event_matrix <- function(name,filename,motif=NULL,
                                   xMax=NA,yMax=NA,mainFontSize=0.9,
                                   width=5,height=5.6,newWindow=T,pdfName=NULL)
	{
	dd = read.table(filename,header=T,
	                colClasses=c("integer","character","numeric",
	                             "integer","integer","integer",
	                             "integer","integer","integer"))

	if (!is.null(motif))
		dd = dd[(dd[,"motif"]==motif),]

	dd[,"events"] = dd[,"m"]+dd[,"mm"]+dd[,"io"]+dd[,"ix"]+dd[,"do"]+dd[,"dx"]
	dd.xMax = max(dd[,"mm"],dd[,"io"]+dd[,"ix"],dd[,"do"]+dd[,"dx"])
	dd.yMax = max(dd[,"events"])

	if (is.na(xMax))
		xMax = dd.xMax
	else if (xMax < dd.xMax)
	    warning(paste("xMax=",xMax," hides some points; (actual xMax is ",dd.xMax,")",sep=""))

	if (is.na(yMax))
		yMax = dd.yMax
	else if (yMax < dd.yMax)
	    warning(paste("yMax=",yMax," hides some points; (actual yMax is ",dd.yMax,")",sep=""))

	mmSlope = sum(dd[,"mm"]) / sum(dd[,"events"])
	ioSlope = sum(dd[,"io"]) / sum(dd[,"events"])
	ixSlope = sum(dd[,"ix"]) / sum(dd[,"events"])
	doSlope = sum(dd[,"do"]) / sum(dd[,"events"])
	dxSlope = sum(dd[,"dx"]) / sum(dd[,"events"])

	title = paste("alignment events in",name)
	motifs = unique(dd[,"motif"])
	if (length(motifs) == 1)
		title = paste(title,"\nfor ",motifs[1],sep="")

	alignedBases = sum(dd[,"m"],dd[,"mm"])
	yLab = paste("total events in alignment (m+mm+i+d)",
	             "\n(",format(alignedBases,big.mark=",",trim=T)," bases aligned overall)",sep="")

	if (!is.null(pdfName))
		pdf(file=pdfName,width=width,height=height,pointsize=10)
	else if (newWindow)
		quartz(width=width,height=height)

	legText  = c(paste("mismatch ",format(100*mmSlope,digits=2),"%",sep=""),
	             paste("ins open ",format(100*ioSlope,digits=2),"%",sep=""),
	             paste("ins ext ", format(100*ixSlope,digits=2),"%",sep=""),
	             paste("del open ",format(100*doSlope,digits=2),"%",sep=""),
	             paste("del ext ", format(100*dxSlope,digits=2),"%",sep=""))
	legPch   = c(0,1,3,2,4)
	legColor = c("black","red","green","blue","purple")

	par(mar=c(4.1,5.1,3.1,1.1)) # BLTR
    par(cex.main=mainFontSize)

	plot(dd[,"mm"],dd[,"events"],pch=legPch[1],col=legColor[1],
		 xlim=c(0,xMax),ylim=c(0,yMax),
		 main=title,xlab="errors in alignment",ylab=yLab)
	points(dd[,"io"],dd[,"events"],pch=legPch[2],col=legColor[2])
	points(dd[,"ix"],dd[,"events"],pch=legPch[3],col=legColor[3])
	points(dd[,"do"],dd[,"events"],pch=legPch[4],col=legColor[4])
	points(dd[,"dx"],dd[,"events"],pch=legPch[5],col=legColor[5])
	lines(c(0,mmSlope*yMax),c(0,yMax),lty=2,col=legColor[1])
	lines(c(0,ioSlope*yMax),c(0,yMax),lty=2,col=legColor[2])
	lines(c(0,ixSlope*yMax),c(0,yMax),lty=2,col=legColor[3])
	lines(c(0,doSlope*yMax),c(0,yMax),lty=2,col=legColor[4])
	lines(c(0,dxSlope*yMax),c(0,yMax),lty=2,col=legColor[5])
	legend("bottomright",legend=legText,pch=legPch,col=legColor)

	if (!is.null(pdfName))
		dev.off()
	}

# plot_ncrf_filter_results--
#   Plot, one dot per alignment, accepted/rejected filtering results.
#
# The input file is the output of "error_nonuniformity_filter --report:matrix".
# It has NO header line and one row for each alignment;  2M+2 columns per row,
# where M is the motif length.  Column 1 is the line number of the alignment
# (in the input to error_nonuniformity_filter).  Column 2 is the outcome of the
# test.  Columns 3 thru M+2 are positional match counts for that alignment,
# and columns M+3 thru 2M+2 are the positional error counts.  We assume all
# rows have the same number of columns, i.e. that the same motif length is
# represented in all rows.
#
# typical input:
#   1  rejected     294  298  277  298  296  49  26  70  31  55
#   10 not_rejected 214  222  219  222  219  45  22  33  26  36
#   19 rejected     313  324  311  323  316  70  30  58  31  44
#   28 not_rejected 834  857  826  858  836  154 102 167 119 149
#   37 not_rejected 709  734  701  730  722  156 88  149 91  112
#    ...

plot_ncrf_filter_results <- function(name,filename,motifLength,
                                     width=5,height=5.6,newWindow=T,pdfName=NULL)
	{
	dd = read.table(filename,header=F,
		            colClasses=c("integer","character",rep("integer",2*motifLength)))

	resultCol = 2
	mCol = 3
	xCol = mCol + motifLength
	dd[,"m*"] = rowSums(dd[,mCol:(mCol+motifLength-1)])
	dd[,"x*"] = rowSums(dd[,xCol:(xCol+motifLength-1)])
	dd[,"mRatio"] = dd[,"m*"] / (dd[,"m*"]+dd[,"x*"])

	xMax = max(dd[,"m*"])
	yMax = max(dd[,"x*"])

	accepted = (dd[,resultCol]=="not_rejected")
	rejected = (dd[,resultCol]=="rejected")

	title = paste("alignment filtering in",name)
	xLab = "errors in alignment"
	yLab = "matches in alignment"

	if (!is.null(pdfName))
		pdf(file=pdfName,width=width,height=height,pointsize=10)
	else if (newWindow)
		quartz(width=width,height=height)

	legText  = c(paste("accepted (",sum(accepted),")",sep=""),
	             paste("rejected (",sum(rejected),")",sep=""))
	legPch   = c(0,1)
	legColor = c("black","red")

	dd[accepted,"pch"]   = legPch[1]
	dd[rejected,"pch"]   = legPch[2]
	dd[accepted,"color"] = legColor[1]
	dd[rejected,"color"] = legColor[2]

	shuffle = sample(nrow(dd),nrow(dd))

	par(mar=c(4.1,4.1,3.1,1.1)) # BLTR

	plot(dd[shuffle,"m*"],dd[shuffle,"x*"],
	     pch=dd[shuffle,"pch"],col=dd[shuffle,"color"],
	     xlim=c(0,xMax),ylim=c(0,yMax),
		 main=title,xlab=xLab,ylab=yLab)
	legend("bottomright",legend=legText,pch=legPch,col=legColor)

	if (!is.null(pdfName))
		dev.off()
	}

# read_ncrf_summary--
#   Read the output of ncrf_summary.py.
#
# typical input:
#   #line  motif seq               start end   strand seqLen querybp mRatio m     mm   i   d
#   1      GGAAT SRR2036394.100749 9566  10445 +      14279  823     81.7%  730   78   71  15
#   10     GGAAT SRR2036394.100749 11581 12099 +      14279  505     83.8%  446   45   27  14
#   19     GGAAT SRR2036394.101301 12191 12923 +      47491  744     83.0%  635   76   21  33
#    ...

read_ncrf_summary <- function(filename,motif=NULL)
	{
	dd = read.table(filename,header=T,comment.ch="",
	                colClasses=c("integer","character","character",
	                             "integer","integer","character",
	                             "integer","integer","character",
	                             "integer","integer","integer","integer"))
    colnames(dd)[1] = "line"

	if (!is.null(motif))
		dd = dd[(dd[,"motif"]==motif),]

    dd$mRatio <- as.numeric(gsub("%","",dd$mRatio))/100

	dd
	}


# this is the modelfile for joint meta-analysis
# for humerus and femur data
# treating the studies as parallel designs
#

model {

#### Both tests, complete crosstabs for TPR and FPR: group 1
    for(k1 in 1:K.G1) {

        # observational part of the model
        # x and p order is 11 10 01 00
        # first humerus, second femur

        #                  1          2           3           4        5         6
        # eta.xi order is eta1 (hum) eta2 (fem)  eta3 (jtpr) xi1 (hum) xi2 (fem) xi3 (jfpr)
        #

        x.down.11.G1[k1] ~ dbin(p.down.11.G1[k1], N.down.G1[k1])
        x.down.1dot.G1[k1] ~ dbin(p.down.1dot.G1[k1], N.down.G1[k1])
        x.down.dot1.G1[k1] ~ dbin(p.down.dot1.G1[k1], N.down.G1[k1])

        # p11.DOWN <-ilogit(eta3)
        p.down.11.G1[k1] <- ilogit(eta.xi.G1[k1,3])
        # Sensitivity for test 1 (humerus)
        p.down.1dot.G1[k1] <- ilogit(eta.xi.G1[k1,1])
        # Sensitivity for test 2 (femur)
        p.down.dot1.G1[k1] <- ilogit(eta.xi.G1[k1,2])

        # p11.NODOWN
        x.nodown.11.G1[k1] ~ dbin(p.nodown.11.G1[k1], N.nodown.G1[k1])
        x.nodown.1dot.G1[k1] ~ dbin(p.nodown.1dot.G1[k1], N.nodown.G1[k1])
        x.nodown.dot1.G1[k1] ~ dbin(p.nodown.dot1.G1[k1], N.nodown.G1[k1])

        # p11.nodown <-ilogit(eta3)
        p.nodown.11.G1[k1] <- ilogit(eta.xi.G1[k1,6])
        # Sensitivity for test 1 (humerus)
        p.nodown.1dot.G1[k1] <- ilogit(eta.xi.G1[k1,4])
        # Sensitivity for test 2 (femur)
        p.nodown.dot1.G1[k1] <- ilogit(eta.xi.G1[k1,5])

        # structural part of the model
        eta.xi.G1[k1, 1:6] ~dmnorm(Eta.Xi[1:6], Omega[1:6,1:6])

    }

    for(k4 in 1:K.G4) {
        # observational part of the model
        x.down.dot1.G4[k4] ~ dbin(p.down.dot1.G4[k4], N.down.G4[k4])
        x.nodown.dot1.G4[k4] ~ dbin(p.nodown.dot1.G4[k4], N.nodown.G4[k4])

        p.down.dot1.G4[k4] <- ilogit(eta.xi.G4[k4, 1])
        p.nodown.dot1.G4[k4] <- ilogit(eta.xi.G4[k4, 2])

        # structural part of the model
        eta.xi.G4[k4, 1:2] ~ dmnorm(Eta.Xi.G4[1:2], Omega.G4[1:2, 1:2])
    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi[1] ~ dnorm(mu0[1], prec.mu0[1])
    Eta.Xi[2] ~ dnorm(mu0[2], prec.mu0[2])
    Eta.Xi[3] ~ dnorm(mu0[3], prec.mu0[3])
    Eta.Xi[4] ~ dnorm(mu0[4], prec.mu0[4])
    Eta.Xi[5] ~ dnorm(mu0[5], prec.mu0[5])
    Eta.Xi[6] ~ dnorm(mu0[6], prec.mu0[6])

    # S is a diagonal matrix of sd's
    S[1,1] ~ dunif(s.lower[1], s.upper[1])  # or use inverse gamma
    S[2,2] ~ dunif(s.lower[2], s.upper[2])
    S[3,3] ~ dunif(s.lower[3], s.upper[3])
    S[4,4] ~ dunif(s.lower[4], s.upper[4])
    S[5,5] ~ dunif(s.lower[5], s.upper[5])
    S[6,6] ~ dunif(s.lower[6], s.upper[6])

    for(r1 in 1:5) {
        for(c1 in (r1+1):6) {
            S[r1,c1] <- 0
            S[c1,r1] <- 0
        }
    }

    # LL' = U'U is the cholesky decomposition of the correlation matrix (L=U')
    L[1,1] <- 1
    L[1,2] <- 0
    L[1,3] <- 0
    L[1,4] <- 0
    L[1,5] <- 0
    L[1,6] <- 0

    L[2,1] <- cos(phi.21)
    L[2,2] <- sin(phi.21)
    L[2,3] <- 0
    L[2,4] <- 0
    L[2,5] <- 0
    L[2,6] <- 0

    L[3,1] <- cos(phi.31)
    L[3,2] <- cos(phi.32)*sin(phi.31)
    L[3,3] <- sin(phi.32)*sin(phi.31)
    L[3,4] <- 0
    L[3,5] <- 0
    L[3,6] <- 0

    L[4,1] <- cos(phi.41)
    L[4,2] <- cos(phi.42)*sin(phi.41)
    L[4,3] <- cos(phi.43)*sin(phi.42)*sin(phi.41)
    L[4,4] <- sin(phi.43)*sin(phi.42)*sin(phi.41)
    L[4,5] <- 0
    L[4,6] <- 0

    L[5,1] <- cos(phi.51)
    L[5,2] <- cos(phi.52)*sin(phi.51)
    L[5,3] <- cos(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,4] <- cos(phi.54)*sin(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,5] <- sin(phi.54)*sin(phi.53)*sin(phi.52)*sin(phi.51)
    L[5,6] <- 0

    L[6,1] <- cos(phi.61)
    L[6,2] <- cos(phi.62)*sin(phi.61)
    L[6,3] <- cos(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,4] <- cos(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,5] <- cos(phi.65)*sin(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)
    L[6,6] <- sin(phi.65)*sin(phi.64)*sin(phi.63)*sin(phi.62)*sin(phi.61)

    phi.21 ~ dunif(chol.r.lower[1], chol.r.upper[1])
    phi.31 ~ dunif(chol.r.lower[2], chol.r.upper[2])
    phi.32 ~ dunif(chol.r.lower[3], chol.r.upper[3])
    phi.41 ~ dunif(chol.r.lower[4], chol.r.upper[4])
    phi.42 ~ dunif(chol.r.lower[5], chol.r.upper[5])
    phi.43 ~ dunif(chol.r.lower[6], chol.r.upper[6])
    phi.51 ~ dunif(chol.r.lower[7], chol.r.upper[7])
    phi.52 ~ dunif(chol.r.lower[8], chol.r.upper[8])
    phi.53 ~ dunif(chol.r.lower[9], chol.r.upper[9])
    phi.54 ~ dunif(chol.r.lower[10], chol.r.upper[10])
    phi.61 ~ dunif(chol.r.lower[11], chol.r.upper[11])
    phi.62 ~ dunif(chol.r.lower[12], chol.r.upper[12])
    phi.63 ~ dunif(chol.r.lower[13], chol.r.upper[13])
    phi.64 ~ dunif(chol.r.lower[14], chol.r.upper[14])
    phi.65 ~ dunif(chol.r.lower[15], chol.r.upper[15])

    R <- L %*% t(L)
    Tau <- S %*% R %*% S
    Omega <- inverse(Tau)

    # Omega.G4 and Eta.Xi.G4
    # I <- diag(rep(1,6))
    # P.G4 <- I[,c(2, 5, 1, 3, 4, 6)]
    Omega.G4 <- t(P.G4) %*% Omega %*% P.G4
    Eta.Xi.G4 <- Eta.Xi %*% P.G4

    # Data to report
    tpr.hum <- ilogit(Eta.Xi[1])
    tpr.fem <- ilogit(Eta.Xi[2])
    jtpr <- ilogit(Eta.Xi[3])
    fpr.hum <- ilogit(Eta.Xi[4])
    fpr.fem <- ilogit(Eta.Xi[5])
    jfpr <- ilogit(Eta.Xi[6])

    diff.tpr <- tpr.hum - tpr.fem
    diff.fpr <- fpr.hum - fpr.fem

    or.tpr <- exp(Eta.Xi[1]-Eta.Xi[2])
    or.fpr <- exp(Eta.Xi[4]-Eta.Xi[5])

    diff.eta <- Eta.Xi[1]-Eta.Xi[2]
    diff.xi <- Eta.Xi[4]-Eta.Xi[5]

}


winsorize <- function(x, pct=0.05) {
    if (is.matrix(x)) {
        quantiles <- rowQuantiles(x, probs=c(pct,1-pct), na.rm=T)
        low <- quantiles[,1]
        high <- quantiles[,2]
        idx <- which(x < low, arr.ind=T)
        x[idx] <- low[idx[,1]]
        idx <- which(x > high, arr.ind=T)
        x[idx] <- high[idx[,1]]
    }
    else {
        low <- quantile(x, probs=pct, na.rm=T)
        high <- quantile(x, probs=1-pct, na.rm=T)
        idx <- which(x < low)
        x[idx] <- low
        idx <- which(x > high)
        x[idx] <- high
    }
    x
}


#######  Model Estimation #######

### Write model equation for full and maybe some restricted models to compare. Watch out that model matches research hypothesis! ###

# Full
fit.lme.ml.full <- lme(volume ~ group*daydiff, random = ~ daydiff | mouse, data = dfData, method = "ML")
summary(fit.lme.ml.full)

fit.lme.reml.full <- lme(volume ~ group*daydiff, random = ~ daydiff | mouse, data = dfData, method = "REML") # REML Estimation
summary(fit.lme.reml.full)

# Without Random Slope
fit.lme.ml.wors <- lme(volume ~ group*daydiff, random = ~ 1 | mouse, data = dfData, method = "ML")
summary(fit.lme.ml.wors)

# Without Group intercept
fit.lme.ml.wogi <- lme(volume ~ daydiff + group:daydiff , random = ~ daydiff | mouse, data = dfData, method = "ML")
summary(fit.lme.ml.wogi)

fit.lme.reml.wogi <- lme(volume ~ daydiff + group:daydiff , random = ~ daydiff | mouse, data = dfData, method = "REML")
summary(fit.lme.reml.wogi)

# Without Group intercept and without Random Slope
fit.lme.ml.wogirs <- lme(volume ~ daydiff + group:daydiff, random = ~ 1 | mouse, data = dfData, method = "ML")
summary(fit.lme.ml.wogirs)

# Independent Random intercept & slope
fit.lme.ml.wogi.random.independent = lme(volume ~ daydiff + group:daydiff, data = dfData, random = list(mouse = pdDiag(~daydiff)), method = "ML")
summary(fit.lme.ml.wogi.random.independent)

####### Model Validation #######

### Check model performance based on IC and CIs ###

anova(fit.lme.ml.full, fit.lme.ml.wogi)

head(model.matrix(lmer(volume ~ daydiff*group + (daydiff | mouse), data = dfData, REML = FALSE)),10) # Plug in different Models

intervals(fit.lme.ml.full)
intervals(fit.lme.ml.wogi)

anova(fit.lme.ml.full, type="sequential" )

round(r.squaredGLMM(fit.lme.ml.wogi),4)
round(r.squaredGLMM(fit.lme.ml.full),4)

### Predictions ###

pred.ml.wogi = predict(fit.lme.ml.wogi,level=1)

res.ml.wogi = resid(fit.lme.ml.wogi)

pred.reml.wogi = predict(fit.lme.reml.wogi, level = 1)

res.reml.wogi = resid(fit.lme.reml.wogi)

### Check prediction (errors) for: homoscedasticity, outliers, normality and linearity (Correlation between random effects?). ###
### Also within factors (Scatterplot, qqplot). ###

p8=
ggplot(data = dfData,aes(y = res.ml.wogi, x = pred.ml.wogi)) +
  geom_point(color = vColors[1]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by ML") +
  ylab("Residuals")

p9=
  ggplot(data = dfData,aes(y = res.reml.wogi, x = pred.ml.wogi)) +
  geom_point(color = vColors[2]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by REML") +
  ylab("Residuals")

p8.1=
  ggplot(data = dfData,aes(y = res.ml.wogi, x = pred.ml.wogi)) +
  geom_point(aes(color = group)) +
  scale_color_manual(values=vColors[1:2]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by ML") +
  ylab("Residuals")

p9.1=
  ggplot(data = dfData,aes(y = res.reml.wogi, x = pred.ml.wogi)) +
  geom_point(aes(color = v3SplitGroups)) +
  scale_color_manual(values=vColors[1:3]) +
  geom_line(y = 0) +
  theme_minimal() +
  xlab("Fitted by ML") +
  ylab("Residuals")

grid.arrange(p8,p9,p8.1, p9.1, nrow = 2)

p10 =
  ggplot(data = dfData,aes(y = res.ml.wogi, x = group)) +
  geom_boxplot(fill = vColors[1:2], alpha = 0.6, color= vColors[1:2]) +
  theme_minimal() +
  xlab("Two Groups") +
  ylab("Residuals fitted by ML")

p10.1 =
  ggplot(data = dfData,aes(y = res.ml.wogi, x = v3SplitGroups)) +
  geom_boxplot(fill = vColors[1:3], alpha = 0.6, color= vColors[1:3]) +
  theme_minimal() +
  xlab("Three Groups") +
  ylab("Residuals fitted by ML")

p11 =
  ggplot(data = dfData,aes(y = res.ml.wogi, x = as.factor(daydiff))) +
  geom_boxplot(fill = vColors[3], alpha = 0.6, color= vColors[2]) +
  theme_minimal() +
  xlab("Days Passed") +
  ylab("Residuals fitted by ML")

p12 =
  ggplot(data = dfData,aes(y = res.ml.wogi, x = mouse)) +
  geom_boxplot(fill = vColors[3], alpha = 0.6, color= vColors[1]) +
  theme_minimal() +
  xlab("Mouse") +
  ylab("Residuals fitted by ML")

grid.arrange(p10,p10.1, p11,p12, layout_matrix = rbind(c(1,2),c(3,4)))

### Compute Block-Correlation Matrix ###

Omega.matrix = function(model) {
  if(class(model)[1]=="lmerModLmerTest"|class(model)[1]=="lmerMod"){
    sigma2.epsilon = sigma(model)^2
    Psi.star       = crossprod(getME(model,"Lambdat"))*sigma2.epsilon
    Z              = getME(model,"Z")
    Omega          = Z %*% Psi.star %*% t(Z) + sigma2.epsilon* Diagonal(nrow(Z))
    Omega
  }else{
    warning("Function only works on outcput of function lmer()\n")
  }
}

Omega.plot = function(Omega,legend=TRUE,axes=TRUE){
  corw = cov2cor(Omega)
  if(any(corw<0)){
    colw=c(gray(1),rainbow(197)[197:100],gray(.9),rainbow(197)[99:1],gray(0))
    zlim=c(-1,1)
  }else{
    colw=c(gray(.9),rainbow(98)[98:1],gray(0))
    zlim=c(0,1)
  }
  image(z=as.matrix(corw[nrow(corw):1,]),zlim=zlim,axes=FALSE,col=colw)
  if(legend){
    valw = as.numeric(names(table(as.matrix(corw))))
    posw = round(valw*length(colw))
    posw[posw==0] = 1
    posw[posw>length(colw)] = length(colw)
    legend("topright",ncol=1,legend=format(round(valw,4)),
           col=colw[posw],pch=15,bg="light gray",
           title="Values",box.lwd=NA)
  }
  if(axes){
    axis(3,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
    axis(2,at=seq(0,1,length=nrow(Omega)),labels=FALSE)
    axis(2,at=c(1,0),c(1,nrow(Omega)),las=2)
    axis(3,at=c(0,1),c(1,nrow(Omega)),las=1)
  }
}

fit.lme4.ml.wogi <- lmer(volume ~ daydiff + group:daydiff + (daydiff| mouse), data = dfData, REML = FALSE) #lme4 object needed

sigma2.epsilon = sigma(fit.lme4.ml.wogi)^2
Psi.star       = crossprod(getME(fit.lme4.ml.wogi,"Lambdat"))*sigma2.epsilon
Z              = getME(fit.lme4.ml.wogi,"Z")
Omega          = Z %*% Psi.star %*% t(Z) + sigma2.epsilon* Diagonal(nrow(Z))

D = sqrt(diag(diag(Omega)))
DInv = solve(D)
CorOmega = DInv %*% Omega %*% DInv

Omega = Omega.matrix(fit.lme4.ml.wogi)

par(mfrow= c(1,2))
Omega.plot(Omega)
Omega.plot(Omega[-c(1:214),-c(1:214)], legend = FALSE)

### (Partial) Autocorrelation Function ###
par(mfrow= c(1,2))
acf(residuals(fit.lme.ml.wogi))
pacf(residuals(fit.lme.ml.wogi))

### Check normal distribution assumption for residuals and random effects (qqplot) ###

par(mfrow=c(1,3))

qqnorm(ranef(fit.lme.ml.wogi)[,1],main="Random intercept",pch=16,bty='n', col = vColors[3])
qqline(ranef(fit.lme.ml.wogi)[,1],lwd=2,col= vColors[1])

qqnorm(ranef(fit.lme.ml.wogi)[,2],main="Random slope",pch=16,bty='n', col = vColors[3])
qqline(ranef(fit.lme.ml.wogi)[,2],lwd=2,col= vColors[1])

qqnorm(resid(fit.lme.ml.wogi),main="Residuals",pch=16,bty='n', col = vColors[3])
qqline(resid(fit.lme.ml.wogi),lwd=2,col= vColors[2])

ggplot(data = ranef(fit.lme.ml.wogi),aes(y = ranef(fit.lme.ml.wogi)[,2], x = ranef(fit.lme.ml.wogi)[,1])) +
  geom_point(color= vColors[3]) +
  geom_smooth(method='lm',formula=y~x, se=FALSE, color = vColors[2]) +
  theme_minimal() +
  xlab("Random Intercept") +
  ylab("Random Slope")


argmax <- function(x) {
  which.max(x)
}

first_layer <- function(agent_loglikelihoods, alphas, is_argmax, cs) {

  T = dim(agent_loglikelihoods)[2]
  n_agents = dim(agent_loglikelihoods)[1]
  pi_t = matrix(1, length(alphas), n_agents) / n_agents
  prob = array(0, dim=c(T, length(alphas), n_agents))
  loglikehood = matrix(0, length(alphas), T)

  for (t in 1:T) {
    for (j in 1:length(alphas)) {
      alpha = alphas[j]
      if (is_argmax) {
        pi_t[j, ] = alpha * pi_t[j, ]
        p = rep(0, length(pi_t[j, ]))
        p[argmax(pi_t[j, ])] = 1
        prob[t, j, ] = p
        loglikehood[j, t] = sum(agent_loglikelihoods[ , t] * p)
        pi_t[j, ] = pi_t[j, ] + agent_loglikelihoods[ , t]
      }
      else {
        pi_t[j, ] = (pi_t[j, ]^alpha + cs) / (sum(pi_t[j, ]^alpha) + cs)  # pi_t|t-1
        prob[t, j, ] = pi_t[j, ]
        loglikehood[j, t] = log(sum(exp(agent_loglikelihoods[ , t]) * pi_t[j, ]))
        pi_t[j, ] = pi_t[j, ] * exp(agent_loglikelihoods[ , t])
        pi_t[j, ] = pi_t[j, ] / sum(pi_t[j])  # pi_t|t
      }
    }
  }
  return(list("loglikehood"=loglikehood, "prob"=prob))
}

second_layer <- function(loglikehood, deltas, is_argmax) {
  T = dim(loglikehood)[2]
  res_weights = array(0, dim=c(length(deltas), T, dim(loglikehood)[1]))
  res_likelihoods = matrix(0, length(deltas), T)

  for (i in 1:length(deltas)) {
    delta = deltas[i]
    weights = matrix(0, T, dim(loglikehood)[1])
    momentum = rep(0,T)
    csum = matrix(0, T, dim(loglikehood)[1])
    for (t in 1:T) {
      if (is_argmax) {
        p = rep(0, dim(loglikehood)[1])
        if (t==1) {
          p[argmax(csum[t, ])] = 1
        }
        else {
          p[argmax(csum[t-1, ])] = 1
        }
        weights[t, ] = p
        momentum[t] = log(sum(exp(loglikehood[ , t]) * p))
      }
      else {
        if (t==1) {
          m = 0
          p = exp(csum[t, ] - log(sum(exp(csum[t, ] - m))) - m)
        }
        else {
          m = max(csum[t-1, ])
          p = exp(csum[t-1, ] - log(sum(exp(csum[t-1, ] - m))) - m)
        }
        weights[t, ] = p
        momentum[t] = log(sum(exp(loglikehood[ , t]) * p))
      }
      if (t==1) {
        csum[t, ] = loglikehood[ , t]
      }
      else {
        csum[t, ] = delta * csum[t-1, ] + loglikehood[ , t]
      }
    }
    res_likelihoods[i, ] = momentum
    res_weights[i, , ] = weights
  }
  return(list("res_likelihoods"=res_likelihoods, "res_weights"=res_weights))
}

ldf <- function(agent_loglikelihoods, levels, discount_factors, activation_functions, c=10^(-20)) {

  alphas = discount_factors
  is_argmax = activation_functions[1] == "argmax"
  res = first_layer(agent_loglikelihoods, alphas, is_argmax, c)
  loglikehood = res$loglikehood
  prob = res$prob

  if (levels == 2) {
    deltas = discount_factors
    is_argmax = activation_functions[2] == "argmax"
    res = second_layer(loglikehood, deltas, is_argmax)
    momentum = res$res_likelihoods
    param_weights = res$res_weights
    weights = array(0, dim=c(length(deltas), dim(forecasts_lik)[2], dim(forecasts_lik)[1]))
    for (k in 1:length(deltas)) {
      for (i in 1:dim(param_weights)[2]) {
        weights[k, i, ] = apply(t(prob[i, , ]) * param_weights[k, i, ],1,sum)
      }
    }
    list("logscores"=momentum , "weights"=weights, "params_weights"=param_weights)
  }
  else{
    list("logscores"=loglikehood , "weights"=prob, "params_weights"=NULL)
  }

}

forecasts_lik = t(matrix(c(
  c(-2.302585093, -4.605170186, -4.605170186, -1.609437912, -4.605170186, -1.771956842, -1.609437912, -1.386294361,
   -1.386294361, -2.302585093, -1.386294361),
  c(-0.916290732, -1.203972804, -1.609437912, -2.995732274, -4.605170186, -2.302585093, -4.828313737, -1.386294361,
   -1.609437912, -2.991548932, -0.801038303),
  c(-2.302585093, -3.688879454, -3.688879454, -1.897119985, -2.9, -2.302585093, -4.1, -1.1, -0.1, -1.4,
   -1.897119985),
  c(-4.605170186, -4.605170186, -4.605170186, -4.605170186, -4.605170186, -0.9, -4.605170186, -0.510825624,
   -0.287682072, -1.491654877, -1.897119985),
  c(-1.203972804, -1.203972804, -1.290984181, -2.302585093, -4.605170186, -1, -4.605170186, -1.049822124,
   -2.302585093, -2.995732274, -0.597837001)), nrow=11, ncol=5))
discount_factors = c(1, 0.5)

res = ldf(forecasts_lik, 1, discount_factors, c("softmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-24.54868304, -21.48288988))) < 10^(-8))
res = ldf(forecasts_lik, 1, discount_factors, c("argmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-24.57489777, -25.00121507))) < 10^(-8))
res = ldf(forecasts_lik, 2, discount_factors, c("softmax", "softmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-22.13047414, -22.23379625))) < 10^(-8))
res = ldf(forecasts_lik, 2, discount_factors, c("argmax", "argmax"))
stopifnot(max(abs(apply(res$logscores,1,sum) - c(-25.87418075, - 24.27844848))) < 10^(-8))