#' Create an mbm model
#'
#' @param y Square dissimilarity or distance matrix, can be complete or lower triangular
#' 			only. Row and column names are required and must match the site names in the
#' 			rows of \code{x}.
#' @param x Matrix giving a series of covariates (in columns) for all sites (in rows). Row
#' 			names are required. All variables will be included in the model.
#' @param y_name A name to give to the y variable
#' @param link Link function to use
#' @param likelihood Likelihood function to use
# @param n_samples NA or integer; if NA, analytical predictions with standard deviation
# 			are returned, otherwise posterior samples are returned
# @param response_curve The type of response curve to generate. The default
# 			(\code{distance}) will predict over a range of distances assuming pairs of
# 			sites equally spaced across the midpoint of environmental space. \code{none}
# 			Produces no response curve, while \code{all} creates response curves for all
# 			variables.
# @param pyMsg boolean, should we print messages from python? Useful for debugging
#' @param lengthscale Either NULL (in which case all lengthscales will be optimized) or
#'		a numeric vector of length \code{ncol(x)+1}. If a vector, the first entry
#' 		corresponds to environmental distance, and entries \code{i = 1 + (1:n)}
#' 		correspond to the variable in x[,i]. Values must be \code{NULL} or positive
#' 		numbers; if NULL, the corresponding lengthscale will be set via optimization,
#' 		otherwise it will be fixed to the value given.
#' @param sparse Should we use the stochastic variational GP (see 'details').
#' @param force_increasing Boolean; if true, beta diversity will be constrained to
#' 			increase with environmental distance
#' @param sparse_inducing Number of inducing inputs to use if `sparse = TRUE`
#' @param sparse_batch Batch size to use if `sparse = TRUE`
#' @param sparse_iter Maximum number of optimizer iterations if `sparse = TRUE`
#' @param exact_thresh integer; threshold at which mbm will refuse to run an exact gp.
#' @param verbose Should messages during model fitting be printed?
# @param ... Additional arguments to pass to MBM
#'
#' @details For larger datasets (more than ~100 sites), it is recommended to use
#' 			`sparse=TRUE`. This will use a sparse approximation to the default
#' 			method, following the stochastical variational GP (Hensman et al 2013).
#' 			Note that if a link function is selected, it will be applied as a
#' 			transformation of the y data--i.e., for link function L() we fit a SVGP to
#' 			describe the expectation E(L(y))--rather than as a true link function--
#' 			fitting L(E(y))--as is done when `svgp=FALSE`. This is due to a
#' 			limitation in the underlying GP library.
#'
#' @return An S3 object of class mbm, containing the following components:
#' 	* `x`: the original (untransformed) site by covariate matrix
#'	* `y`: the original (untransformed) site by site diversity data
#'  * `covariates`: Transformed x-variables supplied to mbm
#'  * `response`: Transformed response variable; this is the data supplied to mbm
#'  * `covar_sites`: Site names to match the covariate matrix
#'  * `y_transform`: transformation applied to y-data before modelling
#'  * `y_rev_transform`: reverse transformation to get y-data back on the original scale
#'  * `link`: a character string identifying the link function
#'  * `inv_link`: inverse of the link function
#'  * `pyobj`: A list of python objects used by the model; this is not meant for user interaction
#' @references Hensman J, Fusi N, and Lawrence ND. 2013. Gaussian Processes for Big Data.
#' 			In: In Proceedings of the 29th Conference on Uncertainty in Artificial
#' 			Intelligence.
#' @export
# mbm <- function(y, x, predictX, link = c('identity', 'probit', 'log'), scale = TRUE,
# 				n_samples = NA, response_curve = c('distance', 'none', 'all'),
# 				lengthscale, y_name = 'beta', force_increasing = FALSE, svgp = FALSE,
# 				pyMsg = FALSE, exact_thresh = 100, ...)
mbm <- function(y, x, y_name = 'beta', link = c('identity', 'probit'), likelihood = c('gaussian'),
	lengthscale = NULL, sparse = FALSE, force_increasing = FALSE, sparse_inducing = 10,
	sparse_batch = 10, sparse_iter = 10000, exact_thresh = 100, verbose = FALSE)
{
	link <- match.arg(link)
	likelihood <- match.arg(likelihood)
	# sanity check on sample sizes
	if(!sparse & nrow(y) > exact_thresh) {
		msg <- paste0("A model with n = ", nrow(y), " sites is too large and may run out",
			" of memory. Try sparse = TRUE. If you really want an exact GP, you can ",
			"increase the exact_thresh parameter.")
		stop(msg)
	}

	# load python MBM class and dependencies
	GPy <- reticulate::import("GPy")
	pyWarnings <- reticulate::import("warnings")
	# check for warnings
	if(verbose) {
		pyWarnings$simplefilter('default')
	} else {
		pyWarnings$filterwarnings('ignore')
	}

	model <- make_mbm(y, x, y_name, link, likelihood, lengthscale, sparse, force_increasing,
		sparse_inducing, sparse_batch, sparse_iter)

	# set up mbm object
	initialize <- TRUE ## no support for non-initialized models yet
	if(attr(model, 'inference') == 'svgp') {
		# climin <- reticulate::import("climin")
		# stop(climin[["__version__"]])
		reticulate::source_python(system.file("python/svgp_optim.py", package="mbm"))
		mod <- run_svgp(X=model$covariates, Y=model$response,
				Z = model$inducing_inputs, kernel = model$pyobj$kernel,
				likelihood = model$pyobj$likelihood,  mf = model$pyobj$mf,
				bs = as.integer(attr(model, "batchsize")), init = initialize,
				maxiter = as.integer(attr(model, "svgp_maxiter")), verbose = verbose)
		model$n_iter <- mod[[2]]
		model$pyobj$gp <- mod[[1]]

		if(model$n_iter >= attr(model, "svgp_maxiter"))
			warning("Max nubmer of iterations reached indicating the model parameters may not",
				"have converged; try increasing sparse_batch or sparse_iter")
	} else {
		model$pyobj$gp <- GPy$core$GP(X=model$covariates, Y=model$response,
			kernel = model$pyobj$kernel, likelihood = model$pyobj$likelihood,
			inference_method = model$pyobj$inference, initialize = initialize,
			mean_function = model$pyobj$mf)
		model$pyobj$gp$optimize()
	}

	# set up parameters and parameter names
	model$params <- model$pyobj$gp$param_array
	names(model$params) <- parse_param_names(model)
	model
}

#' Determine parameter names to a fit mbm model
#' @param x A fit mbm model
#' @return A vector of parameter names that can be assigned to names(x$params)
#' @keywords internal
parse_param_names <- function(x) {
	pnames <- NULL
	## order matters
	## first inducing inputs if svgp
	if(attr(x, 'inference') == 'svgp') {
		pnames <- c(pnames, apply(expand.grid(1:ncol(x$inducing_inputs),
			1:nrow(x$inducing_inputs)), 1,
			function(xx) paste0('inducing_input.[', xx[2], ',', xx[1], ']')))
	}
	## 2 is mean function parameters if present
	if(attr(x, "mean_function") == "increasing") {
		pnames <- c(pnames, "prior_intercept", paste0("prior_slope_", colnames(x$covariates)))
	}
	## next is variance and lengthscales
	pnames <- c(pnames, 'rbf_variance', paste0('ls_', colnames(x$covariates)))
	## after lengthscale is white noise variance for svgp
	if(attr(x, 'inference') == 'svgp')
		pnames <- c(pnames, 'White_noise.variance')
	## then gaussiam noise variance
	pnames <- c(pnames, 'gaussian_noise_variance')
	## then cholesky decomposition parameters
	if(attr(x, 'inference') == 'svgp') {
		nz <- nrow(x$inducing_inputs)
		nch <- (nz * (nz+1))/2
		pnames <- c(pnames, paste0("u_cholesky.", 1:nch), paste0("u_mean.", 1:nz))
	}
	pnames
}


library(ggplot2)
library(ggridges)
workspace <- "/mnt/fileserver/Henry-SPIM/smart_rotation/11222018/e5/data/workspace/"
for (angle in 0:31){
  df <- read.csv(file=sprintf(paste(workspace,"distribution%02d.csv",sep=""),angle),header=TRUE,sep=',')
  p = ggplot(df,aes(x=Imaging.angle,y= Angular.slices,height=Number,group=Angular.slices))+geom_ridgeline(alpha=0.1,scale=0.003,fill="white",show.legend=TRUE)+labs(x=expression(paste("Imaging angles /",degree)),y=expression(paste("Angular slices /",degree)))+theme_ridges()
  ggsave(filename=sprintf("/mnt/fileserver/Henry-SPIM/smart_rotation/11222018/e5/data/workspace/figures/rainbow/distribution%02d.pdf",angle),dpi = 500,width = 10,height = 7.5)
}


#name: RCaretNBApply
#meta.mlname: RCaretNB
#meta.mlrole: apply
#description: Custom R Apply func for Naive Bayes using Caret
#language: r
#input: blob model
#input: dataframe df
#input: string namesKeys
#input: string namesValues
#output: dataframe data_out

renv::init()
install.packages("naivebayes")
library(naivebayes)

#>>> If original(namesKeys) and new(namesValues) passed, map original names to new
namesKeys = strsplit(namesKeys, ',')[[1]]
namesValues = strsplit(namesValues, ',')[[1]]
if (length(namesKeys) > 0) {
  featuresNames = names(df)
  for (n in 0:length(namesKeys))
    names(df)[featuresNames == namesValues[n]] = namesKeys[n]
}

#>>> Retrieve saved/trained model
trained_model = readRDS(model)

#>>> Predict using trained model
predY = predict(trained_model, df)
data_out = data.frame(predY)


