context("Network level indices - test boot_networklevel & gg_networklevel")

library(dplyr)
library(bipartite)
data(Safariland)

# Helper function to get the length of unique values of the last bootstrap.
get_length_unq <- function(df) {
  df %>%
    select(mean, ci_low, ci_up) %>%
    as.numeric() %>%
    round(digits = 3) %>%
    unique() %>%
    length()
}

# Generate two fictive networks to compare. For full reproducibility we need to
# reorder the Safariland matrix alphabetically. This is needed because in
# boot_specieslevel_once() we use the table() function to (re)construct/sample
# networks and the species names are ordered alphabetically, which is not the
# case for Safariland default matrix that comes with the bipartite package.
set.seed(321)
Safariland_1 <- Safariland[, sort(sample.int(ncol(Safariland), 10))] %>%
  .[order(rownames(.)), order(colnames(.))]
set.seed(123)
Safariland_2 <- Safariland[, sort(sample.int(ncol(Safariland), 10))] %>%
  .[order(rownames(.)), order(colnames(.))]

# Test nestedness ---------------------------------------------------------

# Note that, "nestedness" is not be affected by `level` as opposed to "niche
# overlap".

index <- "nestedness"

set.seed(42)
test_both_s1 <- networklevel(Safariland_1, index = index, level = "both")
set.seed(42)
test_both_s2 <- networklevel(Safariland_2, index = index, level = "both")

