#' Y-structure collider
#'
#' X and Y are continuous, they influence continuous S which predicts binary inclusion variable Z
#'
#' @param n Population sample size
#' @param prop Proportion of population in sample
#' @param or_sz Odds ratio for the effect of collider variable S on being included
#' @param b_xy Causal effect of X on Y
#' @param rsq_xs Variance explained by X on collider variable S
#' @param rsq_ys Variance explained by Y on collider variable S
#' @param vx Variance of X. Default = `1`.
#' @param vy Variance of Y. Default = `1`.
#' @param vs Variance of S. Default = `1`.
#' @param sig.level Alpha threshold for power calculation. Default = `5e-8`
#'
#' @export
#' @importFrom stats pnorm power.anova.test
#' @return List of simulation results
simulate_y_structure <- function(n, prop, or_sz, b_xy, rsq_xs, rsq_ys, vx=1, vy=1, vs=1, sig.level=5e-8)
{
  # infer
  logor_sz <- log(or_sz)
  vz <- prop * (1-prop)
  b_xs <- sqrt(abs(rsq_xs) * vs / (vx)) * sign(rsq_xs)
  b_ys <- sqrt(abs(rsq_ys) * vs / vy) * sign(rsq_ys)
  ve <- vs - b_xs^2 * vx - b_ys^2 * vy
  alpha <- log((1 - prop)/prop)
  bh_xy <- (b_xy * vz * vx - b_xs * logor_sz * vz * b_ys * logor_sz * vz * vx * vy) / ((b_ys * logor_sz * vz)^2 * vx * vy + vx*vz)
  cor_xy <- sqrt(bh_xy^2 * vx / vy) * sign(bh_xy)
  if(is.na(n))
  {
    return(list(bh_xy=bh_xy, cor_xy=cor_xy, pow=NA, se=NA, pval=NA, ns=NA))
  }
  ns <- n * prop
  if(ns == 0)
  {
    pow <- 0
  } else {
    pow <- power.anova.test(groups=2, n=ns, between.var=cor_xy^2, within.var = 1 - cor_xy^2, sig.level= sig.level)$power
  }
  se <- sqrt((1 - cor_xy^2) * vs / (ns * vx))
  pval <- pnorm(abs(bh_xy / se), lower.tail=FALSE)
  return(list(bh_xy=bh_xy, cor_xy=cor_xy, pow=pow, se=se, pval=pval, ns=ns))
}

#' Plot Y structure bias across range of parameters
#'
#' Takes a range of OR_sz values, and ranges of rsq_ys and rsq_xs values. Then, for a given proportion of the population being sampled, provides the expected X-Y association for each of the parameter combinations. Enumerates over all combinations so can be slow
#'
#' @param prop Proportion of population included in sample
#' @param b_xy_thresh Target b_xy association - e.g. what value of b_xy are you suspicious could be due to ascertainment on a collider
#' @param or_sz_range Range of OR_sz values to enumerate over. Default = `c(1,100)`
#' @param b_xy Suspected true X-Y effect. Default = `0`
#' @param rsq_xs_range Range of rsq_xs values to enumerate over. Default = `c(0,1)`
#' @param rsq_ys_range  Range of rsq_ys values to enumerate over. Default = `c(0,1)`
#' @param gran Granularity of ranges. Default = `30`
#'
#' @export
#' @return ggplot of simulations
plot_simulate_y_structure <- function(prop, b_xy_thresh, or_sz_range=c(1,100), b_xy=0, rsq_xs_range=c(0,1), rsq_ys_range=c(0,1), gran=30)
{
  message("Calculating surface")
  param <- expand.grid(
      or_sz = exp(seq(log(or_sz_range[1]), log(or_sz_range[2]), length.out=gran)),
      rsq_xs=seq(rsq_xs_range[1], rsq_xs_range[2], length.out=gran),
      rsq_ys=seq(rsq_ys_range[1], rsq_ys_range[2], length.out=gran),
      bh_xy=NA
    ) %>% dplyr::filter(rsq_xs + rsq_ys <=1)
  for(i in 1:nrow(param))
  {
    o <- simulate_y_structure(NA, prop, param$or_sz[i], b_xy, param$rsq_xs[i], param$rsq_ys[i])
    param$bh_xy[i] <- o$bh_xy
  }
    param <- dplyr::mutate(param, thresh = abs(bh_xy) >= abs(b_xy_thresh) & sign(bh_xy) == sign(b_xy_thresh))
    param2 <- param %>% dplyr::filter(thresh) %>%
      dplyr::group_by(rsq_xs, rsq_ys) %>%
      dplyr::summarise(or_sz = min(or_sz))

  message("Plotting")
  g <- ggplot2::ggplot(param, ggplot2::aes(x=rsq_xs, y=rsq_ys)) +
    ggplot2::geom_point(colour="grey", size=0.2) +
    ggplot2::geom_point(data=param2, ggplot2::aes(colour=or_sz), size=2) +
    ggplot2::scale_colour_distiller(palette = "Spectral") +
    ggplot2::labs(x="Variance in S explained by X", y="Variance in S explained by Y", colour="OR (S->Z)")
  g
}

#' Plot the minimum Y-structure required to explain some association
#'
#' For a given Y-structure, can an association of b_xy can be obtained through ascertainment on a collider? Use optimisation to determine the minimum OR_sz for a range of rsq_xs and rsq_ys values
#'
#' @param prop Proportion of population included in sample
#' @param b_xy_thresh Target b_xy association - e.g. what value of b_xy are you suspicious could be due to ascertainment on a collider
#' @param b_xy Suspected true X-Y effect. Default = `0`
#' @param rsq_xs_range Range of rsq_xs values to enumerate over. Default = `c(0,1)`
#' @param rsq_ys_range  Range of rsq_ys values to enumerate over. Default = `c(0,1)`
#' @param gran Granularity of ranges. Default = `101`
#' @param max_or_sz Maximum OR_sz to allow in optimisation.
#'
#' @export
#' @importFrom stats optimize
#' @return ggplot of simulations
plot_simulate_y_structure_optim <- function(prop, b_xy_thresh, b_xy=0, rsq_xs_range=c(0,1), rsq_ys_range=c(0,1), gran=101, max_or_sz=20)
{
  message("Calculating surface")
  param <- expand.grid(
      rsq_xs=seq(rsq_xs_range[1], rsq_xs_range[2], length.out=gran),
      rsq_ys=seq(rsq_ys_range[1], rsq_ys_range[2], length.out=gran),
      bh_xy=NA,
      or_sz=NA
    ) %>% dplyr::filter(rsq_xs + rsq_ys <=1)
  param$id <- 1:nrow(param)
  fn <- function(x, prop, b_xy, rsq_xs, rsq_ys, b_xy_thresh) {
    o <- simulate_y_structure(NA, prop, x, b_xy, rsq_xs, rsq_ys)
    return((o$bh_xy - b_xy_thresh)^2)
  }
  for(i in 1:nrow(param))
  {
    o <- optimize(fn, c(1,max_or_sz+1), prop=prop, b_xy=b_xy, rsq_xs=param$rsq_xs[i], rsq_ys=param$rsq_ys[i], b_xy_thresh=b_xy_thresh)
    param$bh_xy[i] <- b_xy_thresh
    param$or_sz[i] <- o$minimum
  }
  param$thresh <- param$or_sz <= max_or_sz

  message("Plotting")
  g <- ggplot2::ggplot(param %>% subset(., !thresh), ggplot2::aes(x=rsq_xs, y=rsq_ys)) +
    ggplot2::geom_point(colour="grey", size=0.2) +
    ggplot2::geom_point(data=param %>% subset(., thresh), ggplot2::aes(colour=or_sz), size=2) +
    ggplot2::scale_colour_distiller(palette = "Spectral") +
    ggplot2::labs(x="Variance in S explained by X", y="Variance in S explained by Y", colour="OR of S\non inclusion")
  g
}


model_cropheatflux <- function (netRadiationEquivalentEvaporation = 638.142,
         soilHeatFlux = 188.817,
         potentialTranspiration = 1.413){
    #'- Name: CropHeatFlux -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: CropHeatFlux Model
    #'            * Author: Pierre Martre
    #'            * Reference: abModelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: It is calculated from net Radiation, soil heat flux and potential transpiration
    #'- inputs:
    #'            * name: netRadiationEquivalentEvaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** description : net Radiation Equivalent Evaporation
    #'                          ** datatype : DOUBLE
    #'                          ** default : 638.142
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: soilHeatFlux
    #'                          ** description : soil Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 188.817
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: potentialTranspiration
    #'                          ** description : potential Transpiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default :  1.413
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: cropHeatFlux
    #'                          ** description :  crop Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    cropHeatFlux <- netRadiationEquivalentEvaporation - soilHeatFlux - potentialTranspiration
    return (list('cropHeatFlux' = cropHeatFlux))
}


#Calculate SNP-index

#' @title Calculate SNP-index
#' @description This function calculates, for both wild-type and mutant bulks, the SNP-index value of each variant stored inside the data frame (returned by the readBSA_vcf() function),
#' applying the following formula:
#' \deqn{SNPindex=AD_alt/(AD_ref + AD_alt)}
#' Bulks get joined together in a single data frame.
#'
#' Note that the user can select specific variants to consider,
#' by setting the "variants" parameter to "SNP" (default) or "all" (InDels+SNPs).
#'
#' @param vcf.df Data frame of the vcf file
#' @param wtBulk Wild-Type pool
#' @param mBulk Mutant pool
#' @param variants variants to be considered. Default is "SNP" (allowed: "SNP" or "all")
#'
#' @return Data frame containing variand and SNP-index information for each bulk.
#'
#' @details The data frame returned by readBSA_vcf() is filtered by bulk ID to create two separate data frames:
#' one specific to the wild-type bulk variants information and other one specific to the mutant bulk variants information.
#' For every variant in each data frame, the SNP-index value gets calculated and added as a new column.
#'
#' In the instance that the type of variants to be considered is set to "SNP",the variants corresponding to InDel sare discarded.
#' The rows containing more than three characters in the GT_alleles column (e.g.,"T/AT"corresponds to an insertion and contains 4 characters)
#' or containing three characters but one of them being "*", meaning a deletion, are removed from the data frame.
#'
#' Both dataframes are then joined by same chromosome and position to ensure that all the merged rows contain information on the same genomic position.
#' This data frame is returned by the function
#'
#' @export calc_SNPindex
#' @examples
#' ## Calculate SNP-index for both bulks (only SNPs will be considered)
#' vcf_df_SNPindex <- calc_SNPindex(vcf.df=vcf_list$df,
#'                                  wtBulk="pool_S3781_minus",
#'                                  mBulk="pool_S3781_plus")
#'
#' ## Calculate SNP-index considering both InDels and SNPs
#' vcf_df_SNPindex <- calc_SNPindex(vcf.df=vcf_list$df,
#'                                  wtBulk="pool_S3781_minus",
#'                                  mBulk="pool_S3781_plus",
#'                                  variants="all")

calc_SNPindex <- function(vcf.df, wtBulk, mBulk, variants="SNP") {

  #Create data frame for each bulk AND include a new column with SNP index
  vcf.df.wtBulk <- vcf.df %>% dplyr::filter(Indiv==wtBulk) %>% dplyr::mutate("SNPindex"= as.numeric(AD_alt)/(as.numeric(AD_ref) + as.numeric(AD_alt)))
  vcf.df.mBulk <- vcf.df %>% dplyr::filter(Indiv==mBulk) %>% dplyr::mutate("SNPindex"= as.numeric(AD_alt)/(as.numeric(AD_ref) + as.numeric(AD_alt)))

  #Stop the program and show message if user selects a non-allowed 'variants' value
  if (variants!="SNP" & variants!="all") {
    stop("The allowed values for the 'variants' argument are: 'SNP' or 'all'. The latter will consider both InDels and SNPs.")
  }

  #Remove from data frames those rows corresponding to InDel variants (if variants=="SNP")
  if (variants=="SNP") {
    vcf.df.wtBulk <- vcf.df.wtBulk %>% dplyr::filter(nchar(GT_alleles)==3 &
                                                     grepl("[^*]{3}", GT_alleles))
    vcf.df.mBulk <- vcf.df.mBulk %>% dplyr::filter(nchar(GT_alleles)==3 &
                                                   grepl("[^*]{3}", GT_alleles))
  }

  #Join data frames of each bulk by same chromosome (ChromKey) and position
  vcf.df.SNPindex <- dplyr::inner_join(vcf.df.wtBulk,
                                       vcf.df.mBulk,
                                       by = c("ChromKey","POS"),
                                       copy = F,
                                       suffix = c(".WT", ".M"))

  return(vcf.df.SNPindex)
}


#!/usr/bin/env Rscript
#autor:      Joao Sollari Lopes
#local:      University of Reading, Reading, UK
#Rversion:   3.2.3
#criado:     01.03.2010
#modificado: 20.11.2017

