#' Simple screen for outlier cells in a metacell cover, finding genes with overly high expression given their metacell mean
#'
#'
#' @param new_mc_id id of new metacell to create
#' @param mc_id ID of metacell in scdb
#' @param mat_id matrix object to use (should be compatible with mc_id)
#' @param T_lfc maximal log2 fold change over the expected to be considered as an outlier.
#'
#' @export
#'
#' @import dbscan
#' @import entropy
#'
mcell_mc_screen_outliers_1gene_fold = function(new_mc_id, mc_id, mat_id, T_lfc)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("cannot find mc ", mc_id, " when attempting simple outlier detection")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("cannot find mat ", mat_id, " when attempting simple outlier detection")
	}

	lfc_gi = mc_compute_outlier_fc(mc, mat)
	maxlfc_g = apply(lfc_gi, 1, max)
	maxlfc_i = apply(lfc_gi, 2, max)

	if(sum(maxlfc_i > T_lfc) > 0) {
		new_outliers = names(which(maxlfc_i > T_lfc))
		mc@outliers = c(mc@outliers, new_outliers)
		mc@mc = mc@mc[setdiff(names(mc@mc),new_outliers)]
		scdb_add_mc(new_mc_id, tgMCCov(mc@mc, mc@outliers, mat))
	}
}

#' Compute log fold change expression of each gene given its regularized metacell expression
#'
#' Each metacell is defiend by a total set of umis, defining an expected number of umi pere cell per gene. After regularization (1 umi per cell), the fold enrichment of the gene in each cell is computed naively. Note that the MC inferred value is currently based on linear mean, whic his highly inadequate when an outlier is present.
#'
#' @param mc metacell object (not id)
#' @param mat matrix object (not id)
#'
#' @export
#'
mc_compute_outlier_fc = function(mc, mat)
{
	min_outlier_u = 6

	ismc_ci = diag(max(mc@mc))[,mc@mc]

	#we compute the expected number of umi per gene per cell given clust
	u_gi = mat@mat[,names(mc@mc)]

	u_i = colSums(u_gi)

	#saveing computation on boring genes
	ishigh_g = rep(F, times=nrow(u_gi))
	for(i in 0:floor(nrow(u_gi)/1000)) {
		fr = i * 1000 + 1
		to = min(fr+1000, nrow(u_gi))
		if(to < fr + 2) {
			fr = fr - 1
		}
		ishigh_g[fr:to] = apply(u_gi[fr:to,],1,max) >= min_outlier_u
	}
	u_gi = u_gi[ishigh_g,]

	u_gc = u_gi %*% t(ismc_ci)
	u_c = colSums(u_gc)

	p_gc = t(t(u_gc) / u_c)
	p_gi = p_gc %*% ismc_ci
	exp_gi = t(t(p_gi) * u_i)

	k_ureg = 1
	lfc_gi = log2((k_ureg+u_gi)/(k_ureg+exp_gi))

	return(lfc_gi)
}

#' Plot and outlier heat map.
#'
#' This select genes that are expressed in an interesting way in one of the outliers, and visualize their combinatorics as a heatmap.
#'
#' @param mc metacell object (not id)
#' @param mat matrix object (not id)
#'
#' @export
mcell_plot_outlier_heatmap = function(mc_id, mat_id, T_lfc, max_genes_to_plot = 500)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("cannot find mc ", mc_id, " when attempting simple outlier detection")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("cannot find mat ", mat_id, " when attempting simple outlier detection")
	}
	lfc_gi = mc_compute_outlier_fc(mc, mat)
	u_gi = mat@mat[,names(mc@mc)]
	maxlfc_g = apply(lfc_gi, 1, max)
	maxlfc_i = apply(lfc_gi, 2, max)

	if(sum(maxlfc_g>T_lfc) > max_genes_to_plot) {
      out_g_nms = names(tail(sort(maxlfc_g),max_genes_to_plot))
	} else {
		out_g_nms = names(which(maxlfc_g > T_lfc))
	}

# some cells are all zero for max_genes_to_plot. Alternative just select top genes for plotting
	out_i_nms = intersect(names(which(maxlfc_i > T_lfc)), colnames(u_gi)[colSums(u_gi[out_g_nms, ]) != 0])

   #hc1 = hclust(tgs_dist(tgs_cor(outu_gi)), "ward.D2") use mc ord instead

	if(sum(maxlfc_g > T_lfc) > 1 & sum(maxlfc_i > T_lfc) > 2) {
		outu_gi = log2(1 + as.matrix(u_gi[out_g_nms, out_i_nms]))

	#reporting the outlier gene / cell matrix

		hc1 = hclust(tgs_dist(tgs_cor(outu_gi)), "ward.D2")
		hc2 = hclust(tgs_dist(tgs_cor(t(outu_gi))), "ward.D2")
		fig_nm = scfigs_fn(mc_id, "outlier")

		h_mat = 500+length(out_g_nms)*16
		png(fig_nm, w=min(500+20*length(out_i_nms),3000), h=h_mat+100)

		layout(matrix(c(1,2),nrow=2),heights=c(h_mat, 100))
		top_marg=c(0,13,5,20)
		par(mar=top_marg)
		shades = colorRampPalette(c("white", "blue", "red", "yellow", "black"))(1000)
		c_ord = order(mc@mc[out_i_nms])
		image(t(outu_gi[hc2$order, c_ord]), col=shades, xaxt='n', yaxt='n')
		mtext(rownames(outu_gi)[hc2$order], at=seq(0,1,l=length(hc2$order)), las=2, side=2, cex=0.8)
		mtext(rownames(outu_gi)[hc2$order], at=seq(0,1,l=length(hc2$order)), las=2, side=4, cex=0.8)

		lower_marg=c(5,13,0,20)
		par(mar=lower_marg)
		mc_cols = mc@colors[mc@mc[out_i_nms[c_ord]]]
		image(as.matrix(1:length(out_i_nms),nrow=1), col=mc_cols, xaxt='n', yaxt='n')
		dev.off()
	}
}

#' Split and filter metacells using dbscan and outlier gene detection
#'
#' Running intra-metacell clustering on each metacell, identifying splits if existing. Also remove cells with outlier expression from each metacell. Note that this can in many case eliminate doublets as outliers - but may be insffucieint as doublets may constitute homogeneous metacells in large datasets.
#'
#' @param new_mc_id id of metacells to create
#' @param mc_id  id of source metacell object
#' @param mat_id  id of umi matrix
#' @param plot_mats if this is true, a heatmap will be generated for each metacell
#' @param dirichlet if this is true, the distance metric to be used for splitting is dirichlet on the downsampled umi counts. Otherwise (and by default), the correlation between log(1+umi) of the downsampled matrix will be used. Note that downsampling is done given the miminum depth of each metacell, seperately.
#'
#' @export
mcell_mc_split_filt = function(new_mc_id, mc_id, mat_id, T_lfc, plot_mats=T, dirichlet=F)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("cannot find mc ", mc_id, " when attempting simple outlier detection")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("cannot find mat ", mat_id, " when attempting simple outlier detection")
	}

	if(plot_mats) {
	  plot_dir = scfigs_dir(mc_id, "outliers")
	  file.remove(Sys.glob(sprintf("%s/*", plot_dir)))
	}

	split_dbscan = function(nms) {
		id = mc@mc[nms[1]]
#		message("split ", id)
		mc_mat = mat@mat[,nms]
		mc_mat = scm_downsamp(mc_mat, min(colSums(mc_mat)))
		e = rowMeans(mc_mat)
		v = apply(mc_mat, 1, var)
		gs = (v+0.1)/(e+0.1) > 1.2 & apply(mc_mat, 1, max)>2
		if(sum(gs) < 2 | sum(colSums(mc_mat[gs,] > 3)) < 20) {
#			message("no genes for ", id)
			clst = rep(1, times=length(nms))
			names(clst) = nms
			return(clst)
		}
		mc_mat = mc_mat[gs,]
		null_nms = names(which(colSums(mc_mat) <= 3 | apply(mc_mat,2,var)==0))
		filt_nms = setdiff(nms, null_nms)
		if(length(null_nms) > 0) {
#			message("got ", length(null_nms), " cells w.o enough umis")
		}
		if(sum(gs) < 2 | sum(colSums(mc_mat > 3)) < 20) {
#			message("no genes for ", id)
			clst = rep(1, times=length(nms))
			names(clst) = nms
			return(clst)
		}
		mc_mat = mc_mat[, filt_nms]

#		message("split 2 id =", id)
		if(dirichlet) {
			reg = 0.5
			L = length(nms)
			dst = matrix(NA, nrow=L, ncol=L)
			for(i in 1:(L-1)) {
				for(j in (i+1):L) {
					dst[i,j] = KL.Dirichlet(mc_mat[,i], mc_mat[,j], reg, reg)
				}
			}
			dst[is.na(dst)] = t(dst)[is.na(dst)]
			diag(dst) = 0
		} else {
			dst = 1-cor(log(1+7*as.matrix(mc_mat)))
		}
#		message("split 3 id =", id)
		clst = dbscan(as.dist(dst), eps=quantile(dst,0.1), minPts=5)
#		message("done dbscan", id)
		clst = clst$cluster
		names(clst) = filt_nms
		clst[null_nms] = 0
		if(is.na(sum(clst<2))) {
			message("NA after dbscan, clst id ", id)
			clst = rep(1, times=length(nms))
			names(clst) = nms
			return(clst)
		}
		clst[is.na(clst)] = 0
		return(clst)
	}
	mc_cores = get_param("mc_cores")
	nms_mc = split(names(mc@mc), mc@mc)
	message("starting split outliers ")
#	all_clst = lapply(nms_mc, split_dbscan)
	all_clst = mclapply(nms_mc, split_dbscan, mc.cores=mc_cores)

	new_mc = rep(NA, length(mc@mc))
	names(new_mc) = names(mc@mc)
	next_mcid = 1
	good_cells = names(new_mc)
	clust_outliers = c()
	for(cid in 1:length(all_clst)) {
#		message("opening cid ", cid)
		clst = all_clst[[cid]]
#		message("opening clst length ", length(clst))
		#adding cluster 1 and all dbscan outliers that were not filtered parametrically to a new MC
		cl_sz = table(clst)
		clst[cl_sz[as.character(clst)]<8]=1
		new_mc[intersect(good_cells, names(which(clst < 2)))] = next_mcid
		next_mcid = next_mcid + 1
		if(length(clst) > 1 & max(clst) > 1) {
		  for(sub_i in 2:max(clst)) {
				if(sum(clst==sub_i)>0) {
					message("splitting metacell ", cid)
					new_mc[intersect(good_cells, names(which(clst == sub_i)))] = next_mcid
					clust_outliers = c(clust_outliers,
											names(which(clst == sub_i)))
					next_mcid = next_mcid + 1
				}
		  }
		}
	}
	lfc_gi = mc_compute_outlier_fc(mc, mat)
	if(plot_mats) {
		for(clst in all_clst) {
			mc_plot_submc(mc, clst, mat, plot_dir, lfc_gi[,names(clst)])
		}
	}
	maxlfc_i = apply(lfc_gi, 2, max)

	new_outliers = setdiff(names(which(maxlfc_i > T_lfc)), clust_outliers)
	new_outliers = c(new_outliers, names(which(is.na(new_mc))))
	new_outliers = c(mc@outliers, new_outliers)
	new_mc = new_mc[setdiff(names(new_mc),new_outliers)]
	scdb_add_mc(new_mc_id, tgMCCov(new_mc, new_outliers, mat))
}

mc_plot_submc = function(mc, clst, mat, base_dir, lfc_gi)
{
	nms = names(clst)
	mc_id = mc@mc[nms[1]]
	lfp = log2(mc@mc_fp[,mc_id])

	mc_genes = names(tail(sort(lfp),5))

	us = mat@mat[,nms]
	top_genes = union(names(which(apply(us,1,max)>3)),mc_genes)
	us = us[top_genes,]
	sub_fp = t(apply(us,1, function(x) tapply(x,clst,mean)))

	sub_fp = log2((0.1+sub_fp)/(0.1+rowMeans(sub_fp)))
	max_fc0 = sub_fp[,1]
	max_fc0 = max_fc0[max_fc0 > 0.3]
	max_fc0 = sort(max_fc0)
	noise_genes = names(tail(max_fc0, 10))
	fc = apply(abs(sub_fp), 1, max)
	max_fc = fc[fc > 0.5]
	max_fc = sort(max_fc)
	out_genes = c(noise_genes, names(tail(max_fc, 5)))

	genes = unique(c(out_genes, mc_genes))

	lfc_genes = names(which(apply(lfc_gi,1,max) > 3))
	lfc_max = apply(lfc_gi,2, max)
	genes = c(lfc_genes,setdiff(genes,lfc_genes))

	us = us[genes,order(clst + lfc_max/100)]

	png(sprintf("%s/mc%d_out.png", base_dir, mc_id),
											w=400+ncol(us)*5, h=400+nrow(us)*20)
	top_marg=c(5,13,5,20)
	par(mar=top_marg)
	shades = colorRampPalette(c("white", "blue", "red", "yellow", "black"))(1000)
	desc = sprintf("noise %d, clsts %s ", sum(clst==0),
						paste(as.numeric(table(clst[clst>0])),collapse=" "))
	image(log2(1+t(as.matrix(us))), col=shades, xaxt='n', yaxt='n', main=desc)
	abline(v=(-0.5+sum(clst==0))/(length(clst)-1), lwd=3)
	abline(h=(-0.5+length(lfc_genes))/(nrow(us)-1), lwd=3)
	mtext(rownames(us), at=seq(0,1,l=nrow(us)), las=2, side=2, cex=0.8)
	mtext(rownames(us), at=seq(0,1,l=nrow(us)), las=2, side=4, cex=0.8)
	dev.off()
}