test_that('"nestedness" index output is ok for both levels', {
  sf_boot <- list(s1 = Safariland_1, s2 = Safariland_2) %>%
    lapply(web_matrix_to_df) %>%
    boot_networklevel(col_lower = "lower", # column name for plants
                      col_higher = "higher", # column name for insects
                      index = index,
                      level = "both",
                      start = 10,
                      step = 10,
                      n_boot = 6,
                      n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "nestedness", fixed = TRUE)

  expect_true(inherits(sf_boot[["nestedness"]], 'list'))
  expect_true(length(sf_boot[["nestedness"]]) == 2)

  expect_match(names(sf_boot[["nestedness"]])[1], "stats_df", fixed = TRUE)
  expect_match(names(sf_boot[["nestedness"]])[2], "lines_df", fixed = TRUE)

  expect_true(inherits(sf_boot[["nestedness"]][["stats_df"]], 'data.frame'))
  expect_true(inherits(sf_boot[["nestedness"]][["lines_df"]], 'data.frame'))

  expect_true(ncol(sf_boot[["nestedness"]][["stats_df"]]) == 5)
  expect_true(ncol(sf_boot[["nestedness"]][["lines_df"]]) == 4)

  # Get final boot values from the stats_df data frame
  last_boot_s1 <- sf_boot[["nestedness"]][["stats_df"]] %>%
    filter(web == "s1") %>%
    filter(row_number() == n())

  last_boot_s2 <- sf_boot[["nestedness"]][["stats_df"]] %>%
    filter(web == "s2") %>%
    filter(row_number() == n())

  # Are all final boostrap values converging (are all equal) for each web?
  expect_equal(get_length_unq(last_boot_s1), 1)
  expect_equal(get_length_unq(last_boot_s2), 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  expect_equivalent(last_boot_s1 %>% select(mean),
                    test_both_s1)
  expect_equivalent(last_boot_s2 %>% select(mean),
                    test_both_s2)

  # Test graph function
  sf_gg_lst <- gg_networklevel(sf_boot)
  expect_true(inherits(sf_gg_lst, 'list'))
  expect_true(length(sf_gg_lst) == 1)
  expect_true(inherits(sf_gg_lst[["nestedness"]], c("gg", "ggplot")))
})

# Test niche overlap ------------------------------------------------------

# Note that, "niche overlap" is affected by `level`.

index <- "niche overlap"

set.seed(42)
test_both_s1 <- networklevel(Safariland_1, index = index, level = "both")
set.seed(42)
test_both_s2 <- networklevel(Safariland_2, index = index, level = "both")

test_that('"niche overlap" index output is ok for both levels', {
  sf_boot <- list(s1 = Safariland_1, s2 = Safariland_2) %>%
    lapply(web_matrix_to_df) %>%
    boot_networklevel(col_lower = "lower", # column name for plants
                      col_higher = "higher", # column name for insects
                      index = index,
                      level = "both",
                      start = 10,
                      step = 10,
                      n_boot = 6,
                      n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2)

  expect_match(names(sf_boot)[1], "niche.overlap.HL", fixed = TRUE)
  expect_match(names(sf_boot)[2], "niche.overlap.LL", fixed = TRUE)

  expect_true(inherits(sf_boot[["niche.overlap.HL"]], 'list'))
  expect_true(inherits(sf_boot[["niche.overlap.LL"]], 'list'))

  expect_true(length(sf_boot[["niche.overlap.HL"]]) == 2)
  expect_true(length(sf_boot[["niche.overlap.LL"]]) == 2)

  expect_match(names(sf_boot[["niche.overlap.HL"]])[1], "stats_df", fixed = TRUE)
  expect_match(names(sf_boot[["niche.overlap.HL"]])[2], "lines_df", fixed = TRUE)

  expect_match(names(sf_boot[["niche.overlap.LL"]])[1], "stats_df", fixed = TRUE)
  expect_match(names(sf_boot[["niche.overlap.LL"]])[2], "lines_df", fixed = TRUE)

  expect_true(inherits(sf_boot[["niche.overlap.HL"]][["stats_df"]], 'data.frame'))
  expect_true(inherits(sf_boot[["niche.overlap.HL"]][["lines_df"]], 'data.frame'))

  expect_true(inherits(sf_boot[["niche.overlap.LL"]][["stats_df"]], 'data.frame'))
  expect_true(inherits(sf_boot[["niche.overlap.LL"]][["lines_df"]], 'data.frame'))

  expect_true(ncol(sf_boot[["niche.overlap.HL"]][["stats_df"]]) == 5)
  expect_true(ncol(sf_boot[["niche.overlap.HL"]][["lines_df"]]) == 4)

  expect_true(ncol(sf_boot[["niche.overlap.LL"]][["stats_df"]]) == 5)
  expect_true(ncol(sf_boot[["niche.overlap.LL"]][["lines_df"]]) == 4)

  # Get final boot values from the stats_df data frame
  # - high level
  last_boot_s1_hl <- sf_boot[["niche.overlap.HL"]][["stats_df"]] %>%
    filter(web == "s1") %>%
    filter(row_number() == n())

  last_boot_s2_hl <- sf_boot[["niche.overlap.HL"]][["stats_df"]] %>%
    filter(web == "s2") %>%
    filter(row_number() == n())

  # - low level
  last_boot_s1_ll <- sf_boot[["niche.overlap.LL"]][["stats_df"]] %>%
    filter(web == "s1") %>%
    filter(row_number() == n())

  last_boot_s2_ll <- sf_boot[["niche.overlap.LL"]][["stats_df"]] %>%
    filter(web == "s2") %>%
    filter(row_number() == n())

  # Are all final boostrap values converging (are all equal) for each web?
  # - high level
  expect_equal(get_length_unq(last_boot_s1_hl), 1)
  expect_equal(get_length_unq(last_boot_s2_hl), 1)
  # - low level
  expect_equal(get_length_unq(last_boot_s1_ll), 1)
  expect_equal(get_length_unq(last_boot_s2_ll), 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  # - high level
  expect_equivalent(last_boot_s1_hl %>% select(mean),
                    test_both_s1["niche.overlap.HL"])
  expect_equivalent(last_boot_s2_hl %>% select(mean),
                    test_both_s2["niche.overlap.HL"])
  # - low level
  expect_equivalent(last_boot_s1_ll %>% select(mean),
                    test_both_s1["niche.overlap.LL"])
  expect_equivalent(last_boot_s2_ll %>% select(mean),
                    test_both_s2["niche.overlap.LL"])

  # Test graph function
  sf_gg_lst <- gg_networklevel(sf_boot)
  expect_true(inherits(sf_gg_lst, 'list'))
  expect_true(length(sf_gg_lst) == 2)
  expect_true(inherits(sf_gg_lst[["niche.overlap.HL"]], c("gg", "ggplot")))
  expect_true(inherits(sf_gg_lst[["niche.overlap.LL"]], c("gg", "ggplot")))
})


library(survival)
library(survminer)
{{rimport}}('__init__.r', 'plot.r')

set.seed(8525)

# load parameters
infile      = {{i.infile | R}}
outfile     = {{o.outfile | R}}
outdir      = {{o.outdir | R}}
inunit      = {{args.inunit | R}}
outunit     = {{args.outunit | R}}
covfile     = {{args.covfile | R}}
nthread     = {{args.nthread | R}}
rnames      = {{args.inopts | lambda x: x.get('rnames', True) | R}}
combine     = {{args.combine | R}}
method      = {{args.method | R}}
devpars     = {{args.devpars | R}}
params.plot = {{args.params | R}}
pval        = {{args.pval | R}}
mainggs     = {{args.ggs | R}}
ngroups     = as.numeric({{args.ngroups | R}})
autogroup   = as.logical({{args.autogroup | R}})

if (pval == T) {
	pval = 'logrank'
}

tableggs      = mainggs$table
mainggs$table = NULL

test.names = list(
	logrank   = 'Logrank test',
	waldtest  = 'Walk test',
	likeratio = 'Likelihood ratio test'
)
test.coxes = list(
	logrank   = 'sctest',
	waldtest  = 'waldtest',
	likeratio = 'logtest'
)

if (is.list(params.plot) && length(params.plot) > 0) {
	params.default = list(
		pval             = '{method}\np = {pval}',
		risk.table       = T,
		#surv.median.line = 'hv',
		conf.int         = T
	)
	params.plot = update.list(params.default, params.plot)
}

# cut the data in to n parts using quantile
# in case the data has equal numbers, add very small random numbers to it.
ncut = function(dat, n, prefix = 'q') {
	indexes = 1:length(dat)
	x       = cut(
		indexes,
		breaks         = quantile(indexes, probs = seq(0,1,1/n)),
		include.lowest = T,
		labels         = paste0(prefix, 1:n)
	)
	return (x[match(indexes, order(dat))])
}

# get the median value of all types
allTypeMedian = function(dat) {
	return(dat[median(1:length(dat))])
}

# apply survival analysis method (cox or km)
useCox = function(dat, varname) {
	cnames  = colnames(dat)
	var     = cnames[3]
	# all variables
	vars    = cnames[3:length(cnames)]
	# levels of the variable
	varlvls = levels(factor(dat[, var]))
	# apply the model
	fmula.str = paste('Surv(time, status) ~', paste(vars, collapse = ' + '))
	modcox    = coxph(as.formula(fmula.str), data = as.data.frame(data.matrix(dat)))

	# the results
	#   - summary: The result table of the main variable
	#   - cov:  The result of the covariates
	#   - plot: The survival plot
	ret = list(summary = matrix(ncol = 8, nrow = 0), cov = matrix(ncol = 7, nrow = 0), plot = NULL)
	colnames(ret$summary) = c('var', 'method', 'test', 'df', 'pvalue', 'hr', 'ci95_lower', 'ci95_upper')
	colnames(ret$cov) = c('mainvar', 'covar', 'hr', 'ci95_lower', 'ci95_upper', 'z', 'pvalue')

	s = summary(modcox)
	ret$summary = rbind(ret$summary, c(varname, 'logrank', s$sctest, s$conf.int[var, -2]))
	ret$summary = rbind(ret$summary, c(varname, 'waldtest', s$waldtest, s$conf.int[var, -2]))
	ret$summary = rbind(ret$summary, c(varname, 'likeratio', s$logtest, s$conf.int[var, -2]))

	for (v in vars) {
		ret$cov = rbind(ret$cov, c(varname, v, s$conf.int[v, -2], s$coefficients[v, c(4,5)]))
	}
	ret$summary = pretty.numbers(ret$summary, list(
		test..hr..ci95_lower..ci95_upper = '%.3f',
		pvalue = '%.2E'
	))
	ret$cov = pretty.numbers(ret$cov, list(
		hr..ci95_lower..ci95_upper..z = '%.3f',
		pvalue = '%.2E'
	))

	# the pvaldata used to replace the place holders in args.plot.params.pval
	if (!is.logical(pval)) {
		pvaldata = list(
			method = test.names[[pval]],
			pval   = sprintf('%.2E', s[[ test.coxes[[pval]] ]][3]),
			hr     = sprintf('%.3f', s$conf.int[var, 1]),
			ci95L  = sprintf('%.3f', s$conf.int[var, 3]),
			ci95U  = sprintf('%.3f', s$conf.int[var, 4])
		)
	}

	# plot the result out
	if (is.list(params.plot) && length(params.plot) > 0) {
		params.default = list(
			legend.title = paste0('Strata(', varname, ')'),
			legend.labs  = ifelse(length(varlvls)<=ngroups, varlvls, paste0('q', 1:ngroups)),
			xlab         = paste0("Time (", outunit ,")"),
			ylim.min     = 0.0,
			pval.coord   = c(0, 0.1)
		)
		params          = update.list(params.default, params.plot)

		params$legend.title = gsub('{var}', varname, params$legend.title, fixed = T)
		if (!is.logical(pval)) {
			params$pval = gsub('{method}', pvaldata$method, params$pval, fixed = T)
			params$pval = gsub('{pval}',   pvaldata$pval,   params$pval, fixed = T)
			params$pval = gsub('{hr}',     pvaldata$hr,     params$pval, fixed = T)
			params$pval = gsub('{ci95L}',  pvaldata$ci95L,  params$pval, fixed = T)
			params$pval = gsub('{ci95U}',  pvaldata$ci95U,  params$pval, fixed = T)
		} else {
			params$pval = FALSE
		}
		# use Kaplan Merier to plot
		km            = useKM(dat, varname, params)
		ret$plot      = km$plot
		ret$quantdata = km$quantdata

		ret$summary = cbind(ret$summary, groups = rep(km$groups, nrow(ret$summary)))
	}

	return(ret)
}

useKM = function(dat, varname, params = NULL) {
	# @description:
	#   Use Kaplan Merier to do survival analysis
	# @params:
	#   dat: The data frame, where:
	#     - 1st col is time
	#     - 2nd col is status (censoring)
	#     - 3rd col is the varialbe (var)
	#   varname: The variable name to display instead of var (3rd colname)
	#   params:  The params used for ggsurvplot. If provided, global plot$params will not be override

	# get the variable name
	cnames  = colnames(dat)
	var     = cnames[3]

	# get the levels of the values of the variable
	varlvls = levels(factor(dat[, var]))
	# how many levels are there?
	nvlvls = length(varlvls)

	fmula = as.formula(paste('Surv(time, status) ~', var))
	# the result:
	#   - summary: The result table
	#   - plot:    The survival plot
	#   - quantdata: The data to determine the quantile percentage
	ret   = list(summary = matrix(ncol = 6, nrow = 0), plot = NULL, quantdata = NULL)

	# if there are way more levels than expected number of groups, do the cut
	if (nvlvls > ngroups) {
		if (ngroups == 2 && autogroup) {
			quantsteps = seq(0.15, 0.85, by = 0.005)
			survscores = sapply(quantsteps, function(x){
				newdata = dat
				newdata[, var] = as.numeric(dat[, var] >= quantile(dat[, var], x))
				tryCatch({
					coxph(fmula, data = newdata)$score
				}, error = function(x) 1)
			})
			if (is.list(params.plot)) {
				ret$quantdata = data.frame(step = quantsteps, survscore = survscores)
			}
			idxmax = sample(which(survscores == max(survscores)), 1)
			quant  = quantsteps[idxmax]
			dat[, var] = paste0(
				"q",
				c(1, 2)[as.numeric(dat[, var] >= quantile(dat[, var], quant)) + 1]
			)
			varlvls = levels(factor(dat[, var]))
			rm(quantsteps, survscore)
		} else {
			dat[, var] = ncut(dat[, var], ngroups)
			varlvls = levels(factor(dat[, var]))
		}
	}
	# apply the model
	modkm     = surv_fit(fmula, data = dat)

	# called directly
	if (is.null(params)) {
		# get the pvalue
		survpval  = surv_pvalue(modkm)
		pval      = 'logrank'
		# format the pvalue
		if (!is.logical(pval)) {
			pvaldata  = list(
				method = test.names[[pval]],
				pval   = sprintf('%.2E', survpval$pval)
			)
		}

		colnames(ret$summary) = c('var', 'method', 'test', 'groups', 'df', 'pvalue')
		if (nvlvls == 1) {
			ret$summary = rbind(ret$summary, c(varname, 'logrank', 'NA', nrow(dat), 1, '1.00E+00'))
			return (ret)
		} else {
			ret$summary = rbind(ret$summary, c(varname, 'logrank', 'NA', paste(table(dat[, var]), collapse = ','), 1, survpval$pval))
			ret$summary = pretty.numbers(ret$summary, list(
				pvalue = '%.2E'
			))
		}
	}

	if (is.list(params.plot) && length(params.plot) > 0) {
		if (is.null(params)) {
			params.default = list(
				legend.title = varname,
				legend.labs  = varlvls,
				xlab         = paste0("Time (", outunit ,")"),
				ylim.min     = 0.0,
				pval.coord   = c(0, 0.1)
			)
			params          = update.list(params.default, params.plot)

			if (!is.logical(pval)) {
				params$pval = gsub('{method}', pvaldata$method, params$pval, fixed = T)
				params$pval = gsub('{pval}',   pvaldata$pval,   params$pval, fixed = T)
			} else {
				params$pval = FALSE
			}
		}
		ylim.min        = params$ylim.min
		params$ylim.min = NULL
		if (!is.numeric(ylim.min)) { # auto
			ylim.min = min(modkm$lower[!is.na(modkm$lower)]) - .2
			ylim.min = max(ylim.min, 0)
			params$ylim          = c(ylim.min, 1)
			params$pval.coord[2] = params$pval.coord[2] + ylim.min
		} else if (ylim.min > 0) {
			params$ylim          = c(ylim.min, 1)
			params$pval.coord[2] = params$pval.coord[2] + ylim.min
		}
		params$fit     = modkm
		params$data    = dat

		varlvls = levels(factor(dat[, var]))
		if (length(varlvls) < length(params$legend.labs))
			params$legend.labs = varlvls

		ret$groups    = paste(table(dat[, var]), collapse = ',')
		ret$plot      = do.call(ggsurvplot, params)
		ret$plot$plot = apply.ggs(ret$plot$plot, mainggs)

		# hack the table
		if (params$risk.table) {
			tableggs.one = list(
				ylab             = list(varname),
				xlab             = list(paste0("Time (", outunit ,")")),
				scale_y_discrete = list(labels = rev(params$legend.labs))
			)
			tableggs.one   = update.list(tableggs.one, tableggs)
			ret$plot$table = apply.ggs(ret$plot$table, tableggs.one)
		}
	}
	return(ret)
}

# do survival analysis on one variable and all covariants
# the input data should be a data frame with header:
#
# 	time	status	var
# sample1	100	1	1.2
# sample2	89	0	3.3
#
# the cvdata (covariant data frame) should be:
# 	sex	age
# sample1	1	39
# sample2	0	87
survivalOne = function(data, varname, cvdata = NULL) {
	if (!is.null(cvdata)) {
		data = cbind.fill(data, cvdata)
	}
	# only keep samples with all data available
	data      = data[complete.cases(data), , drop = F]
	# construct formula like 'Surv(time, status) ~ age + sex' using column names
	cnames    = make.names(colnames(data))
	colnames(data) = cnames

	var     = cnames[3]
	vars    = cnames[3:length(cnames)]
	varlvls = levels(factor(data[, var]))
	nvlvls  = length(varlvls)
	m       = method
	if (m == 'auto') {
		m = if (length(vars) == 1) 'km' else 'cox'
	}

	if (m == 'km') {
		ret = useKM(data, varname)
	} else {
		ret = useCox(data, varname)
	}

	return(list(ret))
}

data  = read.table.nodup(infile, sep = "\t", header = T, row.names = if(rnames) 1 else NULL, check.names = F)
vdata = NULL
if (!is.null(covfile) && covfile != '') {
	if (!rnames)
		stop('Rownames are required for covariant analysis.')
	vdata = read.table.nodup(covfile, sep = "\t", header = T, row.names = 1, check.names = F)
}

fct = 1
{% case (args.inunit, args.outunit) %}
	{% when ('days', 'weeks') %}
	fct = 1 / 7
	{% when ('days' ,'months') %}
	fct = 1 / 30
	{% when ('days' ,'years') %}
	fct = 1 / 365
	{% when ('weeks', 'days') %}
	fct = 7
	{% when ('weeks', 'months') %}
	fct = 7*12/365
	{% when ('weeks', 'years') %}
	fct = 7/365
	{% when ('years', 'days') %}
	fct = 365
	{% when ('years', 'weeks') %}
	fct = 365/7
	{% when ('years', 'months') %}
	fct = 12
{% endcase %}

cnames = colnames(data)
vars   = cnames[3:length(cnames)]

cnames[1] = 'time'
cnames[2] = 'status'

colnames(data) = cnames

if (fct != 1) {
	data[,1] = data[,1]*fct
}

# if there is only one variable to analyze
if (length(vars) == 1 || nthread == 1) {
	rets = NULL
	for (i in 1:length(vars))  {
		var  = vars[i]
		rets = c(rets, survivalOne(data[, c(1, 2, i+2), drop = F], var, vdata))
	}
} else {
	library(doParallel)
	cl <- makeCluster(nthread)
	registerDoParallel(cl)

	rets = foreach (i = 1:length(vars), .verbose = T, .combine = c, .packages = c('survival', 'survminer')) %dopar% {
		survivalOne(data[, c(1, 2, i+2), drop = F], vars[i], vdata)
	}
	stopCluster(cl)
}

allsums = NULL
allcovs = NULL
if (is.list(combine) && length(combine) > 0) {
	survplots   = NULL
	for (ret in rets) {
		allsums = rbind(allsums, ret$summary)
		if ('cov' %in% names(ret))
			allcovs = rbind(allcovs, ret$cov)
		if (!is.null(ret$plot))
			survplots  = c(survplots, list(ret$plot))
		if (!is.null(ret$quantdata)) {
			plotfile = file.path(outdir, paste0(ret$summary[1, 'var'], '.quant.png'))
			plot.scatter(ret$quantdata, plotfile, ggs = list(geom_line = list()), devpars = devpars)
		}
	}
	if (!is.null(survplots)) {
		if (!'ncol' %in% names(combine)) combine$ncol = 1
		if (!'nrow' %in% names(combine)) combine$nrow = 1
		maxdim         = max(combine$ncol, combine$nrow)
		devpars$height = maxdim * devpars$height
		devpars$width  = maxdim * devpars$width
		plotfile = file.path(outdir, '{{i.infile | fn2}}.survival.png')
		do.call(png, c(plotfile, devpars))
		do.call(arrange_ggsurvplots, c(list(x = survplots, print = T), combine))
		dev.off()
	}
} else {
	for (ret in rets) {
		if ('cov' %in% names(ret))
			allcovs = rbind(allcovs, ret$cov)
		allsums  = rbind(allsums, ret$summary)
		if (!is.null(ret$plot)) {
			plotfile = file.path(outdir, paste0(ret$summary[1, 'var'], '.survival.png'))
			do.call(png, c(plotfile, devpars))
			print (ret$plot)
			dev.off()
		}
		if (!is.null(ret$quantdata)) {
			plotfile = file.path(outdir, paste0(ret$summary[1, 'var'], '.quant.png'))
			plot.scatter(ret$quantdata, plotfile, ggs = list(geom_line = list()), devpars = devpars)
		}
	}
}
write.table(allsums, outfile, sep="\t", quote=F, col.names = T, row.names = F)

if (!is.null(allcovs))
	write.table(allcovs, '{{o.outfile | prefix | prefix}}.covariants.txt', sep="\t", quote=F, col.names = T, row.names = F)


# Analysis of barometers based on the KNMI series v01.

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]
  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'logger.name' = logger.name)
}