# @arg rej_file  - file with rejection step results (.dat)
get_cp <- function(data_file){

	#import leaps library
	library(leaps)

    #info on summstats
	lsstats <- c("pi1","S1","k_S1","sH_S1","avMFS1","sdMFS1")
	nsstats <- length(lsstats)

	#import the .dat file
	abc.data <- data.matrix(read.table(data_file))

    #normalize summstats
	sstats <- abc.data[,7:12]
	sstats.s <- sstats
	for(i in 1:nsstats){
		sstats.s[,i] <- (sstats[,i] - mean(sstats[,i]))/sd(sstats[,i])
	}

	#get Cp values
	x.ne <- regsubsets(x=sstats.s,y=log(abc.data[,6]),nbest=1,nvmax=6,method="exhaustive",really.big=TRUE)
	res <- summary(x.ne)
    mat <- cbind(res$rsq,res$cp,res$which[,-1])
    colnames(mat) <- c("r-sq","cp",lsstats)
    print(mat)
}

args = commandArgs(trailingOnly=TRUE)
get_cp(args[1])


#' @title calcPropDia
#'
#' @description Calculate propeller diameter (\code{propDiam}) (m).
#'
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with \code{tankerBulkCarrierGCargoShipTypes} and
#' \code{containerShipTypes} groupings
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#' \code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#' vessels (vector of strings)
#' @param containerShipTypes Ship types specified in input \code{shipTypes} to
#' be modeled as container ships (vector of strings)
#'
#'@details
#'This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierGCargoShipTypes} and \code{containerShipTypes} grouping
#' parameters to provide these ship type groupings. Any ship types not included
#' in these groupings will be considered as miscellaneous vessels.
#'
#' @return \code{propDiam} (vector of numericals, m)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#' @examples
#' calcPropDia(c("bulk.carrier","container.ship"), c(13.6,15.6))
#' calcPropDia(c("other.tanker","container.ship"), c(13.6,15.6),
#'             tankerBulkCarrierGCargoShipTypes=c("other.tanker","bulk.carrier"))
#'
#' @export