catalog_predictions <- function(min.tx = 45, K.values, MW, WT, minimum_threshold, similarity = 'both', filename, percent_remove = 0, nb_iter = 1, comm_id = FALSE, community) {

    # -----------------------------------------------------------------------------
    # # PARAMETERS:
    #     filename                name of file under which to same the results of the predictions
    #     min.tx                  minimal number of taxon for empirical food webs to be included in the analysis
    #     K.values                Kc and Kr values to test in the KNN algorithm
    #     MW                      Minimum weight for candidate resources to be included as predictions
    #     WT                      Weights for the two-way Tanimoto algorithm
    #     blind                   Whether the analysis whould be blind, i.e. no a priori information for taxa in catalog
    #     minimum_threshold       Minimum similarity threshold for similar taxa to be considered as candidate resources
    #     similarity              String character either being c('consumer', 'resource', 'both') for the similarity measurements
    #
    # # OUTPUT:
    #     tanimoto_analysis       List of predictions for all parameters tested
    # -----------------------------------------------------------------------------
    load("./RData/Tanimoto_data.RData")
    load("./RData/interactions_source.RData")
    load("./RData/S0_catalog.RData")

    if(similarity == 'both') { # For similarity matrices already evaluated
        suppressMessages(load("./RData/Similarity_consumers.RData"))
        suppressMessages(load("./RData/Similarity_resources.RData"))
    } else if(similarity == 'consumer') {
        suppressMessages(load("./RData/Similarity_consumers.RData"))
    } else if (similarity == 'resource') {
        suppressMessages(load("./RData/Similarity_resources.RData"))
    }

    # setting up the analyses for multiple communities
    # Data for communities on which to test the algorithm
        Cm <- unique(interactions_sources[, 'source'])
        communities <- vector("list", length(Cm))
        names(communities) <- Cm

        # Taxa list per community to predict
            for(i in 1:length(communities)) {
                Ci <- which(interactions_sources[, 'source'] == Cm[i])
                S1 <- unique(c(interactions_sources[Ci, 'consumer'], interactions_sources[Ci, 'resource']))

                if(length(which(!S1 %in% S0_catalog)) > 0) {
                    print('Taxa in C[i] are not all included in taxa list S0')
                    break
                }

                communities[[i]] <- S1
            }

    # Substracting GloBI interactions for this portion
        Cm.lg <- numeric()
        for(i in 1:length(communities)) {
            Cm.lg <- c(Cm.lg,length(communities[[i]]))
        }

        if(comm_id == FALSE) {
            to.delete <- c(which(Cm.lg < min.tx), which(Cm.lg > 1000)) # > 1000 is for GloBI
            Cm <- Cm[-to.delete]
            for(i in rev(to.delete)) {
                communities[[i]] <- NULL
            }
            names(communities) <- Cm
        } else { # comm_id = TRUE
            to.delete <- which(!Cm %in% community)
            Cm <- Cm[-to.delete]
            for(i in rev(to.delete)) {
                communities[[i]] <- NULL
            }
            names(communities) <- Cm
        }

    # Setting up lists to store the results
    # weights
        wt.init <- c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1)
        wt.remove <- which(!wt.init %in% WT)# selecting a subset of similarity matrices
        for(i in rev(wt.remove)) {
            if(similarity == 'both') { # For similarity matrices already evaluated
                similarity.consumers[[i]] <- NULL
                similarity.resources[[i]] <- NULL
            } else if(similarity == 'consumer') {
                similarity.consumers[[i]] <- NULL
            } else if (similarity == 'resource') {
                similarity.resources[[i]] <- NULL
            }
        }

        sim.wt <- WT
        Tanimoto_analysis <- vector("list",length(sim.wt))
        names(Tanimoto_analysis) <- sim.wt
        for(i in 1:length(sim.wt)) {
            Tanimoto_analysis[[i]] <- vector("list", length(Cm))
            names(Tanimoto_analysis[[i]]) <- Cm
        }

        # List to store results of multiple K values
        K <- vector("list", length(K.values))
        for(i in 1:length(K.values)) {
            K[[i]] <- Tanimoto_analysis
        }
        Tanimoto_analysis <- K
        names(Tanimoto_analysis) <- K.values
        remove(K)

        #Minimum weight
        min.wt <- vector("list", length(MW))
        for(i in 1:length(MW)) {
            min.wt[[i]] <- Tanimoto_analysis
        }
        Tanimoto_analysis <- min.wt
        names(Tanimoto_analysis) <- MW
        remove(min.wt)

        #Number of iterations
        iter <- vector('list', nb_iter)
            for(i in 1:nb_iter) {
                iter[[i]] <- Tanimoto_analysis
            }
        Tanimoto_analysis <- iter
        names(Tanimoto_analysis) <- seq(1,nb_iter)
        remove(iter)

        # Percent remove in communities
        pc_rm <- vector('list', length(percent_remove))
            for(i in 1:length(percent_remove)) {
                pc_rm[[i]] <- Tanimoto_analysis
            }
        Tanimoto_analysis <- pc_rm
        names(Tanimoto_analysis) <- percent_remove
        remove(pc_rm)

    # Initial time save for temporary saving in case analysis fails mid process
    file.to.save <- serialNext("./Analyses/Tanimoto_temp/Tanimoto_analysis.RData")
    save(x = Tanimoto_analysis, file = file.to.save)

    iteration <- 1
    init.time <- Sys.time()
    pb <- txtProgressBar(min = 0,max = length(percent_remove) * nb_iter * length(Cm) * length(WT) * length(K.values) * length(MW), style = 3)
    for(p in 1:length(percent_remove)){
        percent_rm <- percent_remove[p]
        for(o in 1:nb_iter){
            for(n in 1:length(MW)) {
                mw <- MW[n]
                for(m in 1:length(K.values)) {

                    # Tanimoto analysis with different weights for different communities
                        # Parameters:
                            Kc <- K.values[m]  # Integer, how many neighbors to select for consumers
                            Kr <-  K.values[m]  # Integer, how many neighbors to select for resources
                            # MW = minimum_weight  # Mimimum weight to accept a candidate as a prey
                        #   wt  Weight of traits in similarity measurement
                        #   S0  A large set of species and their preys, with column structure ['taxon', 'taxonomy', 'resource', 'non-resource']
                        #   S1  The subset of S0 where we want to predict new preys, string vector with taxa name

                        # Output:
                        #   A vector of sets of resources for each taxon
                        for(i in 1:length(WT)){ #1st loop for all types of wt values
                            wt <- WT[i]
                            for(j in 1:length(Cm)) { #2nd loop for all C[i]
                                S1 <- communities[[j]]
                                S0 <- S0_catalog

                                if(similarity == 'both') { # For similarity matrices already evaluated
                                    similarity.consumer <- similarity.consumers[[i]]
                                    similarity.resource <- similarity.resources[[i]]
                                } else if(similarity == 'consumer') {
                                    similarity.consumer <- similarity.consumers[[i]]
                                } else if (similarity == 'resource') {
                                    similarity.resource <- similarity.resources[[i]]
                                }

                                # setting up the iterative process to evaluate the accuracy ~ # taxa in catalog
                                # removing a certain percentage of the # of species for which there are interactions as consumers described in the original food web.

                                # inter_Cm <- unique(subset(interactions_sources[, 'consumer'], interactions_sources[, 'source'] == Cm[j] & interactions_sources[, 'inter'] == "1")) # Species for which there are interactions as consumer in Cm[j]

                                interactions <- interactions_sources[-which(interactions_sources[, 'source'] == Cm[j]), 1:3] # interaction catalog without interactions coming from Cm[j]

                                # inter_Cm2 <- unique(interactions[which(interactions[, 'consumer'] %in% inter_Cm), 'consumer']) # consumers in Cm[j] for which information is still available in catalog after deletion of Cm[j] from catalog

                                #Removing a percentage of consumers described in catalog
                                    # sample_iter <- sample(x = inter_Cm2, size = round((percent_rm / 100) * length(inter_Cm2)), replace = FALSE)
                                    sample_iter <- sample(x = S1, size = round((percent_rm / 100) * length(S1)), replace = FALSE) # To use if removing a percent of all taxa in original web

                                    if(length(sample_iter) == 0) {
                                        S1_no_mod <- seq(1,length(S1))
                                    } else {
                                        for(k in 1:length(sample_iter)) {
                                          S0[sample_iter[k], 'resource'] <- ""
                                          S0[sample_iter[k], 'non-resource'] <- ""
                                          S0[sample_iter[k], 'consumer'] <- ""
                                          S0[sample_iter[k], 'non-consumer'] <- ""
                                        }
                                        S1_no_mod <- which(!S1 %in% sample_iter)
                                    }

                                # 2. Preexisting information kept to inform algorithm
                                    if(length(S1_no_mod) == 0) {
                                        NULL
                                    } else {
                                    # Only modifying those that are loosing data from the catalogue, less time
                                        to.change <- numeric()
                                        for(k in 1:length(S1_no_mod)) {
                                            to.change <- c(to.change, which(interactions[, 'consumer'] == S1[S1_no_mod[k]]), which(interactions[, 'resource'] == S1[S1_no_mod[k]]))
                                        }
                                        to.change <- unique(to.change)

                                    # Modifying sets of resources and non-resources for taxa in S1_no_mod
                                        interactions <- interactions[to.change, ]
                                        rownames(interactions) <- seq(1,nrow(interactions))
                                        resource_set <- consumer_set_of_resource(consumer = interactions[, 'consumer'],
                                                                                resource = interactions[, 'resource'],
                                                                                inter_type = interactions[, 'inter'])

                                        consumer_set <- resource_set_of_consumer(consumer = interactions[, 'consumer'],
                                                                                resource = interactions[, 'resource'],
                                                                                inter_type = interactions[, 'inter'])

                                    # From binary interactions catalogue with consumer, resources, interaction or non-interaction (rownames need to == taxa name)
                                        for(k in 1:nrow(resource_set)) {
                                          S0[resource_set[k, 'consumer'], 3] <- resource_set[k, 'resource']
                                          S0[resource_set[k, 'consumer'], 4] <- resource_set[k, 'non-resource']
                                        }
                                        for(k in 1:nrow(consumer_set)) {
                                          S0[consumer_set[k, 'resource'], 5] <- consumer_set[k, 'consumer']
                                          S0[consumer_set[k, 'resource'], 6] <- consumer_set[k, 'non-consumer']
                                        }
                                    remove(interactions, resource_set, to.change)
                                    }#if

                                # Recalculate similarity
                                    similarity.consumer <- similarity_taxon_predict(S0 = S0,
                                                                                S1 = S1,
                                                                                wt = wt,
                                                                                similarity.matrix = similarity.consumer,
                                                                                taxa = 'consumer')

                                    similarity.resource <- similarity_taxon_predict(S0 = S0,
                                                                                S1 = S1,
                                                                                wt = wt,
                                                                                similarity.matrix = similarity.resource,
                                                                                taxa = 'resource')

                                # Predicting interactions
                                    Tanimoto_analysis[[p]][[o]][[n]][[m]][[i]][[j]] <- two_way_tanimoto_predict(Kc = Kc,
                                                                                Kr = Kr,
                                                                                S0 = S0,
                                                                                S1 = S1,
                                                                                MW = mw,
                                                                                similarity.consumer = similarity.consumer,
                                                                                similarity.resource = similarity.resource,
                                                                                minimum_threshold = minimum_threshold)

                                save(x = Tanimoto_analysis, file = file.to.save)
                                remove(S0, S1, similarity.consumer, similarity.resource)
                                iteration <- iteration + 1
                                setTxtProgressBar(pb, iteration)
                            }#2nd loop for all C[i]

                            save(x = Tanimoto_analysis, file = file.to.save)
                            remove(wt)

                        }#1st loop for all types of wt values
                }#m
            }#n
        }#o
    }#p
    #Saving number of species in original web vs catalog once web removed
    # percent_original <- length(inter_Cm2) / length(inter_Cm)
    # x <- c(percent_original, length(inter_Cm), length(inter_Cm2))
    # file.to.save2 <- serialNext("./Analyses/Tanimoto_temp/Tanimoto_analysis_pc_tx.RData")
    # save(x = x, file = file.to.save2)

    close(pb)
    print(Sys.time() - init.time)

    save(x = Tanimoto_analysis, file = paste('./Analyses/',filename,'.RData',sep=''))

    return(Tanimoto_analysis)
}


steadman_indoor_index <- function(t, rh) {
    .Call('biometeoR_steadman_indoor', PACKAGE = 'biometeoR', t, rh)
}


library(tidyverse)
library(sf)
library(rvest)
library(stringr)
library(scales)
map.world <- ggplot2::map_data('world')
# country = region, e.g. region == "USA"
# state  = subregion e.g. subregion =="Florida"
gxSESmapValues = data.frame(subregion="Florida", gxSES = 1)
gxSESmap <- merge(map.world, gxSESmapValues, by = 'subregion')
ggplot(gxSESmap, aes( x = long, y = lat, group = group )) + geom_polygon(aes(fill = gxSES))

pp = ggplot(gxSESmap, aes( x = long, y = lat, group = group ))
pp = pp + geom_polygon(aes(fill = gxSES, color = as.factor(opec_ind)))
pp = pp + scale_fill_gradientn(colours = c('#461863','#404E88','#2A8A8C','#7FD157','#F9E53F')
	,values = scales::rescale(c(100,96581,822675,3190373,10000000))
	,labels = comma, breaks = c(100,96581,822675,3190373,10000000))
pp = pp + guides(fill = guide_legend(reverse = T))
pp = pp + labs(fill = 'Barrels per day\n2016' ,color = 'OPEC Countries',title = 'OPEC countries produce roughly 44% of world oil' ,x = NULL,y = NULL)
pp = pp + theme(text = element_text(family = 'Gill Sans', color = '#EEEEEE')
        ,plot.title = element_text(size = 28)
        ,plot.subtitle = element_text(size = 14)
        ,axis.ticks = element_blank()
        ,axis.text = element_blank()
        ,panel.grid = element_blank()
        ,panel.background = element_rect(fill = '#333333')
        ,plot.background = element_rect(fill = '#333333')
        ,legend.position = c(.18,.36)
        ,legend.background = element_blank()
        ,legend.key = element_blank()
  )
pp = pp + annotate(geom = 'text' ,label = 'Source: U.S. Energy Information Administration\nhttps://en.wikipedia.org/wiki/List_of_countries_by_oil_production\nhttps://en.wikipedia.org/wiki/OPEC'
           ,x = 18, y = -55
           ,size = 3
           ,family = 'Gill Sans'
           ,color = '#CCCCCC'
           ,hjust = 'left'
  )
pp = pp + scale_color_manual(values = c('1' = 'orange', '0' = NA), labels = c('1' = 'OPEC'), breaks = c('1'))

pp


#!/var/www/html/OmicsARules/R-3.2.3/bin/Rscript

.libPaths("/var/www/html/OmicsARules/R-3.2.3/library");
library(dplyr)

