###############################################################################
## Purpose: this file loads joined datasets and analyzes them.

## Depends:
## O7PredictorExploration.r
## 16SurveyExploration.r
## 21CostDescriptive.r
## tidyverse
## epiR

## Inputs:
##

## Outputs:
##

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

# Packages______________________________________________________________________
library(tidyverse)
library(epiR)
library(psych)
source("Functions/importing.r")

# Functions_____________________________________________________________________
create_timepoints <- function(dat) {
    timepoints <- list()
    for (i in 1:4) {

        # Read in data to include only those where both
        # dyad members are available
        dat_for_list <- import_available_survey_data(
            data = dat,
            timepoint = i,
            survey = "COST",
            obs = "dyad"
        )
        timepoints[[i]] <- dat_for_list
    }
    return(timepoints)
}

loop_correlation <- function(list_in) {
    ### Initiate Empty Lists
    cost_cor_list <- list()

    ### Loop over timepoints
    for (i in 1:4) {
        dat <- list_in[[i]]

        # Reshape data structure
        dat_wide <- lengthen_widen(
            data = dat, start_col = "facit_cost01",
            end_col = "facit_cost11"
        )

        # Summarise Raw Scores
        dat_sum <- summarise_survey(data = dat_wide)

        # Create Correlation table
        dat_cor <- creat_corr_table(dat = dat_wide)

        # Join raw and correlation
        dat_raw_cor <- dat_sum %>%
            left_join(dat_cor)

        cost_cor_list[[i]] <- dat_raw_cor
    }
    return(cost_cor_list)
}

calc_correlation <- function(dat, question) {

    ## Creates empty tibble for data
    ques_df <- tibble(
        question = NA,
        pearson_cor = NA,
        pearson_low = NA,
        pearson_high = NA,
        ccc_cor = NA,
        ccc_low = NA,
        ccc_high = NA
    )
    ## Populates question into tibble
    ques_df$question <- question
    ## Pulls data out of dataframe
    dat <- dat %>%
        filter(question == {{ question }})
    ## Run Pearson
    pear_list <- cor.test(
        x = dat$patient,
        y = dat$caregiver,
        method = "pearson",
        alternative = "t"
    )
    ## Extract Pearson
    ques_df$pearson_cor <- pear_list$estimate
    ques_df$pearson_low <- pear_list$conf.int[[1]]
    ques_df$pearson_high <- pear_list$conf.int[[2]]
    ## Run CCC
    ccc_list <- epi.ccc(
        x = dat$patient,
        y = dat$caregiver
    )
    ccc_df <- ccc_list$rho.c
    ## Extract CCC
    ques_df$ccc_cor <- ccc_df$est
    ques_df$ccc_low <- ccc_df$lower
    ques_df$ccc_high <- ccc_df$upper
    ## Return
    return(ques_df)
}

creat_corr_table <- function(dat) {
    ## create empty df to hold output
    df <- tibble(
        question = NA,
        pearson_cor = NA,
        pearson_low = NA,
        pearson_high = NA,
        ccc_cor = NA,
        ccc_low = NA,
        ccc_high = NA
    )

    ## find unique question names
    vec_question_names <- unique(dat$question)
    ## Loop over unique question names
    for (i in seq_along(vec_question_names)) {
        question <- vec_question_names[i]

        correlation <- calc_correlation(
            dat = dat,
            question = question
        )

        df <- df %>%
            rbind(correlation) %>%
            filter(!is.na(ccc_cor))
    }
    ## Return
    return(df)
}

lengthen_widen <- function(data, start_col, end_col, names = "question",
                           values = "score") {
    dat_long <- data %>%
        tidyr::pivot_longer(
            cols = {{ start_col }}:{{ end_col }},
            names_to = names,
            values_to = values
        )
    dat_wide <- dat_long %>%
        tidyr::pivot_wider(
            names_from = src,
            values_from = score
        )
    return(dat_wide)
}

summarise_survey <- function(data) {
    data_out <- data %>%
        group_by(question) %>%
        summarise(
            mean_pt = mean(patient, na.rm=TRUE),
            sd_pt = sd(patient, na.rm=TRUE),
            mean_cg = mean(caregiver, na.rm=TRUE),
            sd_cg = sd(caregiver, na.rm=TRUE)
        )
}
loop_chronbach <- function(list_in) {

    ### Intiate empty tibble
    cost_chron_tibble <- tibble(
        tp = c(NA, NA, NA, NA),
        patient = c(NA, NA, NA, NA),
        caregiver = c(NA, NA, NA, NA)
    )

    ### Loop over timepoints
    for (i in 1:4) {

        # Store timepoint
        cost_chron_tibble$tp[i] <- i

        # Patient
        ## filter data
        dat <- list_in[[i]] %>%
            filter(src == "patient") %>%
            select(facit_cost01:facit_cost11)

        ## Calculate Chronbach Alpha
        chr_a <- psych::alpha(dat)$total[[1]]

        ## Store Value
        cost_chron_tibble$patient[i] <- chr_a

        # Caregiver
        ## Filter Data
        dat <- list_in[[i]] %>%
            filter(src == "caregiver") %>%
            select(facit_cost01:facit_cost11)

        ## Calculate Chronbach Alpha
        chr_a <- psych::alpha(dat)$total[[1]]

        ## Store Value
        cost_chron_tibble$caregiver[i] <- chr_a
    }
    return(cost_chron_tibble)
}

tidy_chronbach <- function(data) {
    tidy_data <- data %>%
        mutate(across(patient:caregiver,
            round,
            digits = 2
        )) %>%
        rename(
            "Timepoint" = tp,
            "Patient" = patient,
            "Caregiver" = caregiver
        )
    return(tidy_data)
}
tidy_correlation <- function(list_in) {
    out_list <- list()
    ### Loop over timepoints
    for (i in 1:4) {

        # Round

        dat <- list_in[[i]] %>%
            mutate(across(mean_pt:ccc_high,
                round,
                digits = 2
            ))

        # Merge Patient

        dat <- dat %>%
            mutate(patient_mean_sd = paste0(
                mean_pt,
                " (",
                sd_pt,
                ")"
            )) %>%
            select(-(mean_pt:sd_pt))

        # Merge Caregiver

        dat <- dat %>%
            mutate(caregiver_mean_sd = paste0(
                mean_cg,
                " (",
                sd_cg,
                ")"
            )) %>%
            select(-(mean_cg:sd_cg))

        # Merge Pearson

        dat <- dat %>%
            mutate(pearson_95_ci = paste0(
                pearson_cor,
                " (",
                pearson_low,
                "-",
                pearson_high, ")"
            )) %>%
            select(-(pearson_cor:pearson_high))

        # Merge CCC
        dat <- dat %>%
            mutate(ccc_95_ci = paste0(
                ccc_cor,
                " (",
                ccc_low,
                "-",
                ccc_high, ")"
            )) %>%
            select(-(ccc_cor:ccc_high))
        # Add timepoint
        dat <- dat %>%
            mutate(timepoint = i)
        # Store in list
        out_list[[i]] <- dat
    }
    df_out <- map_df(
        .x = out_list,
        .f = rbind
    )
}
# Data In_______________________________________________________________________
## Predictors-------------------------------------------------------------------
### Wide
pred_wide <- read_csv(file = "IntData/dat_wide.csv")

## Cohorts----------------------------------------------------------------------
### Cohort 3
dat_cohort3 <- read_csv(file = "IntData/CohortThree.csv")

## Surveys----------------------------------------------------------------------
### Cost
cost_full <- read_csv(
    file = "IntData/cost_full.csv"
)

# Data transformation___________________________________________________________
## drop unused outcomes---------------------------------------------------------
cost_full <- cost_full %>%
    select(-c(
        cost_lgl,
        cost_cat,
        count_na
    ))

## Create Cohorts in lists------------------------------------------------------
### Define Cohorts
cost_cohort_one <- cost_full
cost_cohort_two <- cost_full %>%
    filter(partid %in% pred_wide$partid)

cost_cohort_three <- cost_full %>%
    filter(partid %in% dat_cohort3$partid)

### Create timepoint lists
c1_timepoints <- create_timepoints(cost_cohort_one)
c2_timepoints <- create_timepoints(cost_cohort_two)
c3_timepoints <- create_timepoints(cost_cohort_three)

# Analysis______________________________________________________________________
## 1: Crude correlation at each timepoint---------------------------------------
c1_correlation <- loop_correlation(list_in = c1_timepoints)
c2_correlation <- loop_correlation(list_in = c2_timepoints)
c3_correlation <- loop_correlation(list_in = c3_timepoints)

## 2. Chronbach's alpha---------------------------------------------------------
c1_chronbach <- loop_chronbach(list_in = c1_timepoints)
c2_chronbach <- loop_chronbach(list_in = c2_timepoints)
c3_chronbach <- loop_chronbach(list_in = c3_timepoints)

# Tidying_______________________________________________________________________
## 1. Raw Correlation-----------------------------------------------------------
corr <- list(
    c1_tidy_corr <- tidy_correlation(list_in = c1_correlation) %>%
        mutate(Cohort = 1),
    c2_tidy_corr <- tidy_correlation(list_in = c2_correlation) %>%
        mutate(Cohort = 2),
    c3_tidy_corr <- tidy_correlation(list_in = c3_correlation) %>%
        mutate(Cohort = 3)
)

tidy_corr <- map_df(
    .x = corr,
    .f = rbind
) %>%
    arrange(question)

## 2. Chronbach-----------------------------------------------------------------
chron <- list(
    c1_tidy_chronbach <- tidy_chronbach(c1_chronbach) %>%
        mutate(Cohort = 1),
    c2_tidy_chronbach <- tidy_chronbach(c2_chronbach) %>%
        mutate(Cohort = 2),
    c3_tidy_chronbach <- tidy_chronbach(c3_chronbach) %>%
        mutate(Cohort = 3)
)

tidy_chronbach <- map_df(
    .x = chron,
    .f = rbind
)

# Output________________________________________________________________________
## Tidy-------------------------------------------------------------------------
path <- "OutData/CorrTables/"

### Correlation
write_csv(
    x = tidy_corr,
    file = paste0(path, "COST_correlation.csv")
)

### Chronbach's
write_csv(
    x = tidy_chronbach,
    file = paste0(
        path,
        "COST_chronbach.csv"
    )
)


# what weird species are where?
# so far this script identifies the cities where Canada wide weird species occur. it also calculates the standard deviation of the SLA of Canada-wide weird species in each city and how many Canada-wide weird species a place has

library(purrr)

# get weird species at all three spatial scales
paths <- c("analysis/canada_weird.csv", "analysis/city_weird.csv", "analysis/quadrat_weird.csv")

weirdspecies <- map(paths, read.csv, header=TRUE, stringsAsFactors=FALSE)
names(weirdspecies) <- c("canada", "city", "quadrat")

weirdspecies$city$City <- factor(weirdspecies$city$City, levels = c("Vancouver", "Edmonton", "Winnipeg", "Toronto", "Montreal", "Halifax"))

# get all species and their SLA trait data
species <- read.csv("data/species_and_their_traits.csv", header=TRUE, stringsAsFactors = FALSE) %>%
    filter(TraitName == "Leaf area per leaf dry mass (specific leaf area, SLA or 1/LMA): petiole excluded") %>%
    mutate(TraitName = "SLA") # Make the trait name easier to work with

species$City <- factor(species$City, levels = c("Vancouver", "Edmonton", "Winnipeg", "Toronto", "Montreal", "Halifax"))

# Which Canada-wide weird species are in each city?

globalweird_in_cities <- species %>%
    filter(species %in% weirdspecies$canada$species) %>%
    group_by(City)

globalweird <- ggplot(globalweird_in_cities, aes(x=value, fill=City)) +
    geom_density() +
    theme_bw() +
    ggtitle("Distribution of SLA", subtitle = "for Canada-wide weird species") +
    facet_wrap("City")

ggsave("figures/weird_slas_by_city.png", globalweird, width=8, height=9, units="in")

## Which city has the highest standard deviation in SLA for weird species, and how many weird species does it have in total?
city_sd <- globalweird_in_cities %>%
    summarize(sd = sd(value), num=n()) %>%
    arrange(desc(sd))

# Which city-wide species are in each quadrat
quadrat_sd <- weirdspecies$city %>%
    group_by(City, quadrat) %>%
    summarize(sd=sd(value), num=n()) %>%
    arrange(desc(sd))

# Top 5 weirdest quadrats
# # Groups:   City [6]
# City      quadrat    sd   num
# <chr>       <int> <dbl> <int>
# 1 Halifax         3  24.7     3
# 2 Halifax         4  24.2     3
# 3 Vancouver       1  23.9    83
# 4 Montreal        1  22.8    77
# 5 Vancouver       3  22.6     4

# Plot of the "weird" species traits in each city and quadrat
weirdslaquadratcity <- ggplot(weirdspecies$city, aes(x=value, fill=City)) +
    geom_density(alpha=0.5) +
    facet_grid(factor(quadrat, levels = c("5", "4", "3", "2", "1")) ~ .) +
    theme_classic(base_size = 18) +
    theme(legend.position = "bottom", axis.text.y=element_blank() ) +
    labs(x="SLA")