calcPropDia <-function(shipType, maxDraft,
                       tankerBulkCarrierGCargoShipTypes=c("general.cargo","tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                       containerShipTypes=c("container.ship")
                       ){

  propDiam<-ifelse( #case 1
    shipType %in% tankerBulkCarrierGCargoShipTypes,
    #if true return:
    0.395*maxDraft+1.3,
    #otherwise:
    ifelse( #case 2
      shipType%in%containerShipTypes,
      #if true return:
      0.623*maxDraft-0.16,
      #otherwise: (RoRo etc...)
      0.713*maxDraft-0.08
    )#end case 2
  )#end case 1

  return(propDiam)
}


#
# Copyright (c) 2016 10x Genomics, Inc. All rights reserved.
#

#' Normalization functions
#'

#' Normalize barcodes by sum to the median barcode by sum
#'
#' @param gbm a GeneBCMatrix to normalize
#' @return A GeneBCMatrix with barcode-normalized values
#' @export
#' @examples
#' gbm_norm_by_bc <- normalize_barcode_sums_to_median(gbm1)
#'
normalize_barcode_sums_to_median <- function(gbm) {
  bc_sums <- colSums(gbm)
  median_sum <- median(bc_sums)
  new_matrix <- sweep(exprs(gbm), 2, median_sum/bc_sums, '*')

  return(newGeneBCMatrix(new_matrix, fData(gbm), pData(gbm), template=gbm))
}

#' Take the element-wise log(1+count) of a gene-barcode matrix while maintaining sparsity
#'
#' @param gbm a GeneBCMatrix to log
#' @param base base of logarithm to use
#' @return A GeneBCMatrix with logged counts
#' @export
#' @examples
#' gbm_log <- log_gene_bc_matrix(gbm1)
#'
log_gene_bc_matrix <- function(gbm, base=2) {
  x <- uniqTsparse(as(exprs(gbm), 'dgTMatrix'))
  slot(x, 'x') <- log(1+slot(x, 'x'), base=base)
  return(newGeneBCMatrix(x, fData(gbm), pData(gbm), template=gbm))
}


#Jenny Smith

#Feb 28, 2018

#purpose: to create a classical multidimensional scaling plot with convex hulls based on Kmeans or kmedians.

MDSplot.Hull <- function(df,cols, method="kmeans",ellipseType="convex", k){
  #df has the clinical data and expression data.
  #patients as rows and genes as columns
  #enusre ONLY the gene expression data is numeric!!
  #cols is a character vector of colnames for the clinical data to be used for fills or shapes

  library(dplyr)
  library(vegan)
  library(flexclust)
  library(ggpubr)

  MDS <- capscale(select_if(df,is.numeric) ~ 1, distance = "bray", add=TRUE)

  scores.mds <- scores(MDS, display="sites") %>%
    data.frame()

  if (method == "kmeans"){
    kmean <- kmeans(scores[,1:2],k)
    groups <- as.factor(kmean$cluster)

  }else if (method == "kmedians"){
    require(flexclust)
    kmed <- flexclust::kcca(scores[,1:2],k=k, family = kccaFamily("kmedians"), save.data=TRUE)
    groups <- as.factor(kmed@cluster)
  }

  scores <- scores %>%
    mutate(k.groups=groups) %>%
    bind_cols(df[,cols]) #same order as in the input df to the capscale() function.

  mds.plot <- ggscatter(scores, x="MDS1", y="MDS2",
                        size=3.0,
                        color=cols[1], #just use the first column by default, will change later to have more than 1 variable
                        palette = "jco",
                        ellipse =FALSE,
                        ellipse.type = "norm",
                        repel = TRUE,
                        add.params = list(alpha=0.5))

  if (ellipseType=="convex"){
    find_hull <- function(df) df[chull(df$MDS1, df$MDS2), ]
    hulls <- plyr::ddply(scores,"k.groups",find_hull)

    mds.plot <- mds.plot +
      geom_polygon(data=hulls, aes(fill=k.groups), alpha=0.2) +
      theme(text = element_text(size=20)) +
      labs(x="MDS1", y="MDS2")

  }else if(ellipseType=="t"){
    mds.plot <- mds.plot +
      stat_ellipse(data=scores, mapping = aes(group=k.groups,fill=k.groups),
                   geom="polygon", alpha=0.15, color="black", level=0.95) +
      theme(text = element_text(size=20)) +
      labs(x="MDS1", y="MDS2")

  }

  res <- list(MDS, scores, mds.plot)
  names(res) <- c("mds.obj","mds.scores","mds.plot")

  return(res)
}


# 3. faza: Vizualizacija podatkov

# ---------------------------------------------------------------------------- #
# -------------------------- SLOVENSKA STATISTIKA ---------------------------- #
# ---------------------------------------------------------------------------- #

# Za zacetek bomo z histogramom prikazali, katera starostna skupina prevladuje pri
# odseljevanju za vsak spol.

# IZSELJEVANJE MOSKEGA PREBIVALSTVA PO STAROSTI

Izseljevanje_Moski_Starost_Graf <- ggplot(Starost_Spol %>% filter(Spol == "Moski"), aes(Leto, Stevilo, fill = Starost)) +
geom_bar(stat = "identity", position = "fill") +
labs(y = "Delez", x = "Leto") +
ggtitle("IZSELJEVANJE MOSKEGA PREBIVALSTVA : Delezi starostnih skupin") +
scale_x_continuous(breaks = seq(2011, 2020, 1)) +
theme(panel.background = element_rect(fill = "white"),
      panel.grid.major = element_line(color = "black", linetype = "dotted"),
      legend.title = element_blank());

# IZSELJEVANJA ZENSKEGA PREBIVALSTVA PO STAROSTI

Izseljevanje_Zenske_Starost_Graf <- ggplot(Starost_Spol %>% filter(Spol == "Zenske"), aes(Leto, Stevilo, fill = Starost)) +
geom_bar(stat = "identity", position = "fill") +
labs(y = "Delez", x = "Leto") +
ggtitle("IZSELJEVANJE ZENSKEGA PREBIVALSTVA : Delezi starostnih skupin") +
scale_x_continuous(breaks = seq(2011, 2020, 1)) +
theme(panel.background = element_rect(fill = "white"),
      panel.grid.major = element_line(color = "black", linetype = "dotted"),
      legend.title = element_blank());

# IZSELJEVANJE MLADEGA IN ZRELEGA PREBIVALSTVA

# Pri tem histogramu nas zanima predvsem kaksna je razlika med odseljevanjem
# mladega in zrelega prebivalstva. To je predvsem pomembno ce se odseli vec mladih
# kot zrelih, saj je to zelo "negativen" trend.

Izseljevanje_Mladi_Zreli_Graf <- Starost_Spol %>%
filter(Starost != "Stari") %>% unite(Kategorija, c(Spol, Starost)) %>%
ggplot(aes(Leto, Stevilo, fill = Kategorija)) +
geom_bar(stat='identity', position='dodge') +
scale_x_continuous(breaks = seq(2011, 2021, 1)) +
scale_y_continuous(breaks = seq(0, 10000, 500)) +
ggtitle("IZSELJEVANJE MLADEGA IN ZRELEGA PREBIVALSTVA ZA OBA SPOLA") +
labs(x = "Leto", y = "Stevilo") +
scale_fill_discrete(labels = c("Mladi", "Zreli", "Mlade", "Zrele")) +
theme(panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(color = "black", linetype = "dotted"),
        legend.position = "bottom",
        legend.title = element_blank(),
        legend.background = element_rect(color = "grey"));

# V naslednjem delu bomo analizirali vsako skupino glede na spol in izobrazbo
# izpustili bomo staro populacijo saj ni nobenega vidnega trenda
# zanima nas izbrazbena struktua odseljenega prebivalstva glede na spol in starost

graf_area <- function(starost, spol, naslov){
  Starost_Izobrazba_Spol %>% filter(Starost == starost, grepl(spol, Izobrazba)) %>%
  ggplot() +
    geom_area(aes(Leto, Stevilo, fill = Izobrazba), position = "fill",alpha = 0.8, color = "black") +
    labs(x = "Leto", y = "Delez") +
    coord_flip() +
    scale_x_continuous(breaks = seq(2011, 2020, 1)) +
    scale_fill_discrete(labels = c("OS", "SS", "VS")) +
    ggtitle(naslov) +
    theme(panel.background = element_rect(fill = "white"),
          panel.grid.major = element_line(color = "black", linetype = "dotted"),
          legend.position = "bottom",
          legend.title = element_blank(),
          legend.background = element_rect(color = "grey"));
}

# Starost_Izobrazba_Spol %>% filter(Starost == "Mladi", grepl("moski", Izobrazba)) %>% ggplot() + geom_area(aes(Leto, Stevilo, fill = Izobrazba), position = "fill",alpha = 0.8, color = "black")

Izseljevanje_Mladi_Moski_Graf <- graf_area("Mladi", "moski", "IZSELJEVANJE MLADEGA MOSKEGA PREBIVALSTVA")
Izseljevanje_Mlade_Zenske_Graf <- graf_area("Mladi", "zenske", "IZSELJEVANJE MLADEGA ZENSKEGA PREBIVALSTVA")
Izseljevanje_Zreli_Moski_Graf <- graf_area("Zreli", "moski", "IZSELJEVANJA ZRELEGA MOSKEGA PREBIVALSTVA")
Izseljevanje_Zrele_Zenske_Graf <- graf_area("Zreli", "zenske", "IZSELJEVANJA ZRELEGA ZENSKEGA PREBIVALSTVA")

# V naslednje delu bomo na prvo mesto postavili izobrazbo in zeleli ugotoviti
# katera skupina in starosti in spolu prevladuje v vsaki izobrazbeni skupini.
# Rezultat bo prikazan s tortnim diagramom.

# IZSELJEVANJA PREBIVALSTVA Z VISOKOSOLSKO IZOBRAZBO V  ZADNJEM DESETLETJU

graf <- function(izobrazba1, izobrazba2, naslov){
  Starost_Izobrazba_Spol %>% filter(Leto %in% c(2011, 2020)) %>%
    filter(Izobrazba  %in% c(izobrazba1, izobrazba2)) %>%
    unite(Kategorija, c(Izobrazba , Starost )) %>%
    ggplot(aes(Leto, Stevilo, group = Kategorija)) +
    geom_line(aes(color = Kategorija), size = 2 , alpha = 0.5) +
    geom_point(aes(color = Kategorija), size = 4, alpha = 0.5) +
    theme_bw() +
    theme(legend.position = "bottom", panel.border = element_blank(),
          axis.title.y = element_blank(), axis.text.y = element_blank(),
          panel.grid.major.y = element_blank(), panel.grid.minor.y = element_blank(),
          axis.title.x  = element_blank(), panel.grid.major.x = element_blank(),
          axis.text.x.top = element_text(size=12), axis.ticks = element_blank(),
          plot.title  = element_text(size=14, face = "bold", hjust = 0.5),
          plot.subtitle = element_text(hjust = 0.5), legend.title = element_blank())+
    scale_x_continuous(breaks = seq(2011, 2020,9)) +
    geom_text(aes(label = paste0(Stevilo)), fontface = "bold", size = 4) +
    ggtitle(naslov)
}

VS_Graf <- graf("VS_moski", "VS_zenske", "VISOKOŠOLSKA IZOBRAZBA") # IZSELJEVANJA PREBIVALSTVA Z VISJEŠOLSKO IZOBRAZBO V DESETLETJU
SS_Graf <- graf("SS_moski", "SS_zenske", "SREDNJEŠOLSKA IZOBRAZBA") # IZSELJEVANJA PREBIVALSTVA Z SREDNJOŠOLSKO IZOBRAZBO V ZADNJEM DESETLETJU
OS_Graf <- graf("OS_moski", "OS_zenske", "OSNOVNOŠOLSKA IZOBRAZBA") # IZSELJEVANJA PREBIVALSTVA Z OSNOVNOŠOLSKO IZOBRAZBO V DESETLETJU

# Na koncu slovenske statistike pa se sledi razlika po aktivnosti. Zanima nas
# ali se izseli vec ljudi, ki so ze delovno aktivni in iscejo boljso placo ali
# zato ker ne dobijo sluzbe. Med neaktivne lahko stejemo tudi studente, ki takoj
# po narejeni univerzi delajo v tujini. Locili bomo med mladimi in starimi.

# ZAPOSLENO PREBIVALSTVO

Aktivni_Graf <- Aktivnost %>%
  filter(Aktivnost == "Zaposleni") %>%
  ggplot() +
  geom_line(aes(Leto, Stevilo, color = Starost ), size = 1.5, alpha = 0.75) +
  geom_point(aes(Leto, Stevilo, color = Starost ), size = 4, alpha = 0.5) +
  ggtitle("ODSELJEVANJE ZAPOSLENEGA PREBIVALSTVA") +
  scale_x_continuous(breaks = seq(2011, 2020, 1)) +
  scale_y_continuous(breaks = seq(100, 1100, 100)) +
  theme(panel.background = element_rect(fill = "white"),
          panel.grid.major = element_line(color = "black", linetype = "dotted"),
          legend.position = "bottom",
          legend.title = element_blank(),
          legend.background = element_rect(color = "white"));

# NEZAPOSLENO PREBIVALSTVO

Neaktivni_Graf <- Aktivnost %>%
  filter(Aktivnost == "Nezaposleni") %>%
  ggplot() +
  geom_line(aes(Leto, Stevilo, color = Starost ), size = 1.5, alpha = 0.75) +
  geom_point(aes(Leto, Stevilo, color = Starost ), size = 4, alpha = 0.5) +
  ggtitle("ODSELJEVANJE NEZAPOSLENEGA PREBIVALSTVA") +
  scale_x_continuous(breaks = seq(2011, 2020, 1)) +
  scale_y_continuous(breaks = seq(50, 200, 50)) +
    theme(panel.background = element_rect(fill = "white"),
          panel.grid.major = element_line(color = "black", linetype = "dotted"),
          legend.position = "bottom",
          legend.title = element_blank(),
          legend.background = element_rect(color = "white"));

# ---------------------------------------------------------------------------- #
# -------------------------- EVROPSKA STATISTIKA ----------------------------- #
# ---------------------------------------------------------------------------- #

# VIZUALIZACIJA EVROPE

# Z zemljevidom Evrope bomo prikazali v katere drzave se izseli najvec Slovencev

Evropa_map <- ggplot(mapdata, aes(x = long, y = lat, group = group)) +
  geom_polygon(aes(fill = SKUPNO), color = "black") +
  scale_fill_gradient(low = "yellow", high = "red") +
  theme(
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.line = element_blank(),
    axis.ticks = element_blank(),
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    panel.background = element_blank(),
    panel.border = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    plot.background = element_blank()
  );

# PRISELJEVANJE RAZLICNIH STAROSTNIH SKUPIN V DRZAVE Z NAJVECJIM PRISELJEVANJEM

# Na podlagi zgornjega zamljevida smo izbrali 6 drzav, katere se izseljuje najvec
# Slovencev. To so Nemcija, Italija, Hrvaska, Svica, Zdruzeno Kraljestvo in Avstrija.
# Za vsako drzavo bomo prikazali starostno sestavo odseljevanja.
# Zelena <- mladi, Rdeca <- zreli, Modra <- stari

Drzave_Graf <- Starost_Evropa %>%
  ggplot() + geom_line(aes(Leto, Stevilo, col = Starost), size = 1.5, alpha = 0.75) +
  geom_point(aes(Leto, Stevilo, col = Starost), size = 3, alpha = 0.5) +
  facet_wrap(. ~ Drzava, ncol = 3) +
  scale_x_continuous(breaks = seq(2011, 2021, 2)) +
  theme(panel.background = element_rect(fill = "white"),
        panel.grid.major = element_line(color = "black", linetype = "dotted"),
        legend.title = element_blank(),
        axis.title.x = element_blank(),
        axis.title.y = element_blank());


## SRTM download options for movement data
#srtm15p extracts terrestrial topography and marine bathymetry data from: Tozer, B, Sandwell, D. T., Smith, W. H. F., Olson, C., Beale, J. R., & Wessel, P. (2019). Global bathymetry and topography at 15 arc sec: SRTM15+. Earth and Space Science, 6, 1847– 1864. https://doi.org/10.1029/2019EA000658
#srtm90m extracts terrestrial data from: Jarvis A., H.I. Reuter, A. Nelson, E. Guevara, 2008, Hole-filled seamless SRTM data V4, International Centre for Tropical Agriculture (CIAT), available from http://srtm.csi.cgiar.org.
#citation: Reuter H.I, A. Nelson, A. Jarvis, 2007, An evaluation of void filling interpolation methods for SRTM data, International Journal of Geographic Information Science, 21:9, 983-1008.

library(RCurl)
library(raster)
srtm15p <- function(x){
  bb <- as.vector(extent(x)*1.5)
  txt <- postForm("https://topex.ucsd.edu/cgi-bin/get_srtm15.cgi",
           submitButton = "get data",
           north=bb[4],
           west=bb[1],
           east=bb[2],
           south=bb[3],
           style = "POST")
  xyz <- data.frame(matrix(as.numeric(unlist(strsplit(unlist(strsplit(txt, "\n")), "\t"))), ncol=3, byrow=T))
  names(xyz) <- c("long", "lat", "alt")
  coordinates(xyz) <- ~long+lat
  gridded(xyz) <- TRUE
  return(raster(xyz))
}

srtm90m <- function(x, method="wget", quiet=F){
  bb <- as.vector(extent(x)*1.5)
  xtilellc <- ceiling((bb[1]+180)/5)
  ytilellc <- 24 - floor((bb[3]+60)/5)
  xtileurc <- ceiling((bb[2]+180)/5)
  ytileurc <- 24 - floor((bb[4]+60)/5)
  combi <- expand.grid(xtilellc:xtileurc, ytilellc:ytileurc)
  tile <- apply(combi, 1, function(x) paste("srtm_", sprintf("%02d",x[1]), "_" , sprintf("%02d", x[2]), ".zip", sep=""))
  tileURL <- lapply(tile, function(tn) paste("http://srtm.csi.cgiar.org/wp-content/uploads/files/srtm_5x5/TIFF/", tn, sep=""))
  demsDL <- mapply(function(URL, tileName) download.file(URL, paste(tempdir(), tileName, sep="/"), method=method, quiet=quiet), tileURL, tile)
  unzip(paste(tempdir(), tile, sep="/"), exdir=tempdir())
  dems <- lapply(list.files(tempdir(), pattern=".tif", full.names = T), raster)
  # Merge the tiles into a single raster
  if(length(dems)>1){
    DEM <- do.call("merge", dems)}else{DEM <- dems[[1]]}
  # Reduce to the extent of the study area
  DEM <- crop(DEM, bb)
  return(DEM)
}

# Example code with plots
library(move)
library(scales)
Dem15Leroy <- srtm15p(leroy)
Dem90mLeroy <- srtm90m(leroy, quiet=T)
proj4string(Dem15Leroy) <- projection(leroy)
proj4string(Dem90mLeroy) <- projection(leroy)

slope15 <- terrain(Dem15Leroy, opt='slope')
aspect15 <- terrain(Dem15Leroy, opt='aspect')
hill15 <- hillShade(slope15, aspect15, 40, 270)

slope90m <- terrain(Dem90mLeroy, opt='slope')
aspect90m <- terrain(Dem90mLeroy, opt='aspect')
hill90m <- hillShade(slope90m, aspect90m, 40, 270)

ColRamp <- terrain.colors(512)

plot(leroy,  type="n", xaxt="n", yaxt="n", ylab=NA, xlab=NA, bty="n")
plot(crop(hill15, extent(leroy)*1.1), col=alpha(grey(0:512/519), 1), add=T, legend=FALSE, main='')
plot(crop(Dem15Leroy, extent(leroy)*1.1), col=alpha(ColRamp, 0.4), add=T, legend=FALSE)
lines(leroy, col=alpha(c("black"), 1), lwd=1.5)
lines(leroy, col=alpha(c("white"), 1), lwd=1)
lines(leroy, col=alpha(c("purple"), 0.75), lwd=1.25)

plot(leroy,  type="n", xaxt="n", yaxt="n", ylab=NA, xlab=NA, bty="n")
plot(crop(hill90m, extent(leroy)*1.1), col=alpha(grey(0:512/519), 1), add=T, legend=FALSE, main='')
plot(crop(Dem90mLeroy, extent(leroy)*1.1), col=alpha(ColRamp, 0.4), add=T, legend=FALSE)
lines(leroy, col=alpha(c("black"), 1), lwd=1.5)
lines(leroy, col=alpha(c("white"), 1), lwd=1)
lines(leroy, col=alpha(c("purple"), 0.66), lwd=1.25)


data<-read.table('urandom.out',col.names=c('values'))
summary(data)

subset<-head(data$values,1000)
summary(subset)

png("urandomRandom.png", width=600, height=600)
plot(subset)
dev.off()

png("urandomSorted.png", width=600, height=600)
plot(sort(subset))
dev.off()


#Calculate sliding windows and mean values (M/WT bulks)

#' @title Sliding Windows
#' @description This function allows to calculate the sliding window based on the chromosome length of the desired chromosome to analyse.
#' A data frame containing the mean SNP-index values of both bulks gets generated.
#'
#' @param meta meta information stored inside the vcf file
#' @param chrList list of chromosome IDs
#' @param chrID chromosome ID of interest
#' @param windowSize window size (default=1000000)
#' @param windowStep window step (default=10000)
#' @param vcf.df.SNPindex.filt filtered SNP-index data frame
#'
#' @return Data frame containing start, mid and stop positions of each window,
#' as well as the corresponding mean SNP-index value for each bulk.
#'
#' @details Firstly, the length of the chosen chromosome is extracted from the  meta information store inside the VCF file.
#' To this end, the lines from the meta information which contain a sequence of key words (including ID and length) that make them unique from others, are extracted into a character vector.
#' For each element of that vector, the characters before and after the chromosome length are removed, so the final character vector contains all chromosomes lengths in the way they are named and ordered in the VCF file (which matches the order of the elements in chrList).
#'
#' The length of the chosen chromosome is then found by extracting the index of the chrIDin chrListsince that index will be equal to the index of the length of the chosen chromosome in the vector of lengths.
#'
#' Once the length of the chromosome has been extracted, the start, mid and stop positions of each window are calculated across the chromosome length.
#' The stop position of each window is calculated by adding the window size (either the default value or the one specified by the user) to the start position of the window.
#' The start position of the first window is 1 and the start position of the following window is calculated by adding the step size to the start position of the previous window.
#'
#' The windows where the stop position falls past the chromosome length are removed.
#' The start, mid and stop positions of each window in the chromosome are stored in a data frame.
#'
#' Then, the input data frame, which is the one returned by filter_SNPindex(), is filtered by the chosen chromosome to restrict the data frame to variants specific to that chromosome.
#'
#' Next, for each window, only the SNP-indexes of the variants comprised between the initial and final position of the window are considered, and the mean SNP-index of the variants between those positions is calculated for both wild-type and mutant bulks.
#' The mean SNP-index of both the wild-type bulk and the mutant bulk in each window are added in separate columns to the data frame containing the start, mid and stop positions.
#' In case no variants are found in a specific window, 0.5 will be the value added to the data frame as the mean SNP-index - to avoid gaps in the plot corresponding to "Not a Number" (NaN) values.
#' The final data frame with the window positions and mean SN-indexes gets returned.
#'
#' @importFrom dplyr %>%
#' @export slidingWindow
#' @examples
#' ## Default parameters
#' SNPindex_windows <- slidingWindow(meta=vcf_list$meta,
#'                                   chrList=chromList,
#'                                   chrID="SL4.0ch03",
#'                                   vcf.df.SNPindex.filt=vcf_df_SNPindex_filt)
#' ## Custom parameters
#' SNPindex_windows <- slidingWindow(meta=vcf_list$meta,
#'                                   chrList=chromList,
#'                                   chrID="SL4.0ch03",
#'                                   windowSize=2000000,
#'                                   windowStep=20000,
#'                                   vcf.df.SNPindex.filt=vcf_df_SNPindex_filt)

slidingWindow <- function(meta, chrList, chrID, windowSize=1000000, windowStep=10000, vcf.df.SNPindex.filt){

  # -------------------------- Length of chosen chromosome ---------------------------
  #Extract those meta lines containing the length of the chromosomes
  lengthLines <- meta[grep("<ID.*length=", meta)]
  #Remove characters before length number (by replacing with "")
  chrLengths <- sub(".*length=", "", lengthLines)
  #Remove characters after length number (by replacing with "")
  chrLengths <- as.numeric(sub(">", "", chrLengths))

  #Find length of chosen chromosome (index corresponding to chosen chromosome is the same in chrLengths and chrList)
  chrLength <- chrLengths[grep(chrID, chrList)]

  # -------------------- Find start and stop points of each window --------------------
  #Find the start points of each window
  windowStart <- seq(from = 1, to = chrLength, by = windowStep)
  #Add window size to each start point to find stop points
  windowStop <- windowStart + windowSize

  #Remove windows whose stop positions fall past the chromosome length
  windowStart <- windowStart[which(windowStop < chrLength)]
  windowStop <- windowStop[which(windowStop < chrLength)]

  #Store in data frame start, stop and mid positions for each window
  SNPindex.windows <- data.frame(start = windowStart, stop = windowStop,
                                 mid = windowStart + (windowStop-windowStart)/2)

  # ---------------- Apply sliding window to calculate mean SNP-index -----------------
  #Add new columns to store mean SNP-index (both wild-type and mutant) relative to each window
  SNPindex.windows$mean_SNPindex.WT <- NA
  SNPindex.windows$mean_SNPindex.M <- NA

  #Filter data frame by chosen chromosome
  if (length(grep(chrID, chrList)) != 0) { #True if a correct chromosome ID is entered
    df.chr <- vcf.df.SNPindex.filt %>% dplyr::filter(ChromKey==grep(chrID, chrList))
  }
  else {
    #Stop program if an incorrect chromosome ID was entered
    stop("The entered 'chrID' was not found in the VCF file. Please, enter a correct one.")
  }

  for (n in 1:nrow(SNPindex.windows)) {
    #Restrict data frame to rows whose positions are between the start and stop of the data frame
    df.window <- df.chr[which(df.chr$POS >= SNPindex.windows$start[n] & df.chr$POS <= SNPindex.windows$stop[n]),]

    #Calculate mean SNP-index of the variants in that window
    mean_SNPindex.WT <- mean(df.window$SNPindex.WT)
    mean_SNPindex.M <- mean(df.window$SNPindex.M)

    #Replace NaN in case they are introduced (when no variants are found in the window)
    if (is.nan(mean_SNPindex.WT)) {mean_SNPindex.WT <- 0.5}
    if (is.nan(mean_SNPindex.M)) {mean_SNPindex.M <- 0.5}

    #Set corresponding mean SNP-index of each row
    SNPindex.windows$mean_SNPindex.WT[n] <- mean_SNPindex.WT
    SNPindex.windows$mean_SNPindex.M[n] <- mean_SNPindex.M
  }

  return(SNPindex.windows)
}


#!/usr/bin/env Rscript

# Standard error = Standard deviation / sqrt(n)
stderr <- function(x) sd(x)/sqrt(length(x))

# Read data from stdin and aggregate
df <- read.table(file("stdin"), sep="\t", header=FALSE, col.names=c("Real", "User", "Sys"))

for (i in names(df)) {
  cat(sprintf("  %-4s  %f±%fms\n", i, mean(df[[i]]), stderr(df[[i]])))
}


Rebol [
    Title: "Bincode"
    Author: "Christopher Ross-Gill"
    Date: 19-Apr-2022
    Home: https://github.com/rgchris/Scripts
    File: %bincode.r
    Version: 0.0.3
    Rights: http://opensource.org/licenses/Apache-2.0
    Purpose: {
        (Un)Pack primitive values from a binary source
    }

    Type: 'module
    Name: 'rgchris.bincode
    Exports: [
        advance consume accumulate
    ]

    History: [
        19-Apr-2022 0.0.3 "Refactoring of datatype components"
        01-Feb-2022 0.0.2 "Initial set of export types"
        22-Jan-2022 0.0.1 "Initial set of import types"
    ]

    Notes: [
        http://mathcenter.oxford.emory.edu/site/cs170/ieee754/
        "The IEEE 754 Format"

        http://sandbox.mc.edu/~bennet/cs110/flt/index.html
        "Floating-Point Conversion Examples"

        http://www.rebol.org/view-script.r?script=ieee.r
        "Rebol to IEEE-32 FLOAT v0.0.2 Piotr Gapinski"
    ]
]

do %do-with.r

assert-all: func [
    conditions
][
    assert reduce [
        'all conditions
    ]
]

signed-32: make object! [
    encode: func [
        value [number!]
    ][
        if decimal? value [
            value: to integer! value
        ]

        debase/base to-hex value 16
    ]

    decode: func [
        source [binary!]
        /le

        /local value
    ][
        value: copy/part source 4

        if le [
            reverse value
        ]

        to integer! value
    ]
]

unsigned-32: make object! [
    encode: func [
        [catch]
        value [number!]
    ][
        case [
            value < 0 [
                throw make error! "Number overflow"
            ]

            value <= 2147483647 [
                signed-32/encode to integer! value
            ]

            value <= 4294967295 [
                signed-32/encode to integer! value - 4294967296
            ]

            <else> [
                throw make error! "Number overflow"
            ]
        ]
    ]

    decode: func [
        source [binary!]
        /le

        /local value
    ][
        value: copy/part source 4

        if le [
            reverse value
        ]

        value: to integer! value

        if negative? value [
            value: 4294967296.0 + value
        ]

        value
    ]
]

signed-64: make object! [
    ; need encode

    decode: func [
        source [binary!]
        /le

        /local
        has-sign value
    ][
        assert [
            8 <= length? source
        ]

        source: copy/part source 8

        if le [
            reverse source
        ]

        if has-sign: not zero? source/1 and 128 [
            source: complement source
        ]

        value:
        add 4294967296.0 * to integer! take/part source 4
        add 65536.0 * to integer! take/part source 2
        to integer! source

        either has-sign [
            -1 - value
        ][
            value
        ]
    ]
]

float-32: make object! [
    encode: func [
        value [number!]

        /local
        sign exponent fraction
    ][
        either zero? value [
            #{00000000}
        ][
            sign: either negative? value [#{80}] [#{00}]
            value: abs value
            exponent: to integer! log-2 value

            if 1 > fraction: value * power 2 negate exponent [
                ; not clear why this adjustment is necessary,
                ; I presume it's an issue where a decimal fraction is not
                ; well represented in base-2
                ;
                ; print [<adjusted> num]
                exponent: exponent - 1
                fraction: value * power 2 negate exponent
            ]

            assert-all [
                2 >= fraction
                exponent + 127 < 255
            ]

            fraction: signed-32/encode round fraction - 1 * 8388608
            exponent: signed-32/encode round shift/left exponent + 127 23

            sign or fraction or exponent
        ]
    ]

    decode: func [
        source [binary!]

        /local
        value part
    ][
        assert [
            4 = length? source
        ]

        value: to integer! source

        part: reduce [
            ; exp: 8 frac: 23
            ; 127 = 2 ** (exp - 1) - 1
            ; 8388608 = 2 ** frac
            ;

            ; -1 ^^ sign
            ;
            power -1 shift source/1 7

            ; 1 + fraction
            ;
            add 1 value and 8388607 / 8388608

            ; exp - bias
            ;
            subtract 255 and shift value 23 127
        ]

        case [
            [1 -127] = next part [
                0.0
            ]

            ; ... NaN / Inf handlers here ...

            <else> [
                part/1 * part/2 * power 2 part/3
            ]
        ]
    ]
]

float-64: make object! [
    encode: func [
        value [number!]

        /local
        sign exponent fraction
    ][
        either zero? value [
            #{0000000000000000}
        ][
            sign: either negative? value [#{80}] [#{00}]
            value: abs value
            exponent: to integer! log-2 value

            if 1 > fraction: value * power 2 negate exponent [
                ; not clear why this adjustment is necessary,
                ; I presume it's an issue where a decimal fraction is not
                ; well represented in base-2?
                ;
                exponent: exponent - 1
                fraction: value * power 2 negate exponent
            ]

            assert-all [
                1 <= fraction
                2 > fraction
                exponent + 1023 < 2047
            ]

            fraction: fraction - 1 * power 2 52
            exponent: signed-32/encode round shift/left exponent + 1023 20

            sign or exponent or rejoin [
                signed-32/encode to integer! fraction / 4294967296
                unsigned-32/encode mod fraction 4294967296
            ]
        ]
    ]

    decode: func [
        source [binary!]

        /local
        value part
    ][
        assert [
            8 = length? source
        ]

        ; Can handle the oversized precision integer as two
        ; smaller numbers: add (val1 and 0x0fffff) val2
        ;
        value: consume source [
            reduce [
                source/1 signed-32 unsigned-32
            ]
        ]

        part: reduce [
            ; exp: 11 frac: uint 52 (20 + 32)
            ; bias: 1023 = 2 ** (exp - 1) - 1
            ; 1048576 = 2 ** frac  ; first part
            ;
            ; -1 ^^ sign
            ;
            power -1 shift value/1 7

            ; 1 + fraction
            ;
            add 1 value/2 and 1048575 * 4294967296.0 + value/3 / power 2 52

            ; exp - bias
            ;
            subtract 2047 and shift value/2 20 1023
        ]

        case [
            [1 -1023] = next part [
                0.0
            ]

            ; ... NaN / Inf handlers here ...

            <else> [
                part/1 * part/2 * power 2 part/3
            ]
        ]
    ]
]

advance: func [
    "Adjust word assigned to a binary value"

    'series [word!]
    "Word assigned to source binary"

    offset [integer!]
    "Offset from current binary index"

    /local
    source
][
    either all [
        binary? source: get :series
        offset <= length? source
    ][
        set :series skip source offset
        yes
    ][
        no
    ]
]

consume: func [
    [catch]
    "Extract a value of specified type from a binary series"

    'series [word!]
    "Word assigned to source binary"

    type [word! integer! binary! block!]
    "Value type or batch of value types"

    /local
    source part value length
][
    assert [
        binary? source: get :series
    ]

    switch type?/word type [
        integer! [
            length: type
            type: 'part
        ]

        binary! [
            length: length? type
            part: type
            type: 'match
        ]

        word! [
            length: switch/default type [
                int
                byte
                char
                signed-8
                unsigned-8 [
                    1
                ]

                short
                signed-16
                signed-16-le
                unsigned-16
                unsigned-16-le [
                    2
                ]

                long
                float-32
                signed-32
                signed-32-le
                unsigned-32
                unsigned-32-le [
                    4
                ]

                long-long
                double
                float-64
                signed-64
                signed-64-le
                unsigned-64
                unsigned-64-le [
                    8
                ]

                utf-8 [
                    case [
                        tail? source [0]
                        source/1 < 127 [1]
                        source/1 < 194 [0]
                        source/1 < 224 [2]
                        source/1 < 240 [3]
                        source/1 < 245 [4]
                        <else> [0]
                    ]
                ]
            ][
                throw make error! rejoin [
                    uppercase form type ": not supported"
                ]
            ]
        ]

        block! [
            length: 0
            part: type
            type: 'batch
        ]
    ]

    assert [
        integer? length
    ]

    switch/default type [
        int
        signed-8 [
            advance :series 1

            shift shift/left source/1 24 24
        ]

        byte
        unsigned-8 [
            advance :series 1

            source/1
        ]

        char [
            advance :series 1

            to char! source/1
        ]

        short
        signed-16 [
            advance :series 2

            ; value << 16 >> 16
            ;
            shift shift/left add source/2 shift/left source/1 8 16 16
        ]

        signed-16-le [
            advance :series 2

            shift shift/left add source/1 shift/left source/2 8 16 16
        ]

        unsigned-16 [
            advance :series 2

            add source/2 shift/left source/1 8
        ]

        unsigned-16-le [
            advance :series 2

            add source/1 shift/left source/2 8
        ]

        long
        signed-32 [
            advance :series 4

            add source/4
            add shift/left source/3 8
            add shift/left source/2 16
            shift/left source/1 24
        ]

        signed-32-le [
            advance :series 4

            add source/1
            add shift/left source/2 8
            add shift/left source/3 16
            shift/left source/4 24
        ]

        unsigned-32 [
            advance :series 4
            unsigned-32/decode source
        ]

        unsigned-32-le [
            advance :series 4
            unsigned-32/decode/le source
        ]

        ; does not handle NaN/INF at this point
        ;
        float-32 [
            float-32/decode consume :series 4
        ]

        long-long
        signed-64 [
            signed-64/decode consume :series 8
        ]

        signed-64-le [
            advance :series 8
            signed-64/decode/le source
        ]

        float-64 [
            float-64/decode consume :series 8
        ]

        utf-8 [
            switch/default length [
                0 []
            ]
        ]

        match [
            if find/match source part [
                advance :series length
                part
            ]
        ]

        part [
            assert [
                advance :series length
            ]

            copy/part source length
        ]

        batch [
            do-with part [
                le: true
                be: false

                signed-8: func [] [
                    consume :series 'signed-8
                ]

                unsigned-8: func [] [
                    consume :series 'unsigned-8
                ]

                signed-16: func [
                    /le
                ][
                    consume :series either le ['signed-16-le] ['signed-16]
                ]

                unsigned-16: func [
                    /le
                ][
                    consume :series either le ['unsigned-16-le] ['unsigned-16]
                ]

                signed-32: func [
                    /le
                ][
                    consume :series either le ['signed-32-le] ['signed-32]
                ]

                unsigned-32: func [
                    /le
                ][
                    consume :series either le ['unsigned-32-le] ['unsigned-32]
                ]

                float-32: func [] [
                    consume :series 'float-32
                ]

                signed-64: func [
                    /le
                ][
                    consume :series either le ['signed-64-le] ['signed-64]
                ]

                float-64: func [] [
                    consume :series 'float-64
                ]

                consume: func [
                    value [binary! integer!]
                ][
                    consume :series value
                ]

                advance: func [
                    value [integer!]
                ][
                    advance :series value
                ]

                get-offset: func [] [
                    get :series
                ]

                set-offset: func [
                    position [binary!]
                ][
                    set :series position
                ]
            ]
        ]
    ][
        throw make error! "Consumable type not yet supported"
    ]
]

accumulate: func [
    [catch]
    "Append values to a binary series"

    target [binary!]
    "Binary to append to"

    value
    "Value or batch of values to append"

    /as type [word!]
    "Use a specific value type"

    /local
    mark
][
    mark: tail target

    case [
        block? value [
            type: 'batch
        ]

        type = 'batch [
            throw make error! "Batch Accumulation by block! only"
        ]

        not type [
            switch/default type?/word value [
                integer! [
                    type: 'signed-32
                ]

                decimal! [
                    type: 'float-64
                ]

                money! [
                    type: 'float-64
                    value: to decimal! value
                    ; future BCD?
                ]

                char! [
                    type: 'unsigned-8
                ]

                binary! [
                    type: 'part
                ]

                string! [
                    type: 'part
                    value: as-binary value
                ]

                issue! url! email! tag! [
                    type: 'part
                    value: as-binary form value
                ]

                tuple! [
                    type: 'part
                    value: to binary! part
                ]
            ][
                throw make error! "Cannot accumulate value"
            ]
        ]
    ]

    switch type [
        int
        signed-8 [
            case [
                not number? value [
                    throw make error! "ACCUMULATE SIGNED-8 expected number"
                ]

                value < -128 [
                    throw make error! "Signed-8 out of range"
                ]

                value < 0 [
                    insert mark to char! 256 + value
                ]

                value < 128 [
                    insert mark to char! value
                ]

                <else> [
                    throw make error! "SIGNED-8 value out of range"
                ]
            ]
        ]

        byte char
        unsigned-8 [
            case [
                not number? value [
                    throw make error! "ACCUMULATE UNSIGNED-8 expected number"
                ]

                value < 0 [
                    throw make error! "UNSIGNED-8 value out of range"
                ]

                value < 256 [
                    insert mark to char! value
                ]

                <else> [
                    throw make error! "UNSIGNED-8 value out of range"
                ]
            ]
        ]

        short
        signed-16
        signed-16-le [
            case [
                not number? value [
                    throw make error! "ACCUMULATE SIGNED-16(-LE) expected number"
                ]

                value < -32768 [
                    throw make error! "Signed-16 out of range"
                ]

                value < 0 [
                    value: remove remove signed-32/encode 65536 - value

                    if type = 'signed-16-le [
                        reverse value
                    ]

                    insert mark value
                ]

                value < 32768 [
                    value: remove remove signed-32/encode value

                    if type = 'signed-16-le [
                        reverse value
                    ]

                    insert mark value
                ]

                <else> [
                    throw make error! "SIGNED-16 value out of range"
                ]
            ]
        ]

        unsigned-16
        unsigned-16-le [
            case [
                not number? value [
                    throw make error! "ACCUMULATE UNSIGNED-16 expected number"
                ]

                value < 0 [
                    throw make error! "UNSIGNED-16 value out of range"
                ]

                value < 65536 [
                    value: remove remove signed-32/encode value

                    if type = 'unsigned-16-le [
                        reverse value
                    ]

                    insert mark value
                ]

                <else> [
                    throw make error! "UNSIGNED-16 value out of range"
                ]
            ]
        ]

        long
        signed-32
        signed-32-le [
            case [
                not number? value [
                    throw make error! "ACCUMULATE SIGNED-32 expected number"
                ]

                value < -2147483648 [
                    throw make error! "SIGNED-32 value out of range"
                ]

                value <= 2147483647 [
                    value: signed-32/encode value

                    if type = 'signed-32-le [
                        reverse value
                    ]

                    insert mark value
                ]

                <else> [
                    throw make error! "SIGNED-32 value out of range"
                ]
            ]
        ]

        unsigned-32
        unsigned-32-le [
            case [
                not number? value [
                    throw make error! "ACCUMULATE UNSIGNED-32 expected number"
                ]

                value < 0 [
                    throw make error! "UNSIGNED-32 value out of range"
                ]

                value < 4294967296 [
                    value: unsigned-32/encode value

                    if type = 'unsigned-32-le [
                        reverse value
                    ]

                    insert mark value
                ]

                <else> [
                    throw make error! "UNSIGNED-32 value out of range"
                ]
            ]
        ]

        float-32 [
            either number? value [
                insert mark float-32/encode value
            ][
                throw make error! "ACCUMULATE FLOAT-32 expected number"
            ]
        ]

        long-long
        signed-64
        signed-64-le [
            throw make error! "64-bit numbers not yet supported"
        ]

        float-64 [
            either number? value [
                insert mark float-64/encode value
            ][
                throw make error! "ACCUMULATE FLOAT-64 expected number"
            ]
        ]

        part [
            either binary? value [
                insert mark value
            ][
                throw make error! "ACCUMULATE PART expected binary"
            ]
        ]

        batch [
            assert [
                block? value
            ]

            do-with value [
                signed-8: func [
                    value [number!]
                ][
                    accumulate/as target value 'signed-8
                ]

                unsigned-8: func [
                    value [number!]
                ][
                    accumulate/as target value 'unsigned-8
                ]

                signed-16: func [
                    value [number!]
                    /le
                ][
                    accumulate/as target value either le ['signed-16-le] ['signed-16]
                ]

                unsigned-16: func [
                    value [number!]
                    /le
                ][
                    accumulate/as target value either le ['unsigned-16-le] ['unsigned-16]
                ]

                signed-32: func [
                    value [number!]
                    /le
                ][
                    accumulate/as target value either le ['signed-32-le] ['signed-32]
                ]

                unsigned-32: func [
                    value [number!]
                    /le
                ][
                    accumulate/as target value either le ['unsigned-32-le] ['unsigned-32]
                ]

                float-32: func [
                    value [number!]
                ][
                    accumulate/as target value 'float-32
                ]

                signed-64: func [
                    value [number!]
                    /le
                ][
                    accumulate/as target value either le ['signed-64-le] ['signed-64]
                ]

                float-64: func [
                    value [number!]
                ][
                    accumulate/as target value 'float-64
                ]

                accumulate: func [
                    value
                ][
                    accumulate target value
                ]

                get-mark: func [] [
                    tail target
                ]

                accumulate-to: func [
                    mark [binary!]
                ][
                    target: mark
                ]
            ]
        ]
    ]

    mark
]


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")
library("ggplot2")