#!/usr/bin/Rscript

get_sepsis_score = function(data){
    x_mean = c(
        83.8996, 97.0520,  36.8055,  126.2240, 86.2907,
        66.2070, 18.7280,  33.7373,  -3.1923,  22.5352,
        0.4597,  7.3889,   39.5049,  96.8883,  103.4265,
        22.4952, 87.5214,  7.7210,   106.1982, 1.5961,
        0.6943,  131.5327, 2.0262,   2.0509,   3.5130,
        4.0541,  1.3423,   5.2734,   32.1134,  10.5383,
        38.9974, 10.5585,  286.5404, 198.6777)
    x_std = c(
        17.6494, 3.0163,  0.6895,   24.2988, 16.6459,
        14.0771, 4.7035,  11.0158,  3.7845,  3.1567,
        6.2684,  0.0710,  9.1087,   3.3971,  430.3638,
        19.0690, 81.7152, 2.3992,   4.9761,  2.0648,
        1.9926,  45.4816, 1.6008,   0.3793,  1.3092,
        0.5844,  2.5511,  20.4142,  6.4362,  2.2302,
        29.8928, 7.0606,  137.3886, 96.8997)
    c_mean = c(60.8711, 0.5435, 0.0615, 0.0727, -59.6769, 28.4551)
    c_std = c(16.1887, 0.4981, 0.7968, 0.8029, 160.8846, 29.5367)

    m = dim(data)[1]
    n = dim(data)[2]
    x = data[1:m, 1:34]
    c = data[1:m, 35:40]

    x_norm = matrix(, m, 34)
    c_norm = matrix(, m, 6)
    for (i in 1:m){
        x_norm[i, 1:34] = (x[i, 1:34] - x_mean) / x_std
        c_norm[i, 1:6] = (c[i, 1:6] - c_mean) / c_std
    }

    x_norm[is.nan(x_norm)] = 0
    c_norm[is.nan(c_norm)] = 0

    beta = c(
        0.1806,  0.0249, 0.2120,  -0.0495, 0.0084,
        -0.0980, 0.0774, -0.0350, -0.0948, 0.1169,
        0.7476,  0.0323, 0.0305,  -0.0251, 0.0330,
        0.1424,  0.0324, -0.1450, -0.0594, 0.0085,
        -0.0501, 0.0265, 0.0794,  -0.0107, 0.0225,
        0.0040,  0.0799, -0.0287, 0.0531,  -0.0728,
        0.0243,  0.1017, 0.0662,  -0.0074, 0.0281,
        0.0078,  0.0593, -0.2046, -0.0167, 0.1239)
    rho = 7.8521
    nu = 1.0389

    xstar = cbind(x_norm, c_norm)
    exp_bx = exp(xstar %*% beta)
    l_exp_bx = (4.0 / rho) ** nu * exp_bx

    scores = 1 - exp(-l_exp_bx)
    labels = (scores > 0.45)
    results = cbind(scores, labels)
    return(results)
    }

read_challenge_data = function(input_file){
    data = data.matrix(read.csv(input_file, sep='|'))
    column_names = colnames(data)

    # ignore SepsisLabel column if present
    m = dim(data)[1]
    n = dim(data)[2]
    if (column_names[n] == 'SepsisLabel'){
        data = data[1:m, 1:n-1]
    }

    return(data)
    }

# load library and arguments
args = commandArgs(trailingOnly=TRUE)

# get input filenames
tmp_input_dir = 'tmp_inputs'
unzip(args[1], files = NULL, exdir = tmp_input_dir)
input_files = sort(list.files(path = 'tmp_inputs', recursive = TRUE))

# make temporary output directory
tmp_output_dir = 'tmp_outputs'
dir.create(tmp_output_dir)

# generate scores
n = length(input_files)
output_files = list()

for (i in 1:n){
    # read data
    input_file = file.path(tmp_input_dir, input_files[i])
    data = read_challenge_data(input_file)

    # make predictions
    results = get_sepsis_score(data)
    colnames(results) = c('PredictedProbability', 'PredictedLabel')

    # write results
    file_path = unlist(strsplit(input_file, .Platform$file.sep))
    file_name = file_path[length(file_path)]
    output_file = file.path(tmp_output_dir, file_name)
    write.table(results, file = output_file, sep = '|', quote=FALSE, row.names = FALSE)
    output_files[i] = output_file
}

# perform clean-up
zip(args[2], files = unlist(output_files))
unlink(tmp_input_dir, recursive=TRUE)
unlink(tmp_output_dir, recursive=TRUE)


fname_responses_null <- "./R/fits/responses_null"
fname_responses_null_stan <- "./R/models/responses_null.stan"
m_responses_null <- brm(ResponseYes ~ cGrammatical * cAttractorPlural +
                                (cGrammatical * cAttractorPlural + 1| subject) +
                                (cGrammatical * cAttractorPlural + 1| item),
                    data = df_merged_nofillers,
                    family = bernoulli("probit"),
                    prior = c(
                            set_prior("student_t(3,0,2.5)", class = "Intercept"),
                            set_prior("normal(0,1)", class = "b", coef = "cAttractorPlural"),
                            set_prior("normal(0,1)", class = "b", coef = "cGrammatical"),
                            set_prior("normal(0,1)", class = "b", coef = "cGrammatical:cAttractorPlural"),
                            set_prior("normal(0,1)", class = "sd"),
                            set_prior("lkj(2)", class = "cor")
                            ),
                    chains = n_chains, cores = n_cores, iter = n_iter, warmup = n_warmup, init_r = .1,
                    file = fname_responses_null, save_model = fname_responses_null_stan,
                    save_all_pars = TRUE)

lml_null <- bridgesampling::bridge_sampler(m_responses_null, silent = TRUE)

brm_fit_multiple <- function(prior_sd, lower_boundary, fname) {

    fit <- brm(
        ResponseYes ~ cEndsInConsonant * cGrammatical * cAttractorPlural +
                    (cGrammatical * cAttractorPlural + 1 | subject) +
                    (cGrammatical * cAttractorPlural + 1 | item),
        data = df_merged_nofillers,
        prior = c(
            prior(normal(0,1), class = Intercept),
            set_prior(paste0("normal(0,", prior_sd, ")"), class = "b", lb = lower_boundary),
            prior(normal(0,1), class = "sd"),
            prior(lkj(2), class = "cor")
        ),
        family = bernoulli("probit"),
        chains = 4, cores = 6,
        iter = 20000, warmup = 2000, init_r = .1,
        save_all_pars = TRUE,
        file = file.path("./R/fits", fname),
        save_model = file.path("./R/models", paste0(fname, ".stan")),
    )

    fit

}

m_responses_normal0_01 <- brm_fit_multiple(.01, NA, "m_responses_normal0_01")
m_responses_normal0_02 <- brm_fit_multiple(.02, NA, "m_responses_normal0_02")
m_responses_normal0_04 <- brm_fit_multiple(.04, NA, "m_responses_normal0_04")
m_responses_normal0_06 <- brm_fit_multiple(.06, NA, "m_responses_normal0_06")
m_responses_normal0_08 <- brm_fit_multiple(.08, NA, "m_responses_normal0_08")
m_responses_normal0_1 <- brm_fit_multiple(.1, NA, "m_responses_normal0_1")
m_responses_normal01 <- brm_fit_multiple(1, NA, "m_responses_normal01")

m_responses_normal_plus0_01 <- brm_fit_multiple(.01, 0, "m_responses_normal_plus0_01")
m_responses_normal_plus0_02 <- brm_fit_multiple(.02, 0, "m_responses_normal_plus0_02")
m_responses_normal_plus0_04 <- brm_fit_multiple(.04, 0, "m_responses_normal_plus0_04")
m_responses_normal_plus0_06 <- brm_fit_multiple(.06, 0, "m_responses_normal_plus0_06")
m_responses_normal_plus0_08 <- brm_fit_multiple(.08, 0, "m_responses_normal_plus0_08")
m_responses_normal_plus0_1 <- brm_fit_multiple(.1, 0, "m_responses_normal_plus0_1")
m_responses_normal_plus01 <- brm_fit_multiple(1, 0, "m_responses_normal_plus01")

models_priors <- c(
    m_responses_normal0_01,
    m_responses_normal0_02,
    m_responses_normal0_04,
    m_responses_normal0_06,
    m_responses_normal0_08,
    m_responses_normal0_1,
    m_responses_normal01,
    m_responses_normal_plus0_01,
    m_responses_normal_plus0_02,
    m_responses_normal_plus0_04,
    m_responses_normal_plus0_06,
    m_responses_normal_plus0_08,
    m_responses_normal_plus0_1,
    m_responses_normal_plus01
)

df_bf_priors_info <- data.frame(
    model_name = models_priors,
    beta_prior_sd = rep(c(0.01, seq(0.02, 0.1, 0.02), 1), 2),
    beta_lb = c(rep(c(NA,0), each = 7)),
)

df_bf_priors <- data.frame()

for (m in models_priors) {
    lml_fit <- bridgesampling::bridge_sampler(m, silent = TRUE)

    s <- posterior_samples(m)

    diff <- exp(s$b_Intercept + s$b_cGrammatical + s$b_cAttractorPlural + s$b_cGrammatical:cAttractorPlural) -
            exp(s$b_Intercept + s$b_cGrammatical + s$b_cAttractorPlural - s$b_cGrammatical:cAttractorPlural)

    temp_df <- data.frame(
        BF = bridgesampling::bayes_factor(lml_fit, lml_null)$bf,
        beta_posterior_mean = posterior_summary(m, pars = "b_cGrammatical:cAttractorPlural")[, "Estimate"],
        beta_posterior_lq = posterior_summary(m, pars = "b_cGrammatical:cAttractorPlural")[, "Q2.5"],
        beta_posterior_hq = posterior_summary(m, pars = "b_cGrammatical:cAttractorPlural")[, "Q97.5"],
        diff_mean = mean(diff),
        diff_lq = quantile(diff, 0.025),
        diff_hq = quantile(diff, 0.975)
    )

    df_bf_priors <- rbind(df_bf_priors, temp_df)

}

df_bf_priors <- cbind(df_bf_priors_info, df_bf_priors)


qlife = function (r_times, p = c(0.25, 0.75)) {
  # type 8 is the recommended method, see help('quantile')
  ql = quantile(r_times, probs = p, type = 8, names = F)
  data.frame(q25 = ql[1], q75 = ql[2])
}


calmod <- function(target,x,sumstat,tol,gwt,rejmethod=T)
{
# this function uses categorical regression to estimate the posterior probability of a particular model
#      under the ABC framework P(Y=y | S = s)
#
# target is the set of target summary stats - i.e. s, what you measured from the data.
# x is the parameter vector, Y (long vector of numbers from the simulations) and is the dependent variable for the regression
#          This is a categorical variable, taking values 1, 2, .. n where there are n categories (models)
# sumstat is an array of simulated summary stats, S (i.e. independent variables).
# tol is the required proportion of points nearest the target values
# gwt is a vector with T/F weights, weighting out any 'bad' values (determined by the simulation program - i.e. nan's etc)
# if rejmethod=T it doesn't bother with the regression, and just does rejection.

# If rejmethod=F it returns a list with the following components:-

# $x1 expected value on a logit scale, with standard errors of the estimate
# $x2 expected value on a natural scale - i.e. p(Y=y | S = s) This is what we would normally report.
# $vals - the Ys in the rejection region. The proportion of the different Ys (different models) is a Pritchard etal-style, rejection-based
#                                         estimate of the posterior probability of the different models. You might get some improvement by
#                                          weighting the frequencies with $wt.
# $wt - the Epanechnikov weight.
# $ss - the sumstats corresponding to the points in $vals.

if(missing(gwt))gwt <- rep(T,length(sumstat[,1]))

nss <- length(sumstat[1,])

# scale everything

    scaled.sumstat <- sumstat

    for(j in 1:nss){

    	scaled.sumstat[,j] <- normalise(sumstat[,j],sumstat[,j][gwt])
    }
    target.s <- target

    for(j in 1:nss){

    	target.s[j] <- normalise(target[j],sumstat[,j][gwt])
    }

# calc euclidean distance

    sum1 <- 0
    for(j in 1:nss){
    	sum1 <- sum1 + (scaled.sumstat[,j]-target.s[j])^2
   }
   dst <- sqrt(sum1)
# includes the effect of gwt in the tolerance
    dst[!gwt] <- floor(max(dst[gwt])+10)

# wt1 defines the region we're interested in
    abstol <- quantile(dst,tol)
    wt1 <- dst < abstol
    nit <- sum(wt1)

    if(rejmethod){
        l1 <- list(x=x[wt1],wt=0)
    }
    else{
        regwt <- 1-dst[wt1]^2/abstol^2

        catx <- as.numeric(names(table(x[wt1])))
        ncat <- length(catx)
        yy <- matrix(nrow=nit,ncol=ncat)
        for(j in 1:ncat){
        	yy[,j] <- as.numeric(x[wt1] == catx[j])
        }

        tr <- list()

        for(j in 1:nss){
        	tr[[j]] <- scaled.sumstat[wt1,j]
        }

        xvar.names <- paste("v",as.character(c(1:nss)),sep="")

        names(tr) <- xvar.names

        fmla <- as.formula(paste("yy ~ ", paste(xvar.names, collapse= "+")))

#        fit1 <- vglm(fmla,data=tr,multinomial) this is the version described in the
#               manuscript,which did not use the Epanechnikov weights.

        fit1 <- vglm(fmla,data=tr,multinomial,weights=regwt)

        target.df <- list()
        for(j in 1:nss){
        	target.df[[j]] <- target.s[j]
        }
        names(target.df) <- xvar.names

#        prediction1 <- predict.vglm(fit1,target.df,se.fit=T)        #commented 2014-12-10
#        prediction2 <- predict.vglm(fit1,target.df,type="response") #commented 2014-12-10
        prediction1 <- predict(fit1,target.df,se.fit=T)              #added 2014-12-10
        prediction2 <- predict(fit1,target.df,type="response")       #added 2014-12-10

        l1 <- list(x1=prediction1,x2=prediction2,vals=x[wt1],wt=regwt,ss=sumstat[wt1,])

    }
    l1
}