data.ref <- read.baro('KNMI_20200312_hourly')
with(data.ref, plot(x = TIMESTAMP_UTC, y = PRESSURE_VALUE, type = 'l'))

compare <- function(df, df.ref, make.plot = TRUE) {
  if (nrow(df) == 0L || nrow(df.ref) == 0L) return(data.table::data.table())
  df <- data.table::copy(df)
  df.ref <- data.table::copy(df.ref)

  # Center based on median
  df[, 'PRESSURE_VALUE' := PRESSURE_VALUE - median(PRESSURE_VALUE)]
  df.ref[, 'PRESSURE_VALUE' := PRESSURE_VALUE - median(PRESSURE_VALUE)]

  df.diff <- df[J(df.ref), .(
    'PRESSURE_VALUE' = x.PRESSURE_VALUE,
    'PRESSURE_VALUE_REF' = i.PRESSURE_VALUE,
    'PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE,
    TIMESTAMP_UTC)
    ][!is.na(PRESSURE_DIFF), ]

  if (nrow(df.diff) < 100L) return(data.table::data.table())

  wiskers <- boxplot.stats(df.diff[, PRESSURE_DIFF])$stats[c(1, 5)]
  wisker.diff <- wiskers[2L] - wiskers[1L]
  stats <- sprintf(paste0(
    'IRQ: %0.3f\n',
    'WISK: %0.3f\n',
    '95 %% RANGE: %0.3f\n',
    'SD: %0.3f'
    ),
    IQR(df.diff[, PRESSURE_DIFF]),
    wisker.diff,
    quantile(df.diff[, PRESSURE_DIFF], 0.975) - quantile(df.diff[, PRESSURE_DIFF], 0.025),
    sd(df.diff[, PRESSURE_DIFF])
  )

  p.both <- ggplot2::ggplot(data = df.diff, mapping = ggplot2::aes(x = TIMESTAMP_UTC)) +
    ggplot2::geom_line(mapping = ggplot2::aes(y = PRESSURE_VALUE_REF), col = 'red') +
    ggplot2::geom_line(mapping = ggplot2::aes(y = PRESSURE_VALUE), col = 'black') +
    ggplot2::coord_cartesian(ylim = quantile(with(df.diff, c(PRESSURE_VALUE, PRESSURE_VALUE_REF)),
                                             probs = c(0.001, 0.999))) +
    ggplot2::theme_light() +
    ggplot2::theme(axis.title.x = ggplot2::element_blank(),
                   axis.text.x = ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  p.diff <- ggplot2::ggplot(data = df.diff, mapping = ggplot2::aes(x = TIMESTAMP_UTC)) +
    ggplot2::geom_hline(yintercept = median(df.diff[1L:as.integer(.N*0.25), PRESSURE_DIFF]), alpha = 0.5) +
    ggplot2::geom_line(mapping = ggplot2::aes(y = PRESSURE_DIFF), col = 'black') +
    ggplot2::coord_cartesian(ylim = quantile(with(df.diff, PRESSURE_DIFF),
                                             probs = c(0.001, 0.999))) +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  binwidth <- 1.5 * IQR(df.diff$PRESSURE_DIFF) / nrow(df.diff) ^ (1/3)
  p.hist <- ggplot2::ggplot(data = df.diff, mapping = ggplot2::aes(x = PRESSURE_DIFF)) +
    ggplot2::geom_histogram(binwidth = binwidth, fill = 'black') +
    ggplot2::theme_light() +
    ggplot2::coord_cartesian(xlim = quantile(with(df.diff, PRESSURE_DIFF),
                                             probs = c(0.001, 0.999))) +
    ggplot2::ylab('FREQUENCY')

  p.txt <- ggplot2::ggplot() +
    ggplot2::annotate("text", x = 0, y = 0, size = 8, label = stats) +
    ggplot2::theme_void() +
    ggplot2::theme(panel.grid.major = ggplot2::element_blank(),
                   panel.grid.minor = ggplot2::element_blank())

  layout_matrix <- rbind(c(1, 1, 1, 4),
                         c(2, 2, 2, 3))

  grob.title <- grid::textGrob(sprintf('%s (#%s observations compared with %s)',
                                       basename(attr(df, 'logger.name')),
                                       nrow(df.diff),
                                       basename(attr(df.ref, 'logger.name'))),
                               x = 0.05, hjust = 0)

  filename <- sprintf('./drifts/analysis_12/WISK%08.3f_%s.png', wisker.diff,
                      tools::file_path_sans_ext(basename(basename(attr(df, 'logger.name')))))

  local({
    if (!make.plot) return()
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    print(gridExtra::grid.arrange(p.both, p.diff, p.hist, p.txt,
                                  layout_matrix = layout_matrix,
                                  top = grob.title))
  })

  structure(df.diff, 'logger.name' = attr(df, 'logger.name'))
}

#compare(read.baro(logger.names[1]),  data.ref)
results <- lapply(logger.names, function(name) compare(read.baro(name), data.ref))


library(igraph)
start_time <- Sys.time()
g <- erdos.renyi.game(1000000,10000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,10000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,10000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,10000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,10000000,"gnm")
end_time <- Sys.time()
end_time - start_time

print("end of exp1, start 1m, 100m")

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(1000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

print("end of exp2, start 10m 100m")
start_time <- Sys.time()
g <- erdos.renyi.game(10000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(10000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(10000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(10000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time

start_time <- Sys.time()
g <- erdos.renyi.game(10000000,100000000,"gnm")
end_time <- Sys.time()
end_time - start_time


calc.tempo <- function(mcmc.data, by.int, out.file="") {
  years <- seq(from = floor(min(mcmc.data)), to = ceiling(max(mcmc.data)), by = by.int)
  res.mat <- matrix(ncol = length(years), nrow = dim(mcmc.data)[1])

  for (i in 1:length(years)) {
    gte <- mcmc.data <= years[i]
    res.mat[,i] <- rowSums(gte)
  }
  means <- colMeans(res.mat)
  sds <- apply(res.mat, 2, sd)
  res.df <- data.frame(mean = means, sd = sds, year = years)

  if (!(out.file == "")) {
    write.csv(res.df, out.file)
  }
  return(res.df)
}

plot.tempo <- function(tempo.data = NULL, in.file = "",  out.file = "", max.x = NA,
                              min.x = NA, y.label = "Cumulative Events",
                              x.label = "Calendar Year", plot.ht = 7,
                              plot.wi = 7){
  library(ggplot2)
  if (is.null(tempo.data)){
    if (in.file == ""){
      stop("No data source")}
    else {
        tempo.data <- read.csv(in.file)}
  }
  h <- ggplot(tempo.data, aes(x = year))
  h <- h + geom_ribbon(aes(ymin = mean - sd, ymax = mean + sd))
  h <- h + geom_line(aes(y = mean))
  h <- h + xlab(x.label) + ylab(y.label)
  if (!(is.na(max.x) | is.na(min.x))){
    h <- h + xlim(min.x, max.x)
  }
  if (!(out.file == "")) {
    ggsave(filename = out.file, plot= h, height = plot.ht, width = plot.wi)
  }
  old.par <- par(no.readonly = T)
  dev.new(width = plot.wi, height = plot.ht)
  print(h)
  par(old.par)
}


#' @title calcKristWettedSA
#'
#'@description Calculate hull wetted surface area (\code{wettedSA}) (m^2)
#' using the Kristensen method.
#'
#' @param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with \code{paxTugShipTypes},
#'\code{tankerBulkCarrierGCargoShipTypes}, and \code{containerShipTypes}
#'groupings
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param actualDraft Actual draft (vector of numericals, m)
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCbw}})
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'@param paxTugShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as passengers and tug vessels (vector of strings)
#'@param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#'vessels (vector of strings)
#'@param containerShipTypes Ship types specified in input \code{shipTypes}to be
#'modeled as container ships (vector of strings)
#'
#' @details
#'
#' This method this requires ship types to be grouped. Use the
#' \code{paxTugShipTypes}, \code{tankerBulkCarrierGCargoShipTypes}, and
#' \code{containerShipTypes} grouping  parameters to provide these ship
#' type groupings. Any ship types not included in this grouping will be
#' considered as miscellaneous vessels.
#'
#'
#' Container ship wetted surface area:
#'
#' = 0.995(disp./lloyds draft + 1.9 * Lwl * lloyds draft)-2.4(lloyds draft-actual draft)(lwl+breadth)
#'
#' Bulk carrier, tanker, and general cargo ship wetted surface area:
#'
#' = 0.99(disp./lloyds draft + 1.9 * Lwl * lloyds draft)-2(lloyds draft- actual draft)(lwl+breadth)
#'
#' Cruise ships and tugs treated as twin screw RORO in Kristensen formulas on
#' the basis of sample of vessels from Lloyds and their number of propellers.
#'
#' Twin Screw RORO wetted surface area:
#'
#' = 1.21(disp./lloyds draft +1.3*lwl*lloyds draft)*(1.2-0.34*Cbw)-2.5(lloyds draft-actual draft)*(lwl+breadth)
#'
#' Auto carriers, miscellaneous, reefer, and RORO ships are treated as single
#' skeg ROROs in Kristensen formulas on the basis of sample of vessels from
#' Lloyds and their number of propellers.
#'
#' Single screw RORO wetted surface area:
#'
#' 0.87(disp./lloyds draft +2.7*lwl*lloyds draft)*(1.2-0.34*Cbw)-3.0(lloyds draft-actual draft)*(lwl+breadth)
#'
#' Note: Actual draft is typically obtained from sources such as AIS messages or ship records.
#'
#' @return \code{wettedSA} (vector of numericals, m^2)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calcShipType}}
#'}
#'
#' @family Kristensen Calculations
#'
#' @examples
#' calcKristWettedSA("bulk.carrier", 80097, 13.6, 12.5, 218, 32.25, 0.8099003, 1.025)
#' calcKristWettedSA("other.tanker", 238942, 15.6, 14, 400, 49, 0.7490287, 1.025,
#'                   tankerBulkCarrierGCargoShipTypes=c("other.tanker","bulk.carrier"))
#' calcKristWettedSA("container.ship", 238942, 15.6, 14, 400, 49, 0.7490287, 1.025)
#'
#' @export

calcKristWettedSA <- function(shipType, maxDisplacement, maxDraft, actualDraft, lwl, breadth, Cbw, seawaterDensity=1.025,
                              tankerBulkCarrierGCargoShipTypes=c("general.cargo","tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                              containerShipTypes=c("container.ship"),
                              paxTugShipTypes=c("ferry.pax","ferry.ro.pax","cruise","cruise.ed","yacht","tug","passenger","ro.ro")
                              ){

  wettedSA<- ifelse(#case 1
    shipType %in% containerShipTypes,
                    0.995*( maxDisplacement/(seawaterDensity*maxDraft) + 1.9*lwl*maxDraft)
                    - 2.4*(maxDraft-actualDraft)*(lwl+breadth)
                    ,
                    ifelse(#case2
                      shipType %in% tankerBulkCarrierGCargoShipTypes,
                            0.99*( maxDisplacement/(seawaterDensity*maxDraft) + 1.9 *lwl*maxDraft)
                            - 2*(maxDraft-actualDraft)*(lwl+breadth)
                            ,
                            ifelse(#case3
                              shipType %in% paxTugShipTypes,
                                  1.21*( maxDisplacement/(seawaterDensity*maxDraft) + 1.3*lwl*maxDraft)*(1.2-0.34*Cbw)
                                  - 2.5*(maxDraft-actualDraft)*(lwl+breadth)
                                  ,
                                  #miscelaneous case: reefer, roro, etc...
                                  0.87*( maxDisplacement/(seawaterDensity*maxDraft) + 2.7*lwl*maxDraft)*(1.2-0.34*Cbw)
                                  - 3.0*(maxDraft-actualDraft)*(lwl+breadth)
                                  )#end case 3
                          )#end case 2
                    )#end case 1

  return(wettedSA)
}


# Splits the pheno into 3 bins with the cut points between values rather at the exact value for the quantile
equalSizedBins <- function(phenoAvg, varlogfile)
{
    # Equal sized bins
    q <- quantile(phenoAvg, probs=c(1/3, 2/3), na.rm=TRUE)
    minX <- min(phenoAvg, na.rm=TRUE)
    maxX <- max(phenoAvg, na.rm=TRUE)
    phenoBinned <- phenoAvg

    cat("Split into three bins: ", file=varlogfile, append=TRUE)

    if (q[1] == minX) {

        # Edge case - quantile value is lowest value
        # Assign min value as cat1
        idx1 <- which(phenoAvg == q[1])
        phenoBinned[idx1] <- 0
        cat("0: [", q[1], ",", q[1], "],", file=varlogfile, append=TRUE, sep="")

        # Divide remaining values into cat2 and cat3
        phenoAvgRemaining <- phenoAvg[which(phenoAvg!=q[1])]
        qx <- quantile(phenoAvgRemaining, probs=c(0.5), na.rm=TRUE)
        minXX <- min(phenoAvgRemaining, na.rm=TRUE)
        maxXX <- max(phenoAvgRemaining, na.rm=TRUE)

        if (qx[1] == minXX) {
            # Edge case again - quantile value is lowest value
            idx2 <- which(phenoAvg == qx[1])
            cat(" 1: [", qx[1], ",", qx[1], "],", file=varlogfile, append=TRUE, sep="")

            idx3 <- which(phenoAvg > qx[1])
            cat(" 2: >", qx[1], " ||", file=varlogfile, append=TRUE, sep="")

        } else if (qx[1] == maxXX) {
            # Edge case again - quantile value is max value
            idx2 <- which(phenoAvg < qx[1] & phenoAvg > q[1])
            cat(" 1: (", q[1], ",", qx[1], "),", file=varlogfile, append=TRUE, sep="")
            idx3 <- which(phenoAvg == qx[1])
            cat(" 2: [",qx[1],",", qx[1], "] ||", file=varlogfile, append=TRUE, sep="")
        } else {
            idx2 <- which(phenoAvg < qx[1] & phenoAvg > q[1])
            cat(" 1: (", q[1], ",", qx[1], "),", file=varlogfile, append=TRUE, sep="")
            idx3 <- which(phenoAvg >= qx[1])
            cat(" 2: >=", qx[1], " ||", file=varlogfile, append=TRUE, sep="")
        }

        phenoBinned[idx2] <- 1
        phenoBinned[idx3] <- 2

    } else if (q[2] == maxX) {

        # Edge case - quantile value is highest value
    	# Assign max value as cat3
    	idx3 <- which(phenoAvg == q[2])
    	phenoBinned[idx3] <- 2

    	# Divide remaining values into cat1 and cat2
    	phenoAvgRemaining <- phenoAvg[which(phenoAvg!=q[2])]
        qx <- quantile(phenoAvgRemaining, probs=c(0.5), na.rm=TRUE)
    	minXX <- min(phenoAvgRemaining, na.rm=TRUE)
        maxXX <- max(phenoAvgRemaining, na.rm=TRUE)

    	if (qx[1] == minXX) {
            # edge case again - quantile value is lowest value
            idx1 <- which(phenoAvg == qx[1])
            cat("0: [", qx[1], ",", qx[1],"],", file=varlogfile, append=TRUE, sep="")
            idx2 <- which(phenoAvg > qx[1] & phenoAvg < q[2])
            cat(" 1: (", qx[1], ",", q[2], "),", file=varlogfile, append=TRUE, sep="")
        } else if	(qx[1] == maxXX) {
            # edge case again - quantile value is max value
            idx1 <- which(phenoAvg < qx[1])
            cat("0: <", qx[1], ",", file=varlogfile, append=TRUE, sep="")
            idx2 <- which(phenoAvg == qx[1])
            cat(" 1: [", qx[1], ",", qx[1], "] ", file=varlogfile, append=TRUE, sep="")
        } else {
            idx1 <- which(phenoAvg < qx[1])
            cat("0: <", qx[1], ",", file=varlogfile, append=TRUE, sep="")
            idx2 <- which(phenoAvg >= qx[1] & phenoAvg < q[2])
            cat(" 1: [", qx[1], ",", q[2], "),", file=varlogfile, append=TRUE, sep="")
    	}

        phenoBinned[idx1] <- 0
        phenoBinned[idx2] <- 1

        cat(" 2: [", q[2], ",", q[2],"] ||", file=varlogfile, append=TRUE, sep="")

    } else if (q[1] == q[2]) {

        # Both quantiles correspond to the same value so set
        # cat1 as < this value, cat2 as exactly this value and
        # cat3 as > this value

        phenoBinned <- phenoAvg
        idx1 <- which(phenoAvg < q[1])
        idx2 <- which(phenoAvg == q[2])
        idx3 <- which(phenoAvg > q[2])
        cat("0: <", q[1], ", 1: [", q[2], ",", q[2], "], 2: >", q[2]," ||", file=varlogfile, append=TRUE, sep="")
        phenoBinned[idx1] <- 0
        phenoBinned[idx2] <- 1
        phenoBinned[idx3] <- 2

    } else {

        # Standard case - split the data into three roughly equal parts where
        # cat1 < q1, cat2 between q1 and q2, and cat3 >= q2

        phenoBinned <- phenoAvg
        idx1 <- which(phenoAvg < q[1])
        idx2 <- which(phenoAvg >= q[1] & phenoAvg < q[2])
        idx3 <- which(phenoAvg >= q[2])
        cat("0: <", q[1],", 1: [", q[1], ",", q[2], "), 2: >=", q[2]," ||", file=varlogfile, append=TRUE, sep="")

        phenoBinned[idx1] <- 0
        phenoBinned[idx2] <- 1
        phenoBinned[idx3] <- 2
    }

    cat("cat N: ", length(idx1), ", ", length(idx2), ", ",
        length(idx3), " || ", sep="", file=varlogfile, append=TRUE)

    return(phenoBinned)
}


library(ggplot2)
data <- read.csv("./metrics-histogram-fidelity/results.csv", header = FALSE)
ggplot(data, aes(x = V1, y = V2, color = V3)) +
    labs(x = "quantile", y = "error %", color = "source") +
    geom_path() +
    facet_wrap(~ V3) +
    ggsave("tmp.png", width = 10, height = 5)


# Chunk 1
options(warn=-1)
games=games <- read.csv("input/games.csv")
head(games,3)
# Chunk 2
names(games)
# Chunk 3
#File read.r
#function which prepares the data
#return: a data set without missing values
getGames<-function(){
games <- read.csv("input/games.csv")
initialRows<-nrow(games)
initialCols<-ncol(games)
#Remove unsued columns
games$NA_Sales<-NULL
games$EU_Sales<-NULL
games$JP_Sales<-NULL
games$Other_Sales<-NULL
games$User_Score<-NULL
games$User_Count<-NULL
games$Rating<-NULL
games$Developer<-NULL
games$Name<-NULL
games$Publisher<-NULL
games$Critic_Score<-NULL
games$Critic_Count<-NULL
#Delete rows without a proper Genre
index<-which(games$Genre=="")
games<-games[-index,]
games$Genre<-factor(games$Genre)
#Delete rows without the release year
index<-which(games$Year_of_Release=="N/A")
games<-games[-index,]
#Set year of release as a date.
#dates$Year<-as.Date(games$Year_of_Realese,"%Y")
#Set proper names
names(games)[2]<-"Year"
names(games)[4]<-"Sales"
games<-games[complete.cases(games), ]
message(initialRows- nrow(games)," rows and "
,initialCols - ncol(games)," cols deleted" )
games
}
games<-getGames()
# Chunk 4
qqnorm(games$Sales)
# Chunk 5
qqnorm(log(games$Sales))
# Chunk 6
av.aov<-aov(games$Sales~games$Year)
summary(av.aov)
# Chunk 7
pv.aov<-aov(games$Sales~games$Platform)
summary(pv.aov)
# Chunk 8
gv.aov<-aov(games$Sales~games$Genre)
summary(gv.aov)
# Chunk 9
rm(av.aov)
rm(pv.aov)
rm(gv.aov)
# Chunk 10
table(games$Year)
# Chunk 11
#File clean.R
cleanGames<-function(games){
#Change one error
index<-which(games$Year=="2020")
games[index,"Year"]="2009"
#group the firsts years 1980-1994
fy<-seq(1980,1994)
fyears<-which(games$Year %in% fy)
games$Year<-as.character(games$Year)
games[fyears,"Year"]<-"1980-1994"
#Delete the 3 games from 2017
y2017=which(games$Year=="2017")
games<-games[-y2017,]
games$Year<-as.factor(games$Year)
games
}
games<-cleanGames(games)
# Chunk 12
library("reshape2")
games1<-dcast(games,games$Year+games$Platform~games$Genre, sum)
names(games1)[1]<-"Year"
names(games1)[2]<-"Device" #platform is a genre!!!
#Creating a new column with the sum of all sales
#in all genres per year.
games1$Sales<-rowSums(games1[,3:length(games1)])
#Proportion and then percentages
games2<-sweep(games1[,3:length(games1)],1,games1[,length(games1)],"/")
games2<-games2*100 #more readable
#Adding some columns
games2$Year<-games1$Year
games2$Device<-games1$Device
games2$Sales<-NULL
head(games2,4)
#Construim un altra dataframe només pels anys i gènere,
#idependent de la plataforma
gamesg1<-dcast(games,games$Year ~ games$Genre, sum)
names(gamesg1)[1]<-"Year"
gamesg1$Sales<-rowSums(gamesg1[,2:length(gamesg1)])
gamesg2<-sweep(gamesg1[,2:(length(gamesg1)-1)],1,gamesg1[,length(gamesg1)],"/")
gamesg2<-gamesg2*100
gamesg2$Year<-gamesg1$Year
#A games1 hi ha les vendes per any i device vs genere en format absolut
#A games2 hi ha les vendes per any i device vs genere en percentatge
#A gamesg1 hi ha les vendes per any vs gènere en format absolut
#A games2 hi ha les vendes per any vs gènere en percentatge
# Chunk 13
gamesg1matrix<-gamesg1[,2:length(gamesg1)]
round(cor(gamesg1matrix),2)
# Chunk 14
attach(gamesg1)
lm.sales<-lm(Sales~Adventure)
plot(Adventure,Sales)
lines(Adventure,fitted(lm.sales))
segments(Adventure,fitted(lm.sales),+Adventure,Sales)
# Chunk 15
par(mfrow=c(2,2), mex=0.6)
plot(lm.sales)
# Chunk 16
subset(gamesg1,select=c(3,14))
# Chunk 17
gamesg1[10,]
# Chunk 18
mlm.sales<-lm(Sales~Action+Adventure+Misc+
`Role-Playing`+Shooter+Simulation+Sports)
anova(mlm.sales)
# Chunk 19
mlm.sales<-lm(Sales~Action+Adventure+Sports)
anova(mlm.sales)
par(mfrow=c(2,2), mex=0.6)
plot(mlm.sales)
# Chunk 20
gamesg2matrix<-gamesg2[,1:(length(gamesg2)-1)]
round(cor(gamesg2matrix),2)
# Chunk 21
#Take the position of the greatest value for each row
index<-apply(gamesg2matrix,1,which.max)
#create a new dataframe to save the results
yres<-as.data.frame(matrix(3,23))
#Get the names of the genre
yres$genre<-names(gamesg2matrix)[index]
#Get the values
yres$value<-apply(gamesg2matrix,1,max)
yres$sv<-paste(round(yres$value,0),"%",sep="")
#Get the years
yres$year<-gamesg2$Year
#Concat year and platform
yres$label<-paste(yres$year,yres$genre, sep=" ")
yres$label<-paste(yres$label,yres$sv,sep=" ")
yres$V1<-NULL
par(mfrow=c(1,1), mex=0.6)
plot(yres$year,yres$value, xlab="Year",ylab="% of sales",main="Most popular genre")
text(yres$year,yres$value,yres$label, cex=0.6, pos=1, col="blue")
# Chunk 22
mSales=0.5
par(mfrow=c(1,1), mex=0.6)
#Delete rows with a low sales (~24 rows)
games2<-games2[which(games1$Sales>mSales),]
for (device in levels(games2$Device)){
nr=nrow(games2[which(games2$Device==device ),])
if (nr>1){
plaf=as.data.frame(matrix(1,nr))
plaf<-(games2[which(games2$Device==device ),])
if(nrow(plaf)>1){
plafmatrix<-plaf[,1:(length(gamesg2)-2)]
#Take the position of the greatest value for each row
index<-apply(plafmatrix,1,which.max)
#create a new dataframe to save the results
yres<-as.data.frame(matrix(3,nr))
#Get the names of the genre
yres$genre<-names(plafmatrix)[index]
#Get the values
yres$value<-apply(plafmatrix,1,max)
yres$sv<-paste(round(yres$value,0),"%",sep="")
#Get the years
yres$year<-factor(plaf$Year)
#Concat year and platform
yres$label<-paste(yres$year,yres$genre, sep=" ")
yres$label<-paste(yres$label,yres$sv,sep=" ")
yres$V1<-NULL
tit=paste("Most popular genre for",device, sep=" ")
fil=paste("img/",device,sep="")
fil=paste(fil,".png",sep="")
#png(fil,width = 800, height = 600)
par(mfrow=c(1,1), mex=0.6)
plot(yres$year,yres$value, xlab="Year",ylab="% of sales",main=tit)
text(yres$year,yres$value,yres$label, cex=0.6, pos=1, col="blue")
#dev.off()
}
}
}
# Chunk 23
res<-data.frame("","","","")
names(res)<-c("Plataforma","Inici","Fi","Genere")
res$Plataforma<-as.character(res$Plataforma)
res$`Inici`<-as.character(res$`Inici`)
res$`Fi`<-as.character(res$`Fi`)
res$Genere<-as.character(res$Genere)
first=1
for (device in levels(games2$Device)){
nr=nrow(games2[which(games2$Device==device ),])
if (nr>1){
plaf=as.data.frame(matrix(1,nr))
plaf<-(games2[which(games2$Device==device ),])
if(nrow(plaf)>1){
plafmatrix<-plaf[,1:(length(gamesg2)-2)]
#Take the position of the greatest value for each row
index<-apply(plafmatrix,1,which.max)
yres<-as.data.frame(matrix(3,nr))
yres$genre<-names(plafmatrix)[index]
yres$year<-as.character(plaf$Year)
yres$yearlable<-yres$year
if ("1980-1994" %in% yres$year)  { #it has to be the first one
yres[1,2]="1987"
}
yres$year<-as.numeric(yres$year)
}
miny=which.min(yres$year)
maxy=which.max(yres$year)
gen=tail(names(sort(table(yres$genre))), 1)
message("\nPlataforma: ",device,". Temps de vida: ",yres[miny,3],
" fins ", yres[maxy,3],".\n Gènere dominant: ",gen)
res[first,1]=device
res[first,2]=yres[miny,3]
res[first,3]=yres[maxy,3]
res[first,4]=gen
first=first+1
}
}
# Chunk 24
write.csv(games, file = "output/games.csv")
write.csv(games1, file = "output/games1.csv")
write.csv(gamesg1, file = "output/gamesg1.csv")
write.csv2(res, file = "output/res.csv")
detach(gamesg1)
savehistory("~/sincron/dataScience/tipologia/pacs/games2/codi.r")


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#criado:     02.07.2017
#modificado: 02.07.2017

library("class")

trainset <- read.csv("../data/golf.csv",header=TRUE)
testset <- read.csv("../data/golf-testset.csv",header=TRUE)

res <- knn(trainset[,c("Temperature","Humidity")], #attributes of training set
           testset[,c("Temperature","Humidity")],  #testing set
           trainset[,"Play"],                      #classes of trainset
           k=1)                                    #k-nearest neighbour

#Confusion Matrix
conf_mat <- table(testset[,c("Play")],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)
library(abind)
library(zoo)
library(tidyverse)
library(magrittr)

source("utils/ifr-tools.r")

process_covariates_regions <- function(
  region_to_country_map,
  mobility,
  interventions,
  d,
  ifr.by.country,
  N2,
  formula,
  formula_partial,
  death_thresh_epi_start=10,
  mobility_processing="none"
){
  interventions$Country <- factor(interventions$Country)

  serial.interval = read.csv("data/serial_interval.csv")
  # Pads serial interval with 0 if N2 is greater than the length of the serial
  # interval array
  if (N2 > length(serial.interval$fit)) {
    pad_serial.interval <- data.frame(
      "X"=(length(serial.interval$fit)+1):N2,
      "fit"=rep(1e-17, max(N2-length(serial.interval$fit), 0 ))
    )
    serial.interval = rbind(serial.interval, pad_serial.interval)
  }
  # various distributions required for modeling
  infection_to_onset <- c("mean"=5.1, "deviation"=0.86)
  onset_to_death <- c("mean"=18.8, "deviation"=0.45)
  # infection-to-onset distribution
  x1 = rgammaAlt(1e6,infection_to_onset["mean"], infection_to_onset["deviation"])
  # onset-to-death distribution
  x2 = rgammaAlt(1e6,onset_to_death["mean"], onset_to_death["deviation"])
  ecdf.saved <- ecdf(x1+x2)
  # stan data definition
  stan_data <- list(M=length(names(region_to_country_map)),N=NULL,deaths=NULL,f=NULL,
                    N0=6,cases=NULL,SI=serial.interval$fit[1:N2],
                    EpidemicStart = NULL, pop = NULL)
  # Other values
  forecast <- 0
  dates <- list()
  reported_cases <- list()
  deaths_by_country <- list()
  intervention_length <- length(colnames(interventions))
  mobility_length <- length(colnames(mobility))

  covariate_list <- list()
  covariate_list_partial <- list()
  processed_mobility <-list()
  preprocess_error = FALSE

  k=1
  # going over each region
  for(Region in names(region_to_country_map))
  {
    Country = region_to_country_map[[Region]]
    message(sprintf("Region: %s in country: %s ",Region,Country))

    # COVID data processing
    if(!any(d$Country==Region)){
      preprocess_error = TRUE
      message(sprintf(
        "ERROR: Region %s in country %s had no data (region length(region)==0)", Region, Country))
      next
    }
    region <- d[d$Country==Region,]
    region <-region[order(as.Date(region$DateRep)),]  # ensure date ordering
    region$Deaths = remove_negative_deaths(region$Deaths)

    # IFR processing
    IFR = ifr_from_array(ifr.by.country, Country, Region)
    region_pop = population_from_array(ifr.by.country, region, Country, Region)

    # Mobility processing
    mobility1 <- mobility[mobility$country==Region,]
    if(!any(mobility$country==Region)){
      preprocess_error = TRUE
      message(sprintf(
        "ERROR: Region %s in country %s had no mobility data (region length(mobility1)==0)", Region, Country))
      next
    }
    mobility1$date<-ymd(mobility1$date)
    mobility1<-na.locf(mobility1)
    mobility1 <- mobility1[order(mobility1$date),]  # ensure date ordering
    # padding in raw data backwards ex. portugal

    date_min <- dmy('31/12/2019')
    region <- pad_dates_region_dataframe(
      region, date_field="DateRep",
      date_start=date_min,
      col_fill=list("Cases", "Deaths")
    )

    # Padding in mobility data for dates before first time data exists
    mobility_numeric_fields = list(
        "grocery.pharmacy", "parks", "residential",
        "retail.recreation", "transitstations", "workplace"
      )
    mobility1 <- pad_dates_region_dataframe(
      mobility1, date_field="date",
      date_start=date_min,
      col_fill=mobility_numeric_fields,
      fill_value=c(0, "extend", "extend")
    )

    # forecasting mobility data
    date_max = max(region$DateRep)
    date_mobility_max = max(mobility1$date)

    # Foreward padding mobility data using repetition of last 7 days of data
    if (date_mobility_max < date_max){
      message(paste('\t',Region,'In padding mobility forward'))
      forecast_days <- date_max - date_mobility_max
      pad = mobility1[(nrow(mobility1)-6):nrow(mobility1),]
      padded_data = pad[rep(seq_len(nrow(pad)), length.out = forecast_days[1]),]
      padded_data$date = date_mobility_max + days(1:forecast_days[[1]])
      mobility1 <- bind_rows(mobility1,padded_data)
    }
    mobility1 = mobility1[order(mobility1$date),]  # ensure date ordering
    mobility1 <- na.locf(mobility1)
    mobility1 <- preprocess_mobility(
      mobility1, processing=mobility_processing,
      numerical_fields=mobility_numeric_fields
    )

    index = which(region$Cases>0)[1]
    index1 = which(cumsum(region$Deaths)>=death_thresh_epi_start)[1] # also 5
    if (is.na(index1)) {
      preprocess_error = TRUE
      message(sprintf(
        "ERROR: Region %s in country %s has not reached 10 deaths on %s, it cannot be processed\nremove from 'active-countries.cfg' or 'active-regions.cfg'\n",
        Region, Country, max_date))
      next
    }
    index2 = index1-30

    message(sprintf("\tFirst non-zero cases is on day %d, and 30 days before 10 deaths is day %d",index,index2))
    region=region[index2:nrow(region),]
    stan_data$EpidemicStart = c(stan_data$EpidemicStart,index1+1-index2)
    stan_data$pop = c(stan_data$pop,region_pop)

    mobility1 = mobility1[index2:nrow(mobility1),]

    # NPI interventionss are being used
    interventions_region <- interventions[interventions$Country == Country, c(2,3,4,5,6)] # school, self-isolation, public, lockdown, social-distancing
    for (ii in 1:ncol(interventions_region)) {
      covariate = names(interventions_region)[ii]
      region[covariate] <- (region$DateRep >= as.data.frame(interventions_region)[1,covariate])*1  # should this be > or >=?
    }

    dates[[Region]] =region$DateRep
    # hazard estimation
    N = nrow(region)
    message(sprintf("\t%s has %d days of data; start date %s",Region,N, region$DateRep[1]))
    forecast = N2 - N

    if (forecast<0){
      stop(message("Error Modelling length is shorter than the length of the data, please increase N2"))
    }
    if (nrow(mobility1)>N2){
      message("WARNING: Modelling length (N2) is shorter than the length of the mobility data, trimming.")
      mobility1 <- mobility1[1:N2,]
    }

    # IFR is the overall probability of dying given infection
    convolution = function(u) (IFR * ecdf.saved(u))

    f = rep(0,N2) # f is the probability of dying on day i given infection
    f[1] = (convolution(1.5) - convolution(0))
    for(i in 2:N2) {
      f[i] = (convolution(i+.5) - convolution(i-.5))
    }
    reported_cases[[Region]] = as.vector(as.numeric(region$Cases))
    deaths=c(as.vector(as.numeric(region$Deaths)),rep(-1,forecast))
    cases=c(as.vector(as.numeric(region$Cases)),rep(-1,forecast))
    deaths_by_country[[Region]] = as.vector(as.numeric(region$Deaths))
    region_intervention <- as.data.frame(region[, colnames(interventions_region)])
    # This line will prevent modelling of a future change of interventions
    region_intervention[N:(N+forecast),] <- region_intervention[N,]
    mobility1[N:(N+forecast),] <- mobility1[N,]
    ## append data
    stan_data$N = c(stan_data$N,N)
    # stan_data$x = cbind(stan_data$x,x)
    stan_data$f = cbind(stan_data$f,f)
    stan_data$deaths = cbind(stan_data$deaths,deaths)
    stan_data$cases = cbind(stan_data$cases,cases)

    stan_data$N2=N2
    stan_data$x=1:N2
    if(length(stan_data$N) == 1) {
      stan_data$N = as.array(stan_data$N)
    }
    #parsing features
    df_features <- data.frame(
      'schools_universities' = region_intervention$schools_universities,
      'self_isolating_if_ill' = region_intervention$self_isolating_if_ill,
      'social_distancing_encouraged' = region_intervention$social_distancing_encouraged,
      'public_events' = region_intervention$public_events,
      'lockdown' = region_intervention$lockdown,
      'first' = 1*((region_intervention$schools_universities+
                      region_intervention$self_isolating_if_ill+
                      region_intervention$social_distancing_encouraged+
                      region_intervention$public_events+
                      region_intervention$lockdown) >= 1),
      'residential' = mobility1$residential,
      'transit' = mobility1$transitstations,
      'grocery' = mobility1$grocery.pharmacy,
      'parks' = mobility1$parks,
      'retail' = mobility1$retail.recreation,
      'workplace' = mobility1$workplace,
      'averageMobility' = (mobility1$grocery.pharmacy + mobility1$parks +
                             mobility1$retail.recreation + mobility1$workplace)/4)
    features <- model.matrix(formula, df_features)
    features_partial <- model.matrix(formula_partial, df_features)
    processed_mobility <- bind_rows(processed_mobility, bind_cols(mobility1,region_intervention))
    covariate_list[[k]] <- features
    covariate_list_partial[[k]] <- features_partial
    k <- k+1
  }

  stan_data$P = dim(features)[2]
  stan_data$X = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P ))
  stan_data$P_partial = dim(features_partial)[2]
  # If there is no partial pooling of variables set of dim 1 to avoid overflows
  if(stan_data$P_partial==0){
    stan_data$X_partial = array(0, dim = c(stan_data$M , stan_data$N2, 1))
  }
  # If there partial pooling of variables set X_partial to the correct size:
  # (countries or regions)* N2 * P_partial
  else{
    stan_data$X_partial = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P_partial))
  }
  # Unpack covariates and partial covariates to pass to stan model
  for (i in 1:stan_data$M){
    stan_data$X[i,,] = covariate_list[[i]]
    if(stan_data$P_partial != 0)
      stan_data$X_partial[i,,] = covariate_list_partial[[i]]
  }
  if(stan_data$P_partial == 0) # special case when ther are no partial covariates
    stan_data$P_partial = 1

  # Normalise positive covariate effects to be between 0 and 1
  stan_data$X=normalise_covariate_array(stan_data$X)
  # Normalise positive pooled covariate effects to be between 0 and 1
  stan_data$X_partial=normalise_covariate_array(stan_data$X_partial)

  return(list("stan_data" = stan_data, "dates" = dates, "reported_cases"=reported_cases,
   "deaths_by_country" = deaths_by_country, "processed_mobility"=processed_mobility))
}