#load data
dftrain <- read.csv("train.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1

#Add Year column
dftrain[,"Year"] <- (as.numeric(format(as.Date(dftrain$Date), "%Y")))

# Plot total sales per week (accumulated)
dftrain_plot <- dftrain %>%
  group_by(Seasonality) %>%
  summarise(Weekly_Sales = sum(Weekly_Sales))

ggplot(dftrain_plot, aes( x = Seasonality, y = Weekly_Sales)) + geom_line()

# Plot total sales per week per dept (accumulated)
dftrain_plot <- dftrain %>%
  group_by(Seasonality, Dept) %>%
  summarise(Weekly_Sales = sum(Weekly_Sales))

ggplot(dftrain_plot, aes(x = Seasonality, y = Weekly_Sales, color = Dept)) + geom_line()
ggplot(dftrain_plot, aes(x = Seasonality, y = Weekly_Sales)) + geom_line() + facet_wrap(~Dept, ncol = 10)
ggplot(subset(dftrain_plot, Dept == 1), aes(x = Seasonality, y = Weekly_Sales, color = Dept)) + geom_line()

# Plot total sales per week per store (accumulated)
dftrain_plot <- dftrain %>%
  group_by(Seasonality, Store) %>%
  summarise(Weekly_Sales = sum(Weekly_Sales))

ggplot(dftrain_plot, aes(x = Seasonality, y = Weekly_Sales, color = Store)) + geom_line()
ggplot(dftrain_plot, aes(x = Seasonality, y = Weekly_Sales)) + geom_line() + facet_wrap(~Store, ncol = 7)
ggplot(subset(dftrain_plot, Store == 1), aes(x = Seasonality, y = Weekly_Sales, color = Store)) + geom_line()


ronum <- c(1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1)
rostr <- c("M", "CM", "D", "CD", "C", "XC", "L", "XL", "X", "IX", "V", "IV", "I")

cat(sapply(as.integer(readLines(tail(commandArgs(), n=1))), function(s) {
  i <- 1
  r <- c()
  while (s > 0) {
    if (s >= ronum[i]) {
      r <- append(r, rostr[i])
      s <- s - ronum[i]
    } else {
      i <- i + 1
    }
  }
  paste(r, collapse="")
}), sep="\n")


pdf_file<-"pdf/scatterplots_connected.pdf"
cairo_pdf(bg="grey98", pdf_file,width=10,height=10)

par(mai=c(1.1,1.25,0.15,0),omi=c(1,0.5,1,0.5), mgp=c(4.5,1,0),family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
myData<-read.xls("myData/gapminder/Greece.xlsx", encoding="latin1")
myData<-myData[myData$Year>=1985, ]

attach(myData)
n<-nrow(myData)
grGDP<-vector()
grLEXP<-vector()
for (i in 2:n)
{
grGDP[i]<-(GDP[i]-GDP[i-1])/GDP[i-1]
grLEXP[i]<-(LEXP[i]-LEXP[i-1])/LEXP[i-1]
}
myData$grGDP<-grGDP*100
myData$grLEXP<-grLEXP*100
myData<-myData[2:n, ]

n<-nrow(myData)

t <- 1:n
ts <- seq(1, n, by = 1/10)
xs <- splinefun(t, myData$grGDP)(ts)
ys <- splinefun(t, myData$grLEXP)(ts)

# Define chart and other elements

plot(myData$grGDP, myData$grLEXP, type="n", xlab="Growth rate GDP (%)", ylab="Growth rate life expectancy (%)", cex.lab=1.5, axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025,cex.axis=1.25)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025,cex.axis=1.25)

lines(xs, ys,lwd=7,col="grey")
for (i in 1:n)
{
symbols(myData$grGDP[i],myData$grLEXP[i],bg="brown",fg="white",circles=1,inches=0.25,add=T)
text(myData$grGDP[i],myData$grLEXP[i], myData$Year[i],col="white")
}

# Titling

mtext("GDP and life expectancy in Greece",3,adj=0,line=1.5,cex=2.5,family="Lato Black",outer=T)
mtext("Correlation of growth rates, 1986-2010",3,adj=0,line=-0.25,cex=1.5,font=3,outer=T)
mtext("Source: gapminder.org",1,line=2,adj=1,cex=1.25,font=3,outer=T)
dev.off()


#getting plot and site level means of NEON cosmopolitan genera for forecast validation.
#This would be worth throwing on the cluster. Runs in like 20-30 on pecan2.
rm(list=ls())
library(runjags)
library(foreach)
library(doParallel)
source('paths.r')
source('NEFI_functions/hierarch_ddirch_means.r')
source('NEFI_functions/tic_toc.r')
tic()

#set output.path----
output.path <- NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path

#load data and format.----
d <- readRDS(NEON_ITS_fastq_all_cosmo_phylo_groups_1k_rare.path)

#register parallel environment.----
n.cores <- detectCores()
registerDoParallel(n.cores)

#loop over levels.----
output <- list()
output <-
  foreach(i = 1:length(d)) %dopar% {
    #Get y multivariate matrix.
    abundances <- d[[i]]$abundances
    seq.depth  <- d[[i]]$seq_total
    #y <- abundances / seq.depth #modified for multinomial dirichlet. Crashes function currently, need a hierarch multinomial dirichlet function.
    y <- as.matrix((abundances + 1) / rowSums(abundances + 1)) #use this for stanadard dirichlet.

    #get core_plot and plot_site indexing.
    core_plot <- substr(rownames(y), 1, 8)
    core_site <- substr(rownames(y), 1, 4)
    plot_site <- unique(core_plot)
    plot_site <- substr(plot_site, 1, 4)

    #fit the hierarchical means.
    fit <- hierarch_ddirch_means(y=y, core_plot = core_plot, plot_site = plot_site, jags.method = 'parallel')

    #add row and column names - plot level (you should put this in the function).
    for(j in 1:length(fit$plot.fit)){
      rownames(fit$plot.fit[[j]]) <- unique(core_plot)
      rownames(fit$site.fit[[j]]) <- unique(plot_site)
      colnames(fit$plot.fit[[j]]) <- colnames(y)
      colnames(fit$site.fit[[j]]) <- colnames(y)
    }
    fit$core.fit <- y #add in the core-level data!
    return(fit)
    cat(names(d)[i],'model fit.',i,'of',length(d),'groups aggregated.\n')
  }
names(output) <- names(d)

#save matrix lists.----
saveRDS(output, output.path)
cat('Script complete. ');toc()


# test neutral_models

context("neutral model functions")

test_that("calculating expected K for a population in a WFIA model works", {
  n <- 2000
  t <- 20

  observed <- expected_k_pop(n,t)

  expected <- 81.2528

  expect_equal(expected, observed, tolerance=0.1)
})


library(ggvis)

shinyServer(function(input, output, session) {
  mtcars <- cbind(mtcars, id = seq_len(nrow(mtcars)))

  # Create a linked brush object
  lb <- linked_brush(keys = mtcars$id, "red")

  # Just the brushed points
  selected <- lb$selected
  mtcars_selected <- reactive({
    if (!any(selected())) return(mtcars)
    mtcars[selected(), ]
  })

  mtcars %>%
    ggvis(~wt, ~mpg) %>%
    layer_points(fill := lb$fill, fill.brush := "red") %>%
    lb$input() %>%
    add_data(mtcars_selected) %>%
    layer_model_predictions(model = "lm")%>%
    bind_shiny("plot1")

  output$brush_data <- renderPrint({
    cat("Number of points selected: ", nrow(mtcars_selected()), "\n\n")
    print(summary(mtcars_selected()))
  })
})


#############
#Overview plots and Land Cover
#############

################3
#Correlograms MU/MPM presence absence by distance (Figure 2b)
################

library(ncf)
#Not used Moran I assumption data is normal
#
# qqnorm(MUGeo$Total.ER.Present)
# qqline(MUGeo$Total.ER.Present,col="blue")
#
#

cor.MUPos <- correlog(MUGeo.proj$lat, MUGeo.proj$lon, MUGeo$Total.MU.Present..VNTR., increment = 10000, resamp = 100)
plot(cor.MUPos,xlab= "Distance (m, mean of class)",ylab="Correlation (MU positivity)",main="")
abline(h = 0, col = "purple")

#
# dev.off()
# tiff("output/CorrelogramMUPresence.tiff", width = 84, height = 84, units = 'mm', res = 1200)
# plot(cor.MUPos,xlab= "Distance (m, mean of class)",ylab="Correlation (MU positivity)",main="")
# abline(h = 0, col = "purple")
#
# dev.off()

cor.MPMPos <- correlog(MUGeo.proj$lat, MUGeo.proj$lon, MUGeo$Total.ER.Present, increment = 10000, resamp = 100)

plot(cor.MPMPos,xlab= "Distance (m, mean of class)",ylab="Correlation (MPM positivity)",main="")
abline(h = 0, col = "purple")
#
# dev.off()
# tiff("output/CorrelogramMPMPresence.tiff", width = 84, height = 84, units = 'mm', res = 1200)
# plot(cor.MPMPos,xlab= "Distance (m, mean of class)",ylab="Correlation (MPM positivity)",main="")
# abline(h = 0, col = "purple")
#
# dev.off()

#############
#Land use graph MU
############

#pal_nlcd Function modified from https://space-lab-msu.github.io/MSUGradSpatialEcology/lab3_patch_design.html
#Table of values avialable at https://github.com/JPReceveur/SpatialEcologyFinalProj

pal_nlcd <- function() {
  data.frame(
    class = c("forest", "forest",
              "forest", "shrubland",
              "anthropogenic", "anthropogenic",
              "wetland","anthropogenic",
              "forest", "No Data",
              "Sand", "shrubland",
              "herbaceous", "herbaceous",
              "No Data", "anthropogenic",
              "shrubland", "forest",
              "anthropogenic", "anthropogenic",
              "No Data","shrubland",
              "shrubland","herbaceous",
              "Oasis","shrubland",
              "shrubland","water",
              "forest","anthropogenic",
              "No Data"),
    code = as.character(c(7, 15,
                          28, 2, 8, 78,
                          3,
                          24, 1, 99,
                          10,12, 31,
                          4, 0, 27, 32,
                          25, 13,
                          6, 98,11,29,23,5,16,22,9,21,14,255)),
    description = c("Mangrove", "Gallery/ Riparian Forest",
                    "Swamp Forest", "Savanna",
                    "Agriculture", "Open Mine",
                    "Wetland","Agriculture/ flood recessional",
                    "Forest", "Cloud",
                    "Sandy","Bare soil",
                    "Herbaceous savanna", "Steppe",
                    "No data","Cropland/ oil palms",
                    "Shrubland",  "Woodland",
                    "Settlements","Plantation",
                    "Cloud shadow", "Rocky land",
                    "Sahelian short grass savanna", "Thicket",
                    "Oasis","Shrub and savanna",
                    "Bowe", "Water bodies",
                    "Degraded forest","Irrigated agriculture",
                    "No Data"),
    color = c("#33cccc", "#aa5ce8",
              "#beffa6", "#8cb08c",
              "#ffff96", "#505050",
              "#000081","#ebc961",
              "#8400a8", "#ffffff",
              "#ff99cc", "#a87000",
              "#0a9696", "#ffd09b",
              "#ffffff", "#77AD93",
              "#749373", "#28734b",
              "#ff0000", "#808000",
              "#ffffff", "#969696",
              "#a7c38d", "#f8a37b",
              "#99C147", "#77AD93",
              "#DCD939", "#3366ff",
              "#d296e6", "#cdff66",
              "##ffffff"
    ),
    stringsAsFactors = FALSE)
}

NLCD <- as.matrix(table(raster::values(LULCRaster)))
cols <- dplyr::filter(pal_nlcd(), code %in% row.names(NLCD))
par(xpd = FALSE,mai = c(0.5, 0.5, 0.2, 0))

plot(LULCRaster, legend=FALSE,axes=TRUE,box=FALSE,col=cols$color,
     xlab="", ylab="")
par(xpd = TRUE) # reset to limit plotting to figure region
plot(GhanaOutline.Meter,add=T)
legend(x = -2000, y = 690000, legend = cols$description, fill = cols$color,
       ncol = 2,  cex = 0.85, inset = 0.9)
legend(x=500183,y=615115,legend =c("MU +","MU -"),pch=c(17,16),col=c('red','blue'))
scalebar(100000,xy = c(439429.8,61762), type="bar", divs = 2, label = c(0,50,100),below="km")
north.arrow(x=500183, y=345827, len = 10000, cex.lab = 0.75, col = "black", fg = "red")
plot(Presence.Meter,col="red",bg="red",add=T,pch=24)
plot(Absence.Meter,col="blue",bg="blue",add=T,pch=21)

#
# dev.off()
# tiff("output/LUGhana.tiff", width = 174, height = 174, units = 'mm', res = 600)
# par(xpd = FALSE,mai = c(0.5, 0.5, 0.2, 0))
#
# plot(LULCRaster, legend=FALSE,axes=TRUE,box=FALSE,col=cols$color,
#      xlab="", ylab="")
# par(xpd = TRUE) # reset to limit plotting to figure region
# plot(GhanaOutline.Meter,add=T)
# legend(x = -2000, y = 690000, legend = cols$description, fill = cols$color,
#        ncol = 2,  cex = 0.85, inset = 0.9)
# legend(x=450183,y=645115,legend =c("MU +","MU -"),pch=c(17,16),col=c('red','blue'))
# scalebar(100000,xy = c(439429.8,61762), type="bar", divs = 2, label = c(0,50,100),below="km")
# north.arrow(x=500183, y=345827, len = 10000, cex.lab = 0.75, col = "black", fg = "red")
# plot(Presence.Meter,col="red",bg="red",add=T,pch=24)
# plot(Absence.Meter,col="blue",bg="blue",add=T,pch=21)
#
# dev.off()

##############
#LandUseGraph MPM
###############

#Plotted as above but showing MPM pres/abs
par(xpd = FALSE,mai = c(0.5, 0.5, 0.2, 0))

plot(LULCRaster, legend=FALSE,axes=TRUE,box=FALSE,col=cols$color,
     xlab="", ylab="")
par(xpd = TRUE) # reset to limit plotting to figure region
plot(GhanaOutline.Meter,add=T)
legend(x = -2000, y = 690000, legend = cols$description, fill = cols$color,
       ncol = 2,  cex = 0.85, inset = 0.9)
legend(x=450183,y=645115,legend =c("MPM +","MPM -"),pch=c(17,16),col=c('red4','blue'))
scalebar(100000,xy = c(439429.8,61762), type="bar", divs = 2, label = c(0,50,100),below="km")
north.arrow(x=500183, y=345827, len = 10000, cex.lab = 0.75, col = "black", fg = "red")
plot(PresenceMPM.Meter,col="red4",bg="red4",add=T,pch=24)
plot(AbsenceMPM.Meter,col="blue",bg="blue",add=T,pch=21)

############
#Landscape Metrics
#############
#Landscape Metrics

##Calculate 5k landscape metrics

#Load landscape pachages
library(landscapemetrics)
library(landscapetools)
#Data same as above
MUSurvey<-read.csv("GhanaMUSurvey.csv",header=T)

MUGeo <- subset(MUSurvey, !is.na(lon) & !is.na(lat))

wgs1984.proj <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
MUGeo.proj <- SpatialPoints(coords=MUGeo[,c("lon","lat")], proj4string=wgs1984.proj)

LandCover<-LandCover2k
MUGeo.proj<-spTransform(MUGeo.proj,crs(LandCover))
GhanaOutline2<-spTransform(GhanaOutline,crs(LandCover))

#Sample 5k buffer (5000 m) around each sample point using landscape metrics
Buffer5k<-sample_lsm(
  LandCover,
  MUGeo.proj,
  plot_id = NULL,
  shape = "square",
  size=5000,
  all_classes = FALSE,
  return_raster = FALSE,
  verbose = TRUE,
  progress = FALSE,level="landscape",type="aggregation metric")

Buffer5k
#unique(Buffer$metric)

##Landscape Metric MU 5k

#For loop testing differences between PresAbs values for the chosen metrics (MetricList)
MetricList<-c("contag","np","lsi","cohesion")

for(i in 1:length(MetricList)){
  Subset<-subset(Buffer5k,Buffer5k$metric==MetricList[i])
  print(unique(Subset$metric))

  Subset$plot_id<-MUGeo$USITEID
  Subset$PresAbs<-MUGeo$Total.MU.Present..VNTR.
  Subset$PresAbs[Subset$PresAbs==1]<-"Present"
  Subset$PresAbs[Subset$PresAbs==0]<-"Absent"
  Plot <- ggplot(Subset,aes( x=PresAbs,y=value,col=PresAbs))+ylab(MetricList[i])+xlab("MU VNTR Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red"))+theme(legend.position="none")
  print(Plot)
  print(kruskal.test(data=Subset,value~PresAbs))
  Trtdata <- ddply(Subset, c("metric","PresAbs"), summarise,
                   N    = length(value),
                   mean = mean(value),
                   sd   = sd(value),
                   se   = sd / sqrt(N)
  )
  print(Trtdata)

}