normalise <- function(x,y){

if(var(y) == 0)return (x - mean(y))
(x-(mean(y)))/sqrt(var(y))
}


# PROFILES.R
#
# Simple R program to load a data matrix, scale it and plot the result

# clear out the workspace first
rm(list = ls())

# load data frame from web site
X <- read.table("http://www.bixsolutions.net/profiles.csv", sep=",", header=TRUE)

# rangescale data by dividing by the maximum value in each column
Xmax <- apply(X,2,max)
Xscaled = scale(X, scale=Xmax, center=FALSE)

# plot columns in matrix as lines on a single graph
matplot(Xscaled,type="l",xlab="fraction",ylab="quantity",col=1:6,lty=1:5,lwd=2)

# add legend to graph
legend(x=1,legend=names(X),col=1:6,lty=1:5,lwd=2,bg="snow")


args <- commandArgs(TRUE)
library(beeswarm)
library(RColorBrewer,quiet=T)
#m<-read.table("./tumor_1.0_score.txt")
m<-read.table(args[1])
nn<-ncol(m)
if(nn == 2){
    colnames(m)<-c('state', 'score')
    n<-length(unique(m$state))
    cols <- colors<-colorRampPalette(brewer.pal(12, "Paired"))(n)
    xs<-1:n

    #pdf(file='./MSI.pdf')
    pdf(file=args[2])
    par.lend=par()$lend;par(tck=0.01, lend=1, xpd=T)
    beeswarm(score~state, data=m, method='swarm', pch=16 ,xlab='Sample group', ylab='MSI score(%)', main='MSI score distribution', cex=0.6, las=0, do.plot=T, add=F, at=xs, col=cols[xs], spacing=0.7, xaxs='i', yaxs='i', lwd=.75)
    #beeswarm(score~state, data=m, method='swarm', pch=16, ylim=c(0, 100), xlab='Sample group', ylab='MSI score(%)', main='MSI score', cex=0.8, las=0, do.plot=T, add=F, at=xs, col=cols[xs], spacing=0.8, xaxs='i', yaxs='i', lwd=.75)
}else if(nn == 1){
    colnames(m)<-c('score')
    cols <- colors<-colorRampPalette(brewer.pal(12, "Paired"))(1)
    xs<-nrow(1)

    pdf(file=args[2])
    par.lend=par()$lend;par(tck=0.01, lend=1, xpd=T)
    #plot(c(1:xs), m$score, main='MSI score', xlab='Sample group', ylab="MSI score(%)", col="red", pch=19, spacing=1, xaxs='i', yaxs='i')
    beeswarm(m$score, data=m, method='swarm', pch=16, xlab='Sample group', ylab='MSI score(%)', main='MSI score distribution', cex=0.6, las=0, do.plot=T, add=F, at=xs, col=cols[1], spacing=0.9, xaxs='i', yaxs='i', lwd=.75)
}

xmin<-par('usr')[1];
xmax<-par('usr')[2];
ymin<-par('usr')[3];
ymax<-par('usr')[4];
chw<-par()$cxy[1]

axis(1,lwd=NA,tick=T,lwd.ticks=.5,labels=F)
axis(2,lwd=NA,tick=T,lwd.ticks=.5,labels=F)
axis(3,lwd=NA,tick=T,lwd.ticks=.5,labels=F)
axis(4,lwd=NA,tick=T,lwd.ticks=.5,labels=F)


# data processing for the resource test of pneumatic shutter actuator
#written by drapiko e march 2022
#first3 day position sensor calibration screwed
#last two ok
##################################################################################
# DAY1
##################################################################################

t04 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test04.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t04$Pos2<-t04$Pos2/5.5#applying position correction due to wrong saving
t04$Pos2<--((t04$Pos2*(-1.185))/5+4.265-3.08)/0.2+6 #applying sensor calibration factors

s=5206
e=70000

#plot(t04$Pos2[s:e])
#grid()
posmm<-t04$Pos2
i=1
j=1
posmmm<-NULL
for (i in s:e) {# picking flattops
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){#selecting only flattop values
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
i=1
j=1
posmmin<-NULL
for (i in s:e) {#picking flatbottoms
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
#plot(posmmm[40:50])
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade Position Histogram, mm", main = paste("Day1 09.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()
################################################################################
# DAY2 10.03.2022
###############################################################################
t05 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test05.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t05$Pos2<-t05$Pos2/5.5
t05$Pos2<--((t05$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
#plot(t05$Pos2[10005:10009])
#grid()
posmm<-t05$Pos2
s=1000
e=76300
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]

posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
#plot(t05$Pos2[10000:76000])
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade Position Histogram, mm", main = paste("Day2 10.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()
################################################################################
#DAY3 11.03.2022
################################################################################
t06 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test06.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t06$Pos2<-t06$Pos2/5.5
t06$Pos2<--((t06$Pos2*(-1.185))/5+4.265-3.08)/0.2+6

#plot(t06$Pos2[1:64000])
posmm<-t06$Pos2
s=1000
e=64000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day3 11.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

################################################################################
#DAY4 14.03.2022
################################################################################

t07 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test07.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t07$Pos2<--((t07$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
#plot(t07$Pos2[1000:69000])
#grid()
posmm<-t07$Pos2

s=1000
e=69000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day4 14.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

################################################################################
#DAY5 15.03.2022
################################################################################

t08 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test08.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t08$Pos2<--((t08$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
posmm<-t08$Pos2
#plot(posmm)
s=100
e=52000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
  }

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day5 15.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

##################################################
#DAY6 16.03.2022 cam
##################################################

t08$Pos1<-((1-t08$Pos1/5)*328)/52.27
#plot(t08$Pos1[3000:52000])

posmm<-t08$Pos1

s=2000
e=52000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]>6.1)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm>6.14]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day6 CAM 15.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

###########################################
#DAY6_1 16.03.2022
###########################################
t081 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test08_1.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))

t081$Pos2<--((t081$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
posmm<-t081$Pos2
#plot(t081$Pos2[2020:2040])

s=100
e=28000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 40,xlab = "Blade position, mm", main = "Position Histogram day6 16.03.2022")
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.005)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day6_1 16.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

####################cam#########################333
############3######################################3333
t081$Pos1<-((1-t081$Pos1/5)*328)/52.27
#plot(t08$Pos1[3000:52000])

posmm<-t081$Pos1

i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 40,xlab = "Blade position, mm", main = "Position Histogram day6 16.03.2022")
i=1
j=1
posmmin<-NULL

for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.4&posmmm>0]-0.0922
posmmm<-posmmm[posmmm>6.15]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day6_1 CAM 16.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

#############################################################
### DAY7
#####~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

t011 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test011.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
#t011$Pos2<-((t011$Pos2*(-1.185))/5+4.265-3.08)/0.2
t011$Pos2<--((t011$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
#t011$Pos2<-(t011$Pos2/5)*6
posmm<-t011$Pos2
#plot(t011$Pos2[1:62000])
grid()

s=25000
e=62500
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]>4.9)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 50,xlab = "Blade position, mm", main = "Position Histogram day7 22.03.2022")
i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day7 22.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

###############################################################################33333
#################### DAY7 CAM
###############################################################################34
t011$Pos1<-((1-t011$Pos1)*328)/52.27
plot(t011$Pos1[24005:24025])
posmm<-t011$Pos1
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 40,xlab = "Blade position, mm", main = "Position Histogram day7 cam 22.03.2022")
i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}

posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm>6.08]
posmmm<-posmmm[posmmm<6.22]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day7 CAM 22.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

################################################################################33333
###############day8
##################################################################################3
t012 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test012.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
t012$Pos2<--((t012$Pos2*(-1.185))/5+4.265-3.08)/0.2+6
#plot(t012$Pos2)
posmm<-t012$Pos2

s=2500
e=50000
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 50,xlab = "Blade position, mm", main = "Position Histogram day7 22.03.2022")

i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}
posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
posmmm<-posmmm[posmmm<6.5]
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day8 22.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

############################################
###########day8 CAM
############################################
t012$Pos1<-((1-t012$Pos1)*328)/52.27
#plot(t012$Pos1[24005:24025])
posmm<-t012$Pos1
i=1
j=1
posmmm<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.01)&(posmm[i]>6)){
    print(posmm[i])
    print(i)
    posmmm[j]<-posmm[i+1]
    j=j+1
  }
}
#hist(posmmm,breaks = 40,xlab = "Blade position, mm", main = "Position Histogram day7 cam 22.03.2022")
i=1
j=1
posmmin<-NULL
for (i in s:e) {
  if(abs(posmm[i]-posmm[i+1]<0.05)&(posmm[i]<1)){
    print(posmm[i])
    print(i)
    posmmin[j]<-posmm[i+1]
    j=j+1
  }
}

posmmin<-posmmin[posmmin<0.21&posmmin>0]
posmmm<-posmmm[posmmm<6.7&posmmm>0]-mean(posmmin)
enorm_res<-EnvStats::enorm(posmmm, ci=TRUE)
hist(posmmm,prob=T,breaks = 30,xlab = "Blade position Histogram, mm", main = paste("Day8 CAM 22.03.2022","M=",enorm_res$parameters["mean"],"Sd=",enorm_res$parameters["sd"]))
rug(posmmm);lines(density(posmmm));grid()

#t013<-NULL
#ttp013<-NULL
#t013 <- read.delim2("E:/iter/h-alpha/испытания/2022/shutter/data/test013.txt" , dec=".",colClasses = c("Time"="character","Cycle"="numeric","Temperature"="numeric", "Preasure1"="numeric","Preasure2"="numeric","Pos1"="numeric","Pos2"="numeric","Vac"="numeric","Valv1"="numeric","Valv2"="numeric"))
#tt013<-c(t013$Time)
#ttp013<-as.POSIXct(tt013,format="%H:%M:%S")
#plot(ttp013[],t013$Temperature)
#plot(t013$Temperature[59000:74900], type = "l")

#tt32<-c(t32$Time)
#ttp32<-as.POSIXct(tt32,format="%H:%M:%S")


library(data.table)
library(ggplot2)

#transmission rates
transmission.households <- 0.07
transmission.DCCs <- 0.04
transmission.school.classes <- 0.03
transmission.other.contacts <- 0.04

#age bias
age.bias.1 <- 1
age.bias.1to6 <- 0.33
age.bias.7to65 <- 0.18
age.bias.65 <- 0.3

prop.children.attending.DCCs <- 0.79
average.group.size.DCC <- 16.7
average.class.size.school <- 22
probability.of.other.contacts <- 0.5

pop.size <- 5000
n.initial.carriers <- 125
stop.time <- 156

#sweden population pyramid
sweden.pop.props <- c(2.9,2.9,2.7,2.4,3.4,3.4,3.1,3,3.1,3.5,3.1,2.9,2.7,3.2,2.6,1.9,1.4,1,0.6,0.1,0)
names(sweden.pop.props) <- c(seq(0,100,5)[-1], "100+")

#sweden family size proportions
num.siblings.props <- c(0.19,0.48,0.23,0.10)
names(num.siblings.props) <- c(0,1,2,3)
prop.single.parent <- 0.19

pop.ages <- as.numeric(sample(names(sweden.pop.props), pop.size, replace = TRUE, prob = sweden.pop.props))
family.membership <- rep(NA, pop.size)
school.membership <- rep(NA, pop.size)
dcc.membership <- rep(NA, pop.size)
other.close.contact.pair <- rep(NA, pop.size)

#randomly assign an individual a close contact with probability 0.5.
npairs <- rbinom(1, pop.size, 0.5)
pairs <- matrix(sample(pop.size, 2*npairs, replace = TRUE), ncol=2)

#assign families
fam.id <- 1
while(sum(is.na(family.membership[pop.ages<=20]))>0){ #we still have un-assigned children
  n.children <- sample(as.numeric(names(num.siblings.props)), 1, prob=num.siblings.props) + 1
  child.index <- which((pop.ages<=20) & is.na(family.membership))[1:n.children]
  n.parents <- sample(c(1,2), 1, prob = c(prop.single.parent, 1-prop.single.parent))
  parent.index <- which((pop.ages>20) & (pop.ages<=50) & is.na(family.membership))[1:n.parents]
  family.membership[c(child.index, parent.index)] <- fam.id
  fam.id <- fam.id + 1
}