normalise_covariate_array <- function(covariate_array){
  # Normalise positive covariate effects to be between 0 and 1
  dm=dim(covariate_array)
  for(j in 1:dm[3]){ # for covariates
    for(i in 1:dm[1]){ # countries
      raw=covariate_array[i,,j]
      if(all(raw!=0)){
        top = raw[raw>=0]
        bottom = raw[raw<=0]
        adjusted=raw
        # only act on real valued covariates (not the discrete interventions)
        if(sum(top==1)!=length(top)){
          top=rescale(top,to=c(0,1))
          adjusted[raw>=0]=top
        }
        covariate_array[i,,j] = adjusted
      }
    }
  }
  return(covariate_array)
}

pad_dates_region_dataframe <- function(
  region,
  date_field="date",
  date_start=NULL,
  date_end=NULL,
  col_fill=list(),
  fill_value=list(0,0,0)
){
  if(is.null(date_start)){
    date_start <- region[1, date_field]
  }
  if(is.null(date_end)){
    date_end <- region[nrow(region), date_field]
  }

  # Generates an internal pad
  region_internal_pad = data.frame(
    "date"=as.Date(
      date_start + days(0:(date_end-date_start)),
      format="%Y-%m-%d"),
    stringsAsFactors=F)
  # Merges the pad with the regions
  region <- merge(
    region, region_internal_pad,
    by.x=date_field, by.y="date", all=TRUE) # extends region
  region <- merge(
    region, region_internal_pad,
    by.x=date_field, by.y="date") # trims region to internal pad

  region = region[order(region[[date_field]]),]
  # Certain fields must be filled with specific values
  for (field in col_fill) {
    region[[field]] <- na.fill(region[[field]], fill=fill_value)
  }

  # Others with closest non NA value
  region <- na.locf(region, na.rm=FALSE)
  region <- na.locf(region, na.rm=FALSE, fromLast=TRUE)
  return(region)
}