#LSI Landscape shape index #standardized measure of total edge LSI=1 =single patch increases from there pg 158 Fragstats

#NP <- number of patches pg 149
#contagion -sum of proportional abundance of each patch, inverse to edge density pg154

##Landscape Metric MPM 5k

MetricList<-c("contag","np","lsi","cohesion")
#Same as above but using Total.ER.Present to calculate for MPM abundance
for(i in 1:length(MetricList)){
  Subset<-subset(Buffer5k,Buffer5k$metric==MetricList[i])
  print(unique(Subset$metric))

  Subset$plot_id<-MUGeo$USITEID
  Subset$PresAbs<-MUGeo$Total.ER.Present #Total ER presence coded as 1= presence, 0 =absence
  Subset$PresAbs[Subset$PresAbs==1]<-"Present"
  Subset$PresAbs[Subset$PresAbs==0]<-"Absent"
  Plot <- ggplot(Subset,aes( x=PresAbs,y=value,col=PresAbs))+ylab(MetricList[i])+xlab("MPM VNTR Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red4"))+theme(legend.position="none")
  print(Plot)
  print(kruskal.test(data=Subset,PresAbs~value))

}

#10k landscape metrics MU

#Data same as above
MUSurvey<-read.csv("GhanaMUSurvey.csv",header=T)