args<-commandArgs(T);
path=args[1];
FDR_value=as.numeric(args[2]);

result=read.table(paste(path,"result.txt", sep="/"), header=TRUE);
#occurence=result[7];
#greater=result[10];

occurence=result[7];
greater=result[8];

pvalue=greater/1000;

colnames(pvalue)=c("pvalue");
n=nrow(pvalue);
result2=cbind(result, pvalue);

FDR=p.adjust(as.numeric(result2[[9]]),"fdr", n);

result3=cbind(result2, FDR);

data=filter(result3, FDR<= FDR_value);
write.table(data, paste(path, "result.txt", sep="/"), sep="\t", quote=FALSE, row.names = FALSE);


#' rbind
#'
#' \code{rbind()} and \code{cbind()} for floats.
#'
#' @param ...
#' vectors or matrices (numeric or float)
#' @param deparse.level
#' ignored
#'
#' @return
#' A matrix of the same type as the highest precision input.
#'
#' @examples
#' library(float)
#' x = fl(matrix(1:10, 5))
#'
#' rbind(x, x)
#' cbind(x, x)
#'
#' @name bind
#' @rdname bind
NULL

bind_float32 = function(binder, ..., deparse.level)
{
  args = list(...)

  if (any(sapply(args, is.double)))
  {
    args = lapply(args, dbl, strict=FALSE)

   do.call(binder, args)
  }
  else
  {
    raw = lapply(args, function(x) DATA(fl(x, strict=FALSE)))
    ret = do.call(binder, raw)
    float32(ret)
  }
}

#' @method rbind float32
#' @rdname bind
#' @export
rbind.float32 <- function(..., deparse.level=1)
{
  bind_float32(base::rbind, ..., deparse.level=deparse.level)
}

#' @method cbind float32
#' @rdname bind
#' @export
cbind.float32 <- function(..., deparse.level=1)
{
  bind_float32(base::cbind, ..., deparse.level=deparse.level)
}


# Make simulations for the null model
# best to run on cod node with nohup if many sample sizes to make
# Arguments (ONLY SOME ARE IMPLEMENTED RIGHT NOW, SEE wfs_make_sims_null_3times.r FOR EXAMPLE)
#	pop: Can or Lof
#	yr1: 07 or 11 (not needed for Can)
#	yr2: 11_14 to run both 07-11 and 07-14 (not needed for Can)
#	trimlowsampsize: 1 to trim loci with less than half of individuals genotypes, 0 to not trim
#	rerunlow: 0 for default, 1 to only run simulations for loci with low p-values (<=4/(n+1)) in wfs_nullmodel_pos&pvals_*.rds

# read arguments
# args=(commandArgs(TRUE))
# if(length(args)==0){
#     print("No arguments supplied.")
#     pop <- 'Lof'
#     yr1 <- '07'
#     yr2 <- '14'
# 	trimlowsampsize <- 1
# 	rerunlow <- 0
# }else{
# 	for(i in 1:length(args)){
# 		eval(parse(text=args[[i]]))
# 	}
# 	if(!(pop %in% c('Lof', 'Can'))) stop('pop must be Lof or Can!')
# 	if(pop=='Lof' & !(yr1 %in% c('07', '11'))) stop('yr1 must be 07 or 11 for Lof!')
# 	if(pop=='Lof' & !(yr2 %in% c('11', '14'))) stop('yr2 must be 11 or 14 for Lof!')
# 	if(!(trimlowsampsize %in% 0:1)) stop('trimlowsampsize must be 0 or 1!')
# 	if(!(rerunlow %in% 0:1)) stop('rerunlow must be 0 or 1!')
# }

# pop<-'Lof'; yr1<-'07';yr2<-'11_14';trimlowsampsize<-0;rerunlow<-0 # initial run for all Lof loci 07-11 and 07-14
#pop<-'Lof'; yr1<-'07';yr2<-'11_14';trimlowsampsize<-0;rerunlow<-1 # re-run low p-values for all Lof loci 07-11 and 07-14
# pop<-'Can'; yr1<-'00';yr2<-'00';trimlowsampsize<-0;rerunlow<-0 # initial run for all CAN loci
 pop<-'Can'; yr1<-'00';yr2<-'00';trimlowsampsize<-0;rerunlow<-1 # re-run low p-values for all CAN loci

print(paste('Arguments: pop=', pop, ', yr1=', yr1, ', yr2=', yr2, ', trimlowsampsize=', trimlowsampsize, ', rerunlow=', rerunlow, sep=''))

# load functions
source('scripts/wfs_byf1samp.r')
if(!grepl('hpc.uio.no', Sys.info()["nodename"])){
	require(data.table)
}
if(grepl('hpc.uio.no', Sys.info()["nodename"])){
	require(data.table, lib.loc="/projects/cees/lib/R_packages/")
}