remove_negative_deaths <- function (vals) {
  # Removes negative values by setting them to 0 but reflects their
  # effect by scaling the rest of the data keeping the same total number of deaths
  # implied by the data.
  neg_val = sum(vals[vals < 0])
  if (neg_val < 0){
    pos_val = sum(vals[vals > 0])
    tot_val = neg_val + pos_val
    vals[vals < 0] = 0
    val_add = ceiling(vals * (-neg_val / tot_val))
    while (sum(val_add) != -neg_val){
      if (sum(val_add) > -neg_val){
        ix=which.max(val_add)
        val_add[ix] = val_add[ix] - 1
      } else {
        stop("should not be here")
      }
    }
    vals = vals - val_add
    message(sprintf(
      "\tVals edited to have no negative numbers offset: %d (checksum: %d==%d)",
      neg_val, tot_val, sum(vals)
    ))
    if(tot_val != sum(vals)){
      stop(message("ERROR: `remove_negative_deaths should keep constant total.`"))
    }
  }
  return(vals)
}

preprocess_mobility <- function(
  data,
  processing="none",
  item_field="country",
  order_field="date",
  numerical_fields=c()
){

  # Replaces the names in the mobility data with that of the model
  item_list <- unique(data[[item_field]])
  for (item in item_list) {

    item_indexer <- data[[item_field]]==item
    temp <- data[item_indexer,]
    temp <- temp[order(temp[[order_field]]),]
    for (num_f in numerical_fields){
      temp[[num_f]] <- preprocess_mobility_vector(temp[[num_f]], processing)
    }
    data[item_indexer,] <- temp
  }
  return(data)
}