MUGeo <- subset(MUSurvey, !is.na(lon) & !is.na(lat))

#Project to WGS84
wgs1984.proj <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
MUGeo.proj <- SpatialPoints(coords=MUGeo[,c("lon","lat")], proj4string=wgs1984.proj)

LandCover<-LandCover2k
MUGeo.proj<-spTransform(MUGeo.proj,crs(LandCover))
GhanaOutline2<-spTransform(GhanaOutline,crs(LandCover))

#Calculate 10 k buffer (10000 m) around sample points for landscape metrics
Buffer10k<-sample_lsm(
  LandCover,
  MUGeo.proj,
  plot_id = NULL,
  shape = "square",
  size=10000,
  all_classes = FALSE,
  return_raster = FALSE,
  verbose = TRUE,
  progress = FALSE,level="landscape",type="aggregation metric")

#Buffer10k
#unique(Buffer$metric)

##Landscape Metric MU 10 k

MetricList<-c("contag","np","lsi","cohesion")

for(i in 1:length(MetricList)){
  Subset<-subset(Buffer10k,Buffer10k$metric==MetricList[i])
  print(unique(Subset$metric))

  Subset$plot_id<-MUGeo$USITEID
  Subset$PresAbs<-MUGeo$Total.MU.Present..VNTR.
  Subset$PresAbs[Subset$PresAbs==1]<-"Present"
  Subset$PresAbs[Subset$PresAbs==0]<-"Absent"
  Plot <- ggplot(Subset,aes( x=PresAbs,y=value,col=PresAbs))+ylab(MetricList[i])+xlab("MU VNTR Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red"))+theme(legend.position="none")
  print(Plot)
  print(kruskal.test(data=Subset,value~PresAbs))
  Trtdata <- ddply(Subset, c("metric","PresAbs"), summarise,
                   N    = length(value),
                   mean = mean(value),
                   sd   = sd(value),
                   se   = sd / sqrt(N)
  )
  print(Trtdata)

}

