#setwd("D:/Dropbox/Data analyze/Rdocuments/datas")
library(xlsx)
 library(RColorBrewer)

 #读取数据
#k1<-read.xlsx("t_for.xls", sheetName = "0.2", header = TRUE)
#k2<-read.xlsx("t_for.xls", sheetName = "0.3", header = TRUE)
#k3<-read.xlsx("t_for.xls", sheetName = "0.4", header = TRUE)
#k4<-read.xlsx("t_for.xls", sheetName = "0.5", header = TRUE)
fv<-5:3500

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12) #不同的流量下

k<-c(0.8,0.7,0.6,0.5) #不同占空比下无电场时间比例，即1-k_i

v<-4.66e-13  #泰勒锥的体积总量

#jpeg(file="figure2.jpg")

par(mfrow=c(2,2), mar=c(4,2,2,2), oma=c(2,4,2,2))

mycolors<-c("red", "blue", "darkgreen", "yellow3")

c1<- 0.2 * 4.66e-13 #弯月面体积，用以标识体积增量占泰勒锥体积的大小
#c2<- 0.1 * 4.66e-13
#c3<- 0.05 * 4.66e-13
#c4<-0.4 * 4.66e-13
#c5<- 0.6 * 4.66e-13
c<-4.66e-13  #泰勒锥体积