quadrat_sd_trends <- ggplot(quadrat_sd, aes(x=quadrat, y=sd, colour=City)) +
    geom_point(aes(size=num*2)) +
    geom_line() +
    theme_classic(base_size = 25) +
    ylab("standard deviation of weird") +
    scale_size(name="# of species")

ggsave("figures/quadrat_trends.png", quadrat_sd_trends, width=16, height=9, units="in")

ggsave("figures/weird_slas_by_city_and_quad.png", weirdslaquadratcity, width=8, height=9, units="in")


require(randomForest) # required for rf
require(kernlab) # required for svm
require(caret)

# runs cross-validation
# if nfolds > length(y) or nfolds==-1, uses leave-one-out cross-validation
# ...: additional parameters for train.fun
#
# value:
# y: true values
# predicted: cv predicted values
# probabilities: cv predicted class probabilities (or NULL if unavailable)
# confusion.matrix: confusion matrix (true x predicted)
# nfolds: nfolds, use -1 for leave-one-out cv
# params: list of additional parameters
# importances: importances of features as predictors
# regression: does both regression or classification (RMSE and r_squared will be meaningless here)
# modelfun: valid model available in caret package
# group.var = vector of values, to group samples by (e.g. multiple samples per subject id)
"cross.validation.caret" <- function(x, y, nfolds=10, verbose=FALSE, regression=FALSE, modelfun, group.var=NULL, ...){
    if(regression==FALSE)
   	{
		if(class(y) != 'factor') stop('y must be factor for classification\n')
		y <- droplevels(y)
   	}

    folds <- balanced.group.folds(y, nfolds, group.var)

    result <- list()
    result$y <- y
    result$predicted <- result$y
    # initialize class probs as an empty data frame
    result$classprob <- data.frame(matrix(vector(), 0, length(unique(result$y))+1))

    # K-fold cross-validation
    for(fold in sort(unique(folds))){
        if(verbose) cat(sprintf('Fold %d...\n',fold))
        foldix <- which(folds==fold)
        newx <- x[foldix,,drop=F] # make sure df structure is kept even for 1-row newx

        fitControl <- trainControl(method = "none", classProbs = TRUE)
        #set.seed(825)
        model <- train(x=x[-foldix,], y=result$y[-foldix],
                         method = modelfun,
                         trControl = fitControl,
                         verbose = FALSE,
                         metric = "ROC")

        # class
        result$predicted[foldix] <- predict(model, newdata = newx) # class
        # probability
        result$classprob[foldix,] <- cbind(predict(model, newx, type="prob"), fold=fold)

    }
	result$nfolds <- nfolds
    result$params <- list(...)
    return(result)
}

# assign samples to folds so that classes are balanced AND groups samples are in the same fold
# (avoid training and predicting with samples from the same group)
# note: LOO for groups samples will never truly be LOO
"balanced.group.folds" <- function(y, nfolds, group.var=NULL)
{
    if(nfolds==-1) nfolds <- length(y)

    if(is.null(group.var)){
        folds <- balanced.folds(y, nfolds)
    } else {
        group <- data.frame(y, group.var, sample.id=1:length(y))

        # order by group, num response, then response level - then grab first sample as group rep
        # this should work fine for discordant samples (e.g. 1 tumor 1 healthy per subject)
        groupfreq <- as.data.frame(table(group[c("group.var", "y")]))
        # Freq is important because we always pick the class level where there are the most samples for one group.var
        # e.g. 4 tongue samples and 2 tongue samples for a subject assigns it as tongue
        groupfreq_ord <- groupfreq[order(groupfreq$group.var, -groupfreq$Freq, groupfreq$y),]
        groupfreq_uniq <- groupfreq_ord[!duplicated(groupfreq_ord$group.var),]

        # assign folds based on group rep responses
        folds <- balanced.folds(groupfreq_uniq$y, nfolds)
        groupfreq_uniq$folds <- folds

        # reassign original samples to folds, so that all grouped samples remain in the same fold
        group_folds <- merge(group, groupfreq_uniq[,c("group.var", "folds")], by="group.var", all.x=T)

        # preserve original sample order
        folds <- group_folds[order(group_folds$sample.id),"folds"]
    }
    return(folds)
}

"balanced.folds" <- function(y, nfolds=10){
	y <- droplevels(as.factor(y))
    folds = rep(0, length(y))
    classes = levels(y)
    # size of each class
    Nk = table(y)
    # -1 or nfolds = len(y) means leave-one-out
    if (nfolds == -1 || nfolds == length(y)){
        invisible(1:length(y))
    }
    else{
    # Can't have more folds than there are items per class
    nfolds = min(nfolds, max(Nk))
    # Assign folds evenly within each class, then shuffle within each class
        for (k in 1:length(classes)){
            ixs <- which(y==classes[k])
            folds_k <- rep(1:nfolds, ceiling(length(ixs) / nfolds))
            folds_k <- folds_k[1:length(ixs)]
            folds_k <- sample(folds_k)
            folds[ixs] = folds_k
        }
        invisible(folds)
    }
}


# Download and extract WorldClim data
library(raster)
library(dismo)
library(sf)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/db-io.r")

# Temporary directory for storing the data before extraction
TempDir = "../../userdata/master-classification/climate/"
OutDir = "../data/pixel-based/climate/"

# Generate bioclimatic variables manually; for raster-based processing better to download,
# but in this case it's more efficient to generate
DSNames = c("tmin", "tmax", "tavg", "prec", "srad", "wind", "vapr")

DownloadDir = file.path(TempDir, "raw")
if (!file.exists(DownloadDir))
    dir.create(DownloadDir)
if (!file.exists(OutDir))
    dir.create(OutDir)

URLs = paste0("http://biogeo.ucdavis.edu/data/worldclim/v2.0/tif/base/wc2.0_30s_", DSNames, ".zip")
Filenames = paste0(DownloadDir, "/", DSNames, ".zip")
Filenames = Filenames[!file.exists(file.path(DownloadDir, basename(Filenames)))] # Filter already downloaded
if (length(Filenames) > 0)
    download.file(URLs, Filenames)

DSDirs = file.path(TempDir, DSNames)
DSStacks = list()
for (i in 1:length(DSNames))
{
    RasterFiles = list.files(DSDirs[i], pattern=glob2rx("*.tif"), full.names = TRUE)
    if (length(RasterFiles) <= 0)
    {
        unzip(Filenames[i], exdir=DSDirs[i])
        RasterFiles = list.files(DSDirs[i], pattern=glob2rx("*.tif"), full.names = TRUE)
    }
    DSStacks[[i]] = stack(RasterFiles)
}
names(DSStacks) = DSNames

# Extract our values
TrainingPoints = LoadGlobalTrainingData()
ValidationPoints = LoadGlobalValidationData()
PredictionPoints = LoadGlobalRasterPoints()
AllPoints = rbind(TrainingPoints[,c("x", "y")], ValidationPoints[,c("x", "y")], PredictionPoints[,c("x", "y")])

DSValues = list()
for (i in 1:length(DSNames))
{
    DSValues[[i]] = extract(DSStacks[[i]], AllPoints)
}
names(DSValues) = DSNames
BioValues = dismo::biovars(DSValues$prec, DSValues$tmin, DSValues$tmax)

BaseClimateData = do.call("cbind", DSValues)
AllClimateData = cbind.data.frame(X=AllPoints$x, Y=AllPoints$y, BaseClimateData, BioValues)

SpatialClimate = DFtoSF(AllClimateData)
rm(AllClimateData)
st_write(SpatialClimate, file.path(OutDir, "climate.gpkg"))


#' Generate projected seasonal (and holiday) adjustment factors
#'
#' Generates projected adjustment factors from the decomposition of the fractional airline model R routines
#'
#' @param this_est A list object generated by the estimation procedure of the fractional airline model; the regression matrix should not be extended with forecasts.
#' @param this_decomp A list object generated by the decomposition procedure of the fractional airline model; the \code{nfcasts} option should have been specified.
#' @param this_xtype Character vector; Type of regressor used for including regression effects into components (\code{'hol'} for holiday, \code{'ao'} for point outliers, \code{'ls'} for level change outliers).
#' @param this_x Character vector; regression matrix.
#' @param this_log Logical scalar; set to TRUE if the log transformation is used in the decomposition, FALSE otherwise. Default: TRUE
#' @param nfcasts Integer scalar; number of projected adjustment factors; should match the \code{nfcasts} argument used to generate the decomposition.
#' @param return_series Character scalar; component returned by the routine. Default is "combined"; other possible choices are "seasonal" and "holiday".
#' @param return_xts Logical scalar; return projected factors of type \code{return_series} as an \code{xts} time series object. Default is FALSE.
#'        If TRUE, \code{this_x} must be an \code{xts} time series object.
#' @return Array of projected adjustment factors from the fractional airline decomposition
#' @examples
#' ic_est <-
#'    rjd3highfreq::fractionalAirlineEstimation(ic_obs, periods=c(365.25/7),
#'                                              x=ic_default_matrix)
#' ic_decomp <-
#'    rjd3highfreq::fractionalAirlineDecomposition(ic_est$model$linearized, 365.25/7,
#'                                                 stde = TRUE, nfcasts = 104)
#' ic_xtype <- c(rep('hol', 13), rep('ao', 40))
#' ic_proj_seasonal <-
#'    gen_air_projected_factors(ic_est, ic_decomp,
#'                       this_xtype = ic_xtype,
#'                       this_x     = ic_holiday_matrix_fcst,
#'                       this_log = FALSE, nfcasts = 104)
#' @import stats
#' @export
gen_air_projected_factors <- function(this_est, this_decomp, this_xtype, this_x = NULL,
                                      this_log = TRUE, nfcasts = 104, return_series = "combined",
                                      return_xts = FALSE) {
    # Author: Brian C. Monsell (OEUS), Version 3.3, 3/16/2022
    test_nfcasts <- length(this_decomp$decomposition$y) - this_decomp$likelihood$nobs
    if (test_nfcasts != nfcasts) {
        stop(paste0("number of forecasts specified for decomposition (",test_nfcasts,") not the same as nfcasts (",nfcasts,")"))
    }

    if (!(return_series == "combined" | return_series == "seasonal" | return_series == "holiday")) {
        stop("Acceptable entries for return_series are combined, seasonal, or holiday")
    }

    this_max_col <- ncol(this_x)
    this_b <- this_est$model$b[1:this_max_col]

    # generate filters for holiday regressors
    filter_hol <- this_xtype[1:this_max_col] == "hol"

    n_hol <- sum(filter_hol)

    this_seasonal        <- this_decomp$decomposition$s
    this_seasonal_length <- length(this_seasonal)

    if (this_log) {
        this_default <- rep(1, length.out = this_seasonal_length)
    } else {
        this_default <- rep(0, length.out = this_seasonal_length)
    }

    # generate holiday factors
    if (n_hol > 0) {
        this_hol <- as.vector(this_x[, filter_hol] %*% matrix(this_b[filter_hol], ncol = 1))
        if (this_log) {
            this_hol <- exp(this_hol)
        }
    } else {
        this_hol <- this_default
    }

    if (this_log) {
        this_seasonal <- exp(this_seasonal)
        this_combfac <- this_seasonal * this_hol
    } else {
        this_combfac <- this_seasonal + this_hol
    }

    start_factors <- this_seasonal_length - nfcasts + 1
    if (return_series == "combined") {
        this_proj <- this_combfac[start_factors:this_seasonal_length]
    } else {
        if (return_series == "seasonal") {
            this_proj <- this_seasonal[start_factors:this_seasonal_length]
        } else {
            if (return_series == "holiday") {
                this_proj <- this_hol[start_factors:this_seasonal_length]
            }
        }
    }

    # return projected factors
    if (return_xts) {
       this_index <- as.Date(zoo::index(this_x), origin = "1970-01-01")
       this_filter <- seq((this_decomp$likelihood$nobs+1),length(this_decomp$decomposition$y))
       this_proj <-
          xts::xts(x = this_proj, order.by = this_index[this_filter])
       return(this_proj)
    } else {
       return(this_proj)
    }

}


source("usa/code/plotting/format-data-plotting.r")
source("usa/code/plotting/make-three-panel-plots.r")
source("usa/code/plotting/make-rt-plot.r")

library(ggpubr)