preprocess_mobility_vector <- function (data, processing){

  if (processing=="none"){
    # does nothing
  } else if (processing=="rolling_mean"){
    data = rollmean(data, 7, align="right", fill="extend")
  } else {
    data = eval(parse(text=processing))
  }

  return (data)
}


#' split gene set into several modules using clustering of genes by correlation over cells downsampled umi vector
#'
#' @param gset_id current gene set object. Only the list of genes will be used
#' @param mat_id scRNA matrix to use. We assume genes in the set are represented in the matrix, but if force is T we allow filtering of genes by represented matrix entry in addtion to clsutering
#' @param K how many gene modules to generate (cutree parameter)
#' @param force if this is T, we allow clustering usign matrix in which not all genes are represnted. This will override the existing gset will a subset of the genes!
#' @param (ENV) scm_k_nonz_exp - to define transformation of UMIs
#'
#' @export

mcell_gset_split_by_dsmat = function(gset_id, mat_id, K, force=F)
{
	gset = scdb_gset(gset_id)
	if(is.null(gset)) {
		stop("missing gset id ", gset_id, " when trying to split gset into clusts")
	}
	feat = gset_get_feat_mat(gset_id, mat_id, downsamp=T)

	gs  = names(gset@gene_set)
	valid_gs = intersect(rownames(feat)[rowSums(feat) > 0], gs)
	if(!force & length(valid_gs) != length(gs)) {
		stop("MC-ERR Missing genes in the matrix when trying to split gset by mat. Use force=T to filter these genes from the gene set before splitting genes into groups")
	}
	if(length(valid_gs) < 5) {
		stop("MC-ERR less than 5 genes when trying to split gset, this does not make sense, breaking")
	}
	feat = feat[valid_gs, ]

	k_nonz_exp = get_param("scm_k_nonz_exp")

	feat = log2(1+k_nonz_exp*as.matrix(feat))
	feat_cor = tgs_cor(t(feat))
	set.seed(19)
	hc = hclust(as.dist(1-feat_cor), "ward.D2")
	clst = cutree(hc, K)

	desc = sprintf("%s hc K=%d", gset@description,	K)
	scdb_add_gset(gset_id, gset_new_gset(clst, desc))
}