#LSI Landscape shape index #standardized measure of total edge LSI=1 =single patch increases from there pg 158 Fragstats

#NP <- number of patches pg 149
#contagion -sum of proportional abundance of each patch, inverse to edge density pg154

#Subset for Contag only plot
Contag<-subset(Buffer10k,Buffer10k$metric=="contag")
Contag$plot_id<-MUGeo$USITEID
Contag$PresAbs<-MUGeo$Total.MU.Present..VNTR.
Contag$PresAbs[Contag$PresAbs==1]<-"Present"
Contag$PresAbs[Contag$PresAbs==0]<-"Absent"

Plot <- ggplot(Contag,aes( x=PresAbs,y=value,col=PresAbs,shape=PresAbs))+ylab(MetricList[i])+xlab("MU VNTR Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red"))+theme(legend.position="none")+ylab("Contagion Index")+geom_point()
Plot

#
# dev.off()
# tiff("output/ContagPlot.tiff", width = 84, height = 84, units = 'mm', res = 600)
# Plot
# dev.off()

#Landscape Metric MPM Presence Absence
##5 kilometer

#List of metrics to run kruskal.wallis tests on
MetricList<-c("contag","np","lsi","cohesion")

for(i in 1:length(MetricList)){
  Subset<-subset(Buffer5k,Buffer5k$metric==MetricList[i])
  print(unique(Subset$metric))

  Subset$plot_id<-MUGeo$USITEID #unique site ID from file
  Subset$PresAbs<-MUGeo$Total.ER.Present
  Subset$PresAbs[Subset$PresAbs==1]<-"Present"
  Subset$PresAbs[Subset$PresAbs==0]<-"Absent"
  Plot <- ggplot(Subset,aes( x=PresAbs,y=value,col=PresAbs))+ylab(MetricList[i])+xlab("MPM  Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red4"))+theme(legend.position="none")
  #print(Plot)
  print(kruskal.test(data=Subset,value~PresAbs))
  Trtdata <- ddply(Subset, c("metric","PresAbs"), summarise,
                   N    = length(value),
                   mean = mean(value),
                   sd   = sd(value),
                   se   = sd / sqrt(N)
  )
  print(Trtdata)

}

##10k MPM landscape metrics

MetricList<-c("contag","np","lsi","cohesion")

for(i in 1:length(MetricList)){
  Subset<-subset(Buffer10k,Buffer5k$metric==MetricList[i])
  print(unique(Subset$metric))

  Subset$plot_id<-MUGeo$USITEID
  Subset$PresAbs<-MUGeo$Total.ER.Present
  Subset$PresAbs[Subset$PresAbs==1]<-"Present"
  Subset$PresAbs[Subset$PresAbs==0]<-"Absent"
  Plot <- ggplot(Subset,aes( x=PresAbs,y=value,col=PresAbs))+ylab(MetricList[i])+xlab("MPM  Profiling")+geom_boxplot()+scale_color_manual(values=c("blue","red4"))+theme(legend.position="none")
  #print(Plot)
  print(kruskal.test(data=Subset,value~PresAbs))
  Trtdata <- ddply(Subset, c("metric","PresAbs"), summarise,
                   N    = length(value),
                   mean = mean(value),
                   sd   = sd(value),
                   se   = sd / sqrt(N)
  )
  print(Trtdata)

}


code 'sce_contrast_duration'
name '市值与久期对照'
dimensions {
	accbook null
	scene null
	target {
		headModels {
			model ([id:'market',name:'市值'])
			model ([id:'macaulayDuration',name:'麦考利久期'])
			model ([id:'modifiedDuration',name:'修正久期'])
		}
	}
}
layout {
	rows 'accbook'
	columns (['scene','target'])
}
dataRequest {
	name 'scene1'
	table 'sceDuration'
	fields 'accbook,marketValue,macaulayDuration,modifiedDuration,cashflowPresentValue'
	contextParams (['scene1'])
}
dataRequest {
	name 'scene2'
	table 'sceDuration'
	fields 'accbook,marketValue,macaulayDuration,modifiedDuration,cashflowPresentValue'
	contextParams (['scene2'])
}
dataGrids {
	apply selectRows({children!=null},{params['target']=='market'}),{
		formula {sumChildren()}
	}
	apply selectColumns({head.value=='macaulayDuration'||head.value=='modifiedDuration'}),{
		dataType 'numeric'
		formula {
			if(children==null){
				def pv=v([target:'cfpv'])
				// v([target:'macaulayDuration']) or v([target:'modifiedDuration'])
				def dur=v()
				[pv*dur,pv]
			}else{
				def durs=[0.0,0.0]
				children.each{
					def childDur=it.result
					durs[0]+=childDur[0]
					durs[1]+=childDur[1]
				}
				durs
			}
		}
		evaluatedCallback {
			def duration=value[0]
			def cfpv=value[1]
			if(cfpv > 0.0){
				value=duration/cfpv
			}else{
				value=0.0
			}
		}
	}
	apply sel([scene:'scene2']),{
		params {
			dataRequest 'scene2'
		}
	}
}


# Implements the well-known pairwise-based learning to rank algorithm proposed by Burges et al., ICML-2005

# input
	# X_train: matrix of training instances (one instance per row)
	# Y_train: ranking of the instances in the training data
	# net_params: list of network parameters:
		# n_hidden, n_units, batch_normalization, epochs, batch_size, callbacks, validation_split, optimizer_lr, regularizer_l2_l,
		# layer_activation, output_activation, verbose
# output
	# fitted_model: fitted network
	# prediction_model: the model that can further be used for prediction

func_RankNet <- function( X_train, Y_train, net_params ){

	f_construct_prediction_network <- function(){

		xx <- inp <- layer_input(shape = n_features, name = "")

		output_node1 <- layer_dense(
			units = 1,
			activation = net_params$output_activation,
			kernel_regularizer = regularizer_l2(l = net_params$regularizer_l2_l),
			name = "output_node",
			weights = get_weights(get_layer(object = Net, name = "output_node"))
			)

		for(i in seq(n_hidden)){

			nm <- ifelse(batch_normalization, paste0("hiddenNormalized_", i), paste0("hidden_", i))

			dense <- layer_dense(
				units = n_units,
				kernel_regularizer = regularizer_l2(l = net_params$regularizer_l2_l),
				activation = net_params$layer_activation,
				name =  nm,
				weights = get_weights(get_layer(object = Net, name = nm))
				)

			if (batch_normalization==TRUE){
				activation_ <- layer_activation(activation = net_params$layer_activation)
				batchnorm <- layer_batch_normalization( weights = get_weights(get_layer(object = Net, name = paste0("batch_normalization_", i))) )
				xx <- batchnorm( activation_( dense(xx) ) )
			} else {
				xx <- dense(xx)
			}
		}

		output_score <- output_node1(xx)

		keras_model(inputs = c(inp), outputs = output_score)
	}
	f_constructNetwork <- function(){

		hidden_layers <- list()
		# ===== Construct_layers ==========
		in1 <- layer_input(shape = c(n_features), name = "IN1")
		in2 <- layer_input(shape = c(n_features), name = "IN2")

		output_node <- layer_dense(
			units = 1,
			activation = net_params$output_activation,
			kernel_regularizer = regularizer_l2(l = net_params$regularizer_l2_l),
			name = "output_node"
			)

		for(i in seq(n_hidden)){
			dense <- layer_dense(
				units = n_units,
				kernel_regularizer = regularizer_l2(l = net_params$regularizer_l2_l),
				activation = net_params$layer_activation,
				name =  ifelse(batch_normalization, paste0("hiddenNormalized_", i), paste0("hidden_", i))
				)
			hidden_layers <- c(hidden_layers, dense)
		}

		# =================================
		if (batch_normalization==TRUE){

			for( i in seq(n_hidden) ){

				if (i==1){
					activation_ <- layer_activation(activation = net_params$layer_activation)
					batchnorm <- layer_batch_normalization( name=paste0("batch_normalization_", i) )
					enc_x1 <- batchnorm( activation_( hidden_layers[[i]](in1) ) )

					enc_x2 <- batchnorm( activation_( hidden_layers[[i]](in2) ) )
					neg_x2 <- layer_lambda(object = enc_x2, f = function(x) -x, name="negation_func")

					next
				}

				activation_ <- layer_activation(activation = net_params$layer_activation)
				batchnorm <- layer_batch_normalization( name=paste0("batch_normalization_", i) )
				enc_x1 <- batchnorm( activation_( hidden_layers[[i]](enc_x1) ) )

				neg_x2 <- batchnorm( activation_( hidden_layers[[i]](neg_x2) ) )
			}

		} else { # batch_normalization = FALSE

			for( i in seq(n_hidden) ){

				if (i==1){
					enc_x1 <- hidden_layers[[i]](in1)
					enc_x2 <- hidden_layers[[i]](in2)

					neg_x2 <- layer_lambda(object = enc_x2, f = function(x) -x, name="negation_func")

					next
				}

				enc_x1 <- hidden_layers[[i]](enc_x1)
				neg_x2 <- hidden_layers[[i]](neg_x2)
			}
		}

		merged_inputs <- layer_add(inputs = list(enc_x1, neg_x2), name="diff_score")

		output <- output_node(merged_inputs)

		model <- keras_model(inputs = c(in1, in2), outputs = output)

		model
	}

	library(keras)
	n_features <- ncol(X_train)
	n_hidden <- net_params$n_hidden
	batch_normalization <- net_params$batch_normalization
	n_units <- net_params$n_units

	(X_sorted <- X_train[ order(Y_train) ,])
	cmb <- combn(nrow(X_sorted),2)

	(sq <- seq(1, ncol(cmb), 2))
	tmp <- cmb[,sq]
	cmb[,sq][1,] <- tmp[2,]
	cmb[,sq][2,] <- tmp[1,]

	Pairs <- X_sorted[cmb,]
	in1 <- Pairs[ c(TRUE, FALSE) ,]
	in2 <- Pairs[ c(FALSE, TRUE) ,]
	target <- rep_len(c(0,1), length.out = nrow(in1) )

	valid_set <- ceiling(nrow(in1)*net_params$validation_split)
	cat("Train on <", nrow(in1)-valid_set,"> samples, validate on <", valid_set ,"> samples\n")

	Net <- f_constructNetwork()

	print("<Compiling model started>")
	Net %>% compile(
		loss = 'binary_crossentropy',
		optimizer = optimizer_sgd(lr = net_params$optimizer_lr),
		# optimizer = optimizer_adam(),
		metrics = c('accuracy')
	)

	print("<Fitting model started>")
	Net %>% fit(
		list(in1, in2),
		target,
		epochs = net_params$epochs,
		batch_size = net_params$batch_size,
		callbacks = net_params$callbacks,
		validation_split = net_params$validation_split,
		verbose=net_params$verbose,
		shuffle = TRUE
		)

	list(
		fitted_model = Net,
		prediction_model = f_construct_prediction_network()
		)
}