make_plots_all <- function(filename, SIM=FALSE, label = "", last_date_data,
                           ext = ".png", group = NULL){
  print("Making three panel plots")
  load(filename)
  out <- rstan::extract(fit)

  rt_data_long <- NULL
  rt_data_wide <- NULL
  if(!SIM){

    all_data_out <- data.frame()
  }
  for (i in 1:length(states)){

    print(states[i])
    data_state_plot <- format_data(i = i, dates = dates, states = states,
                                   estimated_cases_raw = estimated_cases_raw,
                                   estimated_deaths_raw = estimated_deaths_raw,
                                   reported_cases = reported_cases,
                                   reported_deaths = reported_deaths,
                                   out = out)
    colnames_csv <- c("date","state", "reported_cases", "predicted_cases","cases_min", "cases_max",
                      "reported_deaths","estimated_deaths",
                      "deaths_min", "deaths_max","rt", "rt_min","rt_max")
    if (!SIM){
      data_state_out_temp <- data_state_plot[,colnames_csv]
      colnames(data_state_out_temp) <- c("date","state", "reported_cases",
                                         "predicted_infections_mean","predicted_infections_lower_CI_95", "predicted_infections_higher_CI_95_cumulative",
                                         "reported_deaths", "estimated_deaths_mean", "estimated_deaths_lower_CI_95", "estimated_deaths_higher_CI_95",
                                         "mean_time_varying_reproduction_number_R(t)", "time_varying_reproduction_number_R(t)_lower_CI_95",
                                         "time_varying_reproduction_number_R(t)_higher_CI_95")
      all_data_out <- rbind(all_data_out, data_state_out_temp)
    }
    # Cuts data on last_data_date
    data_state_plot <- data_state_plot[which(data_state_plot$date <= last_date_data),]

    # Read in covariates
    covariates <- readRDS("usa/data/covariates.RDS")
    covariates$Quarantine = NULL
    covariates$GathRecomAny = NULL
    covariates_long <- gather(covariates[which(covariates$StatePostal == states[i]),
                                         2:ncol(covariates)],
                              key = "key", value = "value")
    covariates_long$x <- rep(NA, length(covariates_long$key))
    covariates_long$time <- rep("start", length(covariates_long$key))

    covariates_ended <- readRDS("usa/data/covariates_ended.RDS")
    covariates_ended$Quarantine = NULL
    covariates_ended$GathRecomAny = NULL
    covariates_ended_long <- gather(covariates_ended[which(covariates_ended$StatePostal == states[i]),
                                                     2:ncol(covariates_ended)],
                                    key = "key", value = "value")
    covariates_ended_long$x <- rep(NA, length(covariates_ended_long$key))
    covariates_ended_long$time <- rep("ease", length(covariates_ended_long$key))

    covariates_long <- rbind(covariates_long, covariates_ended_long)
    covariates_long$time <- factor(covariates_long$time, levels = c("start", "ease"))

    un_dates <- unique(covariates_long$value)
    for (k in 1:length(un_dates)){
      idxs <- which(covariates_long$value == un_dates[k])
      max_val <- ceiling(max(data_state_plot$rt_max)) + 0.3
      for (k in idxs){
        covariates_long$x[k] <- max_val
        max_val <- max_val - 0.3
      }
    }

    date_emerg_dec <- covariates_long$value[which(covariates_long$key == "EmergDec" & covariates_long$time == "start")]
    idx_emerg_dec <- which(dates[[i]] == date_emerg_dec)
    if (length(idx_emerg_dec) == 0 || idx_emerg_dec < 3){
      print("Don't simulate before emerg dec")
      rt <- NA
      rt_li <- NA
      rt_ui <- NA
    } else {
      mean_emerg_chain <- rowMeans(out$Rt_adj[,(idx_emerg_dec-3):(idx_emerg_dec+3),i])
      rt <- mean(mean_emerg_chain)
      rt_li <- quantile(mean_emerg_chain, prob=.025)
      rt_ui <- quantile(mean_emerg_chain, prob=.975)
    }

    idx <- which(dates[[i]] == last_date_data)
    mean_chain <- rowMeans(out$Rt_adj[,(idx-6):idx,i])
    rt_current <- mean(mean_chain)
    rt_li_current <- quantile(mean_chain, prob=.025)
    rt_ui_current <- quantile(mean_chain,prob=.975)

    # Collate rt information
    len <- length(data_state_plot$rt)
    rt_data_state_long <- data.frame("state" = c(states[i], states[i]),
                                     "x" = c("start", "end"),
                                     "rt" = c(rt, rt_current),
                                     "rt_min" = c(rt_li, rt_li_current),
                                     "rt_max" = c(rt_ui, rt_ui_current))
    rt_data_long <- rbind(rt_data_long, rt_data_state_long)

    # Make the three panel plot
    plots <- make_three_panel_plots(data_state_plot, jobid = JOBID, state = states[i],
                                    covariates_long = covariates_long, label = label,
                                    ext = ext)
  }
  if(!SIM){
    saveRDS(all_data_out, paste0("usa/results/", "three-panel-data-",JOBID,".RDS"))
  }
  # Get state groupings
  groupings <- read.csv("usa/data/usa-regions.csv", stringsAsFactors = FALSE)
  groupings <- select(groupings, code, region_census_sub_revised,  state_name)
  names(groupings) <- c("state", "groupings", "state_name")
  rt_data_long <- left_join(rt_data_long, groupings, by = "state")

  print("Making rt plot")
  rt_data_long$x <- factor(rt_data_long$x, levels = c("start", "end"))
  make_rt_point_plot(rt_data_long, JOBID = JOBID, label = label, ext = ext)

}


#!/usr/bin/env Rscript

tring <- read.table("../trcurve.txt", head=TRUE)
mcmc <-read.table("curvelog.txt", head=FALSE)

pdf("curves.pdf")
plot(tring$r,mcmc[1e5,],col="light grey", xlab="R [kpc]", ylab="Vc (km/s)")
for (n in seq(1e5,1.01e5)) {
  lines(tring$r,mcmc[n,],col="light grey")
}

lines(tring$r, tring$v, lty=2, lwd=2, col="green")
dev.off() -> dumpvar


library(ggplot2)
library(dplyr)
args <- commandArgs(trailingOnly=TRUE)

if (length(args) != 14) {
  print(args)
  stop("Usage: evaluator_bars_per_group_strategy.r common.r input.csv output.pdf granularity groupName strategy evaluator1 unit1 quantity1 indication1 evaluator2 unit2 quantity2 indication2")
}

common <- args[1]
inFile <- args[2]
outPdf <- args[3]
# granularity <- args[4]
groupName <- args[5]
strategy <- args[6]
e1 <- args[7]
u1 <- args[8]
q1 <- args[9]
i1 <- args[10]
e2 <- args[11]
u2 <- args[12]
q2 <- args[13]
i2 <- args[14]

source(common)

res = read.csv(inFile, header=TRUE)

res <- res[res$strategy == strategy,]

res$origin <- paste(res$file, res$focus, res$strategy)

# Select the right data
res1 <- res[res$evaluator == e1,]
res2 <- res[res$evaluator == e2,]

# Make the output numeric
res$output <- suppressWarnings(as.numeric(as.character(res$output)))

# Replace NaN with '0'
res$output <- replace(res$output, is.na(res$output), 0)

dat <- merge(res1, res2, by = "origin")
dat <- dat[!is.na(dat$output.x),]
dat <- dat[!is.na(dat$output.y),]

dat <- dat %>%
	group_by(file.x, output.x, strategy.x) %>%
	summarise(output.y=mean(output.y))

if (length(dat$output.y) != 0) {
  startPdf(outPdf)

  p <- ggplot(dat, aes(output.x, output.y, fill = strategy.x)) +
    geom_bar(stat="identity", position = "dodge") +
    scale_fill_brewer(palette = "Set1") +
    labs(x = e1) + labs(y = e2) +
    geom_smooth(method='lm', formula=y~x, show.legend=FALSE, show_guide = FALSE) +
    theme(legend.position="none")

  if (strategy == "full-background") {
    e2 <- paste("log(", e2, ")", sep="")
    p <- p + scale_y_log10()
  }

  p <- p +
    xlab(paste(e1, paste("(", q1, ")", sep=""))) +
    ylab(paste(e2, paste("(", q2, ")", sep=""))) +
    theme(axis.title.y=element_text(angle = 0))
  print(p)

} else {
  invalidDataPdf(outPdf)
}


# 3. faza: Vizualizacija podatkov

#Graf za turizem glede na transport za najbolj razvitih 10 držav
drzave.2016 <- turizem_glede_na_transport %>% filter(leto == 2016) %>%
  top_n(10, prihodi_turistov_preko_letalskega_prometa)

graf.turisti <- ggplot(data = turizem_glede_na_transport %>% filter(COUNTRY %in% drzave.2016$COUNTRY),
                       aes(x = leto, y = prihodi_turistov_preko_letalskega_prometa/100000, label = COUNTRY)) +
  geom_point(aes(x = leto, y = prihodi_turistov_preko_letalskega_prometa/100000 ), color = "red") +
  geom_line(aes(group = COUNTRY, x = leto, y = prihodi_turistov_preko_letalskega_prometa/100000, color=COUNTRY)) +
  labs(title ="Prihodi turistov preko letalskega prometa za posamezno leto") +
  xlab("Leto") + ylab("Število potnikov (x 100.000)")  + theme(plot.title = element_text(hjust = 0.5)) +
  theme(axis.title = element_text(size = (9)),
          panel.background=element_rect(fill="#F5ECCE"), plot.title = element_text(size = (15))) +
  scale_color_manual(name = "Države", labels = c("Hrvaška", "Ciper", "Francija", "Nemčija", "Grčija", "Madžarska",
                                                "Italija", "Poljska", "Španija", "Velika Britanija"),
                     values = c("#0000b3", "#3399ff", "#00ff99", "#33cc33", "#008000", "#ff9900",
                                "#ff3300", "#cc0000", "#993366", "#ff00ff"))

# Graf za primerjavo med dobro (Španija) in slabše (Litva) razvito državo
# Da bo graf bolj realen, bom vzela relativne podatke, zato bom število turistov, ki pridejo v državo,
# delila s število prebivalcev tiste države
prebivalci.litve1 <- prebivalstvo %>% filter(Drzava == "Lithuania")
prebivalci.litve <- prebivalci.litve1[1,"Stevilo_prebivalcev"]
prebivalci.spanije1 <- prebivalstvo %>% filter(Drzava == "Spain")
prebivalci.spanije <- prebivalci.spanije1[1,"Stevilo_prebivalcev"]
turizem.transport.span.lit <- turizem_glede_na_transport %>% filter(COUNTRY %in% c("Spain", "Lithuania"))
turizem.span.lit <- turizem_na_splosno %>% filter(COUNTRY %in% c("Spain", "Lithuania"))
zdruzena <- rbind(turizem.span.lit %>% rename(Prihodi=prihodi_turistov) %>% mutate(Kategorija="Vsi prihodi"),
                  turizem.transport.span.lit %>% rename(Prihodi=prihodi_turistov_preko_letalskega_prometa) %>%
                    mutate(Kategorija="Prihodi preko letalskega prometa"))

zdruzena$Prihodi[zdruzena$COUNTRY == "Spain"] <- zdruzena$Prihodi[zdruzena$COUNTRY == "Spain"] / prebivalci.spanije
zdruzena$Prihodi[zdruzena$COUNTRY == "Lithuania"] <- zdruzena$Prihodi[zdruzena$COUNTRY == "Lithuania"] / prebivalci.litve

graf.spa.lit <- ggplot(data = zdruzena, aes(x= leto, y = Prihodi, fill = Kategorija, group = COUNTRY)) +
  geom_col(position = "dodge") + ylab("Prihodi") + xlab("Leto") +
  labs(title ="Primerjava Španije in Litve") + theme(plot.title = element_text(hjust = 0.5))

#Grafa za pregled razvoja turizma in transporta v Španiji
ustanovitve.turizem.spa <- ustanovitve_za_turizem %>% filter(COUNTRY %in% c("Spain"))
ustanovitve.transport.spa <- ustanovitve_za_transport %>% filter(COUNTRY %in% c("Spain"))
zdruzena.ustanovitve.spa <- rbind(ustanovitve.turizem.spa %>%
        rename(Stevilo_ustanovljenih=stevilo_ustanovljenih_enot_za_turizem) %>%
        mutate(Kategorija="Ustanovitve za turizem"), ustanovitve.transport.spa %>%
        rename(Stevilo_ustanovljenih=stevilo_ustanovljenih_enot_za_potniski_promet) %>%
        mutate(Kategorija="Ustanovitve za potniški promet"))

graf.ustanovitve.spa <- ggplot(data = zdruzena.ustanovitve.spa, aes(x=factor(leto), y=Stevilo_ustanovljenih/1000,
  fill= Kategorija, group = COUNTRY)) + geom_col(position = "dodge") + xlab("Leto") +
  ylab("Število ustanovljenih enot (x 1000)") + scale_fill_manual("Kategorija",values = c('#0023a0', '#ffcc80')) +
  labs(title ="Ustanavljanje v Španiji") + theme(plot.title = element_text(hjust = 0.5))

izdatki.turizem.spa <- izdatki_za_turizem %>% filter(COUNTRY %in% c("Spain"))
izdatki.transport.spa <- izdatki_za_transport %>% filter(COUNTRY %in% c("Spain"))
zdruzena.izdatki.spa <- rbind(izdatki.turizem.spa %>%
                            rename(Izdatki=izdatki_za_turizem_v_USD) %>%
                            mutate(Kategorija="Izdatki za turizem"), izdatki.transport.spa %>%
                            rename(Izdatki=izdatki_za_potniski_promet_v_USD) %>%
                            mutate(Kategorija="Izdatki za potniški promet"))