#assign dcc
dcc.id <- 1
n.under.5 <- sum(pop.ages<=5)
indexs.in.dcc <- sample(which(pop.ages<=5), size = floor(prop.children.attending.DCCs*n.under.5))
family.ids <-  unique(family.membership[indexs.in.dcc])
dcc.size <- 0
for(f in family.ids){
  index <- indexs.in.dcc[family.membership[indexs.in.dcc]==f]
  dcc.membership[index] <- dcc.id
  dcc.size <- dcc.size + length(index)
  if(dcc.size>average.group.size.DCC){
    dcc.size <- 0
    dcc.id <- dcc.id + 1
  }
}

#assign schools
#5 to 10
class.id <- 1
indexes.in.school <- which((pop.ages>5) & (pop.ages<=10))
family.ids <-  unique(family.membership[indexes.in.school])
class.size <- 0
for(f in family.ids){
  index <- indexes.in.school[family.membership[indexes.in.school]==f]
  school.membership[index] <- class.id
  class.size <- class.size + length(index)
  if(class.size>average.class.size.school){
    class.size <- 0
    class.id <- class.id + 1
  }
}

#10 to 15yrs
indexes.in.school <- which((pop.ages>10) & (pop.ages<=15))
family.ids <-  unique(family.membership[indexes.in.school])
class.size <- 0
for(f in family.ids){
  index <- indexes.in.school[family.membership[indexes.in.school]==f]
  school.membership[index] <- class.id
  class.size <- class.size + length(index)
  if(class.size>average.class.size.school){
    class.size <- 0
    class.id <- class.id + 1
  }
}

transition.matrix <- matrix(1, nrow = pop.size, ncol = pop.size)
#household transmission
for(f in unique(family.membership[!is.na(family.membership)])){
  index <- which(family.membership==f)
  transition.matrix[t(combn(index, 2))] <- transition.matrix[t(combn(index, 2))] * (
    1 - transmission.households)
}

#dcc transmission
for(f in unique(dcc.membership[!is.na(dcc.membership)])){
  index <- which(dcc.membership==f)
  transition.matrix[t(combn(index, 2))] <- transition.matrix[t(combn(index, 2))] * (
    1 - transmission.DCCs)
}

#school transmission
for(f in unique(school.membership[!is.na(school.membership)])){
  index <- which(school.membership==f)
  transition.matrix[t(combn(index, 2))] <- transition.matrix[t(combn(index, 2))] * (
    1 - transmission.school.classes)
}

#other transmission
transition.matrix[pairs] <- transition.matrix[pairs] * (1 - transmission.other.contacts)
transition.matrix[pairs[,c(2,1)]] <- transition.matrix[pairs[,c(2,1)]] * (1 - transmission.other.contacts)

#bias probability vector
bias.probs <- rep(NA, pop.size)
bias.probs[pop.ages<=5] <- 0.33
bias.probs[pop.ages>65] <- 0.3
bias.probs[is.na(bias.probs)] <- 0.18

status.vector <- rep(0, pop.size)
remaining.carriage <- rep(0, pop.size)

#initialise infections
index <- sample(pop.size, n.initial.carriers)
status.vector[index] <- 1
remaining.carriage[index] <- rpois(n = n.initial.carriers, lambda = 4)

pop.ages.factor <- factor(pop.ages)
n.infected.vector <- rep(NA, stop.time)
n.infected.age.matrix <- matrix(NA, nrow = stop.time, ncol = length(unique(pop.ages.factor)))
colnames(n.infected.age.matrix) <- levels(pop.ages.factor)

for(t in 1:stop.time){
  # message(paste("Time:", t))

  prob.infection <- 1-exp(rowSums(log((1-status.vector) * transition.matrix)))
  prob.infection <- prob.infection*bias.probs
  is.infected <- runif(pop.size)<prob.infection

  n.new.infections <- sum((status.vector<=0) & is.infected)
  remaining.carriage[(status.vector<=0) & is.infected] <- rpois(n = n.new.infections, lambda = 4) + 1
  status.vector <- is.infected
  remaining.carriage <- remaining.carriage-1
  remaining.carriage[remaining.carriage<0] <- 0
  status.vector[remaining.carriage<=0] <- 0

  n.infected.vector[[t]] <- sum(status.vector)

  n.infected.age.matrix[t,] <- table(pop.ages.factor[status.vector==1])

}

plot.df <- data.frame(time=1:stop.time, total.infected=n.infected.vector,
                      stringsAsFactors = FALSE)

# Plot
ggplot(plot.df, aes(x=time, y=total.infected)) +
  geom_line() + xlab("time (weeks)") + ylab("total infected")

plot.df <- melt(n.infected.age.matrix)
colnames(plot.df) <- c("time", "age.group", "number infected")
plot.df$age.group <- cut(plot.df$age.group, breaks = c(0,5,10,15,20,50,100))

ggplot(plot.df, aes(x=time, y=`number infected`, col=age.group)) +
  geom_line() +
  xlab("time (weeks)") + ylab("total infected")

table(cut(pop.ages, breaks = c(0,5,10,15,20,50,100)))


sessionInfo()
library(dHRUM)
library(data.table)
nHrus <- 1
Areas <- 4.7*1000*1000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhrus <- initdHruModel(nHrus,Areas,IdsHrus)

filname2 = "../dHRUM/Calibrations/Amalie/indata/BP_1960_01_01.txt"

setPTInputsToAlldHrusFromFile(dHRUM_ptr = dhrus, filname2)
calcPetToAllHrus(dHRUM_ptr = dhrus,50.1,"HAMON")

ParDF = data.frame( B_SOIL = 1, C_MAX = 100, B_EVAP = 1,  KS = 0.01, KF = 0.03, ADIV = 0.01, CDIV = 0.3,
SDIV = 0.3, CAN_ST = .5, STEM_ST = .2, CSDIV = 0.8, TETR = 0, DDFA = 0.75, TMEL = 0.0,
RETCAP = 2,CMIN =10)

ParDFup = data.frame( B_SOIL = 1, C_MAX = 200, B_EVAP = 2,  KS = 0.8, KF = 0.08, ADIV = 0.99, CDIV = 0.3,
                      SDIV = 0.3, CAN_ST = 0.5, STEM_ST = .1, CSDIV = 0.8, TETR = 0.5, DDFA = 5, TMEL = 0.0,
                      RETCAP = 6 ,CMIN =5)

ParDFlow = data.frame( B_SOIL = 1, C_MAX = 21, B_EVAP = 1,  KS = 0.001, KF = 0.005, ADIV = 0.71, CDIV = 0.05,
                       SDIV = 0.01, CAN_ST = 0.02, STEM_ST = 0.01, CSDIV = 0.01, TETR = -1, DDFA = 0.08, TMEL = -1.0,
                       RETCAP = 2 ,CMIN =1)
ParBest = ParDF
  # set_Params_TodHru(dHRU_ptr = dhrus,as.numeric(ParDF[1,]),names(ParDF),TRUE,0)
  # # for( i in 1:1000){
  # calc_HBInAlldHrus(dHRU_ptr = dhrus)
  # gatherHBdata(dHRU_ptr = dhrus)
  # # }
  # dta <- get_Output(dHRU_ptr = dhrus)
  # dF <-data.frame(dta$outDta)
  # names(dF) <- dta$VarsNams
  # dta

dny=c(30,60,90,120,150,180,210,240,270,300,330,355,364)
p_OBS=dny/365.25

# BP 96.68961 (1.736-2.430446)
RaBP = 96# odhad Martin Hanel
QmBP = c(26, 18, 14, 12, 10, 8.0, 7.0, 6.0, 4.5, 3.5, 2.5, 1.0, 0.5)#l/s in 1 day
A=4.7*1000*1000# plocha BP
RmBP = QmBP * (3600*24) / A #CHMU ZHU mm/day
# simRM=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS)))

sse = function(myPar){
  # myPar =ParDF[1,]
  setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(myPar),names(ParDF))
  # # for( i in 1:1000){
  calcHBInAlldHrus(dHRUM_ptr = dhrus)
  gatherHBdata(dHRUM_ptr = dhrus)
  # # }
  dta <- getOutput(dHRUM_ptr = dhrus)
  dF <-data.frame(dta$outDta)
  names(dF) <- dta$VarsNams
  simRM=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
  # mymae =as.double(sum(abs(simRM - RmBP)))
  mymae =as.double(sum((simRM - RmBP)^2))
  # # mymae=NA
  # if(is.na(mymae)) mymae = 9999
  # (return as.double(mymae))
}

library(RcppDE)

itermaxW=6

decntr<-DEoptim.control(VTR = 0, strategy = 2, bs = FALSE, NP = 200,
                itermax = itermaxW, CR = 0.85, F = 0.95, trace = TRUE,
                initialpop = NULL, storepopfrom = itermaxW + 1,
                storepopfreq = 1, p = 0.2, c = 0, reltol = sqrt(.Machine$double.eps),
                steptol = itermaxW)

n_ens=1
parsBPmatrix=matrix(0,nrow=n_ens, ncol=ncol(ParBest))
for(i in 1:n_ens){
  u=DEoptim( lower=as.numeric(ParDFlow[1,]), upper=as.numeric(ParDFup[1,]), fn=sse, control = decntr)
  u$optim$bestmem
  ParBest[1,] = as.numeric(u$optim$bestmem)
  parsBPmatrix[i,] = as.numeric(u$optim$bestmem)
}

BP_df = data.frame(parsBPmatrix)
names(BP_df) = names(ParBest)
BP_df=cbind(BP_df,ID=rep("BP",times=n_ens))
# save(BP_df,file="par_dHRUM_lumped_PET_HAMON_50_1_BP.rda")
save(BP_df,file="./Calibrations/Amalie/outdata/par_dHRUM_lumped_PET_HAMON_50_1_BP.rda")

load("./Calibrations/Amalie/outdata/par_dHRUM_lumped_PET_HAMON_50_1_BP.rda")
BP_df
!

A=4.7*1000*1000## plocha BP
Par_dHRUm_BP_lumped= list(
  pars =BP_df,
  areaM2 = A,
  Pet_type = "HAMON",
  latitude =50.1
)
pars=rbind(Par_dHRUm_BP_lumped$pars)

pars=cbind(pars,CMIN=1)

Par_dHRUm_Amalie_lumped = list(
  pars =pars,
  areaM2 = data.frame(BP= 4700000),
  Pet_type = "HAMON",
  latitude =50.1
)

save(Par_dHRUm_Amalie_lumped ,file = "./Calibrations/Amalie/outdata/Amalie_lumped_dHRUM.rda")
Par_dHRUm_Amalie_lumped$areaM2$BP
BP_df=cbind(ID=rep("BP",times=n_ens))
BP_df=cbind(ID=rep("CMIN",times=n_ens))

ParBest[1,] = as.numeric(u$optim$bestmem)
# ParBest[1,] =BP_df[1,1:15]

setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(ParBest),names(ParBest))

  # for( i in 1:1000){
calcHBInAlldHrus(dHRUM_ptr = dhrus)
gatherHBdata(dHRUM_ptr = dhrus)
# }
dta <- getOutput(dHRUM_ptr = dhrus)
dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams

dF=as.data.table(dF)
dF[,DM:=paste(DAY,".",MONTH)]

plot(dF$TOTR)

mS=dF[,.(SOIS =mean(SOIS),PR=mean(PREC),SUR = mean(SURS), RET = mean(SURS+SOIS),Ro=mean(TOTR), AEt = mean(AET+EVBS+EVAC+EVAS), PEt =mean(PET)),by=.(DM)]
plot(mS$SOIS,type='l',ylim=c(0,max(mS$SOIS)))
lines(mS$SUR,col="blue")
lines(mS$RET,col="green")
plot(mS$PR)

points(mS$PEt, col="red")
points(mS$AEt)

plot(mS$PEt, col="red")
points(mS$AEt)

plot(mS$Ro)
plot(mS$SOIS)

AAe=(dF$AET+dF$EVBS+dF$EVAC+dF$EVAS)
o=1:1604

plot(dF$SOIS[o])

plot(dF$SOIS)

max(dF$SOIS)
plot(dF$SOIS[o],col='blue',ylim=c(0,max(c(AAe,dF$PET,dF$SOIS))))
lines(dF$EVBS[o],col='darkolivegreen4')
lines(AAe[o],col="red")
lines(dF$PET[o],col='black')

plot(dF$PET[o],type='l')
lines(dF$EVBS[o],col='darkolivegreen4')
lines(AAe[o],col="red")

simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
plot(p_OBS,RmBP, pch=19)
points(p_OBS,simBest,col="red",pch=19)