#####占空比为0.2时######
plot(fv, (k[1]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.2", lwd=2.5, ylim=c(4e-13, 10e-13))#y轴的边界，在不同的占空比k下应该相差不大，最大应该是V_m的2倍，即10e-13左右

for (i in 1:3){
lines(fv,  (k[1]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.2")
legend("topright", c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 2.5e-14, "5% V_M,red", col="blue", cex=1.2, font=2)
#text(50, 4e-14, "10% V_M,blue", col="blue", cex=1.2, font=2)

#####占空比k=0.3######
plot(fv, (k[2]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.3", lwd=2.5, ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv,  (k[2]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.3")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 1.8e-13, "20% V_M,green", col="blue", cex=1.2, font=2)
#text(50, 1.2e-13, "10% V_M,blue", col="blue", cex=1.2, font=2)
#text(50, 0.75e-14, "5% V_M,red", col="blue", cex=1.2, font=2)

#####占空比k=0.4######
plot(fv, (k[3]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.4", lwd=2.5 , ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv,  (k[3]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.4")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 5e-13, "20% V_M, green", col="blue", cex=1.2, font=2)
#text(50, 4e-13, "10% V_M, blue", col="blue", cex=1.2, font=2)
#text(50, 3e-13, "5% V_M, red", col="blue", cex=1.2, font=2)

#####占空比k=0.5######
plot(fv, (k[4]*q[1]/fv+v), col=mycolors[1], log="x", type="l", xlab = expression(log(italic(f["v"])) (Hz)), ylab = expression(italic(volume["increase"](m^3))), main="k=0.5", lwd=2.5 , ylim=c(4e-13, 10e-13))

for (i in 1:3){
lines(fv, (k[4]*q[i+1]/fv+v), lwd=2.5, col=mycolors[i+1] )
}
title("k=0.5")
legend("topright",  c("1.5nl/min","27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, lwd=2.5, lty=1, cex=1.1, bty="n")

abline(h=c, col="red", lty=2, lwd=2)
abline(h=1.2*c, col="blue", lty=2, lwd=2)
abline(h=1.5*c, col="darkgreen",lty=2, lwd=2)

#text(50, 1.6e-12, "60% V_M,yellow", col="blue", cex=1.2, font=2)
#text(50, 1.2e-12, "50% V_M,green", col="blue", cex=1.2, font=2)
#text(50, 0.8e-12, "20% V_M, blue", col="blue", cex=1.2, font=2)
#text(50, 0.5e-12, "5% V_M, red", col="blue", cex=1.2, font=2)

#dev.off()


#' Format data for Occupancy detection models
#'
#' This takes occurrene data in the form of a vector of taxa names, locations
#' and survey (usually a date) and converts them into the form needed for
#' occupancy models (see value section)
#'
#' @param taxa A character vector of taxon names, as long as the number of observations.
#' @param site A character vector of site names, as long as the number of observations.
#' @param survey A vector as long as the number of observations.
#'        This must be a Date if either closure_period is not supplied or if includeJDay = \code{TRUE}
#' @param replicate An optional vector to identify replicate samples (visits) per survey. Need not be globally unique (e.g can be 1, 2, .. n within surveys)
#' @param closure_period An optional vector of integers specifying the closure period.
#'        If \code{FALSE} then closure_period will be extracted as the year from the survey.
#' @param includeJDay Logical. If \code{TRUE} a Julian day column is returned in the
#'        occDetData object.
#'
#' @return A list of length 2 the first element 'spp_vis' is a data.frame with visit
#'  (unique combination of site and time period) in the first column and taxa for all
#'  the following columns. Values in taxa columns are either \code{TRUE} or
#'  \code{FALSE} depending on whether they were observed on that visit. The second
#'  element ('occDetData') is a dataframe giving the site, list length (the number of
#'  species observed on a visit) and year (or time period) for each visit. Optionally this also includes
#'  a Julian Day column, centered on 1 July.
#'
#' @keywords trends, species, distribution, occupancy, bayesian, modeling
#' @references Isaac, N.J.B., van Strien, A.J., August, T.A., de Zeeuw, M.P. and Roy, D.B. (2014).
#'             Statistics for citizen science: extracting signals of change from noisy ecological data.
#'             \emph{Methods in Ecology and Evolution}, 5 (10), 1052-1060.
#' @references van Strien, A.J., Termaat, T., Groenendijk, D., Mensing, V. & Kéry, M. (2010).
#'             Site-occupancy models may offer new opportunities for dragonfly monitoring based on daily species lists.
#'             \emph{Basic and Applied Ecology}, 11, 495-503.
#' @examples
#' \dontrun{
#'
#' # Create data
#' n <- 15000 #size of dataset
#' nyr <- 20 # number of years in data
#' nSurveys <- 100 # set number of dates
#' nSites <- 50 # set number of sites
#'
#' # Create somes dates
#' first <- as.Date(strptime("2010/01/01", "%Y/%m/%d"))
#' last <- as.Date(strptime(paste(2010+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
#' dt <- last-first
#' rDates <- first + (runif(nSurveys)*dt)
#'
#' # taxa are set as random letters
#' taxa <- sample(letters, size = n, TRUE)
#'
#' # three sites are visited randomly
#' site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)
#'
#' # the date of visit is selected at random from those created earlier
#' survey <- sample(rDates, size = n, TRUE)
#'
#' # run the model with these data for one species
#' formatted_data <- formatOccData(taxa = taxa,
#'                                 site = site,
#'                                 survey = survey,
#'                                 includeJDay = TRUE)
#' }
#' @examples
#' \dontrun{
#'
#' # Create data with coarser survey information
#' n <- 1500 #number of species observation in dataset
#' np <- 10 # number of closure periods in data
#' nSurveys <- 100 # set number of surveys
#' nSites <- 20 # set number of sites
#'
#' # taxa are set as random letters
#' taxa <- sample(letters, size = n, TRUE)
#'
#' # three sites are visited randomly
#' site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)
#'
#' # the date of visit is selected at random from those created earlier
#' survey <- sample(nSurveys, size = n, TRUE)
#'
#' # allocate the surveys randomly to closure periods
#' cp <- sample(1:np, nSurveys, TRUE)
#' closure_period <- cp[survey]
#'
#' # run the model with these data for one species
#' formatted_data <- formatOccData(taxa = taxa,
#'                                 site = site,
#'                                 survey = survey,
#'                                 closure_period = closure_period)
#'
#' # format the unicorns data
#' formatted_data <- formatOccData(taxa = unicorns$CONCEPT,
#'                                survey = unicorns$Date,
#'                                site = unicorns$kmsq)
#'}
#'
#' @export
#' @importFrom dplyr distinct
#' @importFrom dplyr summarise
#' @importFrom dplyr group_by
#' @importFrom reshape2 dcast

formatOccData <- function(taxa, site, survey, replicate = NULL, closure_period = NULL, includeJDay = FALSE){

  # Do error checks
  errorChecks(taxa = taxa, site = site, survey = survey, replicate = replicate, closure_period = closure_period)

  # Additional error check whether survey is a date
  if(!'POSIXct' %in% class(survey) & !'Date' %in% class(survey)){
    # This is necessary if either closure_period is not supplied or if includeJDay = TRUE
    if(is.null(closure_period)){
      stop('survey must be a date if closure_period not supplied')
    } else {
      if(includeJDay == TRUE){
        stop('survey must be a date if Julian Date is to be included')
    }
   }
  } # otherwise survey can be anything (including a character vector)

  if(is.null(replicate)) replicate <- rep(1, length(survey)) # all

  # Create dataframe from vectors
  taxa_data <- data.frame(taxa, site, survey, replicate)

  # now add the time period (TP). It's defined by closure_period if supplied
  # TP was formerly referred to as year
  if(!is.null(closure_period)){
    # replace with sort order in case they go in as decades
    lookup <- data.frame(cp = sort(unique(closure_period)),
                        TP = 1:length(unique(closure_period)))

    taxa_data$TP <- lookup$TP[match(closure_period, lookup$cp)]

    #check that surveys are nested within closure_periods
    temp <- group_by(.data = taxa_data, survey, replicate)

    temp <- summarise(temp, ns = length(unique(TP)))
    if(any(temp$ns) > 1) {
      # return a warning but assume they know what they're doing
      warning(paste(as.numeric(table(temp$ns >1)[2]), 'survey identities appear in multiple closure periods'))
    }
  } else {
    # we need to create the TP from the survey date.
    # survey should be a date if we've got this far, so extract the year
    taxa_data$TP <- as.numeric(format(taxa_data$survey,'%Y')) # take year from date year
  }

  # remove duplicates (in order that List Length is correctly calculated)
  taxa_data <- distinct(taxa_data)

  # add list length column
  taxa_data$visit <- paste(taxa_data$site, taxa_data$survey, taxa_data$replicate, sep="") # create a factor which combines site, survey & replicate
  visit_Ls <- as.data.frame(table(taxa_data$visit))
  names(visit_Ls) <- c("visit", "L")
  taxa_data <- merge(taxa_data, visit_Ls)

  # create species_visit dataframe/matrix
  temp <- taxa_data[,c('taxa','visit')]
  names(temp)[1] <- "species_name"
  temp$pres <- TRUE # add TRUE column which will populate the spp with visit matrix/dataframe
  spp_vis <- dcast(temp, formula = visit ~ species_name, value.var = "pres", fill = FALSE) # This is the dataframe that contains a row per visit and a column for each species present or not.  USed to create the focal column in the next step

  # Add Julian Day if needed
  if(includeJDay){
    taxa_data$Jul_date <-as.numeric(
            format(as.POSIXlt(taxa_data[,"survey"],
                        format = "%Y-%m-%d"), "%j")
      )
    occDetdata <- unique(taxa_data[,c("visit", "site", "L", "TP", "Jul_date")])
  } else {
    # create occDetdata which is the main file sent to bugs (1 row per visist) - this will have "focal" added to it within the species loop
    occDetdata <- unique(taxa_data[,c("visit", "site", "L", "TP")])
  }

  return(list(spp_vis = spp_vis, occDetdata = occDetdata))

}


#Spectrum costs
library(tidyverse)
library(ggpubr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, "data_inputs")

files = list.files(path=folder_inputs, pattern="*.csv")

data <-
  do.call("rbind",
          lapply(files,
                 function(x)
                   read.csv(file.path(folder_inputs, x),
                            stringsAsFactors = FALSE)))

data$country = factor(data$country, levels=c("UGA",
                                             "MWI",
                                             "KEN",
                                             "SEN",
                                             "PAK",
                                             "ALB",
                                             "PER",
                                             "MEX"),
                                    labels=c("Uganda\n(Cluster 1)",
                                             "Malawi\n(Cluster 1)",
                                             "Kenya\n(Cluster 2)",
                                             "Senegal\n(Cluster 2)",
                                             "Pakistan\n(Cluster 3)",
                                             "Albania\n(Cluster 4)",
                                             "Peru\n(Cluster 5)",
                                             "Mexico\n(Cluster 6)"))

data$settlement_type = factor(data$settlement_type,
                              levels=c("urban",
                              "rural"),
                      labels=c("Urban",
                               "Rural"
                               ))

subscriptions <- ggplot(data, aes(x=year, y=penetration, group=country)) +
  geom_point(aes(shape=country, color=country), size=2.5) +
  geom_line(aes(color=country)) +
  scale_shape_manual(values=c(0, 1, 2, 3, 4, 5, 6, 7, 8)) +
  scale_color_manual(values=c("#F0E442", "#F0E442","#E69F00", "#E69F00","#D55E00", "#0072B2", "#56B4E9","#009E73"))+
  geom_vline(xintercept=2020, linetype="dashed", color = "grey", size=.5) +
  scale_x_continuous(expand = c(0, 0), limits = c(2020,2030), breaks = seq(2020,2030,1)) +
  scale_y_continuous(expand = c(0, 0), limits = c(0,95)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "bottom", legend.title=element_blank()) +
  labs(title = "Smartphone Penetration",
       subtitle = "Forecast: 2020-2030 ",
       x = NULL, y = "Smartphone Adoption (%)") +
  guides(colour=guide_legend(ncol=4)) +
  facet_wrap(~settlement_type, ncol=1)

path = file.path(folder, 'figures', 'smartphones.png')
ggsave(path, units="in", width=7, height=7, dpi=300)
print(subscriptions)
dev.off()


## Instructions to run your output files in R manually (with ancom package)

## You will need the following files (output from ancomR.sh):
##	1) otufile_for_ancom.txt (OTU table formatted for ancom)

## Open R
R

## Load ancom
library(ancom.R)

## Read in your file
otufile="otufile_for_ancom.txt"
otus <- read.table(otufile, sep="\t", header=TRUE)

## Set alpha level (significance)
alpha="0.5"

## Run ancom without multiple corrections
## Significance level is set at 0.05
ancom.out <- ANCOM(real.data=otus,sig=alpha,multcorr=3)
detections <- ancom.out$detected
plot.un <- plot_ancom(ancom.out)

## List detected OTUs/taxa and generate plots
detections
plot.un

## Run ancom with relaxed FDR correction -- note that multcorr=2 is less stringent than multcorr=1
## Significance level is set at 0.05
ancom.out.fdr.2 <- ANCOM(real.data=otus,sig=alpha,multcorr=2)
detections.fdr.2 <- ancom.out.fdr.2$detected
plot.fdr.2 <- plot_ancom(ancom.out.fdr.2)

## List detected OTUs/taxa and generate plots
detections.fdr.2
plot.fdr.2

## Run ancom with strict FDR correction
## Significance level is set at 0.05
ancom.out.fdr.1 <- ANCOM(real.data=otus,sig=alpha,multcorr=1)
detections.fdr.1 <- ancom.out.fdr.1$detected
plot.fdr.1 <- plot_ancom(ancom.out.fdr.1)

## List detected OTUs/taxa and generate plots
detections.fdr.1
plot.fdr.1

## Produce statistical summary
names0 <- colnames(otus)
counts0 <- ncol(otus)
counts1 <- counts0-1
Group <- names0[1:counts1]
ancom.W <- ancom.out$W
ancom.W.FDRstrict <- ancom.out.fdr.1$W
ancom.W.FDR <- ancom.out.fdr.2$W
Result <- cbind(Group,ancom.W,ancom.W.FDR,ancom.W.FDRstrict)
Result.sort <- Result[order(-ancom.W.FDRstrict, -ancom.W.FDR, -ancom.W, na.last=NA),]

## View Statistics (sorted by W value)
Result.sort

## See the ancom.R documentation for more functionality:
## http://www.niehs.nih.gov/research/resources/software/biostatistics/ancom/index.cfm


#' Calculation of accessibility on a stars object with an opportunity as attribute
#'
#' @param data Stars object of points with an information on opportunities
#' @param opportunities_colname Name of the opportunity attribute
#' @param departures_colname Name of an attribute to filter by, if the value is NA (Optional)
#' @param r5r_core a rJava object to connect with R5 routing engine
#' @param stars_result Defaults to TRUE for stars object. Otherwise a data.table.
#' @param mode string. Transport modes allowed for the trips. Defaults to
#'             "WALK". See details for other options.
#' @param mode_egress string. Transport mode used after egress from public
#'                    transport. It can be either 'WALK', 'BICYCLE', or 'CAR'.
#'                    Defaults to "WALK".
#' @param departure_datetime POSIXct object. If working with public transport
#'                           networks, please check \code{calendar.txt} within
#'                           the GTFS file for valid dates. See details for
#'                           further information on how datetimes are parsed.
#' @param time_window numeric. Time window in minutes for which r5r will
#'                    calculate travel times departing each minute. When using
#'                    frequency-based GTFS files, 5 Monte Carlo simulations will
#'                    be run for each minute in the time window. See details for
#'                    further information.
#' @param percentiles numeric vector. Defaults to '50', returning the accessibility
#'                    value for the median travel time computed for a given
#'                    time_window. If a numeric vector is passed, for example
#'                    c(25, 50, 75), the function will return accessibility
#'                    estimates for each percentile, by travel time cutoff. Only
#'                    the first 5 cut points of the percentiles are considered.
#'                    For more details, see R5 documentation at
#'                    'https://docs.conveyal.com/analysis/methodology#accounting-for-variability'
#' @param decay_function string. Choice of one of the following decay functions:
#'                       'step', 'exponential', 'fixed_exponential', 'linear',
#'                       and 'logistic'. Defaults to 'step', which yields
#'                       cumulative opportunities accessibility metrics.
#'                       More info in `details`.
#' @param cutoffs numeric. Cutoff times in minutes for calculating cumulative
#'                opportunities accessibility when using the 'step decay function'.
#'                This parameter has different effects for each of the other decay
#'                functions: it indicates the 'median' (or inflection point) of
#'                the decay curves in the 'logistic' and 'linear' functions, and
#'                the 'half-life' in the 'exponential' function. It has no effect
#'                when using the 'fixed exponential' function.
#' @param decay_value numeric. Extra parameter to be passed to the selected
#'                `decay_function`.
#' @param max_walk_dist numeric. Maximum walking distance (in meters) to access
#'                      and egress the transit network, or to make transfers
#'                      within the network. Defaults to no restrictions as long
#'                      as `max_trip_duration` is respected. The max distance is
#'                      considered separately for each leg (e.g. if you set
#'                      `max_walk_dist` to 1000, you could potentially walk up
#'                      to 1 km to reach transit, and up to _another_  1 km to
#'                      reach the destination after leaving transit). Obs: if you
#'                      want to set the maximum walking distance considering
#'                      walking-only trips you have to set the `max_trip_duration`
#'                      accordingly (e.g. to set a distance of 1 km assuming a
#'                      walking speed of 3.6 km/h you have to set `max_trip_duration = 1 / 3.6 * 60`).
#' @param max_bike_dist numeric. Maximum cycling distance (in meters) to access
#'                      and egress the transit network. Defaults to no
#'                      restrictions as long as `max_trip_duration` is respected.
#'                      The max distance is considered separately for each leg
#'                      (e.g. if you set `max_bike_dist` to 1000, you could
#'                      potentially cycle up to 1 km to reach transit, and up
#'                      to _another_ 1 km to reach the destination after leaving
#'                      transit). Obs: if you want to set the maximum cycling
#'                      distance considering cycling-only trips you have to set
#'                      the `max_trip_duration` accordingly (e.g. to set a
#'                      distance of 5 km assuming a cycling speed of 12 km/h you
#'                      have to set `max_trip_duration = 5 / 12 * 60`).
#' @param max_trip_duration numeric. Maximum trip duration in minutes. Defaults
#'                          to 120 minutes (2 hours).
#' @param walk_speed numeric. Average walk speed in km/h. Defaults to 3.6 km/h.
#' @param bike_speed numeric. Average cycling speed in km/h. Defaults to 12 km/h.
#' @param max_rides numeric. The max number of public transport rides allowed in
#'                  the same trip. Defaults to 3.
#' @param max_lts  numeric (between 1 and 4). The maximum level of traffic stress
#'                 that cyclists will tolerate. A value of 1 means cyclists will
#'                 only travel through the quietest streets, while a value of 4
#'                 indicates cyclists can travel through any road. Defaults to 2.
#'                 See details for more information.
#' @param n_threads numeric. The number of threads to use in parallel computing.
#'                  Defaults to use all available threads (Inf).
#' @param verbose logical. `TRUE` to show detailed output messages (the default).
#' @param progress logical. `TRUE` to show a progress counter. Only works when
#'                `verbose` is set to `FALSE`, so the progress counter does not
#'                interfere with R5's output messages. Setting `progress` to `TRUE`
#'                may impose a small penalty for computation efficiency, because
#'                the progress counter must be synchronized among all active
#'                threads.
#' @return A stars objects
#'
#' @import units
#' @import sf
#' @import stars
#' @import progress
#' @import data.table
#'
#' @export
#'
#' @section remarks : missing values on opportunity are excluded from any calculation, but not tiles with a zero value.
#' Transforming these values to NA before executing this function may be a good idea.
st_accessibility <- function(data,
                             opportunities_colname,
                             departures_colname = NULL,
                             stars_result = TRUE,
                             r5r_core,
                             mode = "WALK", mode_egress = "WALK",
                             departure_datetime = Sys.time(),
                             time_window = 1L,
                             percentiles = 50L,
                             decay_function = "step",
                             cutoffs = 30L,
                             decay_value = 1,
                             max_walk_dist = Inf,
                             max_bike_dist = Inf,
                             max_trip_duration = 120L,
                             walk_speed = 3.6,
                             bike_speed = 12,
                             max_rides = 3,
                             max_lts = 2,
                             n_threads = Inf,
                             verbose = FALSE,
                             progress = TRUE) {

  if (is.null(st_crs(data))) stop("Coordinates System Referential not defined.")

  resolution <- st_dimensions(data)$x$delta |> abs()
  if (is.na(resolution)) stop("Resolution is not defined in the stars dimensions")
  if (abs(st_dimensions(data)$y$delta) != resolution) stop("Tiles are not squares")

  tictoc::tic()

  # Creation of the idINS (crs 3035)
  if(st_crs(data) != st_crs(3035)) {
    idINS <- st_transform(data, crs = st_crs(3035)) |>
      st_coordinates() |>
      coord2idINS(resolution = resolution)
  } else {
    idINS <- st_coordinates(data) |>
      coord2idINS(resolution = resolution)
  }

  data[["idINS"]] <- matrix(idINS, nrow = dim(data)["x"], ncol = dim(data)["y"])
  message("Creation of idINS.\n")

  # Passage to WSG 84 mandatory to use r5r
  crs_ref <- st_crs(4326)
  if (st_crs(data) != crs_ref) data <- st_transform(data, crs = st_crs(4326))

  # Summary on the area.
  # Assumes resolution in meters.
  side <- set_units(resolution, m)
  surf_area <- (st_dimensions(data)$x$to - st_dimensions(data)$x$from) * (st_dimensions(data)$y$to - st_dimensions(data)$y$from)
  surf_area <- surf_area * side^2
  surf_area <- set_units(surf_area, km^2)
  message("Tile's dimension = ", side, "m x ", side, "m")
  message("Area's dimension = ", surf_area, " km^2")
  message("Number of tiles on the area ~ ", ceiling(surf_area/(side^2)))

  # Selection of origins
  departs <- cbind(st_coordinates(data),
                   data[["idINS"]] |> as.vector())

  names(departs) <- c("lon", "lat", "id")

  if (!is.null(departures_colname)) {
    exclure <- data[[departures_colname]] |> as.vector() |> is.na()
    departs <- departs[!exclure, ]
  }

  # Selection of destinations
  arrivees <- cbind(st_coordinates(data),
                    data[["idINS"]] |> as.vector(),
                    data[[opportunities_colname]] |> as.vector())

  names(arrivees) <- c("lon", "lat", "id", opportunities_colname)

  arrivees <- arrivees[!is.na(opportunities_colname),]

  resultat <- r5r::accessibility(r5r_core = r5r_core,
                                 origins = departs,
                                 destinations = arrivees,
                                 opportunities_colname = opportunities_colname,
                                 mode = mode, mode_egress = mode_egress,
                                 departure_datetime = departure_datetime,
                                 time_window = time_window, percentiles = percentiles,
                                 decay_function = decay_function, cutoffs = cutoffs, decay_value = decay_value,
                                 max_walk_dist = max_walk_dist, max_bike_dist = max_bike_dist, max_trip_duration = max_trip_duration,
                                 walk_speed = walk_speed, bike_speed = bike_speed, max_rides = max_rides,
                                 max_lts = max_lts, n_threads = n_threads, verbose = verbose, progress = progress)

  tictoc::toc()

  if (stars_result){
    acc_dt2stars(resultat, cutoffs = cutoffs, percentiles = percentiles, nom = opportunities_colname)
  } else {
    resultat
  }
}

#' Transform result of r5r::accessibiliy or st_accessibility from data.table to stars
#'
#' @param dt data.table of accessibility
#' @param cutoffs cutoffs of isochrones
#' @param percentiles percentiles of time travel
#' @param nom name of the opportunity which accessibility is evaluated
#'
#' @import data.table
acc_dt2stars <- function(dt, cutoffs, percentiles, nom = "accessibility") {

  grid_noms <- expand.grid(cutoffs, percentiles)
  names(grid_noms) <- c("cutoffs", "percentiles")
  if (length(percentiles) == 1) {
    if(length(cutoffs) == 1) {les_noms <- nom} else {les_noms <- paste0(nom, "_", cutoffs, "mn")}
  } else {
    if(length(cutoffs) == 1) {
      les_noms <- paste0(nom, "_", percentiles, "p")
    } else {
      les_noms <- paste0(nom, "_", grid_noms[, 1], "mn_", grid_noms[, 2], "p")
    }
  }

  res_stars <- purrr::imap(les_noms, ~ {
    res <- dt[percentile == grid_noms$percentiles[.y] & cutoff == grid_noms$cutoffs[.y], ][,
              ':='(percentile = NULL, cutoff = NULL)] |>
              dt2stars(idINS = "from_id")
    names(res) <- .x
    res
  })

  purrr::reduce(res_stars, c)

}


# TODO: 1. Load packages needed for operationalization
usePackage <- function(p) {
    if (!is.element(p, installed.packages()[, 1]))
        install.packages(p, dep = TRUE)
    library(p, character.only = TRUE)
}
usePackage()
usePackage()
usePackage()
usePackage()

# TODO: 2. Configure remote login
# Connect to R Server VM using remoteLogin
pause()

# Wrap model in an R function
apiPredictPurchasePrice <- function(age, gender, productSelected) {
    require(RevoScaleR);
    genders <- factor(c("M", "F"))
    products <- factor(c("coconut water", "soda", "water"))
    myInput <- data.frame(age = as.numeric(age),
                        purchasePrice = 1,
                        gender = genders[2],
                        productSelected = products[3]
    )
    myInput[1,]$age <- age
    myInput[1,]$gender <- gender
    myInput[1,]$productSelected <- productSelected
    prediction <- rxPredict(modelObject = pricingModel, data = myInput)
    purchasePrice <- prediction$purchasePrice_Pred
}

##########################################################
#             Publish Model as a Service                 #
##########################################################

# Generate a unique service name and assign to variable serviceName
serviceName <- "apiPredictPurchasePrice"

# Set `data-dir` to NULL, which will make the model file path
# below based off the PricingModel project path
serviceOption()$set("data-dir", NULL)

# Publish as service using publishService() function from
# mrsdeploy package. Name service and provide unique
# version number. Assign service to the variable `api`
try(deleteService(serviceName, "1.0"))
api <- publishService(
     serviceName,
     code = apiPredictPurchasePrice,
     model = "pricingModel.RData",
     inputs = list(age = "numeric", gender = "character", productSelected = "character"),
     outputs = list(purchasePrice = "numeric"),
     v = "1.0"
)

print("Published service")

# TODO: 3. Consume the API as a test
# Get the published API service (getService), execute apiPredictPurchasePrice with variables
# and print the result's "answer" output.

# TODO: 4. Generate the Swagger JSON file for the API
# Save the generated JSON file to the project directory


opt.table<-function(out.file,dirs,labels,first.y=2051,last.y=2051,stochastic=F,test=F,addFbar=F,tableIndicators=T,relativ=F){
   #####################
  for (dir in dirs) {
    if ( file.access(file.path(data.path,dir,"op.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
  }

  Init.function() # get SMS.contol object  including sp.names

  ref<-Read.reference.points.OP(dir=data.path)
  Blim<-as.vector(c(rep(-1, first.VPA-1),ref[,'Blim']))
  Bpa<-as.vector(c(rep(-1, first.VPA-1),ref[,'Bpa']))
  Fpa<-as.vector(c(rep(-1, first.VPA-1),ref[,'Fpa']))

  bb<-NULL
  for (dir in dirs) {
    a<-Read.OP.rep(dir=file.path(data.path,dir))
    a<-data.frame(scen=dir,objFunc=a$objFunc,npar=a$npar,maxGrad=a$maxGrad,Penalty=a$Penalty)
    bb<-rbind(bb,a)
  }
  bb<-data.frame(labels=labels,bb)
  print(bb)
  write.table(bb,file=file.path(paste(out.file,"_perform",'.out',sep='')),quote=F,row.names=F)

  b<-NULL
  for (dir in dirs) {
    a<-Read.OP.condensed(dir=file.path(data.path,dir))
    a<-droplevels(subset(a,Year>=first.y & Year<=last.y & Species !='Plaice' & Species !='Sole'))
    a<-data.frame(scen=dir,a)
    b<-rbind(b,a)

  }

  b$belowBlim<-ifelse(b$SSB<Blim[b$Species.n],1,0)
  b$belowBpa<-ifelse(b$SSB<Bpa[b$Species.n],1,0)
  b$aboveFpa<-ifelse(b$Fbar>Fpa[b$Species.n],1,0)

  minY<-min(b$Year)
  maxY<-max(b$Year)
  ny<-maxY-minY+1

  a<-aggregate(cbind(Fbar,yield,CWsum,value,SSB)~scen+Species.n+Species,mean,data=b)
  asd<-aggregate(cbind(yield,value,SSB)~scen+Species.n+Species,sd,data=b)
  hh<-dimnames(asd)[[2]]
  hh<-sub('yield', 'yieldSD',hh)
  hh<-sub('value', 'valueSD',hh)
  hh<-sub('SSB', 'SSBSD',hh)
  dimnames(asd)[[2]]<-hh
  a2<-aggregate(list(Fbarmax=b$Fbar),list(scen=b$scen,Species.n=b$Species.n,Species=b$Species),max)

  risk<-aggregate(cbind(belowBlim,belowBpa,aboveFpa)~scen+Species.n+Species,sum,data=b)
  risk$belowBlim<-risk$belowBlim*100/ny
  risk$belowBpa<-risk$belowBpa*100/ny
  risk$aboveFpa<-risk$aboveFpa*100/ny

  aa<-merge(a,a2)
  aa<-merge(aa,asd)
  aa<-merge(aa,risk)

  label<-data.frame(scen=dirs,labels)
  aa<-merge(aa,label)
  aa$lab1<-substr(aa$labels,1,1)
  aa$Species<-paste(aa$Species.n-first.VPA+1,'. ',aa$Species,sep='')
  a<-tapply(aa$Fbarmax,list(aa$Species,aa$labels),sum)
  if (addFbar) {
    a2<-tapply(aa$Fbar,list(aa$Species,aa$labels),sum)
    a<-cbind(a,a2)
  }

  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_F",'.html',sep='')),
             dec=rep(2,dim(a)[[2]]), width='"100%"',units=ifelse (addFbar, c(rep('FMSY',length(dirs)),rep('Fbar',length(dirs))), rep('FMSY',length(dirs))))

  if (relativ) {
    for (i in (2:dim(a)[[2]])) a[,i]<-a[,i]/a[,1]*100
    xtab(a, caption='', cornername='  ',
         file=file.path(paste(out.file,"_F_relativ",'.html',sep='')),
         dec=c(2,rep(0,dim(a)[[2]]-1)), width='"100%"',units=c(' ',rep('(% of default.)',length(dirs)-1)))
  }

  a<-tapply(aa$belowBlim ,list(aa$Species,aa$labels),sum)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_blim",'.html',sep='')),
             dec=rep(1,dim(a)[[2]]), width='"100%"',units=' ')

    a<-tapply(aa$yield ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$yield ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
   xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_yield",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

  if (relativ) {
    for (i in (2:dim(a)[[2]])) a[,i]<-a[,i]/a[,1]*100
    xtab(a, caption='', cornername='  ',
         file=file.path(paste(out.file,"_yield_relativ",'.html',sep='')),
         dec=rep(0,dim(a)[[2]]), width='"100%"',units=c('(kt) ',rep('(% of default.)',length(dirs)-1)))
  }

     a<-tapply(aa$CWsum-aa$yield ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$CWsum-aa$yield ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
   xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_discard",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

     a<-tapply(aa$yield ,list(aa$Species,aa$labels),sum)
     a2<-tapply(aa$yieldSD ,list(aa$Species,aa$labels),sum)
     a<-a2/a*100
     xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_yield_CV",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

     a<-tapply(aa$value ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$value ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_value",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

      a<-tapply(aa$SSB ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$SSB ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_SSB",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

  if (relativ) {
    for (i in (2:dim(a)[[2]])) a[,i]<-a[,i]/a[,1]*100
    xtab(a, caption='', cornername='  ',
         file=file.path(paste(out.file,"_SSB_relativ",'.html',sep='')),
         dec=rep(0,dim(a)[[2]]), width='"100%"',units=c('(kt) ',rep('(% of default.)',length(dirs)-1)))
  }

    a<-tapply(aa$SSB ,list(aa$Species,aa$labels),sum)
    a2<-tapply(aa$SSBSD ,list(aa$Species,aa$labels),sum)
    a<-a2/a*100

  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_SSB_CV",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

 if (tableIndicators) {
  b<-NULL
  for (dir in dirs) {
    a<-Read.OP.community.indicator(dir=file.path(data.path,dir))
    a<-droplevels(subset(a,Year>=first.y & Year<=last.y ))
    a<-data.frame(scen=dir,a)
    b<-rbind(b,a)
  }
  label<-data.frame(scen=dirs,labels)
  aa<-merge(b,label)
  aaa<-aggregate(cbind(bio.demer,bio.small,bio.pelag,bio.forage,comm.Fland,comm.Fall,comm.M,comm.M2,community.life.expect,LFI) ~ labels,data=aa,mean)

  b<-cbind(aaa$comm.M2*100,aaa$comm.Fall*100,aaa$LFI*100,aaa$community.life.expect,aaa$bio.forage/1000,aaa$bio.pelag/aaa$bio.demer)
  b<-t(b)

 dimnames(b)[[1]]<-c("Community M2 (%)","Community F (%)","LFI (%)","life expectancy (years)","Biomass forage (kt)","Biomass ratio pelagic:demersal")
   dimnames(b)[[2]]<-aaa$labels

   xtab3(b, caption='', cornername='  ',
             file=file.path(paste(out.file,"_sys_Indicators",'.html',sep='')),
             dec=c(0,0,0,2,0,2), width='"100%"',units=' ')
 }
}
#################

#dirs<-paste("D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D2f_HCR_2_0_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
dirs<-paste("D1c_HCR_1_1_Rec0_penBpa_atAgeW___CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1e_HCR_1_1_Rec0_penBlim____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1b_HCR_1_1_Rec0_penBlim_atAgeW___CVadj_limF_110_Oth",1:10,sep='')
labels<-c('01. Default','02. Birds','03. R. radiata','04. Gurnards','05. Mackerel','06. Horse Mackerel','07. Grey seal','08. Porpoise','09. Hake','10. All')
opt.table(out.file=file.path(data.path,'opti_compare_determ_HCR1_species_1c'),first.y=2043,last.y=2043,stochastic=F, test=T,
          dirs=dirs,relativ=T,
          labels=labels )

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

dirs<-c(
  "D1a_HCR_1_1_Rec0__atAgeW___CVadj_limF_110_",
  "D1d_HCR_1_1_Rec0_____CVadj_limF_110_",
  "D1b_HCR_1_1_Rec0_penBlim_atAgeW___CVadj_limF_110_",
  "D1e_HCR_1_1_Rec0_penBlim____CVadj_limF_110_",
  "D1c_HCR_1_1_Rec0_penBpa_atAgeW___CVadj_limF_110_",
  "D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_"
)

labels<-c(
  "Value",
  "Yield",
  "Value, penalize SSB < Blim",
  "Yield, penalize SSB < Blim",
  "Value, penalize SSB < Bpa",
  "Yield, penalize SSB < Bpa"
)

opt.table(out.file=file.path(data.path,'opti_compare_determ_Species_HCR1_all'),first.y=2034,last.y=2043,stochastic=F, test=T,
          dirs=dirs,
          labels=labels )

dirs<-c(
  "D2a_HCR_2_0_Rec0__atAgeW___CVadj_limF_110_",
  "D2d_HCR_2_0_Rec0_____CVadj_limF_110_",
  "D2b_HCR_2_0_Rec0_penBlim_atAgeW___CVadj_limF_110_",
  "D2e_HCR_2_0_Rec0_penBlim____CVadj_limF_110_",
  "D2c_HCR_2_0_Rec0_penBpa_atAgeW___CVadj_limF_110_",
  "D2f_HCR_2_0_Rec0_penBpa____CVadj_limF_110_"
)

labels<-c(
  "Value",
  "Yield",
  "Value, penalize SSB < Blim",
  "Yield, penalize SSB < Blim",
  "Value, penalize SSB < Bpa",
  "Yield, penalize SSB < Bpa"
)

opt.table(out.file=file.path(data.path,'opti_compare_determ_Species_HCR2'),first.y=2034,last.y=2043,stochastic=F, test=T,
          dirs=dirs,
          labels=labels )


#!/usr/local/bin/rscript

# Clean-up script for the NWOS data
MINIMUM_ACERAGE = 10

# Load the contents of the file and perform a basic data clean-up
loadData <- function(file, tax = TRUE) {
	raw <- read.csv(file, header = TRUE)
	raw = raw[, -c(1)]								# Toss out the row names
	raw = raw[raw$Freq != 0, ]						# Toss out frequencies of zero
	raw = raw[raw$AC_WOOD >= MINIMUM_ACERAGE, ] 	# Toss out anything below our minimum acerage to include null responses

	# TODO Update everything to make use of tax data
	if (tax) {
		raw = raw[, -c(3)]
	}

	# Toss out all of the invalid ACT_CUT_SALE responses before removing the column
	raw = raw[raw$ACT_CUT_SALE != -1, ]
	raw = raw[, -c(2)]

	# Repalce parcel sizes with liguistic variables { small, medium, large }
	raw$parcel <- NA
	raw[raw$AC_WOOD < 40, ]$parcel = 'small'
	raw[raw$AC_WOOD >= 100, ]$parcel = 'large'
	raw[is.na(raw$parcel), ]$parcel = 'medium'

	# Drop the AC_WOOD column
	raw = raw[, -c(1)]

	# Update the column order and return
	return(raw)
}

# This function processes response data that is part of a 1:5 range of values
process <- function(file) {
	print(file)

	# Load the data and note the index of the relevent variable
	data = loadData(file)
	name = strsplit(basename(file), '\\.')[[1]][1]
	index = grep(name, colnames(data))

	# Process and aggregate the data
	data = data[data[index] > 0, ]				# Discard null responses
	data[data[index] == 8, ][index] = 1			# Rescore NA as no concern
	data = aggregate(Freq ~ ., data = data, sum)

	# Find the odds to use for the data
	data = findOdds(data)

	# Save the results
	file = paste('../nwos/clean/', basename(file), sep = '')
	write.csv(data, file, row.names = FALSE)
}

# This function processes repsones data that is binary (i.e., yes/no)
processBinary <- function(file, dontKnow) {
	print(file)

	# Load the data
	data = loadData(file, FALSE)

	# TODO Update things to make use of green certification; however this
	# TODO field can be discarded for managment plans
	data = data[, -c(2)]

	# Note the name and index
	name = strsplit(basename(file), '\\.')[[1]][1]
	index = grep(name, colnames(data))

	# Process and aggregate the data
	data = data[data[index] >= 0, ]					# Discard null responses
	if (dontKnow) {
		data[data[index] == 9, ][index] = 0			# Rescore 'Don't Know' as no
	}
	data = aggregate(Freq ~ ., data = data, sum)

	# Find the odds to use for the data
	data = findOdds(data, 2)

	# Save the results
	file = paste('../nwos/clean/', basename(file), sep = '')
	write.csv(data, file, row.names = FALSE)
}

findOdds <- function(data, range = 5) {
	for (label in c('small', 'medium', 'large')) {
		# Find the distributions for each group
		total = sum(data[data$parcel == label, ]$Freq)
		data[data$parcel == label, ]$Freq = data[data$parcel == label, ]$Freq / total

		# Make the distributions act as cummulative sums
		for (index in c(2:range)) {
			previous = data[data$parcel == label, ][index - 1, ]$Freq
			value = data[data$parcel == label, ][index, ]$Freq

			data[data$parcel == label, ][index, ]$Freq = previous + value
		}
	}
	return(data)
}

main <- function() {
	dir.create('../nwos/clean', showWarnings = FALSE)

	processBinary('../nwos/raw/CERT.csv', TRUE)
	processBinary('../nwos/raw/MAN_PLAN.csv', FALSE)
	return()

	process('../nwos/raw/CNC_CLIM.csv')
	process('../nwos/raw/CNC_DEV.csv')
	process('../nwos/raw/CNC_FIRE.csv')
	process('../nwos/raw/CNC_TAX.csv')
	process('../nwos/raw/CNC_TRES.csv')
	#process('../nwos/raw/CUT_LOG_SALE.csv')

	process('../nwos/raw/OBJ_BEA.csv')
	process('../nwos/raw/OBJ_CHILD.csv')
	process('../nwos/raw/OBJ_HUNT.csv')
	process('../nwos/raw/OBJ_INV.csv')
	process('../nwos/raw/OBJ_NAT.csv')
	process('../nwos/raw/OBJ_PRI.csv')
	process('../nwos/raw/OBJ_REC.csv')
	process('../nwos/raw/OBJ_TIM.csv')
	process('../nwos/raw/OBJ_WAT.csv')
	process('../nwos/raw/OBJ_WIL.csv')
}
main()


#!/usr/bin/Rscript

## pwsummary2pdf.r -- Converts a pairwise summary (such as that generated from
## pwsummary.txt in 2_maximal.pl) into a heatmap PDF file

## Author: David Eccles (gringer), 2008 <programming@gringer.org>

usage <- function(){
  cat("usage: ./pwsummary2pdf.r <top/right file> [bottom/left file]\n");
  cat("[creates output_pwheatmap.(pdf|svg)]\n");
}

argLoc <- 1;
topFile <- FALSE;
bottomFile <- FALSE;
doSVG <- FALSE;
asImage <- TRUE;
scaleBottom <- TRUE; # should the bottom SNPs be scaled?
preserveGroups <- FALSE; # preserve known groupings when clustering
out.filename <- "output_pwheatmap.pdf";
popLimits <- NULL;
popNames <- NULL;
ignoreIndivs <- NULL;
indLabelSize <- NULL;
showLabels <- TRUE;
startIgnore <- FALSE;
makeDendrogram <- FALSE;

while(!is.na(commandArgs(TRUE)[argLoc])){
  if(file.exists(commandArgs(TRUE)[argLoc])){ # file existence check
    print(paste("found file:",commandArgs(TRUE)[argLoc]));
    if(topFile == FALSE){
      topFile <- commandArgs(TRUE)[argLoc];
    } else {
      if(bottomFile == FALSE){
        bottomFile <- commandArgs(TRUE)[argLoc];
      } else{
        cat("Error: More than two input files specified\n");
        cat("usage: ./pwsummary2pdf.r <top/right file> [bottom/left file]\n");
        quit(save="no", status=2);
      }
    }
  }
  else{ # other command line arguments
    if(commandArgs(TRUE)[argLoc] == "-ignore"){
      startIgnore <- TRUE;
    } else {
      if(startIgnore && length(grep("^[0-9]",commandArgs(TRUE)[argLoc])) != 0){
        ignoreIndivs <-
          append(ignoreIndivs,as.numeric(commandArgs(TRUE)[argLoc]));
        cat("Ignoring individual ",
            as.numeric(commandArgs(TRUE)[argLoc]),"\n",sep="");
      }
      else{
        startIgnore <- FALSE;
      }
    }
    if(commandArgs(TRUE)[argLoc] == "-svg"){
      library(cairoDevice);
      doSVG <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-image"){
      asImage <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-nolabels"){
      showLabels <- FALSE;
    }
    if(commandArgs(TRUE)[argLoc] == "-dendrogram"){
      makeDendrogram <- TRUE;
    }
    if(commandArgs(TRUE)[argLoc] == "-heatmap"){
      asImage <- FALSE;
    }
    if(commandArgs(TRUE)[argLoc] == "-noscale"){
      scaleBottom <- FALSE;
    }
    if(commandArgs(TRUE)[argLoc] == "-size"){
      indLabelSize <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      cat("Changing label size to ", as.numeric(commandArgs(TRUE)[argLoc+1]),"\n",sep="");
      argLoc <- argLoc + 1;
    }
    if(substr(commandArgs(TRUE)[argLoc],1,1) == "p"){
      popNames <- append(popNames, substring(commandArgs(TRUE)[argLoc],2));
      popLimits <- cbind(popLimits,c(as.numeric(commandArgs(TRUE)[argLoc+1]),
                                     as.numeric(commandArgs(TRUE)[argLoc+2])));
      argLoc <- argLoc + 2;
    }
  }
  argLoc <- argLoc + 1;
}
if(doSVG){
  out.filename <- sub(".pdf", ".svg", out.filename);
}

if(topFile == FALSE){
  cat("Error: No [valid] input files specified\n");
  cat("usage: ./pwsummary2pdf.r <top/right file> [bottom/left file]\n");
  quit(save="no", status=2);
}

if(bottomFile == FALSE){
  bottomFile <- topFile;
}

#if(makeDendrogram && (!is.null(popNames))){
#  cat("Error: Dendrogram is incompatible with defined populations\n");
#  cat("usage: ./pwsummary2pdf.r <top/right file> [bottom/left file]\n");
#  quit(save="no", status=2);
#}

##load library for heatmap clusters and sorts
library(gtools, warn.conflicts = FALSE);
library(gdata, warn.conflicts = FALSE);
library(gplots, warn.conflicts = FALSE);
##load top/right comparisons
line = "dummy value"
pw.file = gzfile(topFile);
open(pw.file);
while(length(line)>0){
  line = unlist(readLines(pw.file, n=1));
  if(length(line)>0){
    line = unlist(line);
    if(length(grep("^Pairwise: +[0-9]", line))>0){
      top.pwvalues = as.numeric(unlist(strsplit(line," +"))[-1])
    }
  }
}
close(pw.file);
## determine number of rows
## derived from triangle(x) = (x + x^2) / 2
top.pw.rows <- (sqrt(1+8*length(top.pwvalues)) - 1) / 2 + 1;
## load bottom/left comparisons
line = "dummy value"
pw.file = file(bottomFile, "r", blocking = FALSE)
while(length(line)>0){
  line = unlist(readLines(pw.file, n=1));
  if(length(line)>0){
    line = unlist(line);
    if(length(grep("^Pairwise: +[0-9]", line))>0){
      bottom.pwvalues = as.numeric(unlist(strsplit(line," +"))[-1])
    }
  }
}
close(pw.file)
## determine number of rows
bottom.pw.rows <- (sqrt(1+8*length(bottom.pwvalues)) - 1) / 2 + 1;
if(top.pw.rows != bottom.pw.rows){
  cat("Error: Number of rows in input files differ\n");
  cat("Please choose data sets that have the same cardinality.\n");
  cat("usage: ./pwsummary2pdf.r <top/right file> [bottom/left file]\n");
  quit(save="no", status=2);
}
## scale lower pairwise values to make top colours look nicer
## (makes pw values fit into same range as ref values)
if(scaleBottom){
  top.min = min(top.pwvalues, na.rm = TRUE);
  top.max = max(top.pwvalues, na.rm = TRUE);
  bottom.min = min(bottom.pwvalues, na.rm = TRUE);
  bottom.max = max(bottom.pwvalues, na.rm = TRUE);
  bottom.scale = (bottom.max - bottom.min);
  top.scale = (top.max - top.min);
  bottom.pwvalues = ((bottom.pwvalues - bottom.min)/bottom.scale) *
    top.scale + top.min;
}
## convert values to matrix
top.matrix <- matrix(NA,top.pw.rows,top.pw.rows);
top.matrix[which(lower.tri(top.matrix))] <- top.pwvalues;
top.matrix <- t(top.matrix);
top.matrix[which(lower.tri(top.matrix))] <- top.pwvalues;
bottom.matrix <- matrix(NA,top.pw.rows,top.pw.rows);
bottom.matrix[which(lower.tri(bottom.matrix))] <- bottom.pwvalues;
bottom.matrix <- t(bottom.matrix);
bottom.matrix[which(lower.tri(bottom.matrix))] <- bottom.pwvalues;
## set up reference matrix for dendrogram
ref.matrix <- top.matrix;
if(!is.null(popLimits)){
  cat("Mean, SD of similarity for named population groups:\n");
  for(x in 1:(dim(popLimits)[2])){
    for(y in x:(dim(popLimits)[2])){
      cat(popNames[x]," vs ",popNames[y],": mean = ",
          mean(ref.matrix[popLimits[1,x]:popLimits[2,x],
                         popLimits[1,y]:popLimits[2,y]], na.rm = TRUE),
          ", sd = ",
          sd(as.vector(ref.matrix[popLimits[1,x]:popLimits[2,x],
                                 popLimits[1,y]:popLimits[2,y]]), na.rm = TRUE),
          "\n",sep="");
    }
  }
}
## remove data for intermediate values for dendrogram creation
cluster.matrix <- ref.matrix;
if(!is.null(popLimits)){
  for(x in 1:(dim(popLimits)[2])){
    for(y in 1:(dim(popLimits)[2])){
      if(x != y){
##        cluster.matrix[popLimits[1,x]:popLimits[2,x],
##                       popLimits[1,y]:popLimits[2,y]] <- 0;
      }
    }
  }
}
ref.matrix <- cluster.matrix;
## reorder individuals based on hierarchical ranking
## if groupings should be preserved, then do things on a per-group basis
## (and to keep things simple, only re-order individuals in specifed groups)
if(!is.null(popLimits) && preserveGroups){
  popOrder <- NULL;
  for(x in 1:(dim(popLimits)[2])){
    ## copy subset of table for this population
    popref.matrix <-
      ref.matrix[popLimits[1,x]:popLimits[2,x],
                popLimits[1,x]:popLimits[2,x]];
    ref.means <- colMeans(popref.matrix, na.rm = TRUE);
    hcc <- hclust(dist(popref.matrix));
    ddc <- reorder(as.dendrogram(hcc), ref.means);
    hcc <- rev(order.dendrogram(ddc)) + popLimits[1,x] - 1;
    popOrder <- append(popOrder,hcc);
  }
  if(length(popOrder) == top.pw.rows){
    hcc <- rev(popOrder);
    if(!is.null(ignoreIndivs)){
      ref.matrix[ignoreIndivs,] <- NA;
      ref.matrix[,ignoreIndivs] <- NA;
    }
    dend.matrix <- ref.matrix[hcc,hcc];
  } else{
    top.pw.rows <- length(popOrder);
    bottom.pw.rows <- length(popOrder);
    cat("Warning: Populations defined, but do not cover all individuals.\n");
    cat("Warning: [The resultant table will be smaller,",
        "and may not display correctly]\n");
    hcc <- rev(popOrder);
    if(!is.null(ignoreIndivs)){
      ref.matrix[ignoreIndivs,] <- NA;
      ref.matrix[,ignoreIndivs] <- NA;
    }
    dend.matrix <- ref.matrix[hcc,hcc];
  }
} else {
  ref.means <- colMeans(ref.matrix, na.rm = TRUE);
  hcc <- hclust(dist(ref.matrix));
  ddc <- reorder(as.dendrogram(hcc), ref.means);
  hcc <- rev(order.dendrogram(ddc));
  if(!is.null(ignoreIndivs)){
    ref.matrix[ignoreIndivs,] <- NA;
    ref.matrix[,ignoreIndivs] <- NA;
  }
  dend.matrix <- ref.matrix[hcc,hcc];
}
## put reordered bottom values into matrix
if(!is.null(ignoreIndivs)){
  bottom.matrix[ignoreIndivs,] <- NA;
  bottom.matrix[,ignoreIndivs] <- NA;
}
pw.matrix <- bottom.matrix[hcc,hcc];
rownames(pw.matrix) <- rev(hcc);
colnames(pw.matrix) <- rev(hcc);
## put reordered top values into matrix
pw.matrix[which(upper.tri(pw.matrix))] =
  dend.matrix[which(upper.tri(dend.matrix))];
##calculate range for data for heatmap z limits
zRange <- c(min(pw.matrix,na.rm=TRUE),max(pw.matrix,na.rm=TRUE));
## make key
if(doSVG){
  Cairo_svg(paste("key_",out.filename,sep=""), width = 4.8, height = 2.7);
} else {
  pdf(paste("key_",out.filename,sep=""), width = 4.8, height = 2.7);
}
oldPar <- par(no.readonly = TRUE);
par(mar = c(2,1,2.5,1), mgp = c(2,0.75,0), bg = "white");
image(x=seq(zRange[1],zRange[2],length.out=100),y=0.5,
      z = cbind(seq(zRange[1],zRange[2],length.out=100)),
      col = topo.colors(100), main = "Mean IBS Value",
      yaxt = "n", ylab = "", xlab = "", cex.axis = 1.5, cex.main = 2);
box("figure",lwd = 2);
dummy <- dev.off();
par(oldPar);
##initiate PDF generation
fileWidth <- 8;
if(makeDendrogram && asImage){
  fileWidth <- 11;
}
fileHeight <- 8;
if(doSVG){
    Cairo_svg(out.filename, width = fileWidth, height = fileHeight);
} else {
  pdf(out.filename, width = fileWidth, height = fileHeight);
}
##make heatmap
if(is.null(indLabelSize)){
  ## a rough guess on the best size
  ## based on 0.4 being good for 120 individuals]
  indLabelSize <- ( 50 / top.pw.rows );
}
if(asImage){
  if(makeDendrogram){
    layout(rbind(c(1,2)), widths = c(3/11,8/11));
    par(mar=c(2,0,0.5,0)); # bottom, left, top, right
    plot(rev(ddc), horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none");
    if(!is.null(popLimits)){
      for(x in 1:(dim(popLimits)[2])){
        popNames[x] <- gsub("\\\\n","\n",popNames[x]);
          text(0.45,top.pw.rows - (popLimits[1,x] + popLimits[2,x]) / 2 + 1,
               popNames[x], cex = 2);
      }
    }
  }
  par(mar=c(2,0.5,0.5,2)); # bottom, left, top, right
  image(1:top.pw.rows, 1:top.pw.rows, pw.matrix[ncol(pw.matrix):1,], col =
        topo.colors(100), axes=FALSE, xlab = "", ylab = "", zlim = zRange);
  axis(1, at = top.pw.rows:1, labels=hcc, las = 2, line = -0.5, tick =
       0, cex.axis = indLabelSize);
  axis(4, at = 1:top.pw.rows, labels=hcc, las = 2, line = -0.5, tick =
       0, cex.axis = indLabelSize);
  if(!makeDendrogram){
    if(!is.null(popLimits)){
      for(x in 1:(dim(popLimits)[2])){
        for(y in x:(dim(popLimits)[2])){
          rect(popLimits[1,y] - 0.5, top.pw.rows - popLimits[2,x] + 0.5,
               popLimits[2,y] + 0.5, top.pw.rows - popLimits[1,x] + 1.5, lwd = 2);
          if(showLabels){
            if(x == y){
              text(popLimits[1,y] + (popLimits[2,y] - popLimits[1,y]) * 0.75,
                   top.pw.rows -
                   (popLimits[1,x] + (popLimits[2,x] - popLimits[1,x]) * 0.25),
                   popNames[x], cex = 2, adj = c(0.5,0.5),
                   srt = -45, offset = 0);
            } else {
              text(popLimits[1,y] + (popLimits[2,y] - popLimits[1,y]) * 0.5,
                   top.pw.rows -
                   (popLimits[1,x] + (popLimits[2,x] - popLimits[1,x]) * 0.5),
                   paste(popNames[x],"vs",popNames[y]), cex = 2,
                   adj = c(0.5,0.5), offset = 0);
            }
          }
        }
      }
    }
  }
} else {
  if(makeDendrogram){
    heatmap.2(as.matrix(pw.matrix), symm = TRUE, trace = 'none', Rowv =
              TRUE, key = TRUE, dendrogram = 'row', density.info =
              'none', col = topo.colors(100), main =
              paste("Pairwise similarity heatmap"), xlab = "Row ID",
              zlim = zRange,
              keysize = 1.2, cexRow = indLabelSize, cexCol = indLabelSize);
  } else {
    heatmap.2(as.matrix(pw.matrix), symm = TRUE, trace = 'none', Rowv =
              FALSE, key = TRUE, dendrogram = 'none', density.info =
              'none', col = topo.colors(100), main =
              paste("Pairwise similarity heatmap"), xlab = "Row ID",
              zlim = zRange,
              keysize = 1.2, cexRow = indLabelSize, cexCol = indLabelSize);
  }
}
dummy <- dev.off();


##   Copyright 2021 Neil Ferguson, Imperial College London
##
##   Licensed under the Apache License, Version 2.0 (the "License");
##   you may not use this file except in compliance with the License.
##   You may obtain a copy of the License at
##
##     http://www.apache.org/licenses/LICENSE-2.0
##
##   Unless required by applicable law or agreed to in writing, software
##   distributed under the License is distributed on an "AS IS" BASIS,
##   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
##   See the License for the specific language governing permissions and
##   limitations under the License.

source("libs.r")
source("plots.r")
source("read_data.r")
library(gridExtra)

options(mc.cores=12)
options(max.print=10000)

### compare ORF1ab data data fits ("N" is a old tag for "New")
loo_res.N4pca=readRDS("f_ataN_4p1F_4group_voc_incvacc2_tsd4_corr1_age1_loo.rds")
loo_res.N1pc=readRDS("f_ataN_4p1F_1group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_res.N4p=readRDS("f_ataN_4p1F_4group_voc_incvacc2_tsd4_corr0_loo.rds")
loo_res.N4pc=readRDS("f_ataN_4p1F_4group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_res.N1t=readRDS("f_ataN_4t2F_1group_voc_incvacc2_tsd4_corr0_loo.rds")
loo_res.N1tc=readRDS("f_ataN_4t2F_1group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_comp.N=loo_compare(loo_res.N4pca,loo_res.N4pc,loo_res.N1tc,loo_res.N1pc,loo_res.N4p,loo_res.N1t)
print(loo_comp.N, simplify = FALSE, digits = 3)

### compare E gene data fits
loo_res.E4pca=readRDS("f_ataE_4p1F_4group_voc_incvacc2_tsd4_corr1_age1_loo.rds")
loo_res.E1pc=readRDS("f_ataE_4p1F_1group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_res.E4p=readRDS("f_ataE_4p1F_4group_voc_incvacc2_tsd4_corr0_loo.rds")
loo_res.E4pc=readRDS("f_ataE_4p1F_4group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_res.E1t=readRDS("f_ataE_4t2F_1group_voc_incvacc2_tsd4_corr0_loo.rds")
loo_res.E1tc=readRDS("f_ataE_4t2F_1group_voc_incvacc2_tsd4_corr1_loo.rds")
loo_comp.E=loo_compare(loo_res.E4pca,loo_res.E4pc,loo_res.E1pc,loo_res.E4p,loo_res.E1tc,loo_res.E1t)
print(loo_comp.E, simplify = FALSE, digits = 3)

### outputs for Table S4
loo_res.N4pca
loo_res.N4pc
loo_res.N1tc
loo_res.N1pc
loo_res.N4p
loo_res.N1t

loo_res.E4pca
loo_res.E4pc
loo_res.E1pc
loo_res.E4p
loo_res.E1tc
loo_res.E1t

### load best fit models

fit.N4pca=readRDS("f_ataN_4p1F_4group_voc_incvacc2_tsd4_corr1_age1.rds")
fit.E4pca=readRDS("f_ataE_4p1F_4group_voc_incvacc2_tsd4_corr1_age1.rds")

fit.N4pc=readRDS("f_ataN_4p1F_4group_voc_incvacc2_tsd4_corr1_age1.rds")
fit.E4pc=readRDS("f_ataE_4p1F_4group_voc_incvacc2_tsd4_corr1_age1.rds")

### ORF1ab gene results
fit=fit.N4pca
# fit=fit.E4pca  # for E-gene results

#extract posterior samples
posterior <- rstan::extract(fit, inc_warmup = FALSE, permuted = TRUE)

### looking at individual-level parameter estimates (not included in paper)

# assemble dataframe of individual level mean posterior estimates and 95% CrI
group_names=c("pre-Alpha","Alpha","Delta-unvacc","Delta-vacc")
PersonID=data_list$subjects$PersonID
voc=1+data_list$subjects$voc
age=data_list$subjects$age

# means
PeakVL=colMeans(posterior$p_ln_v_max)/log(10)
VLg=colMeans(posterior$p_v[,,2])/log(10)
VLd=colMeans(posterior$p_v[,,3])/log(10)

# CrI for Peak VL
tmp=as.data.frame(posterior$p_ln_v_max)/log(10)
PeakVL_r <-  tmp %>%
  summarise(across(.cols = everything(),~quantile(.x, probs = c(0.025,0.975))))
PeakVL_r=as.data.frame(t(PeakVL_r))
names(PeakVL_r)=c("PeakVL_0.025","PeakVL_0.975")
# CrI for growth rate
tmp=as.data.frame(posterior$p_v[,,2])/log(10)
VLg_r <-  tmp %>%
  summarise(across(.cols = everything(),~quantile(.x, probs = c(0.025,0.975))))
# CrI for decline rate
tmp=as.data.frame(posterior$p_v[,,3])/log(10)
VLg_r=as.data.frame(t(VLg_r))
names(VLg_r)=c("VLg_0.025","VLg_0.975")
VLd_r <-  tmp %>%
  summarise(across(.cols = everything(),~quantile(.x, probs = c(0.025,0.975))))
VLd_r=as.data.frame(t(VLd_r))
names(VLd_r)=c("VLd_0.025","VLd_0.975")
# put in single dataframe
results <- as.data.frame(cbind(PersonID,age,voc,PeakVL,PeakVL_r,VLg,VLg_r,VLd,VLd_r))
results$voc_group <- as.factor(group_names[results$voc])
results$voc_group <- factor(results$voc_group,levels=group_names)

# now calculate averages across VOC groups
results.sum=NULL
for(i in 1:4) {
  PeakVL=mean(posterior$v_max_voc[,i])/log(10)
  PeakVL_0.025=quantile(posterior$v_max_voc[,i],probs=0.025)/log(10)
  PeakVL_0.975=quantile(posterior$v_max_voc[,i],probs=0.975)/log(10)
  VLg=mean(posterior$v_a_voc[,i])/log(10)
  VLg_0.025=quantile(posterior$v_a_voc[,i],probs=0.025)/log(10)
  VLg_0.975=quantile(posterior$v_a_voc[,i],probs=0.975)/log(10)
  VLd=mean(posterior$v_b_voc[,i])/log(10)
  VLd_0.025=quantile(posterior$v_b_voc[,i],probs=0.025)/log(10)
  VLd_0.975=quantile(posterior$v_b_voc[,i],probs=0.975)/log(10)
  voc=i
  tmp=as.data.frame(t(c(voc,PeakVL,PeakVL_0.025,PeakVL_0.975,VLg,VLg_0.025,VLg_0.975,VLd,VLd_0.025,VLd_0.975)))
  names(tmp)=c("voc","PeakVL","PeakVL_0.025","PeakVL_0.975","VLg","VLg_0.025","VLg_0.975","VLd","VLd_0.025","VLd_0.975")
  results.sum=rbind(results.sum,tmp)
}
results.sum$voc_group <- as.factor(group_names[results.sum$voc])
results.sum$voc_group <- factor(results.sum$voc_group,levels=group_names)

#plot dependence of peak VL on age

res.f=results[results$PeakVL>1.4,]
res.f$PeakVL=res.f$PeakVL-results.sum$PeakVL[res.f$voc]
res.f$PeakVL_0.025=res.f$PeakVL_0.025-results.sum$PeakVL[res.f$voc]
res.f$PeakVL_0.975=res.f$PeakVL_0.975-results.sum$PeakVL[res.f$voc]
res.f$log_age=log(res.f$age)
res.f$g="regression"
p <- ggplot(res.f, aes(x=log_age, y=PeakVL, ymin=PeakVL_0.025, ymax=PeakVL_0.975, colour=voc_group)) +
  geom_point() +
#  geom_smooth(data=res.f, method='lm', formula= y~x) +
  geom_smooth(data=res.f, method='lm', formula= y~x, aes(x=log_age, y=PeakVL, colour=g)) +
#  geom_pointrange(size = 0.3,position="jitter") +
  xlab("Age") +ylab("log10(Peak VL)") + # coord_cartesian(ylim=c(6,9.5)) +
  theme_classic() + theme(legend.position="right") +
  theme(strip.background = element_blank())

p
ggsave(paste0("figAge.pdf"), p, width=8, height = 4.5)

cor.test(res.f$PeakVL,res.f$log_age,method = "pearson")

# nice plot of group level and individual level estimates

p1<-ggplot(results, aes(x=1, y=PeakVL, ymin=PeakVL_0.025, ymax=PeakVL_0.975, colour=voc_group)) +
  facet_wrap(~voc_group) +
  geom_boxplot(data=results.sum,stat = "identity",aes(lower=PeakVL_0.025,middle=PeakVL,upper=PeakVL_0.975)) +
  geom_pointrange(size = 0.3, position = "jitter") +
  xlab("") +ylab("log10(Peak VL)") + coord_cartesian(ylim=c(6,9.5)) +
  theme_classic() + theme(legend.position="none") +
  theme(strip.background = element_blank(), axis.line.x = element_blank()) +
  theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())

p2<-ggplot(results, aes(x=1, y=VLg, ymin=VLg_0.025, ymax=VLg_0.975, colour=voc_group)) +
  facet_wrap(~voc_group) +
  geom_boxplot(data=results.sum,stat = "identity",aes(lower=VLg_0.025,middle=VLg,upper=VLg_0.975)) +
  geom_pointrange(size = 0.3, position = "jitter") +
  xlab("") +ylab("VL growth rate (log10 units/day)") + coord_cartesian(ylim=c(0,15)) +
  theme_classic() + theme(legend.position="none") +
  theme(strip.background = element_blank(), axis.line.x = element_blank()) +
  theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())

p3<-ggplot(results, aes(x=1, y=VLd, ymin=VLd_0.025, ymax=VLd_0.975, colour=voc_group)) +
  facet_wrap(~voc_group) +
  geom_boxplot(data=results.sum,stat = "identity",aes(lower=VLd_0.025,middle=VLd,upper=VLd_0.975)) +
  geom_pointrange(size = 0.3, position = "jitter") +
  xlab("") +ylab("VL decline rate (log10 units/day)") + coord_cartesian(ylim=c(0,2.5)) +
  theme_classic() + theme(legend.position="none") +
  theme(strip.background = element_blank(), axis.line.x = element_blank()) +
  theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())

pl1 = grid.arrange(p1,p2,p3,ncol=3)
pl1

ggsave(paste0("figNew.svg"), pl1, width=8, height = 4.5)

## calculate posterior probabilities of kinetic parameters differing between groups - Tables S9/S10

# .p variables are group level, .mp are within-sample averages

post.v_max.p=array(rep(0,16),dim=c(4,4))
post.v_a.p=array(rep(0,16),dim=c(4,4))
post.v_b.p=array(rep(0,16),dim=c(4,4))

post.v_max.mp=array(rep(0,16),dim=c(4,4))
post.v_a.mp=array(rep(0,16),dim=c(4,4))
post.v_b.mp=array(rep(0,16),dim=c(4,4))

for(i in 1:4)
  for(j in 1:4) {
    tmp=ifelse(posterior$v[,1,j] >= posterior$v[,1,i],1,0)
    post.v_max.p[i,j]=sum(tmp)/length(tmp)
    tmp=ifelse(posterior$v_mean[,2,j] >= posterior$v_mean[,2,i],1,0)
    post.v_a.p[i,j]=sum(tmp)/length(tmp)
    tmp=ifelse(posterior$v_mean[,3,j] >= posterior$v_mean[,3,i],1,0)
    post.v_b.p[i,j]=sum(tmp)/length(tmp)

    tmp=ifelse(posterior$v_max_voc[,j] >= posterior$v_max_voc[,i],1,0)
    post.v_max.mp[i,j]=sum(tmp)/length(tmp)
    tmp=ifelse(posterior$v_a_voc[,j] >= posterior$v_a_voc[,i],1,0)
    post.v_a.mp[i,j]=sum(tmp)/length(tmp)
    tmp=ifelse(posterior$v_b_voc[,j] >= posterior$v_b_voc[,i],1,0)
    post.v_b.mp[i,j]=sum(tmp)/length(tmp)
    tmp=ifelse(posterior$t_a_voc[,j] >= posterior$t_a_voc[,i],1,0)
  }
post.v_max.p
post.v_a.p
post.v_b.p
post.v_max.mp
post.v_a.mp
post.v_b.mp

# posterior estimates for Tables S5/S6
# peak VL, growth rate and decline rate have been divided by ln(10) in Tables 3, S5 & S6 to put results on log10 VL scale

# within sample
print(fit, probs=c(0.025, 0.5, 0.975), pars = c("v_max_voc","v_a_voc","v_b_voc"), digits = 3)

# group level (note v[1,j] is peak VL on ln(VL) scale, v_mean[2,j] is growth rate on linear scale, v[3,j] is decline rate])

print(fit, probs=c(0.025, 0.5, 0.975), pars = c("v","v_mean"), digits = 3)

# estimates for tables S7/S8

print(fit, probs=c(0.025, 0.5, 0.975), pars = c("age_slope","v", "v_sd","Omega","v_s","fp","fp_ct_mean",
                                                "fp_ct_sd"), digits = 3)


#' Plot topological roles
#'
#' @param tRoles Calculated topological roles with the function calc_topological_roles
#' @param g Igraph network object
#' @param spingB Igraph community object
#'
#' @return
#' @export
#'
#' @examples
plot_topological_roles <- function(tRoles,g,spingB){

  spingB.mem<- spingB$membership

  l <- tRoles$within_module_degree
  r <- tRoles$among_module_conn

  # Plot
  require(RColorBrewer)
  colbar.FG <- brewer.pal(length(spingB$csize),"Dark2")
  groups.B<- spingB.mem # 1=phytopl, 2=zoopl, 3=benthos, 4=fish, 5=birds, 6=mammals

  par(mfrow=c(1,1))
  par(oma=c(2.7,1.3,0.7,1)) # change outer figure margins
  par(mai=c(1,1,0.7,0.7)) # size of figure margins
  yran <- range(l)
  xran <- range(r)
  plot(l~r, type="n", axes=T ,tck=F, lwd=2, ann=F, cex.axis=1.2, xlim=xran, ylim=yran)
  lines(c(0.625,0.625), yran, col="grey")
  lines(xran, c(2.5, 2.5), col="grey")
  points(r, l, col=colbar.FG[groups.B], pch=20, cex=2)
  mtext(2, text="Within module degree", line=4,font=2, cex=1.2)
  mtext(1, text="Among module connectivity",line=4, font=2, cex=1.2)
  axis(1, tck=0.02, lwd=1,las=2,lty=1, labels=F, xlim=c(0,1))
  axis(2,tck=0.02, labels=FALSE)

  # Which are the module hubs: many links within its own module.
  #
  modhub <- which(l>2.5)
  modhub <- modhub[which(l>2.5) %in% which(r<=0.625)]
  modlbl <- unlist(vertex_attr(g,index=modhub))
  if(is.null(modlbl))
     modlbl <- modhub
  hub_conn <- data.frame()

  if(length(modhub)) {
     text(r[modhub],l[modhub],labels = modlbl,cex=0.7,pos=3)
     hub_conn <- data.frame(type="modhub",node=modhub,name=modlbl)
  }

  #points(r[modhub], l[modhub], cex=4, col="blue", pch=20)

  # Which are the hub connectors: high within and between-module connectivity
  #                              and are classified super-generalists
  #
  modhub <- which(l>2.5)
  modhub <- modhub[which(l>2.5) %in% which(r>0.625)]
  modlbl <- unlist(vertex_attr(g,index=modhub))
  if(is.null(modlbl))
     modlbl <- modhub
  if(length(modhub)) {
     text(r[modhub],l[modhub],labels = modlbl,cex=0.7,pos=3)
  }

  #points(r[modhub], l[modhub], cex=4, col="blue", pch=20)
  if(length(modhub)){
     hub_conn <- rbind(hub_conn, data.frame(type="hubcon",node=modhub,name=modlbl))
  }

  # Which are the module specialist: Few links and most of them within its own module
  #
  modhub <- which(l<=2.5)
  modhub <- modhub[which(l<=2.5) %in% which(r<=0.625)]
  modlbl <- unlist(vertex_attr(g,index=modhub))
  if(is.null(modlbl))
     modlbl <- modhub

  hub_conn <- rbind(hub_conn, data.frame(type="modspe",node=modhub,name=modlbl))

  # Which are the module connectors: Few links and between modules
  #
  modhub <- which(l<=2.5)
  modhub <- modhub[which(l<=2.5) %in% which(r>0.625)]
  modlbl <- unlist(vertex_attr(g,index=modhub))
  if(is.null(modlbl))
     modlbl <- modhub

  hub_conn <- rbind(hub_conn, data.frame(type="modcon",node=modhub,name=modlbl))

}


#!/usr/bin/env r
library (Rmpi) # calls MPI_Init
rk = mpi.comm.rank(0)
sz = mpi.comm.size(0)
name =  mpi.get.processor.name()
cat("Hello, rank", rk, "size", sz, "on", name, "\n" )

cl <- NULL
ndsvpid <- Sys.getenv("OMPI_MCA_ns_nds_vpid")
if (ndsvpid == "0") {                   # are we master ?
    cl <- makeMPIcluster()
} else {                                # or are we a slave ?
    sink(file="/dev/null")
    slaveLoop(makeMPImaster())
    q()
}

clusterEvalQ(cl, library(RDieHarder))
res <- parLapply(cl, c("mt19937", "mt19937_1999",
                       "mt19937_1998", "R_mersenne_twister"),
                 function(x) {
                     dieharder(rng=x, test="operm5",
                               psamples=100, seed=12345,
                               rngdraws=100000)
                     }
                 )
stopCluster(cl)

pdf("/tmp/snowRDH.pdf")
lapply(res, function(x) plot(x))
dev.off()
print( do.call(rbind, lapply(res, function(x) { x[[1]] } )))


library(covidHubUtils)
library(dplyr)
library(here)
library(lubridate)
library(EuroForecastHub)

cutoff_date <- as.Date("2021-08-31")

raw_forecasts <- load_forecasts(
  source = "local_hub_repo",
  hub_repo_path = here(),
  hub = "ECDC"
) %>%
  filter(between(forecast_date, ymd("2021-03-08"), ymd(cutoff_date)))

## number of models
raw_forecasts %>%
  filter(!grepl("^EuroCOVIDhub-", model)) %>%
  summarise(models = length(unique(model)))

## number of forecasts
raw_forecasts %>%
  filter(!grepl("^EuroCOVIDhub-", model)) %>%
  nrow()

## number of models that supply all quantiles

qf <- raw_forecasts %>%
  group_by(location, target_variable, target_end_date, model, horizon) %>%
  filter(length(setdiff(get_hub_config("forecast_type")$quantiles, quantile)) == 0) %>%
  ungroup()

qf %>%
  filter(!grepl("^EuroCOVIDhub-", model)) %>%
  summarise(models = length(unique(model)))


  clean.surface.area = function (set,  qreject = c( 0.025, 0.975 )) {
     # data extremes to accept/reject

    # final edits / sanity checks
    # many good tows where surface area was not recorded in the historical data
    # filter : set missing values and any large extremes to year-specific medians
    # historical data not touched except if missing

    # ----------------------------------------------------------
    # tow distance
    # quantile truncation of net mensuration-based estimates
    distance.thresholds = quantile( set$distance, probs=qreject, na.rm=T )  # recalc after removing unrealistic extremes
    dist.throwout = which ( set$distance < distance.thresholds[1] | set$distance > distance.thresholds[2] )
    if (length( dist.throwout) > 0 ) set$distance[ dist.throwout ] = NA

    set$dist  = set$dist / 1000 # m->km; these are historical estimates from manually-determined examination (Moncton)
    set$dist0 = set$dist0 / 1000 # distanced based upon logged records from touchdown/lift off records

    # historical data assumed correct (Moncton source)
    j = which( is.finite( set$dist) )
    # plot( dist0 ~ dist, set[j,] )
    # plot( distance ~ dist, set[j,] )
    if (length(j) > 0 ) set$distance[j] = set$dist[j]

    # where distance is missing, assume ship log start-end positions correct
    j = which( is.finite( set$dist0 ) & !is.finite( set$distance) )
    # plot( dist0 ~ dist, set[j,] )
    if (length(j) > 0 ) set$distance[j] = set$dist0[j]

    # final pass for distances.. where missing, fill with average for each year
    j = which( !is.finite( set$distance) )
    if (length(j) > 0 ) {
      distyear = tapply( set$distance, set$yr, mean, na.rm=TRUE )
      set$distance[j] = distyear[ as.character(set$yr[j]) ]
    }

    j = which( !is.finite( set$distance) ) # should be zero
    if (length(j) > 0 ) {
      set$distance[j] = mean( set$distance, na.rm=TRUE )
    }

    #---------------------------------------------------------------
    # net spread
    spread.thresholds = c(0.004, 0.016) # initially fixed at realisitc values based upon net configuration
    j = which( set$spread < spread.thresholds[1] | set$spread > spread.thresholds[2] )
    if (length( j >0 )) set$spread [ j] = NA

    # quantile truncation
    spread.thresholds = quantile( set$spread, probs=qreject, na.rm=T ) # recalc after removing unrealistic extremes
    j = which( set$spread < spread.thresholds[1]  | set$spread > spread.thresholds[2] )
    if (length(j)>0) set$spread[ j ] = NA

    # .. where missing, fill with average for each year
    j = which( !is.finite( set$spread) )
    if (length(j) > 0 ) {
      spreadyear = tapply( set$spread, set$yr, mean, na.rm=TRUE )
      set$spread[j] = spreadyear[ as.character(set$yr[j]) ]
    }

    j = which( !is.finite( set$spread) )
    if (length(j) > 0 ) {
      set$spread[j] = mean( set$spread, na.rm=TRUE )
    }

    # ------------------------------------------
    # time
    time.thresholds = c(4,10) # hard limits
    ith = which( set$dt < time.thresholds[1]  | set$dt > time.thresholds[2] )
    if (length( ith >0 )) set$dt [ ith ] = NA

    time.quants = quantile( set$dt, probs=qreject, na.rm=T )
    ith = which( set$dt < time.quants[1]  | set$dt > time.quants[2] )
    if (length( ith >0 )) set$dt [ ith ] = NA

    j = which( !is.finite(set$dt) )
    if (length(j) > 0) set$sa[ j ] = NA  ## if time is unreliable then so is surface area

    # .. where missing, fill with average for each year
    j = which( !is.finite( set$dt) )
    if (length(j) > 0 ) {
      dtyear = tapply( set$dt, set$yr, mean, na.rm=TRUE )
      set$dt[j] = dtyear[ as.character(set$yr[j]) ]
    }

    j = which( !is.finite( set$dt) )
    if (length(j) > 0 ) {
      set$dt[j] = mean( set$dt, na.rm=TRUE )
    }

    #-----------------------------------------
    # surface area
    # up to this piint set$sa contains historical data, determined by "hand", now merge with modern data streams

    # hard limits (gating)
    qsah = c( 0.001, 0.01 ) # more extreme than these are really not possible -- force as errors
    iqsah = which( set$sa < qsah[1] | set$sa > qsah[2] ) # historical data
    if (length( iqsah)>0 )  set$sa[iqsah] = NA

    iqsah2 = which( set$surfacearea < qsah[1] | set$surfacearea > qsah[2] ) # modern data
    if (length( iqsah2)>0 )  set$surfacearea[iqsah2] = NA

    # quantile truncation
    qsa = quantile( set$sa, qreject, na.rm=T )    # historical data
    iqsa = which( set$sa < qsa[1] | set$sa > qsa[2] )
    if (length( iqsa)>0 )  set$sa[iqsa] = NA

    qsa2 = quantile( set$surfacearea, qreject, na.rm=T ) # ~ 0.0028 0.0057    # modern data streams ...
    iqsa2 = which( set$surfacearea < qsa2[1] | set$surfacearea > qsa2[2] )
    if (length( iqsa2)>0 )  set$surfacearea[iqsa2] = NA

    # surfacearea is determined by automatic mechanisms .. fill where no historical data
    j = which( is.finite(set$surfacearea) & !is.finite( set$sa) )
    set$sa[j] = set$surfacearea[j]

    j = which( !is.finite( set$sa) )
    set$sa[j] = set$distance[j] * set$spread[j]

    j = which( !is.finite( set$sa ) )
    if (length(j) > 0 ) {
      sayear = tapply( set$sa, set$yr, mean, na.rm=TRUE )
      set$sa[j] = sayear[ as.character(set$yr[j]) ]
    }

    j = which( !is.finite( set$sa ) )
    if (length(j) > 0 ) set$sa[ j ] = mean( set$sa, na.rm=TRUE )

    return (set)
  }


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(cowplot))

algorithms <- c("PCA", "ICA", "NMF", "DAE", "VAE")
datasets <- c("TCGA", "TARGET", "GTEX")
collections <- c("GpXCELL",
                 "GpC4CM",
                 "GpH",
                 "GpC2CPG",
                 "GpC2CPREACTOME",
                 "GpC3TFT")

base_dir <- file.path("results", "top_features")

all_top_list <- list()
list_idx <- 1
for (top_file in list.files(base_dir)) {
    if (grepl("top_biobombe_scores", top_file)) {
        dataset <- strsplit(top_file, '_')[[1]][1]
        collection <- strsplit(top_file, '_')[[1]][2]

        top_df <- readr::read_tsv(file.path(base_dir, top_file),
                                col_types = readr::cols(
                                    .default = readr::col_character(),
                                    value = readr::col_double(),
                                    z_score = readr::col_double(),
                                    feature = readr::col_integer(),
                                    z = readr::col_integer(),
                                    abs_z_score = readr::col_double(),
                                    relative_geneset_rank = readr::col_integer(),
                                    absolute_rank = readr::col_integer())) %>%
        dplyr::mutate(collection = collection,
                      dataset = dataset)

        all_top_list[[list_idx]] <- top_df
        list_idx <- list_idx + 1
    }
}

all_top_df <- dplyr::bind_rows(all_top_list) %>%
    dplyr::filter(collection %in% collections)

# Covert z score to p value and generate bonferonni adjusted alphas
all_top_df <- all_top_df %>%
    dplyr::mutate(p_val = 2 * pnorm(-abs_z_score)) %>%
    dplyr::group_by(z) %>%
    dplyr::mutate(bon_alpha = 0.05 / z) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(is_bon_filtered = bon_alpha < p_val)

# Process data for plotting
all_top_df$z <- factor(all_top_df$z,
                       levels = sort(as.numeric(paste(unique(all_top_df$z)))))

all_top_df <- all_top_df %>%
    dplyr::group_by(z, collection, dataset, algorithm) %>%
    dplyr::mutate(num_instance = dplyr::n()) %>%
    dplyr::mutate(normalized_z = num_instance / as.numeric(paste(z))) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(algorithm = toupper(algorithm))

all_top_df$algorithm <- factor(all_top_df$algorithm, levels = algorithms)
all_top_df$collection <- factor(all_top_df$collection, levels = collections)

print(dim(all_top_df))
head(all_top_df)

# How many genesets are filtered
filtered_genesets_df <- reshape2::melt(all_top_df,
                                       id.vars = c("algorithm",
                                                   "dataset",
                                                   "collection"),
                                       measure.vars = 'is_bon_filtered',
                                       value.name = "filtered") %>%
    dplyr::group_by(algorithm, dataset, collection) %>%
    dplyr::summarize(num_filtered = sum(filtered),
                     percent_filtered = sum(filtered) / n()) %>%
    dplyr::arrange(desc(num_filtered))

out_file <- file.path("results", "bonferonni_filtered_counts.tsv")
readr::write_tsv(filtered_genesets_df, out_file)

filtered_genesets_df

# Perform Bonferonni Correction
filtered_top_df <- all_top_df %>%
    dplyr::filter(!is_bon_filtered)

# Split TCGA, GTEx, and TARGET data
tcga_top_df <- filtered_top_df %>%
  dplyr::filter(dataset == "TCGA")

gtex_top_df <- filtered_top_df %>%
  dplyr::filter(dataset == "GTEX")

target_top_df <- filtered_top_df %>%
  dplyr::filter(dataset == "TARGET")

plot_top_feature_distribution <- function(top_df, density_how = "fill") {
    g <- ggplot(data = top_df,
                aes(x = z,
                    fill = collection,
                    group = collection)) +
    geom_density(alpha = 0.5,
                 position = density_how) +
    coord_flip() +
    scale_fill_manual(name = "",
                      values = c("GpC2CPG" = "#0F1FFF",
                                 "GpC2CPREACTOME" = "green",
                                 "GpC3TFT" = "#EDF67D",
                                 "GpH" = "#49DCB1",
                                 "GpC4CM" = "#7D82B8",
                                 "GpXCELL" = "#EF767A"),
                    labels = c("GpC2CPG" = "Perturbations (C2CGP)",
                               "GpC2CPREACTOME" = "Pathways (REACTOME)",
                               "GpC3TFT" = "TF Targets (C3TFT)",
                               "GpH" = "Hallmark Gene Sets",
                               "GpXCELL" = "Cell Types (xCell)",
                               "GpC4CM" = "Cancer Modules (C4CM)")) +
    facet_wrap(dataset ~ algorithm, ncol = 5, scales = 'free_x') +
    xlab("Latent Dimensions") +
    ylab("Relative Density") +
    theme_bw() +
    theme(strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"),
          strip.text.x = element_text(size = 6,
                                      margin = margin(t = 3,
                                                      b = 1.5,
                                                      l = 0,
                                                      r = 0)),
          axis.title = element_text(size = 9),
          axis.text.x = element_text(size = 6),
          axis.text.y = element_text(size = 5),
          legend.position = 'bottom',
          legend.text = element_text(size = 6),
          legend.margin = margin(0, 0, 0, 0),
          legend.box.margin = margin(-8, 0, 0, 0)) +
     guides(fill = guide_legend(reverse = T))

    return(g)

}

tcga_gg <- plot_top_feature_distribution(tcga_top_df)

tcga_gg

target_gg <- plot_top_feature_distribution(target_top_df, density_how = "fill")

target_gg

theme_gtex <- theme(strip.background = element_rect(colour = "black",
                                                    fill = "#fdfff4"),
                    strip.text.x = element_text(size = 6,
                                                margin = margin(t = 3,
                                                                b = 1.5,
                                                                l = 0,
                                                                r = 0)),
                    axis.title = element_text(size = 9),
                    axis.text.x = element_text(size = 8),
                    axis.text.y = element_text(size = 5),
                    legend.position = 'bottom',
                    legend.title = element_text(size = 8),
                    legend.text = element_text(size = 6),
                    legend.margin = margin(0, 0, 0, 0),
                    legend.box.margin = margin(-8, 0, 0, 0))

gtex_stack_gg <- ggplot(data = gtex_top_df,
                        aes(x = z, fill = algorithm, group = algorithm)) +
    geom_density(alpha = 0.5, position = "stack") +
    coord_flip() +
    facet_wrap(dataset ~ collection, ncol = 5) +
    xlab("Latent Dimensions") +
    ylab("Density (Stacked)") +
    scale_fill_manual(name = "Algorithm",
                     values = c("#e41a1c",
                                "#377eb8",
                                "#4daf4a",
                                "#984ea3",
                                "#ff7f00")) +
    theme_bw() +
    theme_gtex +
    guides(fill = guide_legend(reverse = T))

gtex_stack_gg

gtex_fill_gg <- ggplot(data = gtex_top_df,
                       aes(x = z, fill = algorithm, group = algorithm)) +
    geom_density(alpha = 0.5, position = "fill") +
    coord_flip() +
    facet_wrap(dataset ~ collection, ncol = 5) +
    xlab("Latent Dimensions") +
    ylab("Relative Density") +
    scale_fill_manual(name = "Algorithm",
                     values = c("#e41a1c",
                                "#377eb8",
                                "#4daf4a",
                                "#984ea3",
                                "#ff7f00")) +
    theme_bw() +
    theme_gtex +
    guides(fill = guide_legend(reverse = T))

gtex_fill_gg

algorithm_legend_gg <- cowplot::get_legend(gtex_fill_gg)

b_and_c_gg <- cowplot::plot_grid(
    gtex_stack_gg + theme(legend.position = "none"),
    gtex_fill_gg + theme(legend.position = "none"),
    ncol = 2,
    labels = c("c", "d")
)

b_and_c_gg <- cowplot::plot_grid(
    b_and_c_gg,
    algorithm_legend_gg,
    rel_heights = c(1, 0.15),
    nrow = 2
)

main_plot <- cowplot::plot_grid(
    tcga_gg,
    target_gg,
    b_and_c_gg,
    nrow = 3,
    rel_heights = c(1.05, 0.95, 1),
    labels = c("a", "b", "")
)

main_plot

for(extension in c('.png', '.pdf')) {
    gg_file <- paste0("top_feature_density", extension)
    gg_file <- file.path("figures", gg_file)
    cowplot::save_plot(filename = gg_file,
                       plot = main_plot,
                       base_height = 210,
                       base_width = 170,
                       units = "mm")
}

all_top_df <- all_top_df %>% dplyr::mutate(feature_num_group = "greater25")
all_top_df$feature_num_group[as.numeric(paste(all_top_df$z)) < 25] <- "less25"

all_top_df$dataset <- factor(all_top_df$dataset, levels = datasets)
all_top_df$feature_num_group <- factor(all_top_df$feature_num_group, levels = c("greater25", "less25"))

# Setup full group parameter
all_top_df$big_group <- paste(all_top_df$feature_num_group, all_top_df$algorithm)

rank_gg <- ggplot(data = all_top_df,
                  aes(x = algorithm,
                      alpha = feature_num_group,
                      y = absolute_rank,
                      fill = algorithm)) +
    geom_boxplot(outlier.alpha = 0,
                 size = 0.2) +
    geom_point(position = position_jitterdodge(dodge.width = 0.75,
                                               jitter.width = 0.6),
               alpha = 0.5,
               size = 0.2,
               pch = 21,
               stroke = 0.3,
               color = '#00000044',
               aes(fill = algorithm,
                   group = big_group)) +
    facet_wrap(dataset ~ collection,
               scales = 'free_y',
               nrow = 2,
               ncol = 5) +
    scale_fill_manual(name = "Algorithm",
                     values = c("#e41a1c",
                                "#377eb8",
                                "#4daf4a",
                                "#984ea3",
                                "#ff7f00"),
                     labels = c("pca" = "PCA",
                                "ica" = "ICA",
                                "nmf" = "NMF",
                                "dae" = "DAE",
                                "vae" = "VAE")) +
    scale_alpha_manual(name = "k Dimension",
                       values = c("less25" = 0.5,
                                  "greater25" = 1),
                       labels = c("less25" = "k < 25",
                                  "greater25" = "k >= 25")) +
    xlab("Algorithm") +
    ylab("Absolute Rank Enrichment of Top Feature") +
    theme_bw() +
    theme(strip.background = element_rect(colour = "black",
                                          fill = "#fdfff4"),
          strip.text.x = element_text(size = 5,
                                      margin = margin(t = 3,
                                                      b = 2,
                                                      l = 0,
                                                      r = 0)),
          legend.position = "bottom",
          legend.text = element_text(size = 6),
          legend.margin = margin(t = -0.4,
                                 b = 0.1,
                                 l = 0.1,
                                 r = 0.1, "cm"),
          legend.title = element_text(size = 7),
          axis.text.x = element_blank(),
          axis.text.y = element_text(size = 5),
          axis.title.x = element_text(size = 7),
          axis.title.y = element_text(size = 7)) +
    guides(fill = guide_legend(order = 1),
           alpha = guide_legend(override.aes = list(fill = c("less25" = "#e41a1c",
                                                             "greater25" = "#e41a1c")),
                                order = 2))

rank_gg

for(extension in c('.png', '.pdf')) {
    gg_file <- paste0("top_feature_rank", extension)
    gg_file <- file.path("figures", gg_file)
    cowplot::save_plot(filename = gg_file,
                       plot = rank_gg,
                       base_height = 90,
                       base_width = 170,
                       units = "mm")
}


all.prop.estimate <- function (u1,u2) {
	###LogP, LogP.contour
        for ( coef.i in 1:nrow(prop_coef) ){
                prop.name <- rownames(prop_coef)[coef.i]
                for (ramda.i in 1:No.ramda){
                        eval(parse(text=paste( prop.name, " <<- ", ramda.me.box[coef.i,1],"*u1 + ",ramda.me.box[coef.i,2],"*u2 + ",ramda.me.box[coef.i,3], sep="" )))
                        eval(parse( text=paste( prop.name,".contour <<- t(matrix(",prop.name,",row,col) )",sep="") ))
                }
        }
	cat("Calculated:" )
	cat( rownames(prop_coef) )
	writeLines(sep="\n","")
}