graf.izdatki.spa <- ggplot(data = zdruzena.izdatki.spa, aes(x=factor(leto), y=Izdatki/100000000,
  fill= Kategorija, group = COUNTRY)) + geom_col(position = "dodge") + xlab("Leto") +
  ylab("Izdatki v USD (x 100.000.000)") + scale_fill_manual("Kategorija",values = c('#0023a0', '#ffcc80')) +
  labs(title ="Izdatki v Španiji") + theme(plot.title = element_text(hjust = 0.5))

#Grafa za pregled razvoja turizma in transporta v Litvi
ustanovitve.turizem.lit <- ustanovitve_za_turizem %>% filter(COUNTRY %in% c("Lithuania"))
ustanovitve.transport.lit <- ustanovitve_za_transport %>% filter(COUNTRY %in% c("Lithuania"))
zdruzena.ustanovitve.lit <- rbind(ustanovitve.turizem.lit %>%
                                rename(Stevilo_ustanovljenih=stevilo_ustanovljenih_enot_za_turizem) %>%
                                mutate(Kategorija="Ustanovitve za turizem"), ustanovitve.transport.lit %>%
                                rename(Stevilo_ustanovljenih=stevilo_ustanovljenih_enot_za_potniski_promet) %>%
                                mutate(Kategorija="Ustanovitve za potniški promet"))

graf.ustanovitve.lit <- ggplot(data = zdruzena.ustanovitve.lit, aes(x=leto, y=Stevilo_ustanovljenih/100,
  fill= Kategorija, group = COUNTRY)) + geom_col(position = "dodge") + xlab("Leto") +
  ylab("Število ustanovljenih enot (x 100)") + scale_fill_manual("Kategorija",values = c('#0023a0', '#ffcc80')) +
  labs(title ="Ustanavljanje v Litvi") + theme(plot.title = element_text(hjust = 0.5))

izdatki.turizem.lit <- izdatki_za_turizem %>% filter(COUNTRY %in% c("Lithuania"))
izdatki.transport.lit <- izdatki_za_transport %>% filter(COUNTRY %in% c("Lithuania"))
zdruzena.izdatki.lit <- rbind(izdatki.turizem.lit %>%
                                rename(Izdatki=izdatki_za_turizem_v_USD) %>%
                                mutate(Kategorija="Izdatki za turizem"), izdatki.transport.lit %>%
                                rename(Izdatki=izdatki_za_potniski_promet_v_USD) %>%
                                mutate(Kategorija="Izdatki za potniški promet"))

graf.izdatki.lit <- ggplot(data = zdruzena.izdatki.lit, aes(x=leto, y=Izdatki/100000000,
  fill= Kategorija, group = COUNTRY)) + geom_col(position = "dodge") + xlab("Leto") +
  ylab("Izdatki v USD (x 100.000.000)") + scale_fill_manual("Kategorija",values = c('#0023a0', '#ffcc80')) +
  labs(title ="Izdatki v Litvi") + theme(plot.title = element_text(hjust = 0.5))

#Osredotočimo se na sam letalski promet, in sicer najprej na povprečje po državah za vsa leta
izracunaj.povprecje <- function() {
  letalski_promet <- letalski_promet %>% drop_na()
  povprecje.po.drzavah <- letalski_promet %>% group_by(Drzava) %>%
    summarise(Povprecje.potnikov = mean(Stevilo_potnikov))
  return(povprecje.po.drzavah)
}

povprecje.po.drzavah <- izracunaj.povprecje()

#uredimo drzave glede na povprečno število potnikov skozi preučevano obdobje
povprecje.po.drzavah$Drzava <- factor(povprecje.po.drzavah$Drzava, levels = povprecje.po.drzavah$Drzava[order(povprecje.po.drzavah$Povprecje.potnikov)])

graf.povprecje.po.drzavah <- ggplot(data=povprecje.po.drzavah, aes(x=Drzava, y=Povprecje.potnikov/10000)) +
  geom_bar(stat = 'identity', position = 'dodge') + coord_flip() + labs(title ="Povprečje potnikov po državah") +
  ylab("Povprečje potnikov (x 10.000)") + xlab("Država") + theme(plot.title = element_text(hjust = 0.5))

#Zanima me, kako se letalski promet giblje glede na cetrtletja in sicer konkretno za Španijo
letalski.promet.spa <- letalski_promet %>% filter(Drzava %in% c("Spain"))

graf.letalski.promet.spa <- ggplot(data = letalski.promet.spa, aes(x=Cetrtletje, y=Stevilo_potnikov/100000,
  label=Drzava)) + geom_point(aes(x=Cetrtletje, y=Stevilo_potnikov/100000), color = "red") + geom_line() +
  labs(title = "Število potnikov po četrtletjih v Španiji") + theme(plot.title = element_text(hjust = 0.5)) +
  ylab("Število potnikov (x 100.000)") + xlab("Četrtletje")

#Uvozimo zemljevid.
#source("https://raw.githubusercontent.com/jaanos/APPR-2018-19/master/lib/uvozi.zemljevid.r")

zemljevid <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
                            "ne_50m_admin_0_countries", mapa = "zemljevidi", pot.zemljevida = "", encoding = "UTF-8") %>%
  fortify() %>% filter(CONTINENT == "Europe" | SOVEREIGNT %in% c("Cyprus"), long < 45 & long > -45 & lat > 30 & lat < 75)

colnames(zemljevid)[11] <- 'drzava'
zemljevid$drzava <- as.character(zemljevid$drzava)
zemljevid$drzava[zemljevid$drzava == "Republic of Serbia"] <- "Serbia"

#Narišimo zemljevid povprečnega števila potnikov preko letalskega prometa po državah
zemljevid.povprecje.letalskega.prometa <- ggplot() +
  geom_polygon(data = povprecje.po.drzavah %>% right_join(zemljevid, by = c("Drzava" = "drzava")),
  aes(x = long, y = lat, group = group, fill = Povprecje.potnikov/10000), alpha = 0.8, color = "black")+
  scale_fill_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 80) +
  xlab("") + ylab("") + ggtitle("Povprečno število potnikov preko letalskega prometa (x 10.000)")+
  guides(fill=guide_legend(title="Povprečje")) + theme(plot.title = element_text(hjust = 0.5))

zemljevid.povprecje.letalskega.prometa
#Narišimo zemljevid povprečnega števila prihodov turistov v državo
izracunaj.povprecje1 <- function() {
  turizem_na_splosno <- turizem_na_splosno %>% drop_na()
  povprecje.turizma <- turizem_na_splosno %>% group_by(COUNTRY) %>%
    summarise(Povprecje.turistov = mean(prihodi_turistov))
  return(povprecje.turizma)
}

povprecje.turizma <- izracunaj.povprecje1()
povprecje.turizma$COUNTRY[povprecje.turizma$COUNTRY == "Czech Republic"] <- "Czechia"
povprecje.turizma$COUNTRY[povprecje.turizma$COUNTRY == "Russian Federation"] <- "Russia"

zemljevid.turisti <- ggplot() +
  geom_polygon(data = povprecje.turizma %>% right_join(zemljevid, by = c("COUNTRY" = "drzava")),
  aes(x = long, y = lat, group = group, fill = Povprecje.turistov/100000), alpha = 0.8, color = "black")+
  scale_fill_gradient2(low = "yellow", mid = "green", high = "blue", midpoint = 80) +
  xlab("") + ylab("") + ggtitle("Povprečno število turistov (x 100.000)")+
  guides(fill=guide_legend(title="Povprečje")) + theme(plot.title = element_text(hjust = 0.5))

# Naredimo zemljevid, ki bo države razvrstil v skupine
drzave.2017 <- letalski_promet %>% filter(Cetrtletje == "2017-01-01")
drzave.2017 <- drzave.2017[, ! names(drzave.2017) %in% c("Cetrtletje"), drop = F]
drzave.2017 <- drzave.2017[-c(34),]
drzave.2017$Drzava[drzave.2017$Drzava == "Czechia"] <- "Czech Republic"
drzave.norm <- drzave.2017 %>% select(-Drzava) %>% scale()
rownames(drzave.norm) <- drzave.2017$Drzava
k <- kmeans(na.omit(drzave.norm), 2, nstart = 100000)
skupine <- data.frame(Drzava=drzave.2017$Drzava, skupina=factor(k$cluster))

zemljevid.skupine <- ggplot() + geom_polygon(data=zemljevid %>% left_join(skupine, by=c("NAME_LONG"="Drzava")),
            aes(x=long, y=lat, group=group, fill=skupina)) + xlab("") + ylab("") +
            ggtitle("Države po skupinah")+ guides(fill=guide_legend(title="Skupine")) +
            theme(plot.title = element_text(hjust = 0.5))

# Pripravljene tabele za napredno analizo

turizem <- rbind(turizem_na_splosno %>% rename(Prihodi=prihodi_turistov) %>% mutate(Kategorija="Vsi prihodi"),
                 turizem_glede_na_transport %>% rename(Prihodi=prihodi_turistov_preko_letalskega_prometa) %>%
                   mutate(Kategorija="Prihodi preko letalskega prometa"))

turizem1 <- merge(turizem_na_splosno, turizem_glede_na_transport)


#GlitchTables.r
#                   RBLandau 20190130