#
#
#
#
# plot(dF$TOTR, type='l')
# plot(dF$BASF, type='l')
# sum(dF$BASF)/length(dF$BASF)
# plot(dF$DIRR, type='l')
# plot(dF$SOIS, type='l')
# plot(dF$SURS,type= 'l')
# plot(dF$GROS, type='l')
# plot(dF$PREF,type= 'l')
# plot(dF$TROF,type= 'l')
# plot(dF$SNOW, type='l')
#
# plot(dF$CANS, type='l')
# plot(dF$STES, type='l')
#
# plot(dF$EVAC, type='l')
# plot(dF$EVAS, type='l')
# plot(dF$EVBS, type='l')
# plot(dF$AET, type='l')
# plot(dF$MELT, type='l')
#
# which.min(dF$EVBS)
#
# aet=dF$AET+dF$EVBS+dF$EVAC+dF$EVAS
# aet1=dF$AET+dF$EVBS
# plot(aet)
#
#
# # plot((dF$SOIS)[1:1700],type='l')
#
dFF= data.table(
  DTM = as.Date(paste0(dF$YEAR,"-",dF$MONTH,"-",dF$DAY)),
  GW = dF$GROS,
  SO = dF$SOIS,
  SR = dF$SURS,
  P=dF$PREC,
  Sn=dF$SNOW,
  T=dF$TEMP,
  PET=dF$PET,
  AET=dF$AET+dF$EVBS+dF$EVAC+dF$EVAS,
  MEL =dF$MELT,
  R =dF$TOTR,
  BF = dF$BASF,
  DR = dF$DIRR,
  PR = dF$PERC,
  EF = dF$PREF)
dFF[,Month:=month(DTM)]
dFF[,Year:=year(DTM)]

dFF[DTM>as.Date("2006-01-01"),.(GW=mean(GW),SO=mean(SO),SR=mean(SR), SOSR=mean(SO+SR),P=sum(P),Sn=sum(Sn),T=mean(T),PET=sum(PET),AET=sum(AET),MELt=sum(MEL),R=sum(R), BF=sum(BF), DR=sum(DR), PERC= sum(PR),EF = sum(EF)),by=.(Month)]
HBy =dFF[DTM>as.Date("1961-01-01"),.(GW=mean(GW),SO=mean(SO),SR=mean(SR), SOSR=mean(SO+SR),P=sum(P),Sn=mean(Sn),T=mean(T),PET=sum(PET),AET=sum(AET),MELt=sum(MEL),R=sum(R), BF=sum(BF), DR=sum(DR), PERC= sum(PR)),by=.(Year)]
dFF[DTM>as.Date("1961-01-01"),.(GW=mean(GW),SO=mean(SO),SR=mean(SR), SOSR=mean(SO+SR),P=sum(P),Sn=mean(Sn),T=mean(T),PET=sum(PET),AET=sum(AET),MELt=sum(MEL),R=sum(R)),]

mean(HBy$R)
mean(HBy$PET)
mean(HBy$AET)
# simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
#
# plot((dF$AET+dF$EVBS+dF$EVAC+dF$EVAS)[1:700],type='l')
# plot((dF$SOIS)[1:1700],type='l')
# simBest=as.numeric(quantile(dF$TOTR,probs=(1-p_OBS), na.rm = TRUE))
# plot(RmBP, simBest)
#
# plot(RmBP, simBest)
#
#
#
# plot(p_OBS,RmBP, pch=19)
# points(p_OBS,simBest,col="red",pch=19)
#
# (RmBP-simBest)/RmBP*100
#
# # saveRDS(file="./data/basin_params/BP/dHRUM_lumped_BP_03.rds",ParBest)
#


#' dmrff.stats
#'
#' Calculate statistics for a set of genomic regions.
#'
#' @param regions Data frame of genomic regions providing
#' chromosome (chr), start and end coordinates.
#' @param estimate Vector of EWAS effect estimates
#' (corresponds to rows of \code{methylation}).
#' @param se Vector of standard errors of the coefficients.
#' @param methylation Methylation matrix (rows=features, columns=samples).
#' @param chr Feature chromosome (corresponds to rows of \code{methylation}).
#' @param pos Feature chromosome position.
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing summary statistics for all genomic regions.
#'
#' @export
dmrff.stats <- function(regions, estimate, se, methylation, chr, pos, verbose=T) {
    stopifnot(is.data.frame(regions) && all(c("chr","start","end") %in% colnames(regions)))
    stopifnot(is.vector(estimate))
    stopifnot(is.vector(se))
    stopifnot(is.matrix(methylation))
    stopifnot(is.vector(chr))
    stopifnot(is.vector(pos))
    stopifnot(length(estimate) == length(se))
    stopifnot(length(estimate) == nrow(methylation))
    stopifnot(length(estimate) == length(chr))
    stopifnot(length(estimate) == length(pos))

    members <- region.members(regions, data.frame(chr=chr, pos=pos))

    stats <- do.call(rbind, mclapply(members, function(idx) {
        idx <- na.omit(idx)
        if (length(idx) == 0) return(c(B=NA,S=NA))
        ivwfe.stats(estimate[idx], se[idx], methylation[idx,,drop=F])
    }))

    regions$estimate <- stats[,"B"]
    regions$se <- stats[,"S"]
    regions$z <- stats[,"B"]/stats[,"S"]
    regions$p.value <- 2*pnorm(-abs(regions$z), lower.tail=T)
    regions$n <- sapply(members, length)

    regions
}


# Adding missing libraries e.g for forecast:        install.packages("forecast")

library(forecast)
library(fpp)