# read in Ne and frequency data
if(pop=='Lof' & yr1=='07' & yr2=='11'){
	nes <- read.table('analysis/LOF_07_to_LOF_S_11_to_LOF_S_14.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	nchrs <- fread('data_2019_03_18/Frequency_table_Lof07_Lof11.txt', header=TRUE) # read in frequency table data
	gen <- 11
}
if(pop=='Lof' & yr1=='07' & yr2=='14'){
	nes <- read.table('analysis/LOF_07_to_LOF_S_11_to_LOF_S_14.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	nchrs <- fread('data_2019_03_18/Frequency_table_Lof07_Lof14.txt', header=TRUE) # read in frequency table data
	gen <- 11
}
if(pop=='Lof' & yr1=='11' & yr2=='14'){
	nes <- read.table('analysis/LOF_07_to_LOF_S_11_to_LOF_S_14.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	nchrs <- fread('data_2019_03_18/Frequency_table_Lof11_Lof14.txt', header=TRUE) # read in frequency table data
	gen <- 11
}
if(pop=='Lof' & yr1=='07' & yr2=='11_14'){ # both 07-11 and 07-14
	nes <- read.table('analysis/LOF_07_to_LOF_S_11_to_LOF_S_14.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	nchrs11 <- fread('data_2019_03_18/Frequency_table_Lof07_Lof11.txt', header=TRUE) # read in frequency table data
	nchrs14 <- fread('data_2019_03_18/Frequency_table_Lof07_Lof14.txt', header=TRUE) # read in frequency table data
	nchrs11[,yr:=11]
	nchrs14[,yr:=14]
	nchrs <- rbind(nchrs11, nchrs14) # all possible sample size combinations across both pairs of years
	gen <- 11
}
if(pop=='Can'){
	nes <- read.table('analysis/Can_40_to_Can_25kmer_dp.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	freqfile <- paste('data_2019_03_18/Frequency_table_CAN_40_TGA.txt', sep='')
	nchrs <- fread(freqfile, header=TRUE)
	gen <- 8
}

setnames(nchrs, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF'))

# trim out missing loci
	nrow(nchrs)
nchrs <- nchrs[N_CHR_1>0 & N_CHR_2>0,]
	print(nrow(nchrs))

# trim to loci with at least half of individuals genotyped?
if(trimlowsampsize==1){
	print('Trimming to loci with at least half of the individuals genotyped')
	nrow(nchrs)
	nchrs <- nchrs[N_CHR_1>=max(N_CHR_1)/2 & N_CHR_2>=max(N_CHR_2)/2,]
	print(nrow(nchrs))
}

# trim only to loci with low p-values in wfs_nullmodel_pos&pvals_*.rds (from analysis of a previous run)?
if(rerunlow==1){
	print('Trimming to loci with p<=4/(n+1)')
	if(pop=='Lof' & yr2=='11_14'){
		pvals11 <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-11.rds'))
		pvals14 <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-14.rds'))
		pvals11[,yr:=11]
		pvals14[,yr:=14]
		pvals <- rbind(pvals11, pvals14)
		nchrs <- merge(nchrs, pvals[,.(CHROM, POS, n, p, yr)], by=c('CHROM', 'POS', 'yr')) # merge in p-values
	}
	if(pop=='Can'){
		pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_Can.rds')) # NOT SURE YET THIS WORKS FOR CAN
		nchrs <- merge(nchrs, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values
	}
	print(nrow(nchrs))
	nchrs <- nchrs[p<=4/(n+1),]
	print(nrow(nchrs))
	print(paste('retained p=', paste(signif(nchrs[,.(min(p), max(p))], digits=2), collapse=' to '), ', n=', paste(nchrs[,.(min(n), max(n))], collapse=' to '), sep=''))
}

# parameters for the simulation
nsims <- 500000 # number of sims to run for each starting frequency in each sample size
nreps <- 1 # number of repetitions of the number of simulations
if(rerunlow==1) nreps <- 10*nchrs[,max(n)]/nsims # run 10x more sims than already run
print(paste('Running', nreps, 'reps of', nsims, 'simulations for', nreps*nsims, 'total per sample size.'))

c1s <- nchrs[!duplicated(paste(N_CHR_1, N_CHR_2)),N_CHR_1] # the sample sizes to simulate (first sample)
c2s <- nchrs[!duplicated(paste(N_CHR_1, N_CHR_2)),N_CHR_2]
# 	print(c1s)
# 	print(c2s)
	length(c1s)
	length(c2s)

# expand to number of reps (if nreps>1)
print('Expanding sample sizes to number of repetitions')
reps <- rep(1:nreps, times=length(c1s)) # holds repetition counter
c1s <- rep(c1s, each=nreps)
c2s <- rep(c2s, each=nreps)
	print(length(c1s))
	print(length(c2s))
	print(length(reps))

# check that nes >0
print(summary(nes))
print(paste('Of', length(nes), 'Ne values', sum(nes > 0), 'are >0. Trimming all others out.'))
nes <- nes[nes>0]

# check temp directory for previous simulations (if Ne, gen and other parameters are the same)
if(pop=='Lof'){
	torun <- paste(paste(c1s, c2s, sep=','), reps, sep='_') # the list of sample sizes we need to run
	existing <- list.files(path='analysis/temp', pattern='wfs_simsnull_ff.+_[[:digit:]]+\\.ffData') # the existing simulations
	existing <- gsub('wfs_simsnull_ff|.ffData', '', existing) # trim file names to just sample sizes and rep#

	print('Trimming out files already run')
	keep <- !(torun %in% existing) # the sample sizes that still need to be run
	c1s <- c1s[keep]
	c2s <- c2s[keep]
	reps <- reps[keep]
}
if(pop=='Can'){
	torun <- paste(paste(c1s, c2s, sep=','), reps, sep='_') # the list of sample sizes we need to run
	existing <- list.files(path='analysis/temp', pattern='wfs_simsnullCAN_ff.+_[[:digit:]]+\\.ffData') # the existing simulations. works on new and old simulations because I renamed all older sim files to have _1 as of March 5 2019.
	existing <- gsub('wfs_simsnullCAN_ff|.ffData', '', existing) # trim file names to just sample sizes and rep#

	print('Trimming out files already run')
	keep <- !(torun %in% existing) # the sample sizes that still need to be run
	c1s <- c1s[keep]
	c2s <- c2s[keep]
	reps <- reps[keep]
}

print(length(c1s)) # how many to run?
print(length(c2s))
print(length(reps))

# combine into one data.table
torun <- data.table(c1s=c1s, c2s=c2s, reps=reps)

# break into batches of <= 400
nbatch <- ceiling(nrow(torun)/400)
torun[,batch:=0]
for(i in 1:nbatch){
	rows <- ((i-1)*400+1):min(i*400, nrow(torun))
	torun[rows,batch:=i]
}
print(paste(nbatch, 'batches to run'))

# write out the shell script for each batch
for(j in 1:nbatch){
	outfile <- paste('scripts/wfs_make_sims_null_submit_sbatch', j, '.sh', sep='')
	print(paste('Wrote', outfile))

	cat('#!/bin/bash\n', file=outfile, append=FALSE) # header

	for(i in which(torun[,batch==j])){
		cat(paste('sbatch --job-name=nlsm', torun[i,c1s], ',', torun[i,c2s], ' --cpus-per-task=1 scripts/wfs_make_sims_null_sbatch.sh ', pop, ' ', torun[i,c1s], ' ', torun[i, c2s], ' ', yr1, ' ', yr2, ' ', trimlowsampsize, ' ', rerunlow, ' ', torun[i, reps], ' ', nsims, '\n', sep=''), file=outfile, append=TRUE)
	}
}


if (sce=='HCR_1_deter_adjust_single' || sce=='HCR_1_deter20_adjust_single' ||
    sce=='HCR_1_deter_single' || sce=='HCR_1_deter20_single') {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test

  ss<-0.01
  rr<-matrix(c(
    0.0, 0.50, ss,     #  COD
    0.00, 0.15, ss,      # WHG
    0.30, 0.60, ss,     #  HAD
    0.15, 0.60, ss,     # POK omkring 0.37 with hockey and 0.40 with Ricker
    0.10, 0.45, ss,     #  HER
    0.10, 0.60, ss,     # North SAN
    0.15, 0.50, ss,     # South SAN
    0.30, 0.60, ss,     #  NOP
    0.35, 0.70, ss,     # SPR
    0.2,  0.4,  ss,  #  PLE
    0.2,  0.3,  ss )  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]

  rr<-matrix(c(
    0.10, 0.50, ss,     #  COD
    0.00, 0.60, ss,      # WHG
    0.30, 0.90, ss,     #  HAD
    0.15, 0.60, ss,     # POK
    0.20, 0.70, ss,     #  HER
    0.10, 1.0, ss,     # North SAN
    0.10, 0.80, ss,     # South SAN
    0.4, 1.5, ss,     #  NOP
    0.4, 1.5, ss,     # SPR
    0.2,  0.4,  ss,  #  PLE
    0.2,  0.3,  ss )  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_1_deter_had_adjust_wide' | sce=='HCR_1_deter_adjust_wide') {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  if (grepl('_had_',sce)) recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.05
  rr<-matrix(c(
    0.25, 0.50, ss,     #  COD
    0.05, 0.15, ss,      # WHG
    0.30, 0.60, ss,     #  HAD
    0.35, 0.35, ss,     # POK omkring 0.37 with hockey and 0.40 with Ricker
    0.20, 0.40, ss,     #  HER
    0.30, 0.60, ss,     # North SAN
    0.25, 0.50, ss,     # South SAN
    0.30, 0.60, ss,     #  NOP
    0.35, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_2_deter_noadjust_wide' | sce=='HCR_2_deter_adjust_wide' | sce=='HCR_2_deter_had_adjust_wide' |
    sce=='HCR_2_deter_whg_noadjust_wide' ) {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  if (sce=='HCR_2_deter_had_adjust_wide') recruit.adjust.factor[3]<-0.75
  if (sce=='HCR_2_deter_whg_noadjust_wide') recruit.adjust.factor[2]<-1.2

  ss<-0.1
  #s<-0.05
  rr<-matrix(c(
    0.30, 0.60, ss,     #  COD
    0.0,  0.1, ss,      # WHG
    0.30, 0.60, ss,     #  HAD
    0.30, 0.40, ss,     # POK
    0.20, 0.40, ss,     #  HER
    0.20, 0.60, ss,     # North SAN
    0.20, 0.60, ss,     # South SAN
    0.20, 0.60, ss,     #  NOP
    0.20, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_2_deter_had_adjust_narrow' ) {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.05
  rr<-matrix(c(
    0.30, 0.60, ss,     #  COD
    0.0,  0.05, ss,      # WHG
    0.30, 0.60, ss,     #  HAD
    0.35, 0.40, ss,     # POK
    0.25, 0.40, ss,     #  HER
    0.40, 0.60, ss,     # North SAN
    0.30, 0.50, ss,     # South SAN
    0.30, 0.60, ss,     #  NOP
    0.40, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_2_deter_had_adjust_Athen' | sce=='HCR_2_deter_had_adjust_Athen_op1' |
    sce=='HCR_2_deter_had_adjust_Athen_op2' | sce=='HCR_2_deter_had_adjust_Athen_op1') {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.05
  rr<-matrix(c(
    0.30, 0.60, ss,     #  COD
    0.05, 0.15, ss,     # WHG
    0.30, 0.60, ss,     #  HAD
    0.40, 0.40, ss,     # POK
    0.25, 0.40, ss,     #  HER
    0.40, 0.60, ss,     # North SAN
    0.30, 0.50, ss,     # South SAN
    0.30, 0.60, ss,     #  NOP
    0.40, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_2_deter_had_adjust_Athen_op4') {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.02
  rr<-matrix(c(
    0.28, 0.32, ss,     #  COD
    0.06, 0.10, ss,     # WHG
    0.52, 0.60, ss,     #  HAD
    0.40, 0.40, ss,     # POK
    0.32, 0.40, ss,     #  HER
    0.50, 0.58, ss,     # North SAN
    0.34, 0.46, ss,     # South SAN
    0.46, 0.54, ss,     #  NOP
    0.62, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_1_deter_had_adjust_narrow' ) {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.02
  rr<-matrix(c(
    0.28, 0.32, ss,     #  COD
    0.06, 0.10, ss,     # WHG
    0.50, 0.60, ss,     #  HAD
    0.40, 0.40, ss,     # POK
    0.30, 0.40, ss,     #  HER
    0.46, 0.56, ss,     # North SAN
    0.30, 0.44, ss,     # South SAN
    0.40, 0.50, ss,     #  NOP
    0.60, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_1_deter_adjust_narrow' ) {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  #recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.02
  rr<-matrix(c(
    0.28, 0.32, ss,     #  COD
    0.04, 0.10, ss,     # WHG
    0.38, 0.44, ss,     #  HAD
    0.34, 0.38, ss,     # POK
    0.32, 0.40, ss,     #  HER
    0.36, 0.44, ss,     # North SAN
    0.46, 0.54, ss,     # South SAN
    0.46, 0.52, ss,     #  NOP
    0.32, 0.40, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}

if (sce=='HCR_2_deter_had_adjust_Athen2') {
  cat("Scenario: ",sce,'\n')
  #my.OP.output<-15  # detailed output for test
  recruit.adjust.factor[3]<-0.75 # haddock adjust

  ss<-0.025
  rr<-matrix(c(
    0.30, 0.35, ss,     #  COD
    0.10, 0.15, ss,      # WHG
    0.525, 0.60, ss,     #  HAD
    0.40, 0.40, ss,     # POK
    0.325, 0.40, ss,     #  HER
    0.475, 0.55, ss,     # North SAN
    0.30, 0.475, ss,     # South SAN
    0.475, 0.55, ss,     #  NOP
    0.625, 0.70, ss,     # SPR
    PLE.seq, PLE.seq, 0,  #  PLE
    SOL.seq, SOL.seq, 0)  #  SOL
    ,ncol=3,byrow=T)
  dimnames(rr)[[1]]<-sp.names[first.VPA:nsp]
}


# Copyright (c) 2013-2014 Matthias Noack (ma.noack.pr@gmail.com)
#
# Distributed under the Boost Software License, Version 1.0. (See accompanying
# file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt)

# Usage
usage <- "Rscript <this_file.r> <data_file> <output.pdf> (<column_name=average>)"
DEFAULT_COLUMN = "average";

FONT_FAMILY <- "Helvetica" # "Times" # for cairo pdf
HEIGHT_DATA = 0.25 # plot height per bar
X_LIM_STEP <- 10 # x-axis length, 5 more than max rounded to next 5
ROUND_DIGITS <- 2
TITLE <- "Hexciton Runtime per Iteration [ms]"
COL_BAR <- "grey"
DATA_SCALE <- 1 / 1000000 # input data is in ns, output data is in ms

# command line argument handling
args <- commandArgs(trailingOnly = TRUE)

if (length(args) < 2) {
	print("Not enough command line arguments. Usage:")
	print(usage)
	quit()
}

file <- args[1]
output_file <- args[2]

if (length(args) < 3) {
	column <- DEFAULT_COLUMN
} else {
	column <- args[3]
}

if (!file.exists(file)) {
	print("Error: input file not found.")
	quit()
}

# read data
data <- read.table(file, header=TRUE, sep="\t")

# check if column exists
if (!(column %in% colnames(data))) {
	print("Error: Column name not found in input file.")
	quit()
}

# projection to two columns: name and the one to plot
data_plot <- data[, c("name", column)]

# preprocess data
num_data <- nrow(data_plot)
bar_sizes <- round(data_plot[dim(data_plot)[1]:1,2] * DATA_SCALE, ROUND_DIGITS)
X_LIM_STEP <- max(bar_sizes) * 0.25;
x_max <- round(max(bar_sizes) / X_LIM_STEP) * X_LIM_STEP + X_LIM_STEP

# setup pdf output
cairo_pdf(output_file, width=20, height=20, family=FONT_FAMILY) # size = large enough
par(pin=c(3.1, 1.5))
par(pin=c(4, HEIGHT_DATA * num_data))

# create a horizontal bar plot
bplt <- barplot(bar_sizes, col=COL_BAR, horiz=TRUE, names.arg=data_plot[dim(data_plot)[1]:1,1], xlim=c(0, x_max), las=1)
title(TITLE, line=-0.25)

# add value labels, rounded to two digits
text(x=x_max, y=bplt, labels=paste(sprintf("%.2f", bar_sizes), "ms"), xpd=TRUE, adj=c(1,0.5))

# write to file
useless_output <- dev.off()

# crop into same file using the pdfcrop command
system(paste("pdfcrop " , output_file, " ", output_file))


library(ggplot2)
library(readr)

library(stringi)

library(syuzhet)
library(randomForest)

train <- read_csv("train.csv",n_max=100)
test <- read_csv("test.csv",n_max=100)

first <- stri_extract_first_words(train$question1)
second <- stri_extract_first_words(train$question2)
lastOne <- stri_extract_last_words(train$question1)
lastTwo <- stri_extract_last_words(train$question2)

train$first = ifelse(first == second, 1, 0)
train$second = ifelse(lastOne == lastTwo, 1, 0)

sentiment1 <- get_nrc_sentiment(train$question1)
sentiment2 <- get_nrc_sentiment(train$question2)

train = cbind(train, sentiment1, sentiment2)

tr = train[,6:28]

tr = na.omit(tr)

tr[,c(1:23)] = lapply(tr[,c(1:23)],as.factor)

rfModel <- randomForest(is_duplicate~.,data=tr)

pred <- predict(rfModel, newdata = tr,  type="prob")

#Round the results
pred = apply(pred, c(1,2), function(x) min(max(x, 1E-15), 1-1E-15))

logLoss = function(pred, actual){-1*mean(log(pred[model.matrix(~ actual + 0) - pred > 0]))}


full_algorithm <- function(Kc, Kr, S0, S1, MW, wt, minimum_threshold) {
    # Two-way Tanimoto Algorithm
    # ===========================

    # Parameters:
    #   Kc  Integer, how many neighbors to select for consumers
    #   Kr  Integer, how many neighbors to select for resources
    #   S0  A large set of species and their preys, with column structure ['taxon', 'taxonomy', 'resource', 'non-resource']
    #   S1  The subset of S0 where we want to predict new preys, string vector with taxa name
    #   MW  Mimimum weight to accept a candidate as a prey

    # Output
    #   A vector of sets (the preys for each species)

    predictions <- matrix(nrow = length(S1), ncol = 3, data = "", dimnames = list(c(S1), c('consumer','resource_empirical','resource_predictions'))) # empty object for resource predictions
    predictions[, 'consumer'] <- S1

    pb <- txtProgressBar(min = 0,max = length(S1), style = 3)
    for(i in 1:length(S1)) { # loop through each taxon in S1
        candidates <- matrix(nrow = 0, ncol = 2, dimnames = list(c(), c('resource', 'weight')), data = NA) # empty matrix for resource candidate list for S1[i], with taxon name and weight
        resources.S1 <- unlist(strsplit(S0[S1[i], 'resource'], " \\|\\ ")) # resources of S1[i]

        # Add resources that are already listed as resources for S1[i] in predictions[, 'resource_empirical'] or
        # Find similar resources to resources for S1[i] in S1
        if(length(resources.S1) > 0) {
            empirical <- character()
            for(j in 1:length(resources.S1)) { #loop through empirical resources for S1
                if(resources.S1[j] %in% S1) {
                    empirical <- c(empirical, resources.S1[j]) # observed resource found in S1 are automatically added to the column resource_empirical
                } else { # selecting Kr most similar resources in S1
                    # Let's assume for this part that we are not compiling a different similarity measure for predators and preys.

                    similarity.resources <- similarity_full_algorithm(S0 = unique(S0[which(S0[, 'taxon'] %in% S1 | S0[, 'taxon'] == resources.S1[j]), ]), # S1 in S0 + resource for which similarity has to be measured
                                                                    S1 = resources.S1[j], # resource for which similarity has to be measured
                                                                    wt = wt,
                                                                    taxa = 'resource')

                    similar.resource <- matrix(nrow = nrow(similarity.resources), ncol = 2, dimnames = list(c(), c('resource','similarity')), data = NA) # importing K nearest neighbors resources
                    similar.resource[, 'resource'] <- names(similarity.resources[order(similarity.resources, decreasing = TRUE), ])
                    similar.resource[, 'similarity'] <- similarity.resources[order(similarity.resources, decreasing = TRUE)]
                    to.remove <- which(similar.resource[,'resource'] == resources.S1[j])
                    if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
                        similar.resource <- similar.resource[-which(similar.resource[,'resource'] == resources.S1[j]), ]
                    }

                    # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
                    if(similar.resource[Kr+1, 'similarity'] == similar.resource[Kr, 'similarity']) {
                        same.similarity <- which(similar.resource[, 'similarity'] == similar.resource[Kr, 'similarity'])
                        similar.resource[same.similarity, ] <- similar.resource[sample(same.similarity), ]
                        similar.resource <- similar.resource[1:Kr, ]
                    } else {
                        similar.resource <- similar.resource[1:Kr, ]
                    }# if for random draw

                    for(l in 1:Kr) { # extracting resource candidates
                        if(all.equal(similar.resource[, 'similarity'], rep('0',Kr)) == TRUE) { # if similarities all == 0, break
                            break
                        } else if(similar.resource[l, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                            NULL
                            # minimum threshold try.. adding it as a Parameters.. might not make sense, have to discuss it. If we keep it, previous else ifs can be removed
                        } else if(similar.resource[l, 'similarity'] < minimum_threshold) {
                            NULL
                        } else if((similar.resource[l, 'resource'] %in% candidates[, 'resource']) == TRUE) { # if candidate is already in candidate list, add resource' with wt to its weight
                          candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight']) + as.numeric(similar.resource[l, 'similarity'])
                        } else {
                              candidates <- rbind(candidates, similar.resource[l, ]) # if candidate is not in the list, add it resource' with wt to its weight
                        }#if3
                    }#l
                }#if
            }#j
            predictions[S1[i], 'resource_empirical'] <- paste(empirical, collapse = ' | ')
        }#if1

        # Identify similar consumers to S1[i]

        similarity.consumers <- similarity_full_algorithm(S0 = S0,
                                                        S1 = S1[i],
                                                        wt = wt,
                                                        taxa = 'consumer')

        similar.consumer <- matrix(nrow = nrow(similarity.consumers), ncol = 2, dimnames = list(c(), c('consumer','similarity')), data = NA) # importing K nearest neighbors consumers
        similar.consumer[, 'consumer'] <- names(similarity.consumers[order(similarity.consumers, decreasing = TRUE), ])
        similar.consumer[, 'similarity'] <- similarity.consumers[order(similarity.consumers, decreasing = TRUE)]
        to.remove <- which(similar.consumer[,'consumer'] == S1[i])
        if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
            similar.consumer <- similar.consumer[-which(similar.consumer[,'consumer'] == S1[i]), ]
        }

        # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
        if(similar.consumer[Kc+1, 'similarity'] == similar.consumer[Kc, 'similarity']) {
            same.similarity <- which(similar.consumer[, 'similarity'] == similar.consumer[Kc, 'similarity'])
            similar.consumer[same.similarity, ] <- similar.consumer[sample(same.similarity), ]
            similar.consumer <- similar.consumer[1:Kc, ]
        } else {
            similar.consumer <- similar.consumer[1:Kc, ]
        }# if for random draw

        # Est-ce que la valeur de similarité a de l'importance pour l'attribution des proies?
        # If yes, we could add an argument call wt_predator.
          # if(wt_predator == FALSE) {
          #   resources <- unique of all prey species of all similar predators
          # } else {}

        for(j in 1:Kc) { #loop through consumers

            if(all.equal(similar.consumer[, 'similarity'], rep('0',Kc)) == TRUE) { # if similarities all == 0, break
                break
            } else if(similar.consumer[j, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                NULL
            } else if(similar.consumer[j, 'similarity'] < minimum_threshold) {
                NULL
            } else {

                # It's possible that consumers in the list have high taxonomic similarity, but no recorded resource
                candidate.resource <- unlist(strsplit(S0[similar.consumer[j, 'consumer'], 'resource'], " \\|\\ ")) # list of resources for consumer j
                # candidate.resource <- candidate.resource[(candidate.resource %in% resources.S1) == FALSE] # substracting candidate resources that are already listed as resources for S1[i] and hence considered in the preceding code segment

                for(k in 1:length(candidate.resource)) { # loop through resources of consumer j
                    if(length(candidate.resource) == 0) { # if candidate resource list is empty, break
                        break
                    } else if(candidate.resource[1] == "") { # if candidate list is an empty vector "", break
                        break
                    } else if(candidate.resource[k] == S1[i]) {
                    #   #// FIXME: if candidate resource is taxon for which predictions are being made, break (unless we want to allow CANIBALISM). Add argument for cannibalism allowed or not
                         NULL
                    } else if((candidate.resource[k] %in% S1) == TRUE) {
                        if((candidate.resource[k] %in% candidates[, 'resource']) == TRUE) {# if candidate is already in candidate list, add 1 to its weight
                            candidates[which(candidates[, 'resource'] == candidate.resource[k]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == candidate.resource[k]), 'weight']) + 1
                        } else {
                            candidates <- rbind(candidates, c(candidate.resource[k], 1)) # if candidate is not in the list, add it with 1 to its weight
                        }#if2

                    } else {
                        similarity.resources <- similarity_full_algorithm(S0 = unique(S0[which(S0[, 'taxon'] %in% S1 | S0[, 'taxon'] == candidate.resource[k]), ]), # S1 in S0 + resource for which similarity has to be measured
                                                                        S1 = candidate.resource[k], # resource for which similarity has to be measured
                                                                        wt = wt,
                                                                        taxa = 'resource')

                        similar.resource <- matrix(nrow = nrow(similarity.resources), ncol = 2, dimnames = list(c(), c('resource','similarity')), data = NA) # importing K nearest neighbors resources
                        similar.resource[, 'resource'] <- names(similarity.resources[order(similarity.resources, decreasing = TRUE), ])
                        similar.resource[, 'similarity'] <- similarity.resources[order(similarity.resources, decreasing = TRUE)]
                        to.remove <- which(similar.resource[,'resource'] == candidate.resource[k])
                        if(length(to.remove) > 0){ #remove resoures.S1[j] in case it gets through (just keeping it consistant with other similarity evaluation further down in the catalogue, even though it is not necessary in this portion)
                            similar.resource <- similar.resource[-which(similar.resource[,'resource'] == candidate.resource[k]), ]
                        }

                        # If multiple taxa with same similarity, randomly select those that will be used as similar resources.
                        if(similar.resource[Kr+1, 'similarity'] == similar.resource[Kr, 'similarity']) {
                            same.similarity <- which(similar.resource[, 'similarity'] == similar.resource[Kr, 'similarity'])
                            similar.resource[same.similarity, ] <- similar.resource[sample(same.similarity), ]
                            similar.resource <- similar.resource[1:Kr, ]
                        } else {
                            similar.resource <- similar.resource[1:Kr, ]
                        }# if for random draw

                        for(l in 1:Kr) { # extracting resource candidates
                            if(all.equal(similar.resource[, 'similarity'], rep('0',Kr)) == TRUE) { # if similarities all == 0, break
                                break
                            } else if(similar.resource[l, 'similarity'] == '0') { # if similarity l == 0, no candidates provided
                                NULL
                                # minimum threshold try.. adding it as a Parameters.. might not make sense, have to discuss it. If we keep it, previous else ifs can be removed
                            } else if(similar.resource[l, 'similarity'] < minimum_threshold) {
                                NULL
                            } else if((similar.resource[l, 'resource'] %in% candidates[, 'resource']) == TRUE) { # if candidate is already in candidate list, add 1 to its weight
                              candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight'] <- as.numeric(candidates[which(candidates[, 'resource'] == similar.resource[l]), 'weight']) + as.numeric(similar.resource[l, 'similarity'])
                            } else {
                                  candidates <- rbind(candidates, similar.resource[l, ]) # if candidate is not in the list, add it with its weight = similarity
                            }#if3
                        }#l
                    } #if1
                }#k
            }#if
        }#j

        candidates <- candidates[which(candidates[, 'weight'] >= MW), ] # remove candidates with a weight below MW
        if(is.matrix(candidates) == TRUE) { #if it's a vector, there's only one predicted resource, no need to order
            candidates[order(candidates[, 'weight']), ] # sorts candidates according to their weight
            predictions[S1[i], 'resource_predictions'] <- paste(candidates[, 'resource'], collapse = ' | ')
        } else {
          predictions[S1[i], 'resource_predictions'] <- paste(candidates['resource'], collapse = ' | ')
        }#if
    setTxtProgressBar(pb, i)
    }#i
    close(pb)
    return(predictions)
}#full algorithm function


go_term_bar <- function(gsea_results, n_terms = 10, metric = "pval", fill = T, change_labels = T, pval_fill = T) {
  # metric must be either "NES" or "pval"
  # set fill = T to fill with gradient colours, set fill = F to fill with grey only
  # set change_labels = T to change pathway names to lowercase and remove "GO:" from the pathway names, set change_labels = F to keep them as original
  # set pval_fill = T to color the bars based on p value

  require(tidyverse)
  require(pals)

  if (change_labels == T) {
    gsea_results$pathway <- gsea_results$pathway %>%
      gsub(pattern = "GO_", replacement = "", x = ., ignore.case = F) %>%
      gsub(pattern = "_", replacement = " ", x = .) %>%
      gsub(pattern = "plus", replacement = "+", x = .) %>%
      tolower()
  }

  if (fill == T) {
    cols_pval <- viridis(n_terms)
    cols_NES <- magma(n_terms)
  } else if (fill == F) {
    cols_pval <- "grey"
    cols_NES <- "grey"
  }

  if (metric == "pval") {

    data.bar <- gsea_results %>%
      filter(NES > 0) %>%
      arrange(-log10pval) %>%
      slice(., 1:n_terms, .preserve = TRUE)

     bar <- ggplot(data.bar, aes(x = log10pval, y = reorder(pathway, log10pval))) +
       geom_bar(stat = "identity", fill = cols_pval) +
       theme_minimal() +
       labs(x = "-log10 p-value",
            y = "GO term") +
       theme(axis.title.x = element_text(size = 13, color = "black"),
             axis.title.y = element_blank(),
             axis.text.y = element_text(size = 13, color = "black"),
             axis.text.x = element_text(size = 12, color = "black"))

    if (pval_fill) {

      # updated to fix issue with ordering of Y axis
      data.bar$pathway <- factor(data.bar$pathway, levels = rev(data.bar$pathway))
      bar <- ggplot(data.bar, aes(x = log10pval, y = pathway, fill = log10pval)) +
        geom_bar(stat = "identity") +
        scale_fill_gradientn(colours = ocean.matter(n = 1000) %>% rev()) +
        theme_minimal() +
        labs(x = "-log10 p-value",
             y = "GO term") +
        theme(axis.title.x = element_text(size = 13, color = "black"),
              axis.title.y = element_blank(),
              axis.text.y = element_text(size = 13, color = "black"),
              axis.text.x = element_text(size = 12, color = "black"))
      return(bar)

    } else {

      data.bar$pathway <- factor(data.bar$pathway, levels = rev(data.bar$pathway))
      bar <- ggplot(data.bar, aes(x = log10pval, y = pathway)) +
        geom_bar(stat = "identity", fill = cols_pval) +
        theme_minimal() +
        labs(x = "-log10 p-value",
             y = "GO term") +
        theme(axis.title.x = element_text(size = 13, color = "black"),
              axis.title.y = element_blank(),
              axis.text.y = element_text(size = 13, color = "black"),
              axis.text.x = element_text(size = 12, color = "black"))
      return(bar)

    }

  } else if (metric == "NES") {

    data.bar <- gsea_results %>%
      arrange(-NES) %>%
      slice(., 1:n_terms, .preserve = TRUE)

     bar <- ggplot(data.bar, aes(x = NES, y = reorder(pathway, NES))) +
       geom_bar(stat = "identity", fill = cols_NES) +
       theme_minimal() +
       labs(x = "normalized enrichment score",
            y = "GO term") +
       theme(axis.title.x = element_text(size = 13, color = "black"),
             axis.title.y = element_blank(),
             axis.text.y = element_text(size = 13, color = "black"),
             axis.text.x = element_text(size = 12, color = "black"))

    if (pval_fill) {

      data.bar$pathway <- factor(data.bar$pathway, levels = rev(data.bar$pathway))
      bar <- ggplot(data.bar, aes(x = NES, y = pathway, fill = pval)) +
        geom_bar(stat = "identity") +
        scale_fill_gradientn(colours = ocean.matter(n = 1000)) +
        theme_minimal() +
        labs(x = "normalized enrichment score",
             y = "GO term") +
        theme(axis.title.x = element_text(size = 13, color = "black"),
              axis.title.y = element_blank(),
              axis.text.y = element_text(size = 13, color = "black"),
              axis.text.x = element_text(size = 12, color = "black"))
      return(bar)

    } else {

      data.bar$pathway <- factor(data.bar$pathway, levels = rev(data.bar$pathway))
      bar <- ggplot(data.bar, aes(x = NES, y = pathway)) +
        geom_bar(stat = "identity", fill = cols_NES) +
        theme_minimal() +
        labs(x = "normalized enrichment score",
             y = "GO term") +
        theme(axis.title.x = element_text(size = 13, color = "black"),
              axis.title.y = element_blank(),
              axis.text.y = element_text(size = 13, color = "black"),
              axis.text.x = element_text(size = 12, color = "black"))
      return(bar)
    }

  } else {
    stop("metric must be NES or pval")
  }
}

Zebrafish fin vs body bulk RNA-seq analysis /go_term_bar.r


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(patchwork))

source("viz_themes.R")
source("plotting_functions.R")
source("data_functions.R")

output_figure_base <- file.path("figures", "figure2")
extensions <- c(".png", ".pdf")

results_dir <- file.path("../1.Data-exploration/Consensus/")

pm_cellpainting_list <- load_percent_matching(assay = "cellpainting", results_dir = results_dir)
pm_l1000_list <- load_percent_matching(assay = "l1000", results_dir = results_dir)

print(dim(pm_cellpainting_list[["percent_matching"]]))
print(dim(pm_l1000_list[["percent_matching"]]))

print(dim(pm_cellpainting_list[["percent_matching_pvals"]]))
print(dim(pm_l1000_list[["percent_matching_pvals"]]))

p_val_alpha_thresh <- 0.05
plot_thresh <- -log10(p_val_alpha_thresh)

no_replicates_thresh <- 3

cell_painting_pm_df <- pm_cellpainting_list[["percent_matching"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)
l1000_pm_df <- pm_l1000_list[["percent_matching"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)

pm_df <- dplyr::bind_rows(cell_painting_pm_df, l1000_pm_df)

cell_painting_pm_pval_df <- pm_cellpainting_list[["percent_matching_pvals"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)
l1000_pm_pval_df <- pm_l1000_list[["percent_matching_pvals"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)

pm_pval_df <- dplyr::bind_rows(cell_painting_pm_pval_df, l1000_pm_pval_df)

pm_df <- pm_df %>%
    dplyr::left_join(pm_pval_df, by = c("moa", "dose", "assay", "no_of_replicates")) %>%
    dplyr::mutate(pass_thresh = p_value < p_val_alpha_thresh) %>%
    dplyr::mutate(neg_log_10_p_val = -log10(p_value))

pm_df$dose <- factor(pm_df$dose, levels = dose_order)

pm_df$neg_log_10_p_val[pm_df$neg_log_10_p_val == Inf] = 3.5

# Output percent matching (MOA)
output_file <- file.path("results", "moa_scores.tsv")
readr::write_tsv(pm_df, output_file)

print(dim(pm_df))
head(pm_df)

percent_matching_df <- pm_df %>%
    dplyr::group_by(assay, dose) %>%
    dplyr::mutate(percent_matching = paste0(100 * round((sum(pass_thresh) / length(pass_thresh)), 2), "%")) %>%
    dplyr::select(dose, assay, percent_matching) %>%
    dplyr::distinct()

percent_matching_df

# How many compounds per assay per dose with greater than 3 compounds?
for (dose in unique(pm_df$dose)) {
    pm_sub_df <- pm_df %>% dplyr::filter(dose == !!dose)
    print(table(pm_sub_df %>% dplyr::pull(assay)))
}

panel_a_gg <- (
    ggplot(pm_df, aes(x = matching_score, y = neg_log_10_p_val))
    + geom_point(aes(color = no_of_replicates), alpha = 0.6)
    + geom_text(data = percent_matching_df, aes(label = percent_matching, x = 0.5, y = 2))
    + facet_grid("assay~dose")
    + geom_hline(linetype = "dashed", color = "blue", yintercept = plot_thresh)
    + theme_bw()
    + figure_theme
    + scale_color_continuous("Number of\ncompounds\nper MOA", values = scales::rescale(c(0, 2, 4, 6, 8, 15, 30)), type = "viridis")
    + xlab("Median pairwise Pearson correlation between\ncompound profiles of the same mechanism of action (MOA)")
    + ylab("Non-parametric -log10 p value")
)

panel_a_gg

results_dir <- file.path("../1.Data-exploration/Consensus/")

pm_cellpainting_list <- load_percent_matching(assay = "cellpainting", results_dir = results_dir)
pm_l1000_list <- load_percent_matching(assay = "l1000", results_dir = results_dir)

cell_painting_pm_df <- pm_cellpainting_list[["percent_matching"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)
l1000_pm_df <- pm_l1000_list[["percent_matching"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)

pm_df <- dplyr::bind_rows(cell_painting_pm_df, l1000_pm_df)

cell_painting_pm_pval_df <- pm_cellpainting_list[["percent_matching_pvals"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)
l1000_pm_pval_df <- pm_l1000_list[["percent_matching_pvals"]] %>%
    dplyr::filter(no_of_replicates >= no_replicates_thresh)

pm_pval_df <- dplyr::bind_rows(cell_painting_pm_pval_df, l1000_pm_pval_df)

pm_df <- pm_df %>%
    dplyr::left_join(pm_pval_df, by = c("moa", "dose", "assay", "no_of_replicates")) %>%
    dplyr::mutate(pass_thresh = p_value < p_val_alpha_thresh) %>%
    dplyr::mutate(neg_log_10_p_val = -log10(p_value))

pm_df$dose <- factor(pm_df$dose, levels = dose_order)

pm_df$neg_log_10_p_val[pm_df$neg_log_10_p_val == Inf] = 3.5

print(dim(pm_df))
head(pm_df)

# Prep additional data for plotting
replicate_counts_df <- pm_df %>%
    tidyr::drop_na() %>%
    dplyr::group_by(moa, dose) %>%
    dplyr::mutate(avg_replicate_count = mean(no_of_replicates)) %>%
    dplyr::select(moa, dose, avg_replicate_count) %>%
    dplyr::ungroup() %>%
    dplyr::distinct()

cp_pass_thresh <- pm_df %>%
    dplyr::filter(assay == "Cell Painting", pass_thresh) %>%
    dplyr::select(moa, dose, pass_thresh) %>%
    dplyr::rename(pass_thresh_cellpainting = pass_thresh)

l1000_pass_thresh <- pm_df %>%
    dplyr::filter(assay == "L1000", pass_thresh) %>%
    dplyr::select(moa, dose, pass_thresh) %>%
    dplyr::rename(pass_thresh_l1000 = pass_thresh)

pass_thresh_both <- cp_pass_thresh %>%
    dplyr::full_join(l1000_pass_thresh, by = c("moa", "dose")) %>%
    tidyr::replace_na(list(pass_thresh_cellpainting = FALSE, pass_thresh_l1000 = FALSE)) %>%
    dplyr::mutate(pass_both = pass_thresh_cellpainting + pass_thresh_l1000) %>%
    dplyr::mutate(pass_both = ifelse(pass_both == 2, TRUE, FALSE)) %>%
    dplyr::mutate(moa_color_passing = 0)

pass_thresh_both$moa_color_passing[pass_thresh_both$pass_both] <- "#DF74F0"
pass_thresh_both$moa_color_passing[(pass_thresh_both$pass_thresh_cellpainting & !pass_thresh_both$pass_both)] <- paste(assay_colors["Cell Painting"])
pass_thresh_both$moa_color_passing[(pass_thresh_both$pass_thresh_l1000 & !pass_thresh_both$pass_both)] <- assay_colors["L1000"]

head(pass_thresh_both)

plot_ready_pm_df <- pm_df %>%
    reshape2::dcast(moa + dose ~ assay, value.var = "matching_score") %>%
    tidyr::drop_na() %>%
    dplyr::left_join(replicate_counts_df, by = c("moa", "dose")) %>%
    dplyr::left_join(pass_thresh_both, by = c("moa", "dose")) %>%
    tidyr::replace_na(
        list(
            pass_thresh_cellpainting = FALSE,
            pass_thresh_l1000 = FALSE,
            pass_both = FALSE,
            moa_color_passing = "lightgrey"
        )
    )

# Output file for further use
output_pm_file <- file.path("data", "significant_moas_by_threshold_both_assays.tsv.gz")
plot_ready_pm_df %>% readr::write_tsv(output_pm_file)

head(plot_ready_pm_df)

passing_colors <- unique(plot_ready_pm_df$moa_color_passing)
names(passing_colors) <- unique(plot_ready_pm_df$moa_color_passing)

passing_labels <- c("None", "L1000 Only", "CP Only", "Both")
names(passing_labels) <- unique(plot_ready_pm_df$moa_color_passing)

panel_b_gg <- (
    ggplot(plot_ready_pm_df, aes(x = `Cell Painting`, y = L1000))
    + geom_point(aes(size = avg_replicate_count, color = moa_color_passing), alpha = 0.5)
    + facet_grid("~dose")
    + figure_theme
    + scale_color_manual(
        "Pass null\nthreshold",
        values = passing_colors,
        labels = passing_labels
    )
    + scale_size_binned("Number of\ncompounds", range = c(0.5, 5))
    + geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "black")
    + xlim(c(-0.65, 1))
    + ylim(c(-0.3, 1))
    + xlab("Cell Painting\nMedian MOA correlation")
    + ylab("L1000\nMedian MOA correlation")
    + theme(legend.key.size = unit(0.3, 'cm'))
)

panel_b_gg

summary_df <- pm_df %>%
    dplyr::select(moa, dose, assay, p_value) %>%
    reshape2::dcast(moa + dose ~ assay, value.var = "p_value") %>%
    dplyr::rename(
        "Cell_Painting_p_value" = `Cell Painting`,
        "L1000_p_value" = `L1000`
    ) %>%
    dplyr::left_join(
        pm_df %>%
        dplyr::select(moa, dose, assay, matching_score) %>%
        reshape2::dcast(moa + dose ~ assay, value.var = "matching_score") %>%
        dplyr::rename(
            "Cell_Painting_matching_score" = `Cell Painting`,
            "L1000_matching_score" = `L1000`
        ),
        by = c("moa", "dose")
    ) %>%
    dplyr::mutate(
        pass_cellpainting_thresh = Cell_Painting_p_value < p_val_alpha_thresh,
        pass_l1000_thresh = L1000_p_value < p_val_alpha_thresh
    ) %>%
    dplyr::mutate(pass_both = pass_cellpainting_thresh + pass_l1000_thresh) %>%
    dplyr::mutate(pass_both = ifelse(pass_both == 2, TRUE, FALSE))

head(summary_df, 3)

pass_thresh_summary_moa_df <- summary_df %>%
    dplyr::group_by(dose) %>%
    dplyr::mutate(
        num_pass_cellpainting = sum(pass_cellpainting_thresh),
        num_pass_l1000 = sum(pass_l1000_thresh),
        num_pass_both = sum(pass_both)
    ) %>%
    dplyr::ungroup() %>%
    dplyr::select(dose, num_pass_cellpainting, num_pass_l1000, num_pass_both) %>%
    dplyr::distinct() %>%
    dplyr::mutate(
        unique_pass_cellpainting = num_pass_cellpainting - num_pass_both,
        unique_pass_l1000 = num_pass_l1000 - num_pass_both
    )

cell_painting_moa_rect <- pass_thresh_summary_moa_df %>%
    dplyr::select(dose, num_pass_cellpainting, unique_pass_cellpainting, num_pass_both) %>%
    dplyr::rename(c(ymax_bar = num_pass_cellpainting, unique_pass = unique_pass_cellpainting)) %>%
    dplyr::mutate(
        ymin_bar = 0,
        xmin_bar = seq(0, (length(unique(pass_thresh_summary_moa_df$dose)) - 1) * 2, 2),
        xmax_bar = seq(1, (length(unique(pass_thresh_summary_moa_df$dose))) * 2, 2),
        assay = "Cell Painting",
        label_text_y = 2,
        updated_ymin_bar = ymin_bar,
        updated_ymax_bar = ymax_bar - num_pass_both
    )

l1000_moa_rect <- pass_thresh_summary_moa_df %>%
    dplyr::mutate(ymax_bar = num_pass_cellpainting + unique_pass_l1000) %>%
    dplyr::select(dose, ymax_bar, unique_pass_cellpainting, unique_pass_l1000, num_pass_both) %>%
    dplyr::rename(c(ymin_bar = unique_pass_cellpainting, unique_pass = unique_pass_l1000)) %>%
    dplyr::mutate(
        xmin_bar = seq(0, (length(unique(pass_thresh_summary_moa_df$dose)) - 1) * 2, 2),
        xmax_bar = seq(1, (length(unique(pass_thresh_summary_moa_df$dose))) * 2, 2),
        assay = "L1000",
        label_text_y = ymax_bar - 1.5,
        updated_ymin_bar = ymin_bar + num_pass_both,
        updated_ymax_bar = ymax_bar
    )

both_moa_rect <- cell_painting_moa_rect %>%
    dplyr::select(dose, xmin_bar, xmax_bar, updated_ymin_bar, updated_ymax_bar) %>%
    dplyr::left_join(
        l1000_moa_rect %>%
        dplyr::select(dose, xmin_bar, xmax_bar, updated_ymin_bar, updated_ymax_bar),
        by = c("dose", "xmin_bar", "xmax_bar"),
        suffix = c("_cp", "_l1000")
    ) %>%
    dplyr::mutate(
        updated_ymin_bar = updated_ymax_bar_cp,
        updated_ymax_bar = updated_ymin_bar_l1000,
        assay = "Both"
    ) %>%
    dplyr::select(dose, xmin_bar, xmax_bar, assay, updated_ymin_bar, updated_ymax_bar)

full_moa_rect <- dplyr::bind_rows(cell_painting_moa_rect, l1000_moa_rect, both_moa_rect)

num_pass_both_moa_text <- full_moa_rect %>%
    dplyr::filter(assay == "Cell Painting") %>%
    dplyr::select(dose, xmin_bar, ymax_bar, num_pass_both) %>%
    dplyr::left_join(
        full_moa_rect %>%
            dplyr::filter(assay == "L1000") %>%
            dplyr::select(dose, ymin_bar) %>%
            dplyr::rename(c(ymin_l1000_bar = ymin_bar)),
        by = "dose"
    ) %>%
    dplyr::mutate(label_text_y = ymin_l1000_bar + num_pass_both / 2)

total_moas <- length(unique(summary_df$moa))
total_moas

percentile_pass_moa_df <- pass_thresh_summary_moa_df %>%
    dplyr::mutate(
        num_pass_total = unique_pass_l1000 + unique_pass_cellpainting + num_pass_both,
        num_pass_percentile = paste("Total:\n", round(num_pass_total / total_moas, 2) * 100, "%")
    ) %>%
    dplyr::select(dose, num_pass_total, num_pass_percentile)

percentile_pass_moa_df

# Prep legend order
full_moa_rect <- full_moa_rect %>%
    dplyr::left_join(percentile_pass_moa_df, by = "dose")

full_moa_rect$assay <- factor(full_moa_rect$assay, levels = c("L1000", "Both", "Cell Painting"))

updated_assay_colors <- c(assay_colors, "Both" = "#DF74F0")

panel_c_gg <- (
    ggplot(full_moa_rect)
    + geom_rect(
        aes(
            fill = assay,
            ymin = updated_ymin_bar,
            ymax = updated_ymax_bar,
            xmin = xmin_bar,
            xmax = xmax_bar
        ),
        alpha = 0.5
    )
    + geom_text(
        aes(
            x = xmin_bar + 0.5,
            y = label_text_y,
            label = unique_pass
        )
    )
    + geom_text(
        data = num_pass_both_moa_text,
        aes(
            x = xmin_bar + 0.5,
            y = label_text_y,
            label = num_pass_both
        )
    )
    # Select only L1000 below to not duplicate text
    + geom_text(
        data = full_moa_rect %>% dplyr::filter(assay == "L1000"),
        aes(
            x = xmin_bar + 0.5,
            y = ymax_bar + 2,
            label = num_pass_percentile
        ),
        size = 3
    )
    + scale_fill_manual("MOA\nconsistent\nin assay", values = updated_assay_colors)
    + theme_bw()
    + figure_theme
    + scale_x_continuous(
        labels = num_pass_both_moa_text$dose,
        breaks = seq(0.5, length(num_pass_both_moa_text$dose) * 2, 2),
    )
    + ylab("Number of MOAs over 95% threshold\nof scores from matched null MOA median scores")
    + xlab("")
    + ylim(0, max(full_moa_rect$num_pass_total, na.rm = TRUE) + 5)
)

panel_c_gg

moa_count_filter <- 2

moa_match_df <- pm_df %>% dplyr::filter(pass_thresh)

consistent_match_moa_df <- moa_match_df %>%
    dplyr::group_by(assay, moa) %>%
    dplyr::tally() %>%
    dplyr::filter(n >= !!moa_count_filter) %>%
    reshape2::dcast(moa ~ assay, value.var = "n") %>%
    tidyr::replace_na(
        list(
            `Cell Painting` = 0,
            L1000 = 0
        )
    ) %>%
    dplyr::mutate(x_axis_location = "Cell Painting")

consistent_match_moa_df$x_axis_location[consistent_match_moa_df$L1000 > 0] = "L1000"
consistent_match_moa_df$x_axis_location[(consistent_match_moa_df$L1000 > 0 & consistent_match_moa_df$`Cell Painting` > 0)] = "Both"

# Define the order to plot the text
cell_painting_order <- consistent_match_moa_df %>%
    dplyr::filter(x_axis_location == "Cell Painting") %>%
    dplyr::arrange(`Cell Painting`, moa) %>%
    dplyr::mutate(y_axis_location = seq(1, n() * 3, 3)) %>%
    dplyr::select(moa, y_axis_location)

l1000_order <- consistent_match_moa_df %>%
    dplyr::filter(x_axis_location == "L1000") %>%
    dplyr::arrange(L1000, moa) %>%
    dplyr::mutate(y_axis_location = seq(1, n() * 3, 3)) %>%
    dplyr::select(moa, y_axis_location)

both_order <- consistent_match_moa_df %>%
    dplyr::mutate(both_count = (`Cell Painting` + L1000) / 2) %>%
    dplyr::filter(x_axis_location == "Both") %>%
    dplyr::arrange(both_count, moa) %>%
    dplyr::mutate(y_axis_location = seq(1, n() * 3, 3)) %>%
    dplyr::select(moa, y_axis_location)

full_moa_plot_order <- dplyr::bind_rows(cell_painting_order, l1000_order, both_order)

plot_ready_moa_text_df <- consistent_match_moa_df %>% dplyr::left_join(full_moa_plot_order, by = "moa") %>%
    dplyr::mutate(replicate_count = `Cell Painting` + L1000)

plot_ready_moa_text_df$x_axis_location <- factor(plot_ready_moa_text_df$x_axis_location, levels = c("Cell Painting", "Both", "L1000"))

plot_ready_moa_text_df <- plot_ready_moa_text_df %>%
    dplyr::mutate(moa_with_replicate_count = paste0(moa, " (", replicate_count, ")"))

print(length(unique(plot_ready_moa_text_df$moa)))
head(plot_ready_moa_text_df)

moa_labels <- c("None", "L1000", "Cell Painting", "Both")

moa_colors <- unique(plot_ready_pm_df$moa_color_passing)
names(moa_colors) <- moa_labels
names(moa_labels) <- moa_labels

panel_d_gg <- (
    ggplot(plot_ready_moa_text_df, aes(y = y_axis_location, x = 0))
    + geom_text(
        aes(
            label = moa_with_replicate_count,
        ),
        color = "black",
        size = 3.9
    )
    + geom_text(
        aes(
            label = moa_with_replicate_count,
        ),
        color = "black",
        size = 3.9
    )
    + geom_text(
        aes(
            label = moa_with_replicate_count,
            color = x_axis_location
        ),
        size = 3.9
    )
    + facet_wrap("~x_axis_location", strip.position = "bottom")
    + theme_void()
    + theme(strip.text = element_text(size = 14.5))
    + scale_color_manual(
        "Pass null\nthreshold",
        values = moa_colors
    )
    + xlim(-110, 120)
    + ylim(0, 60)
    + guides(color = guide_legend(order = 1))
)

panel_d_gg

left_panel <- (panel_a_gg / panel_b_gg) + plot_layout(heights = c(2, 1))
top_panel <- (left_panel | panel_c_gg) + plot_layout(widths = c(2, 1))

figure_2_gg <- (
    top_panel / panel_d_gg
    + plot_layout(heights = c(2, 1.75))
    + plot_annotation(tag_levels = "a")
)

for (extension in extensions) {
    output_file <- paste0(output_figure_base, extension)
    ggplot2::ggsave(output_file, figure_2_gg, width = 16, height = 11, dpi = 500)
}

figure_2_gg


require(lattice)
##nodes <- read.csv(file="nodes.txt", header=FALSE)
##edges <- read.csv(file="edges.txt", header=FALSE)
##ellipses <- read.csv(file="ellipses.txt", header=FALSE)
## ##new_ellipses <- read.csv(file="ellipses105.txt", header=FALSE)
## old_ellipses <- read.csv(file="cellPos.txt", header=FALSE)
## eigenshape <- read.csv(file="eigen.txt", header=FALSE)
partition_table <- as.matrix(read.csv(file="partition_table.txt", header=FALSE))
distance_table <- as.matrix(read.csv(file="distance_table.txt", header=FALSE))

plot(0, 0, type='n', xlim=c(-25, 25), ylim=c(-25, 25), asp=1)
## ## #plot(0, 0, type='n', xlim=c(-14, -8), ylim=c(-1, 5), asp=1)
points(nodes[, 2:3])
segments(edges[, 4], edges[, 5], edges[, 6], edges[, 7])
## ## points(new_ellipses[, 2:3], col='green', pch=15)
points(ellipses[, 2:3], col='red', pch=15)

## ## ellipses <- read.csv(file="ellipses100.txt", header=FALSE)
## ## cat(dim(ellipses), '\n')
## ## plot(ellipses[,2], ellipses[,3], xlim=c(-30, 30), ylim=c(-20, 20), asp=1)
## ## ellipses <- read.csv(file="ellipses118.txt", header=FALSE)
## ## cat(dim(ellipses), '\n')
## ## points(ellipses[,2], ellipses[,3], col='red', pch=3)
## ## abline(h = c(-10, 10))
## ## abline(v = c(-15, 15))

## plot(ellipses[,2], ellipses[,3], type='p', xlim=c(-30, 30), ylim=c(-20, 20), asp=1)
## ##plot(ellipses[,2], ellipses[,3], type='p', xlim=c(-15, -5), ylim=c(5, 15), asp=1)
## points(old_ellipses[,1], old_ellipses[,2], col='red', pch=3)
## segments(edges[, 4], edges[, 5], edges[, 6], edges[, 7])
## #points(nodes[, 2:3])
## force <- read.csv(file="force189.txt", header=FALSE)
## sumforce <- read.csv(file="sum_force120.txt", header=FALSE)
## subset <- force[,1]==103
## subset2 <- sumforce[,1]==103
## eigensubset <- eigenshape[,1]==1
## eigensubset <- eigenshape[,1]>0
## arrows(force[subset,2], force[subset,3], force[subset,4], force[subset,5],
##        length=0.1, col='blue')
## arrows(sumforce[subset2,2], sumforce[subset2,3], sumforce[subset2,4], sumforce[subset2,5], length=0.1, col='red')
## arrows(eigenshape[eigensubset,2],
##        eigenshape[eigensubset,3],
##        eigenshape[eigensubset,6],
##        eigenshape[eigensubset,7], length=0.1, col='green')
## arrows(eigenshape[eigensubset,2],
##        eigenshape[eigensubset,3],
##        eigenshape[eigensubset,8],
##        eigenshape[eigensubset,9], length=0.1, col='green')
## abline(h = c(-10, 10))
## abline(v = c(-15, 15))


library(leaflet)
library(RColorBrewer)
library(scales)
library(lattice)
library(dplyr)
library(ggplot2)
library(data.table)
library(DT)
library(maptools)

function(input, output, session) {

    # Leaflet bindings are a bit slow; for now we'll just sample to compensate
    set.seed(100)

    output$datevarui <- renderUI({
        dateInput("datevar", label="Select Date", value = max(covid_county_processed$date), min = min(covid_county_processed$date), max = max(covid_county_processed$date),
        format = "yyyy-mm-dd", startview = "month", weekstart = 0,
        language = "en", width = NULL)
    })

    covidCountyDate <- reactive({
        covid.frame <- as.data.frame(covid_county_processed)
        result <- covid.frame[covid.frame$date==input$datevar,]
        #result <- result[complete.cases(result),]
        result
    })

    covidMerge <- reactive({
        req(input$displayvar)
        data.frame(index=covidCountyDate()$index, Selected=as.vector(as.numeric(covidCountyDate()[,input$displayvar] )))
    })

    spatialObject <- reactive({
        covid_merge <- covidMerge()
        spatial_merge <- sp::merge(USA_counties, covid_merge, by="index", duplicateGeoms=TRUE, all.x=TRUE)
        #spatial_merge <- left_join(USA_counties, covid_merge, by = 'index')
        spatial_merge
    })

    myPal <- reactive({
        #req(input$datevar, input$displayvar)

        covid_date <- covidMerge()

        colorNumeric(palette = colorRamp(c('yellow', 'red')), domain = as.vector(as.numeric(covid_date$Selected)))
    })

  ## Interactive Map ###########################################

  chosenLat <- reactive({
      req(input$zipvar)
      na.omit(zips[zips$zip_code %in% input$zipvar, "latitude"])[1]
  })

  chosenLong <- reactive({
      req(input$zipvar)

      na.omit(zips[zips$zip_code %in% input$zipvar, "longitude"])[1]
  })

  # Create the map
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles(
        urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
        attribution = 'Maps by Mapbox'
      ) %>%
      setView(-74.00, 40.71, zoom = 6)
  })

  #output$chosenmap <- renderPlot({
      #leafletProxy("map", data = covidCountyDate()) %>%
      #clearShapes() %>%
        #addPolygons(data = USA, stroke = FALSE, smoothFactor = 0.2, fillOpacity = 0.3, fillColor = ~myPal()(covidCountyDate()[,input$displayvar]), popup = paste("Region: ", USA$NAME_2, "
", input$displayvar, ": ", round(covidCountyDate()[,input$displayvar], 2), "
")) %>%
        #addLegend(position = "bottomleft", pal = myPal(), values = covidCountyDate()[,input$displayvar], title = input$displayvar, opacity = 1)
  #})

  # This observer is responsible for maintaining the circles and legend,
   # according to the variables the user has chosen to map to color and size.
   observe({
       req(input$displayvar, input$datevar)
       #covid_date <- covidCountyDate()
       #covid_date <- covid_date[order(covid_date$state, covid_date$county),]
       mypal <- myPal()

       leafletProxy("map") %>%
       clearControls()

       USA <- spatialObject()
       color_range <- range(na.omit(as.numeric(USA$Selected)))
     #tryCatch(
     leafletProxy("map", data = USA) %>%
     addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 0.3, fillColor = ~mypal(USA$Selected), opacity=USA$Selected/my.max(USA$Selected), popup = paste("Region: ", USA$NAME_2, "
", input$displayvar, ": ", round(USA$Selected, 2), "
")) %>%
           addLegend(position = "bottomleft", pal = mypal, values = na.omit(USA$Selected), title = input$displayvar, opacity = 1)#, error=function(e) NULL)
   })

  # A reactive expression that returns the set of zips that are
  # in bounds right now
  dataInBounds <- reactive({
    if (is.null(input$map_bounds))
      return(covid_county_merge_spatial[FALSE,])
    bounds <- input$map_bounds
    latRng <- range(bounds$north, bounds$south)
    lngRng <- range(bounds$east, bounds$west)

    subset(covid_county_merge_spatial,
      covid_county_merge_spatial$latitude >= latRng[1] & covid_county_merge_spatial$latitude <= latRng[2] &
        covid_county_merge_spatial$longitude >= lngRng[1] & covid_county_merge_spatial$longitude <= lngRng[2])
  })

  dataInBoundsSimple <- reactive({
      req(input$map_bounds)
    data <- dataInBounds()[,!names(dataInBounds()) %in% c("zip_code", "latitude", "longitude")]
    data[!duplicated(data),]
  })

  dataInBoundsPlot <- reactive({
      req(input$map_bounds)
    data <- dataInBoundsSimple()[,c("date", "cases", "deaths", "new_cases", "new_deaths", "cases_norm", "deaths_norm", "cases_pop", "deaths_pop", "new_cases_pop", "new_deaths_pop", "new_cases_7d_avg", "new_deaths_7d_avg")]
    data_modified <- data.table::setDT(data)[, lapply(.SD, mean), by=.(date), .SDcols=c("cases", "deaths", "new_cases", "new_deaths", "cases_norm", "deaths_norm", "cases_pop", "deaths_pop", "new_cases_pop", "new_deaths_pop", "new_cases_7d_avg", "new_deaths_7d_avg")]
    as.data.frame(data_modified)
  })

  # Precalculate the breaks we'll need for the two histograms

  output$cases_timeseries <- renderPlot({
      req(input$map_bounds)
    # If no zipcodes are in view, don't plot
    if (nrow(dataInBounds()) == 0)
      return(NULL)

    temp.frame <- data.frame(Date=dataInBoundsPlot()$date, Cases=dataInBoundsPlot()$new_cases_pop)
    tem.frame <- temp.frame[complete.cases(temp.frame),]
    #temp.frame <- na.omit(temp.frame)

    scatter <- ggplot(aes(Date, Cases), data=temp.frame) +
    stat_smooth() +
    geom_point(colour="blue", alpha=0.4) +
    #geom_line(aes(Date, TTR::DEMA(Cases, 7)), data=temp.frame) +
    #geom_line()
    theme_light(base_size=15) +
    scale_x_date("", date_breaks = "1 month", date_labels="%b") +
    scale_y_continuous("New Cases per 100,000", labels=scales::comma)

    scatter
  })

    output$deaths_timeseries <- renderPlot({
        req(input$map_bounds)
      # If no zipcodes are in view, don't plot
      if (nrow(dataInBoundsPlot()) == 0)
        return(NULL)

      temp.frame <- data.frame(Date=dataInBoundsPlot()$date, Deaths=dataInBoundsPlot()$new_deaths_pop)
      tem.frame <- temp.frame[complete.cases(temp.frame),]
      #temp.frame <- na.omit(temp.frame)

      scatter <- ggplot(aes(Date, Deaths), data=temp.frame) +
      stat_smooth() +
      geom_point(colour="blue", alpha=0.4) +
      #geom_line(aes(Date, TTR::DEMA(Deaths, 7)), data=temp.frame) +
      #geom_line()
      theme_light(base_size=15) +
      scale_x_date("", date_breaks = "1 month", date_labels="%b") +
      scale_y_continuous("New Deaths per 100,000", labels=scales::comma)

      scatter
    })

  observe({
      leafletProxy('map') %>%
        flyTo(lng = chosenLong(), lat=chosenLat(), zoom=9)

  })

  output$covidtable <- DT::renderDataTable({

      df <- dataInBoundsSimple()[dataInBoundsSimple()$data %in% input$datevar,]
      DT::datatable(df)

  })

  output$downloadcovidtable <- downloadHandler(
  filename = function() { paste0("covidregional", '.csv') },
  content = function(file
  ) {
      write.csv(dataInBoundsSimple(), file)
  }
  )

}


subroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror)

# Find the triangle of the extant triangulation in which
# lies the point currently being added.
# Called by initad.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt(3)
dimension itmp(1)
integer tau(3)
logical adjace, anticl

nerror = -1

# The first point must be added to the triangulation before
# calling trifnd.
if(j==1) {
	nerror = 11
	return
}

# Get the previous triangle:
j1     = j-1
tau(1) = j1
tau(3) = nadj(j1,1)
call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror)
if(nerror > 0) return
call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror)
if(nerror>0) {
    return
}
if(!adjace) {
        tau(3) = tau(2)
	call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# Move to the adjacent triangle in the direction of the new
# point, until the new point lies in this triangle.
ktri = 0
1       continue

# Check that the vertices of the triangle listed in tau are
# in anticlockwise order.  (If they aren't then reverse the order;
# if they are *still*  not in anticlockwise order, theh alles
# upgefucken ist; throw an error.)
call acchk(tau(1),tau(2),tau(3),anticl,x,y,ntot,eps)
if(!anticl) {
    call acchk(tau(3),tau(2),tau(1),anticl,x,y,ntot,eps)
    if(!anticl) {
        itmp(1) = j
        call intpr("Point number =",-1,itmp,1)
        call intpr("Previous triangle:",-1,tau,3)
        call rexit("Both vertex orderings are clockwise. See help for deldir.")
    } else {
        ivtmp  = tau(3)
        tau(3) = tau(1)
        tau(1) = ivtmp
    }
}

ntau  = 0 # This number will identify the triangle to be moved to.
nedge = 0 # If the point lies on an edge, this number will identify that edge.
do i = 1,3 {
        ip = i+1
        if(ip==4) ip = 1 # Take addition modulo 3.

# Get the coordinates of the vertices of the current side,
# and of the point j which is being added:
	xt(1) = x(tau(i))
	yt(1) = y(tau(i))
	xt(2) = x(tau(ip))
	yt(2) = y(tau(ip))
	xt(3) = x(j)
	yt(3) = y(j)

# Create indicator telling which of tau(i), tau(ip), and j
# are ideal points.  (The point being added, j, is ***never*** ideal.)
	if(tau(i)<=0) i1 = 1
	else i1 = 0
	if(tau(ip)<=0) j1 = 1
	else j1 = 0
	k1 = 0
	ijk = i1*4+j1*2+k1

# Calculate the ``normalized'' cross product; if this is positive
# then the point being added is to the left (as we move along the
# edge in an anti-clockwise direction).  If the test value is positive
# for all three edges, then the point is inside the triangle.  Note
# that if the test value is very close to zero, we might get negative
# values for it on both sides of an edge, and hence go into an
# infinite loop.
	call cross(xt,yt,ijk,cprd)
	if(cprd >= eps) continue
	else if(cprd > -eps) nedge = ip
	else {
		ntau = ip
		break
	}
}

# We've played ring-around-the-triangle; now figure out the
# next move:

# case 0: All tests >= 0.; the point is inside; return.
if(ntau==0) return

# The point is not inside; work out the vertices of the triangle to which
# to move.  Notation: Number the vertices of the current triangle from 1 to 3,
# anti-clockwise. Then "triangle i+1" is adjacent to the side from vertex i to
# vertex i+1, where i+1 is taken modulo 3 (i.e. "3+1 = 1").

# case 1: Move to "triangle 1"
if(ntau==1) {
	#tau(1) = tau(1)
	tau(2)  = tau(3)
	call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# case 2: Move to "triangle 2"
if(ntau==2) {
	#tau(1) = tau(1)
	tau(3)  = tau(2)
	call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# case 3: Move to "triangle 3"
if(ntau==3) {
	tau(1)  = tau(3)
	#tau(2) = tau(2)
	call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror)
	if(nerror > 0) return
}

# We've moved to a new triangle; check if the point being added lies
# inside this one.
ktri = ktri + 1
if(ktri > ntri) {
    itmp(1) = j
    call intpr("Point being added:",-1,itmp,1)
    call rexit("Cannot find an enclosing triangle.  See help for deldir.")
}
go to 1

end