fnPrintTableShockLow <- function(dfdat, sOutputFilename, sTitle, sSubtitle){

# Tabulate columns by copies and sector lifetime.
tbl.shocklow <- data.frame(with(dfdat,
            tapply(mdmlosspct, list(copies, lifem), FUN=identity)))

# Re-form the data into a table for printing.
foo<-(with(dfdat,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(dfdat$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))

# Pretty-print this to a file with explanatory headings.
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

return(tbl2)

}

# f n M a k e S m a l l L o s s T a b l e
fnMakeSmallLossTable <- function(dfIn) {
    library(reshape2)
    bar.small <- dfIn[,c("copies", "lifem", "mdmlosspct")]
    bar.melted <- melt(bar.small, id=c("copies", "lifem"))
    bar.recast <- dcast(bar.melted, copies~lifem)
    return(bar.recast)
}

# f n S a v e S m a l l L o s s T a b l e
fnSaveSmallLossTable <- function(dfIn, sFilename, sHeading) {
    dfTemp <- fnMakeSmallLossTable(dfIn)
    sink(sFilename)
    cat("MIT Preservation Simulation Project", "\n")
    cat(sFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
    cat(sHeading, "\n\n")
    cat("        half-life-------------------->","\n")
    print(dfTemp)
    sink()
}

#END


#!/usr/bin/env Rscript

fpath <- "benchmark/archiveit/"

p00 <- read.csv("benchmark/archiveit/summary-ukwa-2000.csv", header=T)
p01 <- read.csv("benchmark/archiveit/summary-ukwa-2001.csv", header=T)

print(p00)
print(p01)

#quit()

f2si2<-function (number, rounding=F, sep=" ")
{
    lut <- c(1e-24, 1e-21, 1e-18, 1e-15, 1e-12, 1e-09, 1e-06,
        0.001, 1, 1000, 1e+06, 1e+09, 1e+12, 1e+15, 1e+18, 1e+21,
        1e+24)
    pre <- c("y", "z", "a", "f", "p", "n", "u", "m", "", "k",
        "M", "G", "T", "P", "E", "Z", "Y")
    ix <- findInterval(number, lut)
    if (ix>0 && lut[ix]!=1) {
        if (rounding==T) {
         sistring <- paste(round(number/lut[ix]), pre[ix], sep=sep)
        }
        else {
         sistring <- paste(number/lut[ix], pre[ix], sep=sep)
        }
    }
    else {
        sistring <- as.character(number)
    }
    return(sistring)
}

xlb <- c("H1", "H2", "H3", "H4", "H5", "Hx", "P1", "P2", "P3", "P4", "P5", "Px")
kpos <- pretty(c(0, max(p01$suburi_keys, p00$suburi_keys)), n=10)
klb <- sapply(kpos, FUN=f2si2, rounding=T, sep="")
spos <- pretty(c(0, max(p01$profile_size, p00$profile_size)), n=10)
slb <- sapply(spos, FUN=f2si2, rounding=T, sep="")
tpos <- pretty(c(0, max(p01$profiling_time/60, p00$profiling_time/60)), n=10)
tlb <- sapply(tpos, FUN=f2si2, rounding=T, sep="")

keyline <- paste(fpath, "summary-keys-lineplot.png", sep="")
png(keyline, height=500, width=800, pointsize=18)

par(mar=c(4,4,2,2)+0.1)
plot(p01$suburi_keys, type='b', col="red", xaxt="n", yaxt="n", ylab="", xlab="", ylim=c(0, max(kpos)))
lines(p00$suburi_keys, type='b', col="blue", pch=0)
axis(1, at=c(1:12), labels=xlb)
axis(2, at=kpos, labels=klb)
title(ylab="Number of Sub-URI Keys", xlab="Max segments (H: Host segments, P: Path segments)")

dev.off()

sizeline <- paste(fpath, "summary-filesize-lineplot.png", sep="")
png(sizeline, height=500, width=800, pointsize=18)

par(mar=c(4,4,2,2)+0.1)
plot(p01$profile_size, type='b', col="red", xaxt="n", yaxt="n", ylab="", xlab="", ylim=c(0, max(spos)))
lines(p00$profile_size, type='b', col="blue", pch=0)
axis(1, at=c(1:12), labels=xlb)
axis(2, at=spos, labels=slb)
title(ylab="Profile size", xlab="Max segments (H: Host segments, P: Path segments)")

dev.off()

timeline <- paste(fpath, "summary-time-lineplot.png", sep="")
png(timeline, height=500, width=800, pointsize=18)

par(mar=c(4,4,2,2)+0.1)
plot(p01$profiling_time/60, type='b', col="red", xaxt="n", yaxt="n", ylab="", xlab="", ylim=c(0, max(tpos)))
lines(p00$profiling_time/60, type='b', col="blue", pch=0)
axis(1, at=c(1:12), labels=xlb)
axis(2, at=tpos, labels=tlb)
title(ylab="Profiling time (minutes)", xlab="Max segments (H: Host segments, P: Path segments)")

dev.off()


library(tibble)
library(lubridate)

context('Test Time Filtering')

input_table <- tibble::tribble(
  ~report_month, ~sta6a, ~type,  ~value,
  ymd("2017-03-01"),     "foo",  "short", 10,
  ymd("2017-03-01"),     "foo",  "long",  10,
  ymd("2017-04-01"),     "foo",  "short", 10,
  ymd("2017-04-01"),     "foo",  "long",  10,
  ymd("2018-01-01"),     "foo",  "short", 10,
  ymd("2018-01-01"),     "foo",  "long",  10,
  ymd("2018-02-01"),     "foo",  "short", 10,
  ymd("2018-02-01"),     "foo",  "long",  10,
  ymd("2018-03-01"),     "foo",  "short", 10,
  ymd("2018-03-01"),     "foo",  "long",  10,
  ymd("2018-04-01"),     "foo",  "short", 10,
  ymd("2018-04-01"),     "foo",  "long",  10
)

test_that("Timepoints before most recent x are removed", {
  result <- filter_recent_times(input_table, 4)
  expect_equal(sum(result$report_month < ymd("2018-01-01")), 0)
})

test_that("All timepoints after most recent x are retained", {
  result <- filter_recent_times(input_table, 4)
  expect_equal(nrow(result), 8)
})


#' Data summary
#'
#' @description Compute summary statistics for data
#'
#' @param df data.frame
#'
#' @return tibble
#' @export
#'
#' @examples
#'
#' mtcars
#'
#' df_summary(mtcars)
#'

df_summary <- function(df){

  if(sum(stringr::str_detect(class(df),
                             paste(c("tbl_df","tbl","data.frame","tabyl","grouped_df","data.table"),
                                   collapse = "|"))) ==  0){
    stop("df must be a data.frame/tibble")
  }

  df_num <-
    df %>%
    dplyr::select_if(is.numeric)

  if(ncol(df_num) == 0){

    print("0 numeric variables")

  }else{

    df_num <-
      df_num %>%
      tidyr::gather(var,value) %>%
      dplyr::group_by(var) %>%
      dplyr::summarise(relper::num_summary(value))

   print(paste0(ncol(df_num)," numeric variables"))

   print(df_num)
  }

  df_cat <-
    df %>%
    dplyr::select_if(purrr::negate(is.numeric))

  if(ncol(df_cat) == 0){

    print("0 categoric variables")

  }else{

    df_cat <-
      df_cat %>%
      tidyr::gather(var,value) %>%
      dplyr::group_by(var) %>%
      dplyr::summarise(relper::cat_summary(value))

    print(paste0(ncol(df_cat)," categoric variables"))

    print(df_cat)
  }
}


#! /usr/bin/Rscript --vanilla

#  install.packages("multcomp")
# Download tar from http://cran.r-project.org/web/packages/nparcomp/nparcomp.pdf
# sudo R CMD INSTALL nparcomp_2.0.tar.gz

library("rjson")
library("nparcomp")

args = commandArgs(TRUE)

bugginess <- fromJSON(args[2])
quantile = fromJSON(args[3])

df <- data.frame(bugginess, quantile)

res <- npar.t.test( df$bugginess~df$quantile, data=df, alternative="two.sided", method="logit")

print(res$Analysis)


#!/usr/bin/env Rscript

options(stringAsfactors = FALSE, useFancyQuotes = FALSE)
# This script is used to do cv filtering based on mzMatch
# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for blank filtering!\n")

require(xcms)
inputPeakML<-NA
output<-NA
blank<-"blank"
sample<-"sample"
method<-"max"
rest<-F
previousEnv<-NA
phenoFile<-NA
phenoDataColumn<-NA
cvcut<-0.3
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="qc")
  {
    qc=as.character(value)
  }
  if(argCase=="sample")
  {
    sample=as.character(value)
  }
  if(argCase=="rest")
  {
    rest=as.logical(value)
  }
  if(argCase=="phenoFile")
  {
    phenoFile=as.character(value)
  }
  if(argCase=="phenoDataColumn")
  {
    phenoDataColumn=as.character(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }
    if(argCase=="cvcut")
  {
    cvcut=as.numeric(value)
  }
}

if(is.na(previousEnv) | is.na(output) | any(is.na(qc))) stop("All input, output and blank need to be specified!\n")

load(file = previousEnv)
inputXCMS<-get(varNameForNextStep)
if(!is.na(phenoDataColumn) && !is.na(phenoFile))
{
fileNameMap<-read.csv(phenoFile,stringsAsFactors = F,header = T)

for(i in 1:nrow(inputXCMS@phenoData))
{
massTracesXCMSSet@phenoData[i]<-fileNameMap[fileNameMap[,1]==rownames(massTracesXCMSSet@phenoData)[i],phenoDataColumn]
}
}

        CV<-function(x)
        {
		if(length(na.omit(x))<=2)return(100000)
          sd(x,na.rm = T)/mean(x,na.rm = T)
        }
xset<-inputXCMS
idx <- xcms:::groupidx(xset)
removeGR<-c()
removePk<-c()

for( i in seq_along(idx)){
  peak_select <- xcms::peaks(xset)[idx[[i]], ]
  peaks<-rep(NA,nrow(xset@phenoData))
if(class(peak_select)=="numeric")
{
 peaks[peak_select["sample"]]<-peak_select["into"]
}else
{
peaks[peak_select[,"sample"]]<-peak_select[,"into"]
}

  names(peaks)<-c(as.character(xset@phenoData[,1]))

  QCSamples<-peaks[names(peaks)==qc]
  realSamples<-NA
  if(rest)
  {
    realSamples<-peaks[names(peaks)!=qc]
  }else{
    realSamples<-peaks[names(peaks)==sample]
  }

  controlRemove<-F

  controlRemove<-CV(QCSamples)>=cvcut

  if(controlRemove)
  {

    removeGR<-c(removeGR,i)
    removePk<-c(removePk,idx[[i]])
  }
}

for(i in removeGR)
{
  xset@groupidx[[i]]<-NULL
  xset@groups<-xset@groups[-i,]
}

preprocessingSteps<-c(preprocessingSteps,"cvfilter")

varNameForNextStep<-as.character("xset")

save(list = c("xset","preprocessingSteps","varNameForNextStep"),file = output)


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly = TRUE)

library(tidyverse)

gff_file <- args[1]

dat <- ape::read.gff(gff_file) %>%
    dplyr::as_tibble() %>%
    dplyr::mutate(gene = stringr::str_remove_all(attributes, '.*gene=|;.*'),
           type = as.character(type)) %>%
    dplyr::filter(type == 'CDS') %>%
    dplyr::select(gene, start, end) %>%
    dplyr::mutate(offset = (start %% 3) - 1,
           s = dplyr::if_else(offset == 1, (start + 1) / 3, NaN ),
           s = dplyr::if_else(offset == 0, (start + 2) / 3, s),
           s = dplyr::if_else(offset == -1, (start + 3) / 3, s),
           e = round(((end - start + 1) / 3) + s - 1)) %>%
    dplyr::select(gene, start = s, end = e, offset)

purrr::map(levels(factor(dat$offset)), function(off){
           dat_2 <- dplyr::filter(dat, offset == off)
           if (nrow(dat_2) == 1) {
              dplyr::bind_rows(dat_2, tibble(gene = 'debug',
                                             start = 10000000000,
                                             end = 100000000000,
                                             offset = dat_2$offset)) %>%
              readr::write_csv(paste0('codfreq_gff_offset_', off, '.csv'))
           } else {
              dat_2  %>%
              readr::write_csv(paste0('codfreq_gff_offset_', off, '.csv'))
           }
})


#' Fit a local model via the local adaptive group lasso
#'
#' This function augments the covariates with local interactions, drops
#' observations with zero weight, runs the adaptive grouped lasso, computes the
#' residuals, and returns the necessary values for tuning or reporting.
#'
#' @param x matrix of observed covariates
#' @param y vector of observed responses
#' @param loc location at which to fit a model
#' @param family exponential family distribution of the response
#' @param varselect.method criterion to minimize in the regularization step of
#'   fitting local models - options are \code{AIC}, \code{AICc}, \code{BIC},
#'   \code{GCV}
#' @param tuning logical indicating whether this model will be used to tune the
#'   bandwidth, in which case only the tuning criteria are returned
#' @param kernel.weights vector of observation weights from the kernel
#' @param prior.weights vector of prior observation weights provided by the user
#' @param longlat \code{TRUE} indicates that the coordinates are specified in
#'   longitude/latitude, \code{FALSE} indicates Cartesian coordinates. Default
#'   is \code{FALSE}.
#'
#' @return list of coefficients, nonzero coefficient identities, and tuning data
#' @useDynLib lagr
#'
lagr.fit.inner = function(x, y, group.id, coords, loc, family, varselect.method, oracle, tuning, predict, simulation, n.lambda, lambda.min.ratio, lagr.convergence.tol, lagr.max.iter, verbose, kernel.weights=NULL, prior.weights=NULL, longlat=FALSE) {
    #Find which observations were made at the model location
    colocated = which(apply(coords, 1, function(cc) all(round(cc,5) == round(as.numeric(loc),5))))

    #Bail now if only one observation has weight:
    if (sum(kernel.weights)==length(colocated)) {
        return(list('tunelist'=list('df-local'=1, 'ssr-loc'=list('pearson'=Inf, 'deviance'=Inf))))
    }

    #Use oracular variable selection if specified
    orig.names = colnames(x)
    if (!is.null(oracle)) {
        x = matrix(x[,oracle], nrow=nrow(x), ncol=length(oracle))
        colnames(x) = oracle
    }

    #Establish groups for the group lasso and if there's an intercept, mark it as unpenalized
    if (0 %in% group.id)
        unpen = 0
    raw.vargroup = group.id

    #This is the naming system for the covariate-by-location interaction variables.
    raw.names = colnames(x)
    interact.names = vector()
    for (l in 1:length(raw.names)) {
        for (m in 1:ncol(coords)) {
            interact.names = c(interact.names, paste(raw.names[l], ":", colnames(coords)[m], sep=""))
        }
    }

    #Compute the covariate-by-location interactions
    q = ncol(coords)
    interacted = matrix(0, ncol=q*ncol(x), nrow=nrow(x))
    for (k in 1:ncol(x)) {
        for (ll in 1:q) {
            interacted[,q*(k-1)+ll] = x[,k, drop=FALSE]*(coords[,ll]-loc[[ll]])
            group.id = c(group.id, group.id[k])
        }
    }
    x.interacted = cbind(x, interacted)
    colnames(x.interacted) = c(raw.names, interact.names)

    #Combine prior weights and kernel weights
    w <- prior.weights * kernel.weights
    weighted = which(w>0)
    n.weighted = length(weighted)

    #Limit our attention to the observations with nonzero weight
    xxx = as.matrix(x.interacted[weighted,, drop=FALSE])
    yyy = as.matrix(y[weighted])
    colocated = which(kernel.weights[weighted]==1)
    w = w[weighted]
    sumw = sum(w)

    #Instantiate objects to store our output
    tunelist = list()

    if (is.null(oracle)) {
        #Use the adaptive group lasso to produce a local model:
        model = grouplasso(data=list(x=xxx, y=yyy), weights=w, index=group.id, family=family, maxit=lagr.max.iter, delta=2, nlam=n.lambda, min.frac=lambda.min.ratio, thresh=lagr.convergence.tol, unpenalized=unpen)

        vars = apply(as.matrix(model$beta), 2, function(x) {which(x!=0)})
        df = model$results$df + 1 #Add one because we must estimate the scale parameter.
    } else {
        model = glm(yyy~xxx-1, weights=w, family=family)
        vars = list(1:ncol(xxx))
        varset = vars[[1]]
        df = ncol(xxx) + 1 #Add one for the scale parameter

        fitted = model$fitted
        localfit = fitted[colocated]
        dispersion = summary(model)$dispersion
        k = 1

        #Estimating scale in penalty formula:
        loss = sumw * log(sum(w * model$residuals**2)) - log(sumw) + 1
    }

    if (sumw > ncol(x)) {
        if (is.null(oracle)) {
            #Extract the fitted values for each lambda:
            dispersion = model$results$dispersion

            #Using the grouplasso's criteria:
            loss = model$results[[varselect.method]]

            #Pick the lambda that minimizes the loss:
            k = which.min(loss)
            localfit = model$results$fitted[colocated,]
            df = df[k]
            if (k > 1) {
                varset = vars[[k]]
            } else {
                varset = NULL
            }
        }

        #Prepare some outputs for the bandwidth-finding scheme:
        tunelist[['localfit']] = localfit
        tunelist[['criterion']] = model$results[[varselect.method]]
        tunelist[['dispersion']] = dispersion
        tunelist[['n']] = sumw
        tunelist[['df']] = df
        tunelist[['df-local']] = length(colocated) * df / sumw

    } else {
        fitted = rep(meany, nrow(xxx))
        dispersion = 0
        loss = Inf
        loss.local = c(Inf)
        localfit = meany
    }

    #Get the coefficients:
    if (is.null(oracle)) {
        coefs = drop(model$beta)
        rownames(coefs) = colnames(xxx)

        #Use AIC weights, or not:
        if (varselect.method %in% c('wAIC','wAICc')) {
            #Big average based on a selection criterion:
            w = -model$results[[varselect.method]]
            w = matrix(w / sum(w))
            #coefs = (model$beta %*% w)[1:length(orig.names)]
            #conf.zero = drop((model$beta==0) %*% w)[1:length(orig.names)]
            coefs = drop(model$beta %*% w)
            conf.zero = drop((model$beta==0) %*% w)
        } else {
            #coefs = model$beta[1:length(orig.names),k]
            coefs = model$beta[,k]
            conf.zero = as.numeric(coefs==0)
            names(conf.zero) = names(coefs)
        }

        #list the covariates that weren't shrunk to zero, but don't bother listing the intercept.
        nonzero = raw.names[which(raw.vargroup %in% unique(group.id[which(conf.zero!=1)]))]
        nonzero = nonzero[nonzero != "(Intercept)"]

        #names(coefs) = raw.names
        #names(conf.zero) = colnames(raw.names)
        #names(coefs) = colnames(xxx)
        #names(conf.zero) = colnames(xxx)
    } else {
        #coefs = rep(0, length(orig.names))
        #names(coefs) = orig.names
        coefs = rep(0, ncol(xxx))
        names(coefs) = colnames(xxx)
        coefs[raw.names] = coef(model)[1:length(oracle)]
        nonzero = raw.names
        conf.zero = rep(0, length(orig.names))
        names(conf.zero) = colnames(raw.names)
    }

    if (tuning) {
        return(list(tunelist=tunelist, model=model, s=k, dispersion=dispersion, nonzero=nonzero, weightsum=sumw, loss=loss))
    } else if (predict) {
        return(list(tunelist=tunelist, coef=coefs, weightsum=sumw, s=k, dispersion=dispersion, nonzero=nonzero, conf.zero=conf.zero))
    } else if (simulation) {
        return(list(tunelist=tunelist, coef=coefs, s=k, dispersion=dispersion, fitted=localfit, nonzero=nonzero, conf.zero=conf.zero, actual=yyy[colocated], weightsum=sumw, loss=loss))
    } else {
        return(list(model=model, loss=loss, coef=coefs, nonzero=nonzero, conf.zero=conf.zero, s=k, loc=loc, df=df, loss.local=loss, dispersion=dispersion, fitted=localfit, weightsum=sumw, tunelist=tunelist))
    }
}