tryCatch({  findBestPrediction <- function(Stockadd)
{

  Stock = Stockadd

  # In case not read correctly:
  backUpStock = read.table("./input/AEE.csv", sep=",", header=TRUE);

  # Convert into time series object
  tryCatch({   tsStock = ts(rev(Stock$Close),start=c(2000, 1),frequency=12)}, error=function(e) { tsStock = ts(rev(Stock$Close),start=c(2006, 1),frequency=12) })
  tryCatch({   tsBackUpStock = ts(rev(backUpStock$Close),start=c(2000, 1),frequency=12)}, error=function(e) { backUpStock = ts(rev(Stock$Close),start=c(2006, 1),frequency=12) })

  # Create Train and Test data of the input stock
  tryCatch({   train <- window(tsBackUpStock, end=2010)}, error=function(e) { train = 0 })
  tryCatch({   test <- window(tsBackUpStock, start=2013)}, error=function(e) { test = 0 })
  tryCatch({   Btrain <- window(tsBackUpStock, end=2010)}, error=function(e) { Btrain = 0 })
  tryCatch({   Btest <- window(tsBackUpStock, start=2013)}, error=function(e) { Btest = 0 })

  tryCatch({   train <- window(tsStock, end=2010)}, error=function(e) { train = 0 })
  tryCatch({   test <- window(tsStock, start=2013)}, error=function(e) { test = 0 })
  if (test[1] == Btest[1] && test[2] == Btest[2] && test[3] == Btest[3]) {train = Btrain }

  # Mean Absolute Errors of the 25 predictions are stored here
  tryCatch({ mae = matrix(NA,25,length(test)+1)}, error=function(e) {  mae = matrix(NA,25,10000) })

  tl = seq(2000,2013,length=length(train))
  tl2 = tl^7
  # cat("01")
  tryCatch({   polyStock = lm(train ~ tl + tl2)}, error=function(e) { polyStock = 0 })
  # cat("02")
  tryCatch({   tsStocktrend1=ts(polyStock$fit,start=c(2000, 1),frequency=12)}, error=function(e) { tsStocktrend1 = 0 })
  # cat("03")
  tryCatch({  stlStock = stl(train,s.window="periodic")}, error=function(e) { stlStock = 0 })
  # cat("04")
  tryCatch({   tsStocktrend2 = stlStock$time.series[,2]}, error=function(e) { tsStocktrend2 = 0 })
  # cat("05")
  tryCatch({   HWStock1_ng = HoltWinters(tsStocktrend1,gamma=FALSE)}, error=function(e) { HWStock1_ng = 0 })
  # cat("06")
  tryCatch({   HWStock1 = HoltWinters(tsStocktrend1)}, error=function(e) { HWStock1 = 0 })
  # cat("07")
  tryCatch({   NETfit1 <- nnetar(tsStocktrend1)}, error=function(e) { NETfit1 = 0 })
  # cat("08")
 # tryCatch({   autofit1 =  auto.arima(tsStocktrend1)}, error=function(e) { autofit1 = 0 })
  # cat("09")
  tryCatch({   fit12 <-   arima(tsStocktrend1, order=c(1,0,0), list(order=c(2,1,0), period=12))}, error=function(e) { fit12 = 0 })
  # cat("010")
  tryCatch({   fitl1 <- tslm(tsStocktrend1 ~ trend + season, lambda=0)}, error=function(e) { fitl1 = 0 })
  # cat("011")
  tryCatch({   stlStock1 = stl(tsStocktrend1,s.window="periodic")}, error=function(e) { stlStock1 = 0 })
  # cat("012")
  tryCatch({  HWStock2_ng = HoltWinters(tsStocktrend2,gamma=FALSE)}, error=function(e) { HWStock2_ng = 0 })
  # cat("013")
  tryCatch({   HWStock2 = HoltWinters(tsStocktrend2)}, error=function(e) { HWStock2 = 0 })
  # cat("014")
  tryCatch({   NETfit2 <- nnetar(tsStocktrend2)}, error=function(e) { NETfit2 = 0 })
  # cat("015")
#  tryCatch({   autofit2 =  auto.arima(tsStocktrend2) }, error=function(e) { autofit2 = 0 })
  # cat("016")
  tryCatch({   fit2 <-    arima(tsStocktrend2, order=c(15,3,3))}, error=function(e) { fit2 = 0 })
  # cat("017")
  tryCatch({   fit22 <-    arima(tsStocktrend2, order=c(1,0,0), list(order=c(2,1,0), period=12))}, error=function(e) { fit22 = 0 })
  # cat("018")
  tryCatch({   fitl2 <- tslm(tsStocktrend2 ~ trend + season, lambda=0)}, error=function(e) { fitl2 = 0 })
  # cat("019")
  tryCatch({   stlStock2 = stl(tsStocktrend1,s.window="periodic")}, error=function(e) { stlStock2 = 0 })
  # cat("020")
  tryCatch({   HWStockr_ng = HoltWinters(train,gamma=FALSE)}, error=function(e) { HWStockr_ng = 0 })
  # cat("021")
  tryCatch({   HWStockr = HoltWinters(train)}, error=function(e) { HWStockr = 0 })
  # cat("022")
  tryCatch({   NETfitr <- nnetar(train)}, error=function(e) { NETfitr = 0 })
  # cat("023")
 # tryCatch({   autofitr = auto.arima(train)}, error=function(e) { autofitr = 0 })
  # cat("024")
  tryCatch({   fitr <-arima(train, order=c(15,3,3))}, error=function(e) { fitr = 0 })
  # cat("025")
  tryCatch({   fitr2 <-  arima(train, order=c(1,0,0), list(order=c(2,1,0), period=12))}, error=function(e) { fitr2 = 0 })
  # cat("026")
  tryCatch({   fitlr <- tslm(train ~ trend + season, lambda=0)}, error=function(e) { fitlr = 0 })
  # cat("027")
  tryCatch({   stlStockr = stl(train,s.window="periodic")} , error=function(e) {stlStockr = 0 })
  # cat("  	TRANSITION		-!!!-")

  # cat("1")
  tryCatch({   HWStockr_ng = HoltWinters(train,gamma=FALSE)}, error=function(e) { HWStockr_ng = 0 })
  # cat("2")
 # tryCatch({  predautofitr =   window(forecast(autofitr,h=39)$mean, start=2013)}, error=function(e) { predautofitr = 0 })
  # cat("3")
  tryCatch({  predfitr =  window(forecast(fitr,h=39)$mean, start=2013)}, error=function(e) { predfitr = 0 })
  # cat("4")
  tryCatch({  predfitr2  =   window(forecast(fitr2,h=39)$mean, start=2013)}, error=function(e) { predfitr2 = 0 })
  # cat("5")
  tryCatch({  predNETfitr =  window(forecast(NETfitr,h=39)$mean, start=2013)}, error=function(e) { predNETfitr = 0 })
  # cat("6")
  tryCatch({  predHWStockr =  window(predict(HWStockr,n.ahead=39), start=2013)}, error=function(e) { predHWStockr = 0 })
  # cat("7")
  tryCatch({   predHWStockr_ng =  window(predict(HWStockr_ng,n.ahead=39), start=2013)}, error=function(e) { predHWStockr_ng  = 0 })
  # cat("8")
 #  tryCatch({ predautofit2 =   window(forecast(autofit2,h=39)$mean, start=2013)}, error=function(e) { predautofit2 =0 })
  # cat("9")
  tryCatch({  predfit12 =  window(forecast(fit12,h=39)$mean, start=2013)}, error=function(e) { predfit12 = 0 })
  # cat("10")
  tryCatch({   predfit2 = window(forecast(fit2,h=39)$mean, start=2013)}, error=function(e) { predfit2 = 0 })
  # cat("11")
  tryCatch({ predfit22 =  window(forecast(fit22,h=39)$mean, start=2013)}, error=function(e) { predfit22 = 0 }) # cat("C2")}, error=function(e) { predfit22 = 0 })
  # cat("12")
  tryCatch({   predstlStock1 = window( forecast(stlStock1, h=39)$mean, start=2013)}, error=function(e) { predstlStock1 = 0 })
  # cat("13")
  tryCatch({   predstlStock2 =  window(forecast(stlStock2, h=39)$mean, start=2013)}, error=function(e) { predstlStock2 = 0 })
  # cat("14")
  tryCatch({   predstlStockr =  window(forecast(stlStockr, h=39)$mean, start=2013)}, error=function(e) { predstlStockr = 0 })
  # cat("15")
  tryCatch({   predNETfit2 =  window(forecast(NETfit2,h=39)$mean, start=2013)}, error=function(e) { predNETfit2 = 0 })
  tryCatch({   predHWStock2 =  window(predict(HWStock2,n.ahead=39), start=2013)}, error=function(e) { predHWStock2 = 0 })
  tryCatch({   predHWStock2_ng =  window(predict(HWStock2_ng,n.ahead=39), start=2013)}, error=function(e) { predHWStock2_ng = 0 })
 #  tryCatch({    predautofit1 =  window(forecast(autofit1,h=39)$mean, start=2013)}, error=function(e) { predautofit1 = 0 })
  # cat("after autofit")
  tryCatch({   predfitlr = window(forecast(fitlr, h=39)$mean , start=2013)}, error=function(e) { predfitlr = 0 })
  tryCatch({   predfitl1 =   window(forecast(fitl1, h=39)$mean, start=2013)}, error=function(e) { predfitl1 = 0 })
  tryCatch({   predfitl2 = window(forecast(fitl2, h=39)$mean , start=2013)}, error=function(e) { predfitl2 = 0 })
  tryCatch({   predNETfit1 =  window(forecast(NETfit1,h=39)$mean, start=2013)}, error=function(e) { predNETfit1 = 0 })
  tryCatch({   predHWStock1_ng =  window(predict(HWStock1_ng,n.ahead=39), start=2013)}, error=function(e) { predHWStock1_ng = 0 })
  tryCatch({   predHWStock11 =  window(predict(HWStock1, n.ahead = 39, prediction.interval = T, level = 0.95)[,1], start=2013)}, error=function(e) { predHWStock11 = 0 })
  tryCatch({   predHWStock12 =  window(predict(HWStock1, n.ahead = 39, prediction.interval = T, level = 0.95)[,2], start=2013)}, error=function(e) { predHWStock12 = 0 })
  tryCatch({   predHWStock13 =  window(predict(HWStock1, n.ahead = 39, prediction.interval = T, level = 0.95)[,3], start=2013)}, error=function(e) { predHWStock13 = 0 })
  # cat("  	NEXT	--!!!--")

  # Calculate Mean Absolute Error
  for(i in 1:length(test))
  {
  #  mae[1,i] <- abs <- abs(predautofitr[i]-test[i])
    tryCatch({    mae[2,i] <-abs(predfitr[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[3,i] <- abs <- abs(predfitr2[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[4,i] <- abs(predNETfitr[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[5,i] <- abs(predHWStockr[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[6,i] <- abs(predHWStockr_ng[i]-test[i]) }, error=function(e) { })
 #    mae[7,i] <- abs(predautofit2[i]-test[i])
    tryCatch({    mae[8,i] <- abs(predfit12[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[9,i] <-abs(predfit2[i]-test[i]) }, error=function(e) { })
	# cat("before mae 22")
   tryCatch({   mae[10,i] <- abs(predfit22[i]-test[i]) }, error=function(e) { })
    # cat("after mae 22")
   tryCatch({ 	mae[11,i] <- abs(predstlStock1[i]-test[i]) }, error=function(e) { })
   tryCatch({     mae[12,i] <- abs(predstlStock2[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[13,i] <- abs(predstlStockr[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[14,i] <- abs(predNETfit2[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[15,i] <- abs(predHWStock2[i]-test[i]) }, error=function(e) { })
   tryCatch({     mae[16,i] <- abs(predHWStock2_ng[i]-test[i]) }, error=function(e) { })
  #   mae[17,i] <- abs(predautofit1[i]-test[i])
    tryCatch({    mae[18,i] <- abs(predfitlr[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[19,i] <-  abs(predfitl1[i]-test[i]) }, error=function(e) { })
     tryCatch({   mae[20,i] <- abs(predfitl2[i]-test[i]) }, error=function(e) { })
     tryCatch({   mae[21,i] <- abs(predHWStock1_ng[i]-test[i] ) }, error=function(e) { })
    tryCatch({    mae[22,i] <- abs(predNETfit1[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[23,i] <- abs(predHWStock11[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[24,i] <- abs(predHWStock12[i]-test[i]) }, error=function(e) { })
    tryCatch({    mae[25,i] <- abs(predHWStock13[i]-test[i]) }, error=function(e) { })
  }

  # Sum all Errors
  for(i in 1:25)
  {
    mae[i,5] = sum(mae[i,1:4])
  }

  # Find best Prediction

  best = which.min(mae[1:25,5])

  cat(" - winning model ID:", best )

  return (best)
}}, error=function(e) { cat("findBestPrediction failed for:",Stockadd); });


setwd("E:/MIT4/6.439/pset1")
library(data.table)

df_gamma = read.csv('data/gamma-ray.csv', stringsAsFactors=F)


## compare EWAS methods on simulated data
## randomly select individuals as cases and controls to match distribution per brain bank
## compare 3 models analyses data using data all cell types

runEWAS<-function(row,pheno, status){

	modelLM<-lm(row ~ status * pheno$Cell.type + pheno$CCDNAmAge + pheno$Sex + pheno$Tissue.Centre)
	nullLM<-lm(row ~ status + pheno$Cell.type + pheno$CCDNAmAge + pheno$Sex + pheno$Tissue.Centre)

	data<-cbind(row,status, pheno)
	modelMLM<-lmer(row ~ status * Cell.type + CCDNAmAge + Sex +  + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)
	nullMLM<-lmer(row ~ status + Cell.type + CCDNAmAge + Sex +  + (1 | Tissue.Centre)  + (1 | Indidivual.ID), REML = FALSE, data = pheno)

	p.df <- pdata.frame(data.frame("meth" = row, "phenotype" = status, "age" = pheno$CCDNAmAge, "sex" = pheno$Sex, "cell.type" = pheno$Cell.type, "brain.bank" = pheno$Tissue.Centre, "id" = pheno$Indidivual.ID), index = c("id", "cell.type"), drop.index = F)

	modelp <- plm(meth ~ phenotype * cell.type + age + sex  + brain.bank, data = p.df, model = "pooling")
	nullCRR <- plm(meth ~ phenotype + cell.type + age + sex  + brain.bank, data = p.df, model = "pooling")
	# compute Stata like df-adjustment
	G <- length(unique(p.df$id))
	N <- length(p.df$id)
	dfa <- (G/(G - 1)) * (N - 1)/modelp$df.residual

	# display with cluster VCE and df-adjustment
	firm_c_vcov <- dfa * vcovHC(modelp, type = "HC0", cluster = "group", adjust = T)
	modelCRR<-coeftest(modelp, vcov = firm_c_vcov)

	return(c(summary(modelLM)$coefficients["status1", 4], anova(modelLM, nullLM)[2,6],
	summary(modelMLM)$coefficients["status1", 5], anova(modelMLM, nullMLM)[2,8],
	 modelCRR["phenotype1",4],waldtest(modelp, nullCRR, vcov = firm_c_vcov, test = "F")[2,4]))
}

library(lme4)
library(lmerTest)
library(plm)
library(lmtest)
#library(GenABEL)
library(doParallel)

nSim<-10

args<-commandArgs(trailingOnly = TRUE)
source(args[1])
nChunk<-args[2]

setwd(dataDir)

load(normData)

## remove total samples and cell types with less than 10 samples
pheno<-pheno[which(pheno$Cell.type != "Total"),]
nSample<-table(pheno$Cell.type)
pheno<-pheno[pheno$Cell.type %in% names(nSample[which(nSample > 9)]),]

celltypenormbeta<-celltypenormbeta[,pheno$Basename]

nCores<-detectCores()
cl <- makeCluster(nCores-1)
registerDoParallel(cl)
clusterExport(cl, list("runEWAS", "lmer", "pdata.frame", "plm", "vcovHC", "coeftest", "waldtest"))

## first randomly assign cases control status, do we see inflation?
allSim<-NULL
for(simNum in 1:nSim){
	status<-rep(0,nrow(pheno))

	for(centre in unique(pheno$Tissue.Centre)){
		ids<-unique(pheno$Indidivual.ID[which(pheno$Tissue.Centre == centre)])
		cases<-sample(ids, floor(length(ids)/2))
		status[pheno$Indidivual.ID %in% cases]<-1
	}
	status<-as.factor(status)
	outtab<-foreach(i=1:nrow(celltypenormbeta), .combine = "cbind") %dopar% runEWAS(celltypenormbeta[i,], pheno, status)
	outtab<-t(outtab)

	rownames(outtab)<-rownames(celltypenormbeta)
	colnames(outtab)<-c(paste("LM", c("ME", "Int"), sep = "_"),paste("MLM", c("ME", "Int"), sep = "_"),paste("CRR", c("ME", "Int"), sep = "_"))
	allSim<-cbind(allSim, outtab)
}

save(allSim, file = paste0("nullSimulations_Chunk", nChunk, ".rdata"))


min_clonotype_cell=10

setwd("/scratch/cqs/paula_hurley_projects/20210303_scRNA_human/hto_clonotype_6_fishertest")

clonotypes<-read.csv("../hto_clonotype_4_convert/result/clonotypes.csv", header=T)
rownames(clonotypes)<-clonotypes$clonotype_id
cells<-read.csv("../hto_samples_cutoff_summary/result/PH_scRNA.HTO.summary.csv", header=T)
rownames(cells)<-cells$Sample

#clonotypes<-clonotypes[c(1:10),]

sample_columns=c(paste0(cells$Sample, "_Benign"),paste0(cells$Sample, "_Tumor"))
sample_data=clonotypes[,sample_columns]
max_column<-colnames(sample_data)[max.col(sample_data, ties.method = "first")]
max_sample<-gsub("_Benign|_Tumor","", max_column)

clonotypes$MaxSample=max_sample

benign_names=paste0(max_sample, "_Benign")
tumor_names=paste0(max_sample, "_Tumor")

clonotypes$MaxSample_Clonotype_Benign=unlist(lapply(c(1:length(max_sample)), function(x){
  return(clonotypes[x,benign_names[x]])
}))
clonotypes$MaxSample_Clonotype_Tumor=unlist(lapply(c(1:length(max_sample)), function(x){
  return(clonotypes[x,tumor_names[x]])
}))

clonotypes$MaxSample_Cell_Benign=cells[max_sample, "Benign"]
clonotypes$MaxSample_Cell_Tumor=cells[max_sample, "Tumor"]

fortest<-which(clonotypes$MaxSample_Clonotype_Benign >= min_clonotype_cell | clonotypes$MaxSample_Clonotype_Tumor >= min_clonotype_cell)
testdata<-clonotypes[fortest,]

fts<-apply(testdata, 1, function(x){
  clono_benign=as.numeric(x[["MaxSample_Clonotype_Benign"]])
  clono_tumor=as.numeric(x[["MaxSample_Clonotype_Tumor"]])
  cell_benign=as.numeric(x[["MaxSample_Cell_Benign"]])
  cell_tumor=as.numeric(x[["MaxSample_Cell_Tumor"]])
  clono_test<-matrix(c(clono_tumor, clono_benign,  cell_tumor-clono_tumor, cell_benign-clono_benign),
                     nrow = 2,
                     dimnames = list(Cell = c("Tumor", "Benign"),
                                     Clonotype = c("Yes", "No")))
  ft=fisher.test(clono_test)
  return(data.frame("pvalue"=ft$p.value,"odds_ratio"=ft$estimate))
})
ftsvalues<-do.call(rbind, fts)
ftsvalues$clonotype_id<-testdata$clonotype_id
ftsvalues$adjustp<-p.adjust(ftsvalues$pvalue, method="fdr")
ftsvalues$significant<-ftsvalues$adjustp<0.01

final<-merge(clonotypes,ftsvalues,by = "clonotype_id", all.x = TRUE)
final<-final[order(final$frequency,decreasing = T),]

write.csv(final, file="PH_scRNA.clonotype.fishertest.csv", row.names=F, na = "")


##Ukázka 4=name
##R workshop=group
##vstupni_vrstva=vector
##vzorec_lm=string
##vystupni_vrstva=output vector
library(dplyr)

linearni_regrese <- lm(as.formula(vzorec_lm), data = vstupni_vrstva)

vystupni_vrstva <- vstupni_vrstva %>%
  mutate(predikce = predict(linearni_regrese, vstupni_vrstva))


#devtools::test("asremlPlus")
context("model_selection")

cat("#### Test variofaces using Atieno with asreml4\n")
test_that("Variofaces_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)

  data(chkpeadat)
  testthat::expect_equal(nrow(chkpeadat), 1056)
  testthat::expect_equal(ncol(chkpeadat), 18)

  # Fit a model and caluclate the Wald table
  current.asr <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                        random = ~Smarthouse:Zone + Smarthouse:spl(vLanes),
                        residual = ~dsum(~ar1(Lane):ar1(Position) | Smarthouse),
                        data = chkpeadat, trace = FALSE)
  summary(current.asr)$varcomp
  current.asrt <- as.asrtests(current.asr, denDF = "numeric")
  current.asrt$wald.tab
  recalcWaldTab(current.asrt, denDF="numeric", dDF.na = "maximum")
  testthat::expect_equal(length(current.asrt), 3)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 7)
  testthat::expect_equal(nrow(current.asrt$test.summary), 0)

  # Fit initial model
  current.asr <- asreml(Biomass.plant ~ Smarthouse + Lines*TRT ,
                        random = ~ Smarthouse:(Lane + Position),
                        residual = ~ dsum(~ar1(Lane):ar1(Position) | Smarthouse),
                        data=chkpeadat)
  summary(current.asr)$varcomp

  # Load current fit into an asrtests object
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  # Check for and remove any boundary terms
  current.asrt <- rmboundary(current.asrt)
  print(current.asrt)

  # Test Lanes autocorrelation
  current.asrt <- testresidual(current.asrt, "~ dsum(~Lane:ar1(Position) | Smarthouse)",
                               label="Lane autocorrelation", simpler=TRUE)

  # Test Pos autocorrelation (depends on whether Lane autocorrelation retained)
  k <- match("Lane autocorrelation", current.asrt$test.summary$terms)
  p <- current.asrt$test.summary$p
  {if (p[k] <= 0.05)
    current.asrt <- testresidual(current.asrt, "~ dsum(~ar1(Lane):Position | Smarthouse)",
                                 label="Pos autocorrelation", simpler=TRUE,
                                 update=FALSE)
    else
      current.asrt <- testresidual(current.asrt, "~ dsum(~Lane:Position | Smarthouse)",
                                   label="Pos autocorrelation", simpler=TRUE,
                                   update=FALSE)
  }
  testthat::expect_equal(length(current.asrt), 3)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 5)
  testthat::expect_equal(nrow(current.asrt$test.summary), 3)
  print(current.asrt)

  # Get current fitted asreml object
  current.asr <- current.asrt$asreml.obj
  current.asr <- update(current.asr, aom=TRUE)

  #Produce variogram faces plot (Stefanaova et al, 2009)
  faces <- variofaces(current.asr, nsim = 50, maxiter = 20, seed = 14522)
  testthat::expect_equal(nrow(faces$face1), 48)
  testthat::expect_equal(ncol(faces$face1), 6)
  testthat::expect_equal(nrow(faces$face2), 44)
  testthat::expect_equal(ncol(faces$face2), 6)

  #Get Variety predictions
  Var.pv <- predict(current.asr, classify="Lines")$pvals
  testthat::expect_equal(nrow(Var.pv), 247)
  testthat::expect_equal(ncol(Var.pv), 4)
})


rstudio
# big data bread R code
##### QUESTION FOR TAMMY: (Line 20) Why do we need to EXCLUDEEE zip code from tree predictor values????

# importing workingData (grocery stores, and median income of zipcodes) into a dataframe
groceryStores <- read.csv("workingData.csv", header=T, na.strings="?")
fix(groceryStores)
summary(groceryStores)
summary(groceryStores$Zip.Code)
groceryStores

################################################
# Classification Trees
################################################

# make it into a classification tree
install.packages("tree")
library(tree)

# classification tree for predicting CLASSIFICTION of grocery stores (high/medium/low)
tree.classificationGroceryStores=tree(Word.Classification ~. -Grocery.Store.Name -Address -Zip.Code -Number.Classification, groceryStores)
summary(tree.classificationGroceryStores)
plot(tree.classificationGroceryStores)
text(tree.classificationGroceryStores)

# a perfect classifier should have a deviance of 0... but our deviance is 84.69369,
# ... so classification tree is probably not the way to go
deviance(tree.classificationGroceryStores)

# classification tree for predicting MEAN income per zipcode
tree.meanIncomePerZipcode=tree(Mean.Income.for.Zipcode ~. -Grocery.Store.Name -Address -Zip.Code -Nummber.Classification, groceryStores)
summary(tree.meanIncomePerZipcode)
plot(tree.meanIncomePerZipcode)
text(tree.meanIncomePerZipcode)

# ... nOT GOOD
yikes <- deviance(tree.meanIncomePerZipcode)

# attempt to predict zipcode ... doesn't work well
tree.zipcode=tree(Zip.Code ~. -Grocery.Store.Name -Address -Number.Classification, groceryStores)
summary(tree.zipcode)
plot(tree.zipcode)
text(tree.zipcode)
summary(groceryStores$Zip.Code)

################################################
# Bayes Classifier
################################################

install.packages("e1071")
library(e1071)
help(naiveBayes)

# make a training set of a random sample that's half the size of the groceryStores data
set.seed(2)
train=sample(1:nrow(groceryStores), nrow(groceryStores)/2) #need to play around with "train" data...

bay.c <- naiveBayes(Word.Classification ~. -Grocery.Store.Name -Address -Zip.Code -Number.Classification, groceryStores, subset=train)
summary(bay.c)
bay.c

################################################
# Regression Trees (with bagging!)
################################################
install.packages("randomForest")
library(randomForest)

# create a test-set
grocery.test=groceryStores[-train,"Mean.Income.for.Zipcode"]

# predict MEAN INCOME PER ZIPCODE with regression trees
set.seed(1)
bag.grocery=randomForest(Mean.Income.for.Zipcode ~. -Grocery.Store.Name -Address -Zip.Code, data=groceryStores, subset=train, mtry=3, importance=TRUE)
bag.grocery
yhat.bag = predict(bag.grocery, newdata=groceryStores[-train,])

train
groceryStores[-train,]

plot(yhat.bag, grocery.test)
abline(0, 1)
mean((yhat.bag-grocery.test)^2) # mean squared error is 22-million LOL
yhat.bag
grocery.test
##### saved regression tree as LOL_regressionTreeNoThankYou_Yikes.pdf

# Median income per zipcode provides the most increase in MSE
importance(bag.grocery)
# Median income per zipcode ALSO is the most "pure" in nodes
varImpPlot(bag.grocery)

################################################
# Boosting things (Regression tree)
################################################

#### YIKES ---- only Multnomah county data == NOT ENOUGH DATA for boooooosting!!!!
#install.packages("gbm")
#library(gbm)
#set.seed(1)
#boost.grocery=gbm(Mean.Income.for.Zipcode ~. -Address -Grocery.Store.Name, data=groceryStores[train,], distribution="gaussian", n.trees=20, interaction.depth=4)
#summary(boost.grocery)

################################################
# Regression lines (with multiple regression!!!!!)
################################################

lm.fit=lm(Mean.Income.for.Zipcode ~ . -Address -Grocery.Store.Name -Zip.Code -Number.Classification, data=groceryStores)
lm.fit
summary(lm.fit)

par(mfrow=c(2,2))
plot(lm.fit)

################################################
# Let'z K-meanz cluster dis
#
################################################
set.seed(2)
x <- groceryStores[,c(2, 6, 7, 8)]

km.out=kmeans(x, 3, nstart=20)
km.out$cluster
km.out$centers

plot(x, col=(km.out$cluster+1), main="K-Means Clustering Results with K=3", pch=20, cex=2)

km.out$iter

###### TRY K-MEANS CLUSTERING
### change "classification" value columns (aka "High" to 1; "Medium" to 2; "Low" to 3)

################################################
# Hierarchical clusteringggg
# .... what does this meann!!!!????? it kind of worked
################################################
hc.complete=hclust(dist(groceryStores), method="complete")
hc.average=hclust(dist(groceryStores), method="average")
hc.single=hclust(dist(groceryStores), method="single")

par(mfrow=c(1,3))
plot(hc.complete,main="Complete Linkage", xlab="", sub="", cex=.9)
plot(hc.average,main="Average Linkage", xlab="", sub="", cex=.9)
plot(hc.single,main="Single Linkage", xlab="", sub="", cex=.9)

################################################
# Principal components --- reduces the dimensionality of our dataset
################################################

groceryStoreIncomeAndPop <- groceryStores[,c(6, 7, 8)]

summary(groceryStoreIncomeAndPop)

apply(groceryStoreIncomeAndPop, 2, mean)
apply(groceryStoreIncomeAndPop, 2, var)

pr.out=prcomp(groceryStoreIncomeAndPop, scale=TRUE)
names(pr.out)
pr.out$center
pr.out$scale
pr.out$rotation
pr.out$x

biplot(pr.out, scale=0)


## 3. Assignment ##

# This is a comment, and so is any line that starts with a #
# Comments help provide information about the code.

# Assign the value 10 to the variable bearAwesomeness.
bearAwesomeness <- 10
dogAwesomeness <- 10
# Assign the value 1.5 to the variable guineaPigAwesomeness.
guineaPigAwesomeness <- 1.5
catAwesomeness <- 9.5

## 4. Print ##

# We can print out values
print(10)

# We can also assign a value to a variable, then print the variable
lifeSavings <- 5.5
print(lifeSavings)
lifeSavings <- 9999
print(lifeSavings)

## 5. Types of variables ##

# Assign the value 800 to the variable runDistance.
runDistance <- 800

# This is of type "numeric".
print(class(runDistance))

# Assign the value "Peanut Butter Cup" to favoriteDessert
favoriteDessert <- "Peanut Butter Cup"

# This is of type "character", because it contains text.
print(class(favoriteDessert))

biggestDog <- "Mastiff"
mastiffCount <- 50
biggestDogType = class(biggestDog)
mastiffCountType= class(mastiffCount)

## 6. Vectors ##

# Store a vector of Russian presidents.
russianPresidents <- c("Mikhail Gorbachev", "Boris Yeltsin", "Vladimir Putin")

# Store a vector of stock prices on consecutive days.
applePrices <- c(113, 114, 115)
fibonacci = c(0,1,1,2)

## 7. Vectors and single values ##

dogCount <- 1
catCount <- c(1)

# We can see that these two assignments are identical.  dogCount is a vector, as is catCount.
print(identical(dogCount, catCount))

## 8. Indexing vectors ##

# Print the first element in salaries.
print(salaries[1])

# Print the 50th element in salaries
print(salaries[50])
salary10 = salaries[10]

## 9. Vector length ##

# Initialize the runDistances vector
runDistances <- c(20, 10.5, 30)

# Print the length of the vector.
print(length(runDistances))

# The salaries variable has been loaded in.
salariesLength = length(salaries)

## 10. Vector math ##

# Create a vector of stock prices.
stockPrices <- c(10, 9, 11, 15)

# This results in a new vector.  See how every element has had 2 added to it.
# Every time you do math on a vector, it will change all the elements of the vector.
print(stockPrices + 2)

# But stockPrices is unaffected.
print(stockPrices)
lowerSalaries = salaries /3

## 11. Overwriting variables ##

# Initialize our list of stock prices again.
stockPrices <- c(10, 9, 11, 15)

# Multiply every stock price by two, and overwrite the variable.
stockPrices <- stockPrices * 2
print(stockPrices)
salaries = salaries - 5000

## 12. Vector types ##

mixedVector <- c("Fifteen", 15, 0)

# Everything in mixedVector is a character value.
print(mixedVector)

# mixedVector is of type character.
print(class(mixedVector))

## 13. Getting help ##

# Enter your code here.
help(class)

R Programming Beginner/Introduction to R-125.r


# Classification using Random Forest regression, one model per variable
library(ranger)
library(caret)
library(raster)
library(fields)
source("utils/set-temp-path.r")
source("utils/load-data.r")
source("utils/accuracy-statistics.r")

OutputDir = "../data/"

alldata = LoadClassificationData()
# Bare soil with NAs: 352 364 475
bsna = c(352, 364, 476)
#alldata@data = alldata@data[-bsna,]

set.seed(0xbadcafe)
folds = createFolds(alldata$cropland, 4)

TN = GetTrainingNames(exclude=c("osavi", "aspect", "is.water", "height"))
TNUnoptimised = GetTrainingNames(exclude=c("osavi"))

# Get and plot variable importance
FullFormula = paste0("~", paste(TNUnoptimised, collapse = "+"))
Importances = data.frame()
for (Class in GetValidationNames())
{
    print(Class)
    Formula = update.formula(FullFormula, paste0(Class, " ~ ."))
    set.seed(0xbadcafe)
    rfmodel = holdoutRF(Formula, alldata@data, scale.permutation.importance=TRUE)
    Importances = rbind(Importances, rfmodel$variable.importance)
    names(Importances) = names(rfmodel$variable.importance)
    row.names(Importances)[nrow(Importances)] = Class
}

sort(colSums(Importances))

PrettifyClasses = function(classnames)
{
    classnames = factor(classnames)
    levels(classnames) = list(
        "Overall" = "Overall", "Cultivated" = "cropland", "Dec. trees" = "dec.trees", "Evgr. trees" = "evgr.trees",
        "Shrubs" = "shrubland", "Grass" = "grassland", "Wetland" = "wetland", "Barren" = "bare.soil",
        "Built-up" = "urban", "Water" = "water")
    return(classnames)
}

PrettifyCovariates = function(covarnames)
{
    covarnames = factor(covarnames)
    levels(covarnames) = list(
        "Red" = "red", "NIR" = "nir", "Blue" = "blue", "SWIR" = "swir", "LSWI" = "lswi",
        "Water mask" = "is.water", "Elevation" = "height", "Slope" = "slope", "Aspect" = "aspect",
        "TPI" = "tpi", "Mean NDVI" = "mean.ndvi", "Phase (1)" = "phase1", "Amplitude (1)" = "amplitude1",
        "Phase (2)" = "phase2", "Amplitude (2)" = "amplitude2")
    return(covarnames)
}

pdf("../thesis/thesis-figures/variable-importance.pdf", width=6, height=5)
image.plot(1:length(GetValidationNames()), 1:length(TNUnoptimised), as.matrix(Importances),
    axes=FALSE, xlab = "", ylab = "", #xlab = "Class", ylab = "Covariate")
    bigplot=c(0.25, 0.85, 0.25, 0.95), smallplot=c(0.88, 0.9, 0.25, 0.95))
points(0,0)
axis(side=1, at=1:length(GetValidationNames()), labels=PrettifyClasses(row.names(Importances)), las=2)
axis(side=2, at=1:length(TNUnoptimised), labels=PrettifyCovariates(names(Importances)), las=1)

min.z <- min(Importances)
max.z <- max(Importances)
z.yellows <- min.z + (max.z - min.z)/64*c(20,45)
# Loop for label printing: black letters on light background and white letters on dark background
for (i in 1:length(GetValidationNames()))
{
  for (j in 1:length(TNUnoptimised))
  {
    if ((Importances[i,j] > z.yellows[1]) & (Importances[i,j] < z.yellows[2]))
    {
      text(i,j,round(Importances[i,j]), col="black", cex = 0.8)
    }else
    {
      text(i,j,round(Importances[i,j]), col="white", cex = 0.8)
    }
  }
}
dev.off()

# Do 4-fold cross-validation
RFCV = function(exclude=c(), outdir=OutputDir, filename="stat-randomforest.csv", ...)
{
    TN = GetTrainingNames(exclude=exclude)
    FullFormula = paste0("~", paste(TN, collapse = "+"))
    PredictionsPerFold = data.frame()
    for (i in 1:length(folds))
    {
        Predictions = matrix(ncol=length(GetValidationNames()), nrow=nrow(alldata@data[folds[[i]],]),
            dimnames=list(list(), GetValidationNames()))
        for (Class in GetValidationNames())
        {
            print(Class)
            Formula = update.formula(FullFormula, paste0(Class, " ~ ."))
            rfmodel = ranger(Formula, alldata@data[-folds[[i]],], seed = 0xbadcafe, ...)
            rfprediction = predict(rfmodel, alldata@data[folds[[i]],])
            Predictions[,Class] = rfprediction$predictions
        }
        ScaledPredictions = Predictions
        for (n in 1:nrow(Predictions))
        {
            ScaledPredictions[n,] = Predictions[n,] / sum(Predictions[n,]) * 100
        }
        if (nrow(PredictionsPerFold) == 0)
            PredictionsPerFold = ScaledPredictions
        else
            PredictionsPerFold = rbind(PredictionsPerFold, ScaledPredictions)
    }
    Validator = alldata@data[unlist(folds),GetValidationNames()]
    AST = AccuracyStatTable(PredictionsPerFold, Validator)
    print(AST)
    plot(unlist(PredictionsPerFold), unlist(Validator))
    write.csv(AST, paste0(outdir, filename))
    write.csv(CalcErrors(PredictionsPerFold, Validator), paste0(outdir, "errors-", filename))
}

# Unoptimised
RFCV(filename = "stat-randomforest-unoptimised.csv")
# Optimised
RFCV(exclude=c("osavi", "aspect", "is.water", "height"), splitrule="maxstat", alpha=0.9, minprop=0.11)

#bs: 20.02770 with reduced dataset, 19.90767 without, so keeping it in is fine
# Full dataset: 21.01049
# Without OSAVI: 21.10414
# Without OSAVI and aspect: 21.02937
# Without 4 variables: 20.99727

# Train on pure, predict fuzzy
folds=list(which(!alldata@data$pure))
# Unoptimised
RFCV(filename = "stat-randomforest-pure-unoptimised.csv")
# Optimised
RFCV(exclude=c("osavi", "aspect", "is.water", "height"), splitrule="maxstat", alpha=0.9, minprop=0.11,
    filename = "stat-randomforest-pure.csv")


#' Count overlapping points
#'
#' This is a variant [geom_point()] that counts the number of
#' observations at each location, then maps the count to point area. It
#' useful when you have discrete data and overplotting.
#'
#' @eval rd_aesthetics("geom", "point")
#' @param geom,stat Use to override the default connection between
#'   `geom_count()` and `stat_sum()`.
#' @seealso For continuous `x` and `y`, use [geom_bin2d()].
#' @inheritParams layer
#' @inheritParams geom_point
#' @export
#' @examples
#' ggplot(mpg, aes(cty, hwy)) +
#'  geom_point()
#'
#' ggplot(mpg, aes(cty, hwy)) +
#'  geom_count()
#'
#' # Best used in conjunction with scale_size_area which ensures that
#' # counts of zero would be given size 0. Doesn't make much different
#' # here because the smallest count is already close to 0.
#' ggplot(mpg, aes(cty, hwy)) +
#'  geom_count() +
#'  scale_size_area()
#'
#' # Display proportions instead of counts -------------------------------------
#' # By default, all categorical variables in the plot form the groups.
#' # Specifying geom_count without a group identifier leads to a plot which is
#' # not useful:
#' d <- ggplot(diamonds, aes(x = cut, y = clarity))
#' d + geom_count(aes(size = after_stat(prop)))
#' # To correct this problem and achieve a more desirable plot, we need
#' # to specify which group the proportion is to be calculated over.
#' d + geom_count(aes(size = after_stat(prop), group = 1)) +
#'   scale_size_area(max_size = 10)
#'
#' # Or group by x/y variables to have rows/columns sum to 1.
#' d + geom_count(aes(size = after_stat(prop), group = cut)) +
#'   scale_size_area(max_size = 10)
#' d + geom_count(aes(size = after_stat(prop), group = clarity)) +
#'   scale_size_area(max_size = 10)
geom_count <- function(mapping = NULL, data = NULL,
                       stat = "sum", position = "identity",
                       ...,
                       na.rm = FALSE,
                       show.legend = NA,
                       inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomPoint,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      na.rm = na.rm,
      ...
    )
  )
}


#plot the -logA and the score of each replicate
library(ggplot2)
#library(ggpubr)
args <- commandArgs(trailingOnly=TRUE)

filename <- args[1]

figname <- args[2]

df = read.table(filename, sep='\t', header = TRUE )

p <- ggplot(df) + geom_line(aes(x = physPos, y = CLR, color = log10(s_hat)) ) +
	xlab('Physical Position') + ylab('Composite Likelihood Ratio') +
	scale_color_gradient2(name = expression('log'[10]~hat(italic(a))), limits = c(-3, 9), midpoint = 0, high="red", mid = 'white', low="blue")

p <- p + theme_minimal()

png(figname, width=960, height=400)
print(p)
dev.off()


# Load required library packages from specified CRAN repo
if(!require(tidyverse)) install.packages("tidyverse",repos = "https://mirror.lyrahosting.com/CRAN/")
library(tidyverse)

start_date = "2020-03-01"
end_date = "2022-01-01"

covid_feed <- "https://lcps.nu/wp-content/uploads/covid-19-datafeed.csv"
download.file(covid_feed, "covid19.csv")

covid <-read.table("covid19.csv",header=T,sep=",")
covid$day <- as.POSIXct(covid$Datum, format="%d-%m-%Y")
covid <- filter(covid, day >= as.Date(start_date), day <= as.Date(end_date))
covid[1,]

#dev.new()
covid_plot_1 <- function(covid) {
  png("covid-1.png")
  myplot <- plot(as.Date(covid$day),covid$IC_Bedden_COVID, type = "l",col = 2,xlim=as.Date(c(start_date, end_date)), ylim=c(0,3200), xlab = "Datum", ylab="# Bedden", col.axis="blue", font.axis=3, cex.axis=1)
  lines(as.Date(covid$day),covid$IC_Bedden_Non_COVID, type = "l",col = 3)
  lines(as.Date(covid$day),covid$Kliniek_Bedden, type = "l",col = 4)
  points(covid$day[1],covid$IC_Bedden_COVID[1])
  legend("topright", c("IC_Bedden_COVID", "IC_Bedden_Non_COVID","Kliniek_Bedden"), lty = 1, col = 2:4)
  dev.off()
  browseURL("covid-1.png")
  return(myplot)
}

#plot.new()
covid_plot_2 <- function(covid) {
  myplot <- ggplot() +
    geom_line(data = covid, aes(x = as.Date(day), y = IC_Bedden_COVID), color = "red") +
    geom_line(data = covid, aes(x = as.Date(day), y = IC_Bedden_Non_COVID), color = "green") +
    geom_line(data = covid, aes(x = as.Date(day), y = Kliniek_Bedden), color = "blue") +
    xlab('Datum') +
    ylab('Aantal bedden') +
    scale_x_date(breaks = seq(as.Date(start_date), as.Date(end_date), by="2 month"), date_labels = "%b\n%Y")
  #myplot + scale_linetype_manual()
  #myplot + theme(legend.key = element_rect(fill = "white", colour = "black"))
  #legend("topright", legend = c("IC_Bedden_COVID", "IC_Bedden_Non_COVID","Kliniek_Bedden"), fill=c("red","green","blue"))
  ggsave("covid-2.png")
  browseURL("covid-2.png")
  return(myplot)
}

#covid_plot_1(covid)
covid_plot_2(covid)


rm(list = ls())

library(aphylo)

n <- 200
N <- 500

set.seed(111222)
PAR <- lapply(1:N, function(i) rbeta(5, 2, 20))
SIZ <- ceiling(runif(N, 4, 400))
DAT <- lapply(seq_along(PAR), function(p) raphylo(SIZ[p], psi=PAR[[p]][1:2], mu=PAR[[p]][3:4], Pi=PAR[[p]][5]))

plot_LogLike(DAT[[1]], psi = c(.1, .1), mu = c(.1, .1), Pi=.1)

est <- function(d) {
  tryCatch({
    aphylo_mcmc(params = rep(.05,5), dat = d , control=list(nbatch=5e3, burnin=1e3, thin=10),
                priors = function(u) dbeta(u, 2, 20))
  }, error = function(e) e)
}

# x <- profvis::profvis(x <- raphylo(10000))
# htmlwidgets::saveWidget(x, "~/profile.html")
# browseURL("~/profile.html")

cl <- parallel::makeForkCluster(4)
ANS <- parallel::parLapply(cl, DAT, est)
# ANS <- lapply(DAT, est)
parallel::stopCluster(cl)

PARest <- lapply(ANS, "[[", "par")

OK <- which(grepl("aphy", sapply(sapply(ANS, class), "[[", 1)))

PARest <- do.call(rbind, PARest[OK])
PARh0  <- do.call(rbind, lapply(1:length(OK), function(i) rbeta(5, 2, 20)))

bias   <- PARest - do.call(rbind, PAR[OK])
biash0 <- PARh0 - do.call(rbind, PAR[OK])

oldpar <- par(no.readonly = TRUE)
par(mfrow = c(1, 2))
boxplot(bias, main = "Non random", ylim = c(-.5, .5))
boxplot(biash0, main = "Random", ylim = c(-.5, .5))
par(oldpar)
summary(bias)
summary(biash0)

hist(sapply(ANS[OK], "[[", "counts"))
prop.table(table(abs(bias) < abs(biash0)))


## 2. Motivation ##

library(readr)
uber_trips <- read_csv("uber_trips.csv")

## 3. General Model Form ##

library(ggplot2)

ggplot(data = uber_trips,
       aes(x = date, y = cost)) +
  geom_line()

ggplot(data = uber_trips,
       aes(x = distance, y = cost)) +
  geom_point()

## 5. Inference ##

# question_1 <-
# question_2 <-
question_1 <- 'inference'
question_2 <- 'prediction'

## 6. Error ##

greater_error <- 'line_chart'

## 7. Estimating f with Parametric Models ##

# ggplot(data = uber_trips,
#        aes(x = distance, y = cost)) +
#   geom_point()
ggplot(data = uber_trips,
       aes(x = distance, y = cost)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE)

## 9. Comparing Model Predictions to Reality ##

uber_trips_lm <- read_csv("uber_trips_lm.csv")
MAE <- mean(abs(uber_trips_lm$residuals))
MAE_question <- TRUE

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/1. Linear Regression Modeling in R/1. Introduction to Modeling.r


#' Precheck for Underflow Values Imputation
#'
#' Checks Stanfit objects for underflow values before applying the \code{\link{model_judgement}} function.
#'
#' @param arg A Stanfit object fitted on synthetic data.
#' @param current_model Name of the current model (Currently not in use.)
#' @param lik_name Name under which the log likelihoods have been saved in the models. Needs to be identical
#' @return A list with information regarding the underflow values for each Stanfit object.
precheck <- function(arg, lik_name) {

    nms <- names(arg)

    for(.. in 1:length(arg)){

        lik <- as.matrix(arg[[..]], pars = lik_name)
        colnames(lik) <- NULL
        current_model <- nms[..]
        check <- sum(apply(log(exp(lik)), 2, FUN = sum))

        if(!is.finite(check)==TRUE | is.nan(check)==TRUE | is.na(check)==TRUE){
            status <- "Problematic!"

        }
        else{ status <- 'OK'
        # cat('\n',current_model, 'is', status)
        }

        arg[[..]] <- list("Status" = status)

    }

    df <- rbindlist(arg, fill=TRUE)
    df <- cbind(Model = names(arg), df)
    gc()

    if("Problematic!" %in% df$Status){

        return(list("status" = 0,
                    "troublemakers" = subset.data.frame(as.data.frame(df), Status=="Problematic!") ))
    }

    else{
        return(list("status" = 1))
    }
}