#' add new gene set based on an existing one with filtering specific clusters
#'
#' @param gset_id current gene set object. Only the list of genes will be used
#' @param filt_clusts list of clusters for filtering
#' @param new_id id of newly generated gene set
#'
#' @export

mcell_gset_remove_clusts = function(gset_id, filt_clusts, new_id, reverse=F)
{
	gset = scdb_gset(gset_id)
	if(is.null(gset)) {
		stop("trying to filter non existing gset, id ", gset_id)
	}
	sets = gset@gene_set
	if(!reverse) {
			  filt_sets = sets[!sets %in% filt_clusts]
	} else {
			  filt_sets = sets[sets %in% filt_clusts]
	}
	desc = sprintf("%s cl_filt", gset@description)
	scdb_add_gset(new_id, gset_new_gset(filt_sets, desc))
}


####### Setup #######

library(drgee)

####### Robust Estimation #######

### First robust Model ###

dfRes.Error = dfRes[dfData$structure == "OR"  & dfRes$Pearson_Residuals > 2.5,]

'%ni%' <- Negate('%in%')

dfData.Robust = dfData[dfRes$Index %ni% dfRes.Error$Index,]

levels(dfData.Robust$age_group) = c("5yo", "7+8yo", "7+8yo")

model.gee.robust =
  geeglm(as.integer(success)-1 ~ age_group + structure + match_mismatch,
         data = dfData.Robust,
         id = id,
         corstr = "exchangeable",
         family = binomial(link = "logit"))

summary(model.gee.robust)
QIC(model.gee.robust)

table(as.integer(dfData.Robust$success)-1, as.numeric(model.gee.robust$fitted.values > 0.5))

dfRes.Robust = data.frame(Index = 1:length(qresiduals(model.gee.robust)), Pearson_Residuals = resid(model.gee.robust, type = "pearson"), Estimation = as.character(as.numeric(model.gee.robust$fitted.values > 0.5)))

ggplot(dfRes.Robust, aes(x = dfData.Robust$id , y = Pearson_Residuals)) +
  geom_boxplot(color = vColors[1], outlier.colour = vColors[3]) +
  geom_hline(yintercept = 0,color = vColors[5], linetype= 5, cex = 0.7) +
  geom_hline(yintercept = 2,color = "grey50", linetype= 5, cex = 0.5) +
  geom_hline(yintercept = -2,color = "grey50", linetype= 5, cex = 0.5) +
  ylab("Pearson Residuals") + xlab("id of Child")

ggplot(dfRes.Robust, aes(x = dfData.Robust$structure , y = Pearson_Residuals)) +
  geom_boxplot(color = vColors[1], outlier.colour = vColors[3]) +
  geom_hline(yintercept = 0,color = vColors[5], linetype= 5, cex = 0.7) +
  geom_hline(yintercept = 2,color = "grey50", linetype= 5, cex = 0.5) +
  geom_hline(yintercept = -2,color = "grey50", linetype= 5, cex = 0.5) +
  ylab("Pearson Residuals") + xlab("Structure")

qqnorm(qresiduals(model.gee.robust),pch=16,bty='n',main='Randomized Quantile Residuals', col = vColors[1], ylab = "Sample Quantiles")
qqline(qresiduals(model.gee.robust),lwd=2,col= vColors[5])

model.gee.robust %>% coefficients() %>% exp()

### Second robust Model ###

model.gee.robust2 = drgee(outcome = "success", eformula = formula(success ~ age_group + structure + match_mismatch),
                          iaformula = formula(success~age_group + structure + match_mismatch), elink="logit",
                          data = dfData, estimation.method = "e")
summary(model.gee.robust2)

getScoreResidualsFromClogit(fit = model.gee.robust2, x =  model.gee.robust2$drgee.data$z, y = as.integer(dfData$success)-1, id = dfData$id)

res <- (as.integer(dfData$success)-1 - model.gee.robust2$fitted) /
  sqrt(model.gee$fitted * (1 - model.gee$fitted))

dfRes = data.frame(Index = 1:length(qresiduals(model.gee)), Pearson_Residuals =res, Estimation = as.character(as.numeric(model.gee$fitted.values > 0.5)))

ggplot(dfRes, aes(x = dfData$id , y = Pearson_Residuals)) +
  geom_boxplot(color = vColors[1], outlier.colour = vColors[3]) +
  geom_hline(yintercept = 0,color = vColors[5], linetype= 5, cex = 0.7) +
  geom_hline(yintercept = 2,color = "grey50", linetype= 5, cex = 0.5) +
  geom_hline(yintercept = -2,color = "grey50", linetype= 5, cex = 0.5) +
  ylab("Pearson Residuals") + xlab("Structure")


# make this reusable by implementing input, output

library(googlesheets4)
library(stringr)
library(dplyr)
library("VennDiagram")
library(Matrix.utils)

## preprocess : clean column names and make groups
d0=read.table("count.txt",check.name=F,header=T)
colnames(d0)=str_replace(colnames(d0),".genes.results","")
colnames(d0)=str_replace(colnames(d0),"-","_")

gene= unlist( lapply(row.names(d0), function(x1) str_split(x1,"_")[[1]][2]))
d0 = d0 %>% aggregate.Matrix(groupings=gene)

d=d0[,grep("MDSC",colnames(d0))]
g= paste0(str_match(colnames(d),"VPK|WT"),"_",str_match(colnames(d),"splenic|tumor"))
v=data.frame(id=colnames(d),g=g)

## run DESeq2
dds=DESeqDataSetFromMatrix(as.matrix(round(d)), DataFrame(v), ~0+ g)
dds= dds[rowSums(counts(dds)) >= 10,]
dds = DESeq(dds)
rn=resultsNames(dds)
#"gVPK_splenic" "gVPK_tumor"   "gWT_splenic"  "gWT_tumor"