# 2. faza: Uvoz podatkov

valueForPath <- function(row, path) {
  row %>% html_node(xpath = path) %>% html_text()
}

# Tabela, ki prikazuje stevilke odseljevanja v Evropske drzave
# glede na starost(mladi, zreli, stari)

Starost_Evropa <- read.csv(
  "podatki/starost_tujina.csv"
)

Starost_Evropa <- Starost_Evropa[, c(1,7, 10,11,12,14,16)] %>%
  mutate(Starost = rep(c("Mladi", "Zreli", "Stari"),
                       each = length(unique(Leto)))) %>%
  pivot_longer(-c("Leto", "Starost"), names_to = "Drzava", values_to = "Stevilo")

# Tabela, ki prikazuje stevilke odseljevanja v Evropske drzave
# v tem primeru skoraj za vsako drzavo Evrope

Evropa <- read.csv(
  "podatki/starost_EU.csv",
  fileEncoding = "Windows-1250"
)

evropa <- Evropa %>% select(X, Skupno)
colnames(evropa) <- c("region", "SKUPNO")

mapdata = left_join(map_data("world"), evropa, by="region") %>%
  filter(!is.na(SKUPNO));

# Tabela, ki prikazuje stevilke odseljevanja iz Slovenije
# glede na izobrazbo, spol in starost

Starost_Izobrazba_Spol <- "podatki/starost_izobrazba_splosno.xml" %>%
  read_xml(encoding = "Windows-1250") %>% html_nodes(xpath = "/root/row")

Starost_Izobrazba_Spol <- tibble(
  Leto = as.integer(Starost_Izobrazba_Spol %>% sapply(function(row) {valueForPath(row, "Leto")})),
  Mladi = as.integer(Starost_Izobrazba_Spol %>% sapply(function(row) {valueForPath(row, "Mladi")})),
  Zreli = as.integer(Starost_Izobrazba_Spol %>% sapply(function(row) {valueForPath(row, "Zreli")})),
  Stari = as.integer(Starost_Izobrazba_Spol %>% sapply(function(row) {valueForPath(row, "Stari")})),
)

Starost_Izobrazba_Spol <- Starost_Izobrazba_Spol %>%
  mutate(Izobrazba = rep(c("OS_moski", "SS_moski", "VS_moski", "OS_zenske", "SS_zenske", "VS_zenske"),
  each = length(unique(Leto)))) %>%
  pivot_longer(-c("Leto", "Izobrazba"), names_to = "Starost", values_to = "Stevilo")

# Tabela, ki prikazuje stevilke odseljevanja iz Slovenije
# glede na starost in spol

Starost_Spol <- "podatki/starost_spol.xml" %>%
  read_xml(encoding = "Windows-1250") %>% html_nodes(xpath = "/root/row")

Starost_Spol <- tibble(
  Leto = as.integer(Starost_Spol %>% sapply(function(row) {valueForPath(row, "Leto")})),
  Mladi = as.integer(Starost_Spol %>% sapply(function(row) {valueForPath(row, "Mladi")})),
  Zreli = as.integer(Starost_Spol %>% sapply(function(row) {valueForPath(row, "Zreli")})),
  Stari = as.integer(Starost_Spol %>% sapply(function(row) {valueForPath(row, "Stari")}))
) %>%
  mutate(Spol = rep(c("Moski", "Zenske"),
  each = length(unique(Leto)))) %>%
  pivot_longer(-c("Leto", "Spol"), names_to = "Starost", values_to = "Stevilo")

# Tabela, ki prikazuje stevilke odseljevanja iz Slovenije
# glede na aktivnost(zaposlen, nezaposlen) in spol

Aktivnost <- "podatki/aktivnost_splosno.xml" %>%
  read_xml(encoding = "Windows-1250") %>% html_nodes(xpath = "/root/row")

Aktivnost <- tibble(
  Leto = as.integer(Aktivnost %>% sapply(function(row) {valueForPath(row, "Leto")})),
  Zaposleni = as.integer(Aktivnost %>% sapply(function(row) {valueForPath(row, "Zaposleni")})),
  Nezaposleni = as.integer(Aktivnost %>% sapply(function(row) {valueForPath(row, "Nezaposleni")}))
) %>%
  mutate(Starost = rep(c("Mladi", "Zreli", "Mlade", "Zrele"),
  each = length(unique(Leto)))) %>%
  pivot_longer(-c("Leto", "Starost"), names_to = "Aktivnost", values_to = "Stevilo")


## Exercício 8
## Prof. James Hunter
## from: https://rstudio.cloud/project/1181159
## 12 de maio de 2020

# colocar mpg em memoria

mpg <- mpg

# Objetivo: displ x cty com drv

ggplot(data = mpg, mapping = aes(x = displ, y = cty, colour = drv)) +
  geom_point()


x <- function (x, y, wt = NULL, intercept = TRUE, tolerance = 1e-07,
    yname = NULL)
{
    x <- as.matrix(x)
    y <- as.matrix(y)
    xnames <- colnames(x)
    if (is.null(xnames)) {
        if (ncol(x) == 1L)
            xnames <- "X"
        else xnames <- paste0("X", 1L:ncol(x))
    }
    if (intercept) {
        x <- cbind(1, x)
        xnames <- c("Intercept", xnames)
    }
    if (is.null(yname) && ncol(y) > 1)
        yname <- paste0("Y", 1L:ncol(y))
    good <- complete.cases(x, y, wt)
    dimy <- dim(as.matrix(y))
    if (any(!good)) {
        warning(sprintf(ngettext(sum(!good), "%d missing value deleted",
            "%d missing values deleted"), sum(!good)), domain = NA)
        x <- as.matrix(x)[good, , drop = FALSE]
        y <- as.matrix(y)[good, , drop = FALSE]
        wt <- wt[good]
    }
    nrx <- NROW(x)
    ncx <- NCOL(x)
    nry <- NROW(y)
    ncy <- NCOL(y)
    nwts <- length(wt)
    if (nry != nrx)
        stop(sprintf(paste0(ngettext(nrx, "'X' matrix has %d case (row)",
            "'X' matrix has %d cases (rows)"), ", ", ngettext(nry,
            "'Y' has %d case (row)", "'Y' has %d cases (rows)")),
            nrx, nry), domain = NA)
    if (nry < ncx)
        stop(sprintf(paste0(ngettext(nry, "only %d case", "only %d cases"),
            ", ", ngettext(ncx, "but %d variable", "but %d variables")),
            nry, ncx), domain = NA)
    if (!is.null(wt)) {
        if (any(wt < 0))
            stop("negative weights not allowed")
        if (nwts != nry)
            stop(gettextf("number of weights = %d should equal %d (number of responses)",
                nwts, nry), domain = NA)
        wtmult <- wt^0.5
        if (any(wt == 0)) {
            xzero <- as.matrix(x)[wt == 0, ]
            yzero <- as.matrix(y)[wt == 0, ]
        }
        x <- x * wtmult
        y <- y * wtmult
        invmult <- 1/ifelse(wt == 0, 1, wtmult)
    }
    z <- .Call(C_Cdqrls, x, y, tolerance, FALSE)
    resids <- array(NA, dim = dimy)
    dim(z$residuals) <- c(nry, ncy)
    if (!is.null(wt)) {
        if (any(wt == 0)) {
            if (ncx == 1L)
                fitted.zeros <- xzero * z$coefficients
            else fitted.zeros <- xzero %*% z$coefficients
            z$residuals[wt == 0, ] <- yzero - fitted.zeros
        }
        z$residuals <- z$residuals * invmult
    }
    resids[good, ] <- z$residuals
    if (dimy[2L] == 1 && is.null(yname)) {
        resids <- drop(resids)
        names(z$coefficients) <- xnames
    }
    else {
        colnames(resids) <- yname
        colnames(z$effects) <- yname
        dim(z$coefficients) <- c(ncx, ncy)
        dimnames(z$coefficients) <- list(xnames, yname)
    }
    z$qr <- as.matrix(z$qr)
    colnames(z$qr) <- xnames
    output <- list(coefficients = z$coefficients, residuals = resids)
    if (z$rank != ncx) {
        xnames <- xnames[z$pivot]
        dimnames(z$qr) <- list(NULL, xnames)
        warning("'X' matrix was collinear")
    }
    if (!is.null(wt)) {
        weights <- rep.int(NA, dimy[1L])
        weights[good] <- wt
        output <- c(output, list(wt = weights))
    }
    rqr <- list(qt = drop(z$effects), qr = z$qr, qraux = z$qraux,
        rank = z$rank, pivot = z$pivot, tol = z$tol)
    oldClass(rqr) <- "qr"
    output <- c(output, list(intercept = intercept, qr = rqr))
    return(output)
}


#' Plot catch curves for indices
#'
#' Creates catch curves to estimate Z from index catch data (converted from West Coast style indices).
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param first.age youngest age to use in catch curve, -999 finds peak age (defaults to -999)
#' @export