library(ggplot2)
library(scales)

pos_err_gauss <- as.matrix(read.csv("out/pos_err_gauss.csv"))
vel_err_gauss <- as.matrix(read.csv("out/vel_err_gauss.csv"))

pos_err_pearson <- as.matrix(read.csv("out/pos_err_pearson.csv"))
vel_err_pearson <- as.matrix(read.csv("out/vel_err_pearson.csv"))

Ng <- nrow(pos_err_gauss)
Np <- nrow(pos_err_pearson)

err <- c(pos_err_gauss, vel_err_gauss, pos_err_pearson, vel_err_pearson)

dst <- c(rep("Gaussian Distributions", 8*Ng),
         rep("Pearson Type IV Distributions", 8*Np))

fil <- c(rep(c(rep("HOUSE", Ng),
               rep("UKF",   Ng),
               rep("CUT-4", Ng),
               rep("CUT-6", Ng)), 2),
         rep(c(rep("HOUSE", Np),
               rep("UKF",   Np),
               rep("CUT-4", Np),
               rep("CUT-6", Np)), 2))

cmp <- c(rep("Position Error (m)",   4*Ng),
         rep("Velocity Error (m/s)", 4*Np))

data <- data.frame(err, dst, fil, cmp)

filter <- c("HOUSE", "UKF", "CUT-4", "CUT-6")
data$fil <- factor(data$fil, levels=filter)

colors <- c("#cc3311", "#0077bb", "#ee7733", "#009988", "#ee3377")

ggplot(data, aes(x=fil, y=err, fill=fil)) +
    scale_fill_manual(values=colors) +
    geom_violin(trim=FALSE) +
    geom_boxplot(width=0.1, outlier.shape=NA, fill="white") +
    theme_bw(base_size = 9) +
    theme(panel.grid.major = element_line(),
          legend.position = "none") +
    facet_grid(rows=vars(cmp), cols=vars(dst),
        scales="free_y", switch="y", shrink=FALSE) +
    xlab(NULL) + ylab(NULL) +
    scale_y_log10(breaks = 10^(-10:10),
                  labels = trans_format("log10", math_format(10^.x)))

ggsave("proj_err.eps", width=6, height=6, units="in")


print(z <- nsz(14.084,-3.4107,0.0015,1.8832,timepoints))


##Ukázka 1=name
##R workshop=group
##output_plots_to_html
##Layer=vector
##X=Field Layer
##bins=number 25
library(dplyr)
library(ggplot2)
library(plotly)
library(scales)

data <- Layer %>%
  st_drop_geometry()

ggplot(data) +
  geom_histogram(aes(x = .data[[X]]), bins = bins) +
  scale_x_continuous(labels = scales::comma) +
  coord_trans(x = "log10") +
  theme_bw() +
  theme(aspect.ratio = 9/16)


library(compositions)
library(pracma)
library(rain)
library(dplyr)
library(reshape2)
library(ggplot2)

# Migrate working directory to the location of repository and downloaded test data
# setwd() assuming data is in folder with script
load("TESTDATA_DIEL18S.RData",verbose=T) # Import test data set
head(test_data)

# Repeat from Module 1 Clustering tutorial (QC initial OTU table)
# (1) Remove global singletons:
rowsum<-apply(test_data[2:20],1,sum) # sum numerics in OTU table by row
counts.no1 = test_data[ rowsum>1, ]  # remove rows that sum to 1 or less
dim(test_data)[1] - dim(counts.no1)[1] # report total number of singletons removed
#
# (2) Filter out OTUs which belong to the metazoa:
counts.filtered<-counts.no1[-(which(counts.no1$Level3 %in% "Metazoa")),] # Remove from counts
dim(counts.no1);dim(counts.filtered) # Test data should be left with 1984 total OTUs
#
# (3) Create taxonomy key:
names(counts.filtered)
seq_counts<-counts.filtered[1:20]
tax_key<-counts.filtered[c(1,21:31)]; head(tax_key[1:2,])
# Modify seq_counts data frame so row.names = OTU.ID and all values are numeric
row.names(seq_counts)<-seq_counts$OTU.ID
seq_counts$OTU.ID<-NULL; head(seq_counts[1:2,])

# Centered log-ratio transformation.
# This is necessary due to the compositional nature of OTU results
# ?clr()
df_clr<-as.data.frame(clr(seq_counts))

# Detrend
# ?detrend()
df_detr<-detrend(t(df_clr))

# RAIN analysis
# ?rain()
# Set up RAIN parameters.
# This analysis will treat each time point independently (rather than each 'day' as a replicate)
t<-(1:19)
ft <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)

# Run RAIN
output_RAIN<-rain(as.matrix(df_detr), period=24, measure.sequence=ft, deltat=4, method="independent", na.rm = TRUE)

# Report results
head(output_RAIN[1:3,]) # Output data frame

hist(output_RAIN$pVal) # distribution of p-value results

sig<-subset(output_RAIN, pVal < 0.05); dim(sig)[1] # Total number of OTUs with significant rhymicity (p<0.05)

sig$OTU.ID<-row.names(sig); list_of_sig_OTUs<-unique(sig$OTU.ID) # list of OTUs with significant rhythmicity

# Assessing significance
# Bonferroni correction
# This is the LEAST forgiving form of multiple testing correction (least power and least type I error)
bonf_sig<-subset(output_RAIN, pVal <= (0.05/nrow(output_RAIN)))

# Benjamini-Hochberg Correction
#?p.adjust()
fdr_ps<-p.adjust(output_RAIN$pVal,method='BH')
bh_sig<-output_RAIN[which(fdr_ps<=0.05),]

# Adaptive Benjamini-Hochberg Correction (see Benjamini and Hochberg 2001)
# Step 1: Sort p-values in ascending order
abh_ps<-output_RAIN$pVal[order(output_RAIN$pVal,decreasing=FALSE)]

# Step 2: Find p-values smaller than those expected at 5% FDR.
# Rejecting all null hypotheses which have p-values less than their corresponding abh_metric will
# yield the same results as p.adjust(method='BH') at the 0.05 significance level.
q<-0.05 #Significance level
m<-length(abh_ps) #Number of hypotheses tested
abh_metric<-q*(1:m)/m

#For a visualization of what this procedure does -- we consider all red points that fall below the black
# line significant
plot(1:m,abh_metric,type='l',
  xlab='p-value rank',
  ylab='p-value',lwd=2,
  main='Benjamini-Hochberg FDR Control')
points(1:m,abh_ps,col='red')
legend(650,0.05,fill=c('red','black'),legend=c('p-value','FDR controlled p threshold'))

# Step 3: Estimate the number of false null hypotheses according to the procedure outlined
# in Benjamini and Hochberg 2001
s=0
s_i=0
i=1
while(s>=s_i){
  s_i=s
  s=(1-abh_ps[i])/(1+m-i)
  i=i+1
}
m_0<-ceiling(1/s)+1

# Step 4: Find p-values smaller than those expected at 5% FDR for adjusted number of false hypotheses
abh_updated<-(1:length(abh_ps))*0.05/m_0
# For a similar visualization
plot(1:m,abh_updated,type='l',
     xlab='p-value rank',
     ylab='p-value',lwd=2,
     main='Adaptive Benjamini-Hochberg FDR Control')
points(1:m,abh_ps,col='red')
legend(650,0.05,fill=c('red','black'),legend=c('p-value','FDR controlled p threshold'))

# Step 5: Determine which tests resulted in a p-value significant at the 5% level considering FDR
abh_sigs<-output_RAIN[which(output_RAIN$pVal %in% abh_ps[which(abh_ps<=abh_updated)]),]

# Compile list of significantly perodic OTUs with taxonomic identities (use tax_key generated above)
abh_sigs$OTU.ID<-row.names(abh_sigs)
sig_bytax<-left_join(abh_sigs, tax_key, by="OTU.ID")
dim(abh_sigs); dim(sig_bytax)
# Report list of OTUs found to have significant diel rhythmicity
write.table(sig_bytax, file="SigDiel_OTUs.txt", row.names = FALSE, quote = FALSE)

# Join CLR normalized data with list of significantly periodic OTUs
df_clr2<-df_clr
df_clr2$OTU.ID<-row.names(df_clr)
df_clr3<-left_join(sig_bytax, df_clr2, by="OTU.ID")
unique(df_clr3$Taxa) # What is the overal taxonomic distribution?
head(df_clr3)

# Plot signal of OTUs with significant periodicity
df_clr4<-melt(data.frame(df_clr3$OTU.ID, df_clr3$Taxa, df_clr3$taxonomy, df_clr3[17:35])) #Extract taxa names and CLR normalied values
df_clr4$Time_of_day<-factor(df_clr4$variable,
                            levels = c("X1_6PM","X2_10PM","X3_2AM","X4_6AM","X5_10AM","X6_2PM","X7_6PM","X8_10PM","X9_2AM","X10_6AM","X11_10AM","X12_2PM","X13_6PM","X14_10PM","X15_2AM","X16_6AM","X17_10AM","X18_2PM","X19_6PM"),
                            labels = c("Day 1 6PM","Day 1 10PM","Day 2 2AM","Day 2 6AM","Day 2 10AM","Day 2 2PM","Day 2 6PM","Day 2 10PM","Day 3 2AM","Day 3 6AM","Day 3 10AM","Day 3 2PM","Day 3 6PM","Day 3 10PM","Day 4 2AM","Day 4 6AM","Day 4 10AM","Day 4 2PM","Day 4 6PM"))
colnames(df_clr4)[1:3]<-c("OTU.ID","Taxa","Full taxonomy")
head(df_clr4)
#
# Plot CLR normalized values for those OTUs with significant diel rhythmicity"
diel_plot<-ggplot(df_clr4, aes(x=Time_of_day, y=value, group= OTU.ID))+
    geom_point(size=4,shape=21, color="white", aes(fill=Taxa, group = OTU.ID))+
    geom_line(size=1, linetype = 5, aes(color=Taxa))+
    facet_wrap(OTU.ID ~ `Full taxonomy`,labeller = label_wrap_gen(40))+
    theme_minimal()+
    labs(title="Taxa with significant diel rhythmicity", x = "Time of Day", y = "CLR normalized value")+
    theme(legend.position="none",axis.text.x = element_text(angle=45,hjust=1, vjust=1),
          strip.text = element_text(hjust=0, size=8))+
    geom_rect(data=NULL,aes(xmin=-Inf,xmax=4,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=7,xmax=10,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=13,xmax=16,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=19,xmax=Inf,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)

diel_plot<-ggplot(df_clr4, aes(x=Time_of_day, y=value, group= OTU.ID))+
    geom_point(size=4,shape=21, color="white", aes(fill=Taxa, group = OTU.ID))+
    geom_line(size=1, linetype = 5, aes(color=Taxa))+
    facet_wrap(~`Full taxonomy`,labeller = label_wrap_gen(40))+
    theme_minimal()+
    labs(x = "Time of Day", y = "CLR normalized value")+
    theme(legend.position="none",axis.text.x = element_text(angle=70,hjust=1, vjust=1,size=12),
          strip.text = element_text(hjust=0, size=12),axis.title=element_text(size=14))+
    geom_rect(data=NULL,aes(xmin=-Inf,xmax=4,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=7,xmax=10,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=13,xmax=16,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)+
    geom_rect(data=NULL,aes(xmin=19,xmax=Inf,ymin=-Inf,ymax=Inf),color=NA,fill="#737373",alpha=0.01)
#
# Plot a subset
tax_of_interest<-c("Stramenopiles", "Haptophytes")
diel_plot %+% subset(df_clr4, Taxa %in% tax_of_interest)+
    scale_fill_manual(values=c("#de77ae", "#7fbc41"))+
    scale_color_manual(values=c("#de77ae", "#7fbc41"))

# Plot all
diel_plot