rld <- rlog(dds, blind=TRUE)
plotPCA(rld, intgroup="id")
pheatmap(cor(assay(rld)))

## Wald test
ctr="gWT_splenic"
trt="gVPK_splenic"
ctr="gWT_tumor"
trt="gVPK_tumor"
cont=rep(0,length(rn))
cont[ rn == ctr ] = -1; cont[ rn == trt ] = 1
res=results(dds,contrast=cont,alpha=0.5)
ntd=assay(normTransform(dds))
o=order(res$pvalue)
pheatmap(t(scale(t( ntd[o,][1:100,]))),fontsize_row=5)
#de=list()


#!/usr/bin/env Rscript
rm(list=ls())
library(dplyr)

args = (commandArgs(TRUE))

inFileName = args[1]

system(paste("grep TABLE ", inFileName, " > ", inFileName, ".TABLE", sep=""))
system(paste("grep BETA ", inFileName, " > ", inFileName, ".BETA", sep=""))

mytable = read.table(paste(inFileName, ".TABLE", sep=""), header=T, stringsAsFactors = F)[,-1]
mybeta = read.table(paste(inFileName, ".BETA", sep=""), header=T, stringsAsFactors = F)[,-1]

pdf("tmp.pdf")

plot(mytable$df, ylab = "# of predictor variable")

plot(mytable$rsq, ylab = "Deviance ratio")

plot(diff(mytable$rsq), ylab = "Deviance ratio differences" )

v_idx = c()
plot(c(0, max(mytable$L1norm)),
     c(min(mybeta[,-1]), max(mybeta[,-1])), type="n", xlab = "L1 Norm", ylab = "Coefficient")
for (i in 1:dim(mybeta)[1]){
#    if (sum(mybeta[i,-1])>0){
     lines(c(0,mytable$L1norm), c(0,mybeta[i,-1]), col = i)
#        v_idx = c(v_idx, i)
#    }
}
legend("topleft", legend=mybeta[,1], col = 1:length(mybeta[,1]), lty=1)

dev.off()


# SHAP  for all severity hybrid

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
#library(mgcv)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library("DALEX")
library("iBreakDown")
library("r2d3")
library("data.table")
library("dplyr")
library("ggplot2")
library("gam")

library(doParallel)
detectCores(all.tests = FALSE, logical = TRUE)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

set.seed(1234)

```

# Performance All SeverityAll in Train and Test
```{r}

###
Hoge1 <- fread("SHAP_all_severity_gam.csv")
Hoge2 <- fread("SHAP_all_severity_xgboost.csv")
Hoge <- rbind(Hoge1, Hoge2)

SHAP_data <- Hoge %>%
	group_by(ID, variable_name) %>%
	summarize(
		Variable_value = first(variable_value),
		Contribution = mean(contribution)
		) %>%
	data.table() %>%
	print()

SHAP_data[, Contribution := as.numeric(Contribution), ]
SHAP_data[, Variable_value := as.numeric(Variable_value), ]

SHAP_data[, Variable_value_scale := scale(Variable_value), by = variable_name]

SHAP_data %>%
	group_by(variable_name) %>%
	summarize(
		mean(Variable_value_scale),
		sd(Variable_value_scale),
		)

### plot SHAP
Var <- c(
"temperature", "temperature_past1d_max_diff", "temperature_past1d_mean_diff", "temperature_past1d_min_diff", "DownwardSolarRadiation_kwm2", "relativeHumidity", "precip1Hour", "windSpeed_ms",

"Population100000",
"Population_over_65_100000", "Age_median_city", "SexRatioF", "Mean_income_city_2015", "Green_area_percent",

"RainySeason", "DifDateRain", "holiday_flag", "Hour", "Month"
)

SHAP_data[Variable_value_scale > 5, , ]

SHAP_data[Variable_value_scale < -5, , ]

SHAP_data[abs(Contribution) > 20, , ]

SHAP_data[, Variable_value_scale := ifelse(Variable_value_scale > 5, 5, Variable_value_scale), ]

ggplot(data = SHAP_data) +
    coord_flip() +
	ggforce::geom_sina(
	    aes(x = variable_name, y = Contribution, color = Variable_value_scale),
	    method = "counts", size = 3,
		#maxwidth = .7,
		alpha = 3) +
	#scale_color_gradient(low = "lightblue", high = "red") +
	scale_y_continuous(limits = c(-20, 20), breaks = seq(-20, 20, 5)) +
	scale_x_discrete(limits = rev(Var)) +
	scale_color_gradient(low = "#FFCC33", high = "#6600CC") +
	theme_bw()

ggsave("Out_SHAP_all.png", width = 10, height = 15)

SHAP_data <- SHAP_data[abs(Contribution) <= 20, , ]
fwrite(SHAP_data, "Out_data_figure3_SHAP_hybrid.csv")


# Read CRU TS3.21 tmx temperature data (daily max by month)
require(raster)
require(abind)
require(reshape2)
require(ncdf4)
require(raster)

# Read in CRU TS3.21 tmx data
	fs <- c('data/cru_ts3.21/cru_ts3.21.1981.1990.tmx.dat.nc.gz', 'data/cru_ts3.21/cru_ts3.21.1991.2000.tmx.dat.nc.gz', 'data/cru_ts3.21/cru_ts3.21.2001.2010.tmx.dat.nc.gz')

	for(i in 1:length(fs)){
		n = nc_open(fs[i]) # Open the netCDF file
		# print(n) # get information about the file format

		# get data
		inarray = ncvar_get(n, 'tmx') # dim order: 720 lon x 360 lat x 120 time (observations are month, time measured in days since Jan 1, 1900). 0 lon is at date line.
			# dim(inarray)
		dimnames(inarray) <- list(lon=ncvar_get(n, 'lon'), lat=ncvar_get(n, 'lat'), time=ncvar_get(n, 'time'))

		nc_close(n)

		if(i==1) tmx <- inarray
		if(i>1) tmx <- abind(tmx, inarray, along=3)
	}
	dim(tmx)

# Trim to 1986-2005
times <- as.numeric(dimnames(tmx)[[3]])
tmx <- tmx[,,times > 31425 & times < 38701]
dim(tmx) # 720 x 360 x 240

# Reshape so lat x lon x time since start
tmx <- aperm(tmx, c(2,1,3))

# Flip so lat is 90 to -90 (like cmip5)
tmx <- tmx[dim(tmx)[1]:1,,]

# Rotate so lon is 0-360 (like cmip5)
lons <- as.numeric(colnames(tmx))
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

tmx <- tmx[, newlonord,]
colnames(tmx) <- newcolnms

	dimnames(tmx)
	image(tmx[,,1])

# Already at 0.5x0.5, so no need to interpolate!

# Nicer dimension names
dates <- format(as.Date(as.numeric(dimnames(tmx)[[3]]), origin=as.Date('1900-01-01')), format='%Y%m')
dimnames(tmx) <- list(lat=dimnames(tmx)[[1]], lon=dimnames(tmx)[[2]], time=dates)

# write out array
save(tmx, file='temp/cruts321_tmx.rdata')

#############
## examine
#############
load('temp/cruts321_tmx.rdata')

for(i in 1:dim(tmx)[3]){
	image(t(tmx[nrow(tmx):1,,i]), main=dimnames(tmx)[[3]][i])
	readline(prompt="Press [enter] to continue")
}

##############################################################
# warmest daily high in any month (looking across 1986-2005)
# at 0.25x0.25
##############################################################
load('temp/cruts321_tmx.rdata')
source('scripts/image.scale.r') # for plotting color bar on image
require(RColorBrewer)

# find the month with the warmest average daily high
tasmax <- apply(tmx, MARGIN=c(1,2), FUN=max)

	image(t(tasmax[nrow(tasmax):1,])) # quick image

	# nicer image
	zlims <- range(tasmax, na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=20)
	cols <- colorRampPalette(rev(brewer.pal(9, "RdYlBu")))(length(bks)-1)

	quartz(height=6, width=5)
	layout(matrix(c(1,2),nrow=2), heights=c(3,1))
	par(mai=c(0.5, 0.5, 0.3, 0.1))
	image(x=as.numeric(dimnames(tasmax)[[2]]), y=rev(as.numeric(dimnames(tasmax)[[1]])), t(tasmax[nrow(tasmax):1,]), col=cols, breaks=bks, main='tasmax 1986-2005', xlab='', ylab='')
		par(mar=c(3,1,1,1), mai=c(0.8, 0.2, 0.1, 0.1), mgp=c(2,0.8, 0))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=TRUE, xlab='tmxmx (°C)')

# resample to 0.25x0.25
tasmaxr <- raster(tasmax, xmn=0, xmx=360, ymn=-90, ymx=90) # convert to raster
nmat <- matrix(NA, nrow=720, ncol=1440)
ngrd <- raster(nmat, xmn=0, xmx=360, ymn=-90, ymx=90) # new raster grid
tasmax2 <- resample(tasmaxr, ngrd, method='bilinear')

	plot(tasmax2)

# rename
tasmax <- as.matrix(tasmax2)
rownames(tasmax) <- yFromRow(tasmax2)
colnames(tasmax) <- xFromCol(tasmax2)

# write out array
save(tasmax, file='temp/tasmax.rdata')

##############################################################
# warmest daily high in each month (looking across 1986-2005)
# NOTE: still 0.5x0.5°
##############################################################
load('temp/cruts321_tmx.rdata')

# reshape so month is a separate dimension
tmxmelt <- melt(tmx, value.name='tmx')
tmxmelt$yr <- substr(tmxmelt$time, 1,4)
tmxmelt$mo <- substr(tmxmelt$time, 5,6)
tmxbymo <- acast(tmxmelt, lat ~ lon ~ yr ~ mo, value.var='tmx')
	dim(tmxbymo) # 360 x 720 x 20 x 12

# calculate max in each month, looking across years
tasmaxbymo <- apply(tmxbymo, MARGIN=c(1,2,4), FUN=max)

# reshape so lat is 90 to -90
tasmaxbymo <- tasmaxbymo[dim(tasmaxbymo)[1]:1,,]

	image(t(tasmaxbymo[nrow(tasmaxbymo):1,,1])) # quick image
	image(t(tasmaxbymo[nrow(tasmaxbymo):1,,6])) # quick image

# write out array
save(tasmaxbymo, file='temp/tasmax_bymonth.rdata')


library(dplyr)
dfr %>%
  group_by(Department) %>%
  top_n(2, Salary)