PlotCatchCurvesForIndices <- function(asap,a1,save.plots,od,plotf,first.age=-999){
  # first check to see if any West Coast style indices
  if(sum(asap$control.parms$index.age.comp.flag) == 0){
    return(list())
  }

  # create catch curve plots for each west coast style index
  usr <- par("usr"); on.exit(par(usr))

  catch.curve.ind <- list()
  my.col <- rep(c("blue","red","green","orange","gray50"),50)

  # convert the west coast style indices to catch at age matrices
  index.mats <- ConvertSurveyToAtAge(asap)

  # loop through all the indices
  for (ind in 1:asap$parms$nindices){
    if (asap$control.parms$index.age.comp.flag[ind] == 1){  # used age composition for the index
      title1 <- paste0("Index ",ind)

      min.age <- asap$control.parms$index.sel.start.age[ind]
      max.age <- asap$control.parms$index.sel.end.age[ind]
      ages <- seq(min.age, max.age)
      nages.i <- max.age - min.age + 1
      cohort <- seq(asap$parms$styr-nages.i-min.age, asap$parms$endyr+nages.i-min.age)

      # replace zeros with NA and take logs
      iob <- rep0log(index.mats$ob[[ind]])
      ipr <- rep0log(index.mats$pr[[ind]])

      # make cohorts
      iob.coh <- makecohorts(iob)
      ipr.coh <- makecohorts(ipr)

      # drop plus group
      if (asap$control.parms$index.sel.end.age[ind] == asap$parms$nages){
        iob.coh[,length(iob.coh[1,])] <- NA
        ipr.coh[,length(iob.coh[1,])] <- NA
      }

      first.age.label <- 1
      if (first.age==1) title1 <- paste0(title1," First Age = 1")

      # determine which ages to use for each cohort (default)
      if (first.age == -999){
        iob.coh <- find_peak_age(iob.coh)
        ipr.coh <- find_peak_age(ipr.coh)
        first.age.label <- "find_peak"
        title1 <- paste0(title1," (Peak Age)")

      }

      # or drop youngest ages based on user control
      if (first.age > min.age) {
        iob.coh[,1:(first.age-min.age)] <- NA
        ipr.coh[,1:(first.age-min.age)] <- NA
        title1 <- paste0(title1," First Age = ",first.age)
        first.age.label <- first.age
      }

      # compute Z by cohort
      z.ob <- calc_Z_cohort(iob.coh)
      z.pr <- calc_Z_cohort(ipr.coh)

      # make the plots
      par(mfrow=c(2,1))
      plot(cohort,cohort,type='n',ylim=range(c(iob.coh,ipr.coh),na.rm=T),xlab="",ylab="Log(Index)",main=paste0(title1," Observed"))
      for (i in 1:length(iob.coh[,1])){
        lines(seq(cohort[i],cohort[i]+nages.i-1),iob.coh[i,],type='p',lty=1,pch=seq(1,nages.i),col="gray50")
        lines(seq(cohort[i],cohort[i]+nages.i-1),iob.coh[i,],type='l',lty=1,col=my.col[i])
      }

      Hmisc::errbar(cohort,z.ob[,1],z.ob[,3],z.ob[,2],xlab="Year Class",ylab="Z",ylim=range(c(z.ob,z.pr),na.rm=T))

      if (save.plots) savePlot(paste0(od,"catch_curve_",title1,"_Observed_first_age_",first.age.label,".",plotf), type=plotf)

      plot(cohort,cohort,type='n',ylim=range(c(iob.coh,ipr.coh),na.rm=T),xlab="",ylab="Log(Index)",main=paste0(title1," Predicted"))
      for (i in 1:length(iob.coh[,1])){
        lines(seq(cohort[i],cohort[i]+nages.i-1),ipr.coh[i,],type='p',lty=1,pch=seq(1,nages.i),col="gray50")
        lines(seq(cohort[i],cohort[i]+nages.i-1),ipr.coh[i,],type='l',lty=1,col=my.col[i])
      }

      Hmisc::errbar(cohort,z.pr[,1],z.pr[,3],z.pr[,2],xlab="Year Class",ylab="Z",ylim=range(c(z.ob,z.pr),na.rm=T))

      if (save.plots) savePlot(paste0(od,"catch_curve_",title1,"_Predicted_first_age_",first.age.label,".",plotf), type=plotf)

      # write out .csv files for Z, one file for each fleet
      asap.name <- a1$asap.name

      colnames(z.ob) <-c("Z.obs","low.80%", "high.80%")
      write.csv(z.ob, file=paste0(od,"Z.Ob.Index.",ind,"_",asap.name,".csv"), row.names=cohort)

      colnames(z.pr) <-c("Z.pred","low.80%", "high.80%")
      write.csv(z.pr, file=paste0(od,"Z.Pr.Index.",ind,"_",asap.name,".csv"), row.names=cohort)
    }
  }   # end loop over nindices
  return(catch.curve.ind)
}


require(tseriesChaos)
require(rgl)
amin <- NULL; cosmin <- NULL; maja <- NULL; rob <- NULL; jordan <- NULL; sophia <- NULL;

d <- 3; m <- 12;

amin$e <- read.csv('data/walks/amin.dat',sep=' ',colClasses="numeric",header=FALSE)
cosmin$e <- read.csv('data/walks/cosmin.dat',sep=' ',colClasses="numeric",header=FALSE)
maja$e <- read.csv('data/walks/maja.dat',sep=' ',colClasses="numeric",header=FALSE)
jordan$e <- read.csv('data/walks/jordan.dat',sep=' ',colClasses="numeric",header=FALSE)
rob$e <- read.csv('data/walks/rob.dat',sep=' ',colClasses="numeric",header=FALSE)
sophia$e <- read.csv('data/walks/sophia.dat',sep=' ',colClasses="numeric",header=FALSE)

amin$data <- t(amin$e[,1])
cosmin$data <- t(cosmin$e[,1])
maja$data <- t(maja$e[,1])
jordan$data <- t(jordan$e[,1])
rob$data <- t(rob$e[,1])
sophia$data <- t(sophia$e[,1])

y <- 2:4;
x <- 1:4000;

rgl.open()
rgl.clear()
#rgl.linestrips(amin$e[x,y],color=c("white"), alpha=0.5)
#rgl.linestrips(cosmin$e[x,y],color=c("red"), alpha=0.5)
rgl.linestrips(maja$e[x,y],color=c("blue"), alpha=0.5)
#rgl.linestrips(jordan$e[x,y],color=c("green"), alpha=0.5)
#rgl.linestrips(rob$e[x,y],color=c("yellow"), alpha=0.5)
rgl.linestrips(sophia$e[x,y],color=c("cyan"), alpha=0.5)


# this takes about 6 hours on a mobile i9 with 32 G of RAM
# data saved as data/output.summary.yeast.Rda

# change this to run the simulation if wanted
# depends on TP-FP-yeast-setup.r for datasets
run.this = FALSE

if(!exists('output.summaryFP.yeast')){
  load(paste(my.path,'data/output.summaryFP.yeast.Rda', sep=''))
}
if(run.this == TRUE){

library(foreach)
library(doMC)

# original tests done at 100 replicates
test.size <- 100
max.samples <- 20
registerDoMC(4) # this is the MC backend.
# 4 cores seems to be the performance limit
# beyond that there is throttling of each thread

output.summary <- list()
output.summaryFP.yeast <- list()

output.summaryFP.yeast <- foreach(j = 2:max.samples)%dopar%{
    print(j)
	n.samples = j

	summary.stats <- matrix(data=NA, ncol=6, nrow=test.size)

	colnames(summary.stats) <- c('eff.FP.5','eff.FP1','eff.FP2', 'ol.1.FP', 'diff.1.FP', 'triple.FP')

	for(i in 1:test.size){
		test.col  <- c(sample(1:43,n.samples *2))
		test.conds <- c(rep("a", n.samples), rep("b",n.samples))
		test.data <- d.good[,test.col]
		x.test <- aldex.clr(test.data, test.conds, verbose=F)
		x.e.test <- aldex.effect(x.test, verbose=F)

		test.diff.ol <- rownames(x.e.test)[which(x.e.test$overlap < 0.1)]
		test.diff <- rownames(x.e.test)[which(abs(x.e.test$diff.btw) > 1)]
		test.diff.eff <- rownames(x.e.test)[which(abs(x.e.test$effect) > 0.5)]
		test.diff.eff1 <- rownames(x.e.test)[which(abs(x.e.test$effect) > 1)]
		test.diff.eff2 <- rownames(x.e.test)[which(abs(x.e.test$effect) > 2)]
		test.triple <- intersect(test.diff.eff1, intersect(test.diff.ol, test.diff))

		summary.stats[i,1] <- length(test.diff.eff)
		summary.stats[i,2] <- length(test.diff.eff1)
		summary.stats[i,3] <- length(test.diff.eff2)
		summary.stats[i,4] <- length(test.diff.ol)
		summary.stats[i,5] <- length(test.diff)
		summary.stats[i,6] <- length(test.triple)

	}
    output.summary[[j]] <- summary.stats
}
save(output.summaryFP.yeast, file=paste(my.path,'data/output.summaryFP.yeast.Rda', sep=''))
}

if(!exists('output.summaryFP.ty')){
  load(paste(my.path,'data/output.summaryFP.ty.Rda', sep=''))
}

# original tests done at 100 replicates
test.size <- 100
max.samples <- 20
registerDoMC(6) # this is the MC backend.
# 4 cores seems to be the performance limit
# beyond that there is throttling of each thread
# takes less than an hour on i9 32G

if(run.this == TRUE){

output.summary <- list()
output.summaryFP.ty <- list() # this is the young soldier cohort

output.summaryFP.ty <- foreach(j = 2:max.samples)%dopar%{
    print(j)
	n.samples = j

	summary.stats <- matrix(data=NA, ncol=6, nrow=test.size)

	colnames(summary.stats) <- c('eff.FP.5','eff.FP1','eff.FP2', 'ol.1.FP', 'diff.1.FP', 'triple.FP')

	for(i in 1:test.size){
		test.col  <- c(sample(161:373,n.samples *2))
		test.conds <- c(rep("a", n.samples), rep("b",n.samples))
		test.data <- d[,test.col]
		x.test <- aldex.clr(test.data, test.conds, verbose=F)
		x.e.test <- aldex.effect(x.test, verbose=F)

		test.diff.ol <- rownames(x.e.test)[which(x.e.test$overlap < 0.1)]
		test.diff <- rownames(x.e.test)[which(abs(x.e.test$diff.btw) > 1)]
		test.diff.eff <- rownames(x.e.test)[which(abs(x.e.test$effect) > 0.5)]
		test.diff.eff1 <- rownames(x.e.test)[which(abs(x.e.test$effect) > 1)]
		test.diff.eff2 <- rownames(x.e.test)[which(abs(x.e.test$effect) > 2)]
		test.triple <- intersect(test.diff.eff1, intersect(test.diff.ol, test.diff))

		summary.stats[i,1] <- length(test.diff.eff)
		summary.stats[i,2] <- length(test.diff.eff1)
		summary.stats[i,3] <- length(test.diff.eff2)
		summary.stats[i,4] <- length(test.diff.ol)
		summary.stats[i,5] <- length(test.diff)
		summary.stats[i,6] <- length(test.triple)

	}
    output.summary[[j]] <- summary.stats
}
save(output.summaryFP.ty, file=paste(my.path,'peerj/data/output.summaryFP.ty.Rda', sep=''))
}

med.data.FP.yeast <- matrix(data=NA, nrow=(max.samples - 1), 7)
colnames(med.data.FP.yeast) <- c('n', colnames(output.summaryFP.yeast[[1]]))
upper.data.FP.yeast <- matrix(data=NA, nrow=(max.samples - 1), 7)

for( i in 1:(max.samples - 1) ){
  med.data.FP.yeast[i,1] <- i+1
  med.data.FP.yeast[i,2:7] <- apply(output.summaryFP.yeast[[i]], 2, median)
  upper.data.FP.yeast[i,1] <- i+1
  upper.data.FP.yeast[i,2:7] <- apply(output.summaryFP.yeast[[i]], 2, function(x) quantile(x, probs=c(0.025, 0.5, 0.95))[3])
}

# young soldier cohort, youth cohort gives essentially same result
med.data.FP.ty <- matrix(data=NA, nrow=(max.samples - 1), 7)
colnames(med.data.FP.ty) <- c('n', colnames(output.summaryFP.ty[[1]]))
upper.data.FP.ty <- matrix(data=NA, nrow=(max.samples - 1), 7)

for( i in 1:(max.samples - 1) ){
  med.data.FP.ty[i,1] <- i+1
  med.data.FP.ty[i,2:7] <- apply(output.summaryFP.ty[[i]], 2, median)
  upper.data.FP.ty[i,1] <- i+1
  upper.data.FP.ty[i,2:7] <- apply(output.summaryFP.ty[[i]], 2, function(x) quantile(x, probs=c(0.025, 0.5, 0.95))[3])
}


consumer_set_of_resource <- function(consumer, resource, inter_type) {
  # The arguments must represent binary interactions identifed by 1 (interaction) or 0 (non-interaction)
  consumer_list <- as.character(unique(consumer))
  cons_res <- matrix(nrow = length(consumer_list), ncol = 3, dimnames = list(c(), c('consumer', 'resource', 'non-resource')))
  cons_res[, 'consumer'] <- consumer_list

  for(i in 1:length(consumer_list)){
    yes.resource <- resource[names(which(inter_type[which(consumer == consumer_list[i])] == "1"))]
    non.resource <- resource[names(which(inter_type[which(consumer == consumer_list[i])] == "0"))]
    cons_res[i , 'resource'] <- paste(unique(yes.resource), collapse = ' | ')
    cons_res[i , 'non-resource'] <- paste(unique(non.resource), collapse = ' | ')
  } #i

return(cons_res)

} #function


#
# Combine the results of the two classification runs with gradient boosted models
#
# The population and sampled classifications are in a data frame called "results"
# The tasampled classifications are in a data frame called "subsets" since they're subsets of the single large database
# The combined (non-subsetted) tasampled classification is in a data frame called "combined_results"
#
library(mmadsenr)

load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "balancedbias-neutral-comparison-gbm-dfonly.RData"))
balanced_bias_results <- data.frame(bias_results)
rm(bias_results)

load(get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "bias-model-comparisons-gbm-dfonly.RData"))

balanced_bias_results$exp_group <- 'Mixed Bias/Neutrality Comparison'
bias_results$exp_group <- 'Pro/Anti Conformism Comparison'

full_bias_results <- rbind(balanced_bias_results, bias_results)

###### Add two useful statistics #######

full_bias_results$fdr <- 1.0 - full_bias_results$ppv
full_bias_results$youdensj <- full_bias_results$sensitivity + full_bias_results$specificity - 1.0

############## Complete Processing and Save Results ##########3

# save objects from the environment
image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4/results", filename = "biased-gbm-merged-dfonly.RData")
save(full_bias_results, file=image_file)


b <-
1:5

print (
a
)

1 + 2
-3


#' Cut p-values.
#'
#' Cut p-values according to a significance criterium.
#'
#' This is a simple internal function for cutting a vector of p-values into
#' a set of meaningful categories. The categories are taken from the original
#' book chapter that inspired the package.
#'
#' @param p_values A numeric containing the p-values
#' @return A factor containing the resulting categories.
#' @keywords internal
cut_pvalues = function(p_values) {
  result = cut(
    p_values,
    c(-Inf, 1e-10, 1e-5, 0.001, 0.01, 0.05, Inf),
    labels = c('< 1e-10', '< 1e-5', '< 0.001', '< 0.01', '< 0.05', 'NS'),
    include.lowest = TRUE
    )
  return(result)
}

#' Get p-value from F statistic data.
#'
#' Get p-value from F statistic data in the summary of an \code{lm} object.
#'
#' This is an internal function that extracts the p-value from the information
#' generated by a call to the \code{summary} function on a \code{lm} object. It
#' uses the F statistic value and the degrees of freedom in order to compute the
#' p-value.
#'
#' @param fstat A numeric vector of length three obtained from a linear model
#' fit.
#' @return The computed p-value.
#' @keywords internal
get_p_value = function(fstat) {
  if (is.numeric(fstat['value'])) {
    p_value = 1 - pf(fstat[['value']], fstat[['numdf']], fstat[['dendf']])
  } else {
    warning('Non-numeric F statistic. Setting p-value to 1.')
    p_value = 1
  }
  return(p_value)
}

#' Get variable names suitable for analysis.
#'
#' Get variable names that fulfill the conditions in order to be tested for
#' association.
#'
#' This is an internal function taking the phenotype data.frame as input. It
#' returns a character vector containing the names of those variables which can
#' be tested for association. The current implementation avoids testing on
#' categorical variables where all elements belong to the same level, or where
#' every level has only one observation.
#'
#' @param pdata A data.frame containing the phenotypical data.
#' @return A character vector containing the selected variable names.
#' @keywords internal
get_var_names = function(pdata) {
  if (!is.data.frame(pdata)) {
    stop('Input must be a data.frame.')
  }

  n_levels = sapply(pdata, function(xx) length(unique(xx)))
  var_names = colnames(pdata)[(n_levels > 1 & n_levels < nrow(pdata)) |
                                sapply(pdata, is.numeric)]

  if (length(var_names) == 0) {
    stop('There are no suitable variables for testing.')
  }

  names(var_names) = var_names

  return(var_names)
}

#' Compute associations with phenotypical variables.
#'
#' Compute associations with phenotypical and control variables in order to
#' find out which of them are significant, and thus possibly introducing
#' some confounding in the data.
#'
#' The current implementation allows the user to use two different methods
#' for testing association: a general linear model (lm) and a Kruskal-Wallis
#' test. User should be careful, as the Kruskal Wallis test should not be used
#' for continuous independent variables.
#'
#' An association test is performed between every component (Principal Component
#' or Surrogate Variable) and every phenotype and control variable. P-values are
#' then collected and stored in a \code{tbl_df} object describing all the
#' comparisons.
#'
#' This function receives variable names as a parameter.
#'
#' @inheritParams compute_significance_data
#' @param var_names Variable names to be used for calculating the p_values.
#' @return A data.frame with the results of the association tests.
#' @importFrom dplyr %>% mutate_
#' @importFrom tidyr gather_
#' @importFrom stats lm na.omit pf model.matrix kruskal.test
#' @keywords internal
compute_significance_data_var_names = function(values, pdata, component_names,
                                                var_names,
                                                method = c('lm', 'kruskal')) {
  method = match.arg(method)

  if (is.null(names(var_names))) {
    names(var_names) = var_names
  }

  if (method == 'kruskal') {
    is_col_numeric = vapply(pdata[, var_names], is.numeric, FALSE)

    if (any(is_col_numeric)) {
      stop(paste('Kruskal-Wallis method cannot be used when there are numeric',
                 'phenotype variables.'))
    }

    get_kruskal_p_value = function(val, pd) {
      kruskal.test(val, pd)[['p.value']]
    }
    pvalues = lapply(var_names,
                     function(xx) apply(values, 2,
                                        get_kruskal_p_value,
                                        as.factor(pdata[, xx])))
  } else {
    model_fits = lapply(var_names, function(xx) lm(values ~ pdata[, xx]))
    model_summaries = lapply(model_fits, summary)

    # Result being a nested list depends on the number of columns of values
    if (ncol(values) == 1) {
      pvalues = lapply(
        model_summaries,
        function(xx) get_p_value(xx[['fstatistic']])
      )
    } else {
      pvalues = lapply(
        model_summaries,
        function(xx) sapply(xx, function(yy) get_p_value(yy[['fstatistic']]))
      )
    }
  }
  p_values_df = data.frame(pvalues, check.names = FALSE)

  significance_data = p_values_df %>%
    mutate_('PC' = ~ component_names) %>%
    gather_('Variable', 'P_Value', var_names) %>%
    mutate_('Sig' = ~ cut_pvalues(P_Value))

  return(significance_data)
}

#' Compute associations with phenotypical variables.
#'
#' Compute associations with phenotypical and control variables in order to
#' find out which of them are significant, and thus possibly introducing
#' some confounding in the data.
#'
#' The current implementation allows the user to use two different methods
#' for testing association: a general linear model (lm) and a Kruskal-Wallis
#' test. User should be careful, as the Kruskal Wallis test should not be used
#' for continuous independent variables.
#'
#' An association test is performed between every component (Principal Component
#' or Surrogate Variable) and every phenotype and control variable. P-values are
#' then collected and stored in a \code{tbl_df} object describing all the
#' comparisons.
#'
#' @param values A matrix containing either principal components or surrogate
#' variables.
#' @param pdata A data.frame containing the phenotypical data for the samples.
#' @param component_names A character vector containing the component names.
#' @param method A character indicating the method used for the association
#' tests.
#' @return A data.frame with the results of the association tests.
#' @importFrom dplyr %>% mutate_
#' @importFrom tidyr gather_
#' @keywords internal
compute_significance_data = function (values, pdata, component_names,
                                      method = c('lm', 'kruskal')) {
  var_names = get_var_names(pdata)

  return(compute_significance_data_var_names(values, pdata, component_names,
                                        var_names, method))
}

#' Get control variables.
#'
#' Get a matrix containing the signals for the control probes of a given
#' RGChannelSet object.
#'
#' The function \code{get_control_variables} just takes a \code{RGChannelSet}
#' object as input, accesses the values of its control probes, and returns
#' them as a numeric matrix.
#'
#' This is an internal function. Its purpose is to provide the main analysis
#' functions with more data to test. It is usually useful to test if control
#' probes are introducing some confounding in the dataset, as it might be
#' signaling that there are unknown effects in the data.
#'
#' @param rgset An RGChannelSet object containing the control data.
#' @importFrom methods is
#' @importFrom minfi getControlAddress getRed getGreen
#' @return A matrix with the values of the control elements.
#' @keywords internal
get_control_variables = function(rgset) {
  if (!is(rgset, 'RGChannelSet')) {
    stop('Input must be of RGChannelSet type.')
  }

  bc1 = getControlAddress(rgset, controlType = c('BISULFITE CONVERSION I'))
  bc2 = getControlAddress(rgset, controlType = c('BISULFITE CONVERSION II'))
  ext = getControlAddress(rgset, controlType = c('EXTENSION'))
  tr = getControlAddress(rgset, controlType = c('TARGET REMOVAL'))
  hyb = getControlAddress(rgset, controlType = c('HYBRIDIZATION'))

  control_names = c(
    'BSC-I C1 Grn',
    'BSC-I C2 Grn',
    'BSC-I C3 Grn',
    'BSC-I C4 Red',
    'BSC-I C5 Red',
    'BSC-I C6 Red',
    'BSC-II C1 Red',
    'BSC-II C2 Red',
    'BSC-II C3 Red',
    'BSC-II C4 Red',
    'Target Removal 1 Grn',
    'Target Removal 2 Grn',
    'Hyb (Low) Grn',
    'Hyb (Medium) Grn',
    'Hyb (High) Grn',
    'Extension (A) Red',
    'Extension (T) Red',
    'Extension (C) Grn',
    'Extension (G) Grn'
  )

  control_signals = rbind(
    getGreen(rgset)[bc1[1:3],],
    getRed(rgset)[bc1[7:9],],
    getRed(rgset)[bc2[1:4],],
    getGreen(rgset)[tr[1:2],],
    getGreen(rgset)[hyb[1:3],],
    getRed(rgset)[ext[1:2],],
    getGreen(rgset)[ext[3:4],]
  )
  dimnames(control_signals) = list(control_names, colnames(rgset))

  datac2_m = t(log2(control_signals))

  return(datac2_m)
}


#calculates autofit(p,q)order/arma model,divides list into stationary & non-stationary

rm(list=ls())
library(itsmr)  #adding itsmr package

faana<-"C:\\kindle_patrika\\jugnu_bholu\\"  #file path for r values
madhur<-list.files(faana)

naringi_firangi<-NULL #complete row information for Stationary model
bunty_bubly<-NULL  #for taking all Non-Stationary info

for (sangeet in madhur){

 html_page<-substr(sangeet,1,nchar(sangeet)-4) #name of file
 compendium<- read.table(paste(faana,sangeet,sep=""),skip=1)
   print(paste("Reading-------------------------------->",html_page))

 #autofit(arma)model  & checking for non stationarity
 j<-NULL
 j<-tryCatch(red_money<-autofit(ts(compendium$V1)),error=function(e)e )   #autofit(arma)model (max likelihood method)

 if(inherits(j,"simpleError")){ bunty_bubly<-append(bunty_bubly,html_page);print(paste("Non-Stationary-------------------------->",html_page))}
 else{

 autofit_ar_p<-length(red_money$phi)  #autoregressive p value
 autofit_ma_q<-length(red_money$theta)  #moving average q value
 autofit_aicc<-red_money$aicc   #aicc

 #joining single line
 bumro<-cbind(html_page,autofit_ar_p,autofit_ma_q,autofit_aicc,deparse.level=0)
 naringi_firangi<-rbind(naringi_firangi,bumro)
            } #non-stationary else

}  #last for

#only stationary model
if(is.null(naringi_firangi)){write("Your data has no Autofit ARMA stationary models","C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_arma_stationary.txt") }else{
write.table(naringi_firangi,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_arma_stationary.txt",col.names=c("PDB_file","AutoF_ar_p","AutoF_ma_q","AutoF_aicc"),row.names=F)
     } #else stationary

#Non-Stationary model
if(is.null(bunty_bubly)){ write("Your data has NO Autofit ARMA NON-stationary models","C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_dhak_dhak_non_stat.txt") }else{
write.table(bunty_bubly,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_dhak_dhak_non_stat.txt",col.names="Non-Stationary models",row.names=F)
                      } #else non-stationary


# Scatterplot faceted by payee, colored by account
p <- qplot(date, amount, data = ledger_data, geom = "point", colour = account, alpha = I(1/2)) + facet_wrap(~payee)

ggsave(file = "scatter-amount-vs-date-by-account-faceted-by-payee.svg", plot = p, width = 10, height = 10)