#!/usr/bin/env Rscript

#===============================================================================
# TITLE    : analysis-engine.r
# ABSTRACT : An R script that combines RNA-seq data files and BETA gene lists to
#            generate combined gene activity TSV files
#
# AUTHOR   : Dennis Aldea <dennis.aldea@gmail.com>
# DATE     : 2017-07-12
#
# LICENSE  : MIT <https://opensource.org/licenses/MIT>
#-------------------------------------------------------------------------------
# USAGE:
#
#     ./analysis-engine.r <rna-path> <beta-path> <window-size> <output-path>
#
# DESCRIPTION:
#
#     <rna-path>      : filepath of the file containing RNA-seq data
#     <beta-path>     : filepath of the file containing BETA data
#     <window-size>   : number of genes used to calculate a binding score
#     <output-path>   : filepath where the gene activity TSV file will be saved
#===============================================================================

# store command line arguments into a list with given names and convert numeric
# strings to doubles
store_arguments <- function(name_vector) {
    # store command line arguments in a list
    argument_list <- as.list(commandArgs(trailingOnly = TRUE))
    for (index in 1:length(argument_list)) {
        # if argument is a numeric string, convert it to double
        if (suppressWarnings(!is.na(as.double(argument_list[index])))) {
            argument_list[index] <- as.double(argument_list[index])
        }
    }
    names(argument_list) <- name_vector
    return(argument_list)
}

# generate a vector of window sums of a given size in a given numeric vector
sum_windows <- function(addend_vector, window_size) {
    upper_index <- length(addend_vector)
    # pre-allocate the sum vector (same length as addend column) to reduce
    # calculation time
    sum_vector <- numeric(upper_index)
    # append first window sum to sum vector
    sum_vector[1] <- sum(addend_vector[1:window_size])
    # calculate complete window sums using rolling algorithm
    for (index in 2:upper_index) {
        window_sum <- sum_vector[index - 1] - addend_vector[index - 1]
        if ((index - 1) + window_size <= upper_index) {
            window_sum <- window_sum + addend_vector[(index - 1) + window_size]
        }
        sum_vector[index] <- window_sum
    }
    return(sum_vector)
}

# read arguments from command line
argument_names <- c("rna_path", "beta_path", "window_size", "output_path")
args <- store_arguments(argument_names)

# read RNA-seq data from TSV file
rna_frame <- read.delim(args[["rna_path"]], header = FALSE)
colnames(rna_frame) <- c("gene_name", "transcription_score")

# read BETA data from TSV file
beta_frame <- read.delim(args[["beta_path"]], header = FALSE)
beta_vector <- beta_frame[[ncol(beta_frame)]]

# calculate binding flags from case-insensitive match vector
match_vector <- toupper(rna_frame[["gene_name"]]) %in% toupper(beta_vector)
match_vector <- as.numeric(match_vector)
rna_frame[["binding_flag"]] <- match_vector

# calculate binding scores from binding flags and window size
score_vector = sum_windows(rna_frame[["binding_flag"]], args[["window_size"]])
rna_frame[["binding_score"]] <- score_vector

# extract output frame from input frame
output_columns <- c("gene_name", "transcription_score", "binding_score")
output_frame <- rna_frame[output_columns]

# write output frame to output TSV
write.table(output_frame, file = args[["output_path"]], quote = FALSE,
            sep = "\t", row.names = FALSE, col.names = FALSE)


#' Subsets an array using a list with indices or names
#'
#' @param X      The array to subset
#' @param index  A list of vectors to use for subsetting, or vector if along is given
#' @param along  Along which dimension to subset if index is a vector; default
#'               is last dimension; argument is ignored if X is a vector
#' @param drop   Remove unused dimensions after mapping; default: TRUE
#' @return       The subset of the array
#' @export
subset = function(X, index, along=-1, drop=FALSE) {
    if (!is.list(index)) {
        # ignore along for vectors
        if (is.atomic(X) && is.vector(X))
            along = 1

        # this is required because as.array() will fail on dplyr:df
        if (is.data.frame(X))
            ndim_X = length(dim(X))
        else
            ndim_X = length(dim(as.array(X)))

        # create a subsetting list that covers the whole array first,
        # then set the dimension we are working on to what is requested
        tmp = base::rep(list(TRUE), ndim_X)

        # by default, subset the last dimension
        if (along == -1)
            along = ndim_X
        tmp[[along]] = index
        index = tmp
    }

    if (any(is.na(unlist(index))))
        stop("trying to subset with NA in index")

    do.call(function(...) `[`(X, ..., drop=drop), index)
}


root = 'C:/Users/oxc140530/Documents/Google Drive/UTDALLAS/CS 6301 - Soft. Comprehension and Analysis/Project/BRE/Results/terms/'
systems = c('jabref', 'ofbiz', 'openbravo')

top_results = 5
top_perc = 0.8

for(k in 1:length(systems)){

  system = systems[k]
  patterns_file = paste(root, 'patterns_', system, '.csv', sep = "")

  #read the csv
  data_patt = read.csv(patterns_file, sep = ";", header = TRUE)

  #group by Statement.Type, POS.Pattern
  patt_freq = as.data.frame(table(data_patt$Statement.Type, data_patt$POS.Pattern))
  colnames(patt_freq) <- c("Statement.Type", "POS.Pattern", "Frequencies")
  patt_freq = subset(patt_freq, Frequencies!=0)
  patt_freq$row.names = NULL

  #sorted by statement and frequency(desc)
  patt_freq = patt_freq[with(patt_freq, order(Statement.Type, -Frequencies)), ]

  #-------------------------------------------
  stmts = c('MethodDeclaration','TypeDeclaration', 'SingleVariableDeclaration', 'VariableDeclarationFragment', 'EnumDeclaration', 'EnumConstantDeclaration')

  for (j in 1:length(stmts) ) {
    stmt = stmts[j]
    freq_sub = subset(patt_freq, Statement.Type == stmt)
    num = nrow(freq_sub)
    freq_tot = sum(freq_sub$Frequencies)

    accum_perc = 0;

    pos_types = c()

    for (i in 1:num ) {

      perc =  freq_sub[i,]$Frequencies/freq_tot
      accum_perc = accum_perc + perc
      if (accum_perc > top_perc || i > top_results){
        break;
      }
      pos_types <- c(pos_types,  as.character(freq_sub$POS.Pattern[i]))
    }

    data_sub = subset(data_patt, Statement.Type == stmt &  POS.Pattern %in% pos_types)
    data_sub = data_sub[!duplicated(data_sub[,]), ]
    data_sub = data_sub[with(data_sub, order(Statement.Type, POS.Pattern, NL.Pattern)), ]
    data_sub$row.names = NULL

    write.csv(data_sub, file=paste(root, 'patterns_', stmt,"_", system, '_' , format(accum_perc,digits=2), '.csv', sep = ""), row.names = FALSE)

  }

}

#-------------------------------------------


#!/usr/bin/env Rscript
#
#  phyloseq_ordination_p3.r - generate p3 ordination graphic through phyloseq
#
#  Version 1.0.0 (December 24, 2015)
#
#  Copyright (c) 2014-- Lela Andrews
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Load libraries
library(phyloseq)
library(ggplot2)
library(scales)
library(grid)
library(plyr)
theme_set(theme_bw())

## Recieve input files from bash
args <- commandArgs(TRUE)

otufile=(args[1])
mapfile=(args[2])
treefile=(args[3])
factor=(args[4])

## Load data into phyloseq
map=import_qiime_sample_data(mapfile)
tree=read_tree(treefile)
otus=import_biom(otufile,parseFunction=parse_taxonomy_greengenes)
mergedata=merge_phyloseq(otus,tree,map)
MD=mergedata

## Filter taxa not present at least 5 times in at least 10% of samples
md0 = genefilter_sample(MD, filterfun_sample(function(x) x > 5), A = 0.1 * nsamples(MD))
MD1=prune_taxa(md0, MD)

## Ordinate command
MD.ord <- ordinate(MD1, "NMDS", "bray")

## Make biplot
p3 = plot_ordination(MD1, MD.ord, type = "biplot", color = factor, shape = "Class", title = "Biplot")
#MD1.shape.names = get_taxa_unique(MD1, "Class")
#MD1.shape <- 15:(15 + length(MD1.shape.names) - 1)
#names(MD1.shape) <- MD1.shape.names
#MD1.shape["samples"] <- 16
#p3 + scale_shape_manual(values = MD1.shape)

## Output pdf graphic
pdf(paste0(factor, "_biplot_NMDS.pdf"))
plot(p3)
dev.off()


options(java.parameters = "-Xmx16g")
# launch the IX modeling platform using the local default database
require( 'retixmp' )
ixmp = import('ixmp')
message_ix <- import('message_ix')
mp = ixmp$Platform(dbtype='HSQLDB')

model = "message_indus"
scen = "configuration_test"
annot = "developing the indus basin model"

scen = message_ix$Scenario(mp, model, scen, version = 'new', annotation=annot)
#scen = message_ix$Scenario(mp,model, scen)

# list of sets, maps and parameter available
# set_check_list = objects()[grep('.set',objects())]    # single index sets, vectors in R
# par_check_list = objects()[grep('.par',objects())]    # parameters, dataframes in R

# Create lists containing parameters and force to character string
set_list = list(	node = node.set,
					year = year.set,
					commodity = commodity.set,
					level = level.set,
					lvl_spatial = lvl_spatial.set,
					lvl_temporal = lvl_temporal.set,
					time = time.set,
					type_tec = type_tec.set,
					type_year = type_year.set,
					type_emission = type_emission.set,
					technology = technology.set,
					grade = grade.set,
					mode = mode.set,
					emission = emission.set,
					rating = rating.set,
					#in theory only if useing the share eq
					shares = shares.set
					)

map_list = list(	cat_emission = cat_emission.set,
					cat_year = cat_year.set,
					cat_tec = cat_tec.set,
					map_spatial_hierarchy = map_spatial_hierarchy.set,
					map_temporal_hierarchy = map_temporal_hierarchy.set,
					map_time = map_time.set,
					map_node = map_node.set,
					#if share constraint
					map_shares_commodity_share = map_shares_commodity_share.set,
					map_shares_commodity_total = map_shares_commodity_total.set
					)

par_list = list(	bound_activity_lo = bound_activity_lo.par,
                 bound_activity_up = bound_activity_up.par,
                 bound_total_capacity_up = bound_total_capacity_up.par,
                 bound_total_capacity_lo = bound_total_capacity_lo.par,
                 bound_emission = bound_emission.par,  # might generate error is parameter does not exist, no policy create it
                 capacity_factor = capacity_factor.par,
                 construction_time = construction_time.par,
                 demand = demand.par,
                 duration_time = duration_time.par,
                 emission_factor = emission_factor.par,
                 fix_cost = fix_cost.par,
                 historical_new_capacity = historical_new_capacity.par,
                 input = input.par,
                 interestrate = interestrate.par,
                 inv_cost = inv_cost.par,
                 min_utilization_factor = min_utilization_factor.par,
                 output = output.par,
                 technical_lifetime = technical_lifetime.par,
                 var_cost = var_cost.par ,
                 # for share of renewables
                 share_commodity_lo = share_commodity_lo.par
				 share_commodity_up = share_commodity_up.par
)

nms = names( par_list )
par_list = lapply(seq_along( par_list ), function( iii ){ par_list[[iii]][NROW(par_list[[iii]]) >0] } )
names( par_list ) = nms
par_list = par_list[lengths(par_list,use.names = T) >0]

## Add SETs
res = lapply( seq_along(set_list), function(set){
	scen$add_set( names(set_list[set]), adapt_to_ret(set_list[[set]] ) )
	} )

## Add MAPPING SETs
res = lapply( seq_along(map_list), function(map){
	tmp_name = scen$idx_names(names(map_list)[map])
	tmp_map = map_list[[map]]
	names(tmp_map) = c(tmp_name)
	scen$add_set(names(map_list[map]),adapt_to_ret(tmp_map))
	} )

## Add PARAMETERs

res = lapply( seq_along(par_list), function(par){
	tmp_name = scen$idx_names(names(par_list)[par])
	tmp_par = par_list[[par]]
	names(tmp_par) = c(tmp_name,'value')
	tmp_par$unit = '-'
	scen$add_par(names(par_list[par]), adapt_to_ret(tmp_par))
	print(paste0( '----- ', names(par_list[par]), ' loaded') )
	} )

##### INITIALIZE NEW SETS, VARIABLES AND EQUATIONS

scen$init_set( "full_balance", c( "commodity" ) )
scen$init_equ( "COMMODITY_BALANCE_FULL", c( "node", "commodity", "level", "year", "time" ) )

scen$init_set( "map_storage", c( "node" , "commodity", "level", "year", "time" ) )
new_map_list = list( map_storage = data.frame( lapply( map_storage.set, as.character), stringsAsFactors=FALSE ),
                     full_balance = data.frame(commodity =  full_balance.set ,stringsAsFactors=FALSE))
res = lapply( seq_along(new_map_list), function(map){
	tmp_name = scen$idx_names(names(new_map_list)[map])
	tmp_map = new_map_list[[map]]
	names(tmp_map) = c(tmp_name)
	scen$add_set(names(new_map_list[map]),adapt_to_ret(tmp_map))
	} )

scen$init_par( "bound_storage_lo", c( "node" , "commodity", "level", "year", "time" ) )
scen$init_par( "bound_storage_up", c( "node" , "commodity", "level", "year", "time" ) )
# NEED to initialize storage loss
scen$init_par('storage_loss',c('node','commodity','level','year','time') )

new_par_list = list(
	  bound_storage_lo = bound_storage_lo.par,
    bound_storage_up = bound_storage_up.par,
	  storage_loss = storage_loss.par
	  )

res = lapply( seq_along(new_par_list), function(par){
	tmp_name = scen$idx_names(names(new_par_list)[par])
	tmp_par = new_par_list[[par]]
	names(tmp_par) = c(tmp_name,'value')
	tmp_par$unit = '-'
	scen$add_par(names(new_par_list[par]), adapt_to_ret(tmp_par))
	print(paste0( '----- ', names(new_par_list[par]), ' loaded') )
	} )

scen$init_equ( "STORAGE_BALANCE", c( "node", "commodity", "level", "year", "time" ) )
scen$init_equ( "STORAGE_BALANCE_UP", c( "node", "commodity", "level", "year", "time" ) )
scen$init_equ( "STORAGE_BALANCE_LO", c( "node", "commodity", "level", "year", "time" ) )

#### COMMIT and output to GDX

print( 'Generating GDX' )
comment = 'initial test commit for Indus model'
scen$commit(comment)
scen$set_as_default()

scen$to_gdx( paste( indus_ix_path, '/model/data', sep=''), paste( 'MSGdata_', scname, '.gdx',sep='') )


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     08.02.2019
#modificado: 09.12.2019

#1. FUNCTIONS
source("misc_v2.3.r")

#2. ANALYSE DATA
set.seed(12345)

#load best model
f1 = "../results/lmktattract_2/modsel.RDS"
load(file=f1)
decay = 1e-4   #parameter for weight decay
maxit = 1000   #maximum number of iterations
abstol = 1e-6  #absolute fit criterion
reltol = 1e-12 #relative fit criterion

#fit best model (nn size = 1)
size = 1       #number of units in the hidden layer
f1 = "../results/lmktattract_3/fit_nnet1"
f2 = paste(f1,"_1.log",sep="")
f3 = paste(f1,"_2.log",sep="")
if(!file.exists(f2) | !file.exists(f3)){
    fit_nnet_v2(mod1$formula,mod1$data,nn_size=size,nn_decay=decay,nn_maxit=maxit,
	  nn_abstol=abstol,nn_reltol=reltol,f1=f1,main="LMkt Mobility")
}

#fit best model (nn size = 3)
size = 3       #number of units in the hidden layer
f1 = "../results/lmktattract_3/fit_nnet3"
f2 = paste(f1,"_1.log",sep="")
f3 = paste(f1,"_2.log",sep="")
if(!file.exists(f2) | !file.exists(f3)){
    fit_nnet_v2(mod1$formula,mod1$data,nn_size=size,nn_decay=decay,nn_maxit=maxit,
	  nn_abstol=abstol,nn_reltol=reltol,f1=f1,main="LMkt Mobility")
}

#fit best model (nn size = 10)
size = 10       #number of units in the hidden layer
f1 = "../results/lmktattract_3/fit_nnet10"
f2 = paste(f1,"_1.log",sep="")
f3 = paste(f1,"_2.log",sep="")
if(!file.exists(f2) | !file.exists(f3)){
    fit_nnet_v2(mod1$formula,mod1$data,nn_size=size,nn_decay=decay,nn_maxit=maxit,
	  nn_abstol=abstol,nn_reltol=reltol,f1=f1,main="LMkt Mobility")
}


#!/usr/bin/env Rscript
###
### R script to do run GWAS on pairwise interactions. Choice
### of logistic or gaussian regression, and optional covariates.
###
### DETAILS
###
### For the initial pass, it uses the default settings of lrgpr::glmApply,
### which set missing genotypes to the mean and uses a Wald Chi-square
### test. It also tests all the SNPs - the filters are applied before
### testing interactions.
###
### The second pass uses the regular glm function from R, also with
### default settings, except that NAs are just ignored.
###
#==============================================================================#

library(lrgpr)
library(optparse)

#==============================================================================#

opts = list(make_option('--output'),
            make_option('--test-percent', type='double', default=1),
            make_option('--min-maf', type='double', default=0))
parser = OptionParser(option_list=opts)
argv = parse_args(parser, positional_arguments=TRUE)

outfile = argv$options[['output']]
test_percent = argv$options[['test-percent']]
min_maf = argv$options[['min-maf']]
tfam_file = argv$args[1]
tped_file = argv$args[2]
model_type = argv$args[3]
if(length(argv$args) > 3) {
    covariates_file = argv$args[4]
    covariates = read.table(covariates_file)
    use_covariates = TRUE
} else {
    use_covariates = FALSE
}

## Figure out the type of regression to run
if(model_type == 'gaussian') {
    fam = gaussian(link='identity')
} else if(model_type == 'logistic') {
    fam = binomial(link='logit')
} else {
    stop('Model type not recognized')
}

## Make the binary file
convertToBinary(tped_file, './binary_genotypes', 'TPED')

## Read in data
X = attach.big.matrix('./binary_genotypes_descr', readonly=TRUE)
y = read.table(tfam_file)[, 6]

## Get minor allele frequency and other information
maf = getAlleleFreq(X)
maf[maf > 0.5] = 1 - maf[maf > 0.5]
pos = as.numeric(gsub('.+-', '', colnames(X)))
chr = gsub('-.+', '', colnames(X))

## Set up formula for initial pass
if(use_covariates) {
    f = paste('y ~ ', paste(paste0('covariates[, ', 1:ncol(covariates), ']'),
                            collapse=' + '), '+ SNP')
    f = as.formula(f)
    term = ncol(covariates) + 2
} else {
    f = as.formula('y ~ SNP')
    term = 2
}

## Run initial pass - one SNP at a time
initial_pvalues = glmApply(f, features=X,  terms=term, family=fam)$pValues[, 1]

## Apply filters
snps_to_test = initial_pvalues >= quantile(initial_pvalues,
                                           1-test_percent, na.rm=TRUE)
snps_to_test[is.na(snps_to_test)] = FALSE
snps_to_test = snps_to_test &
                maf >= min_maf
snps_to_test[is.na(snps_to_test)] = FALSE
cat('SNPs to test <=', sum(snps_to_test), '\n',
    file=stderr())

## Run interaction tests
outhandle = file(outfile, 'wb')
cat('chr1\tpos1\tsnp1\tfreq1\t',
    'chr2\tpos2\tsnp2\tfreq2\tconverged\t',
    'N\tp\tbeta\n', sep='', file=outhandle)
for(i in 1:(ncol(X) - 1)) {

    if(!snps_to_test[i])
        next

    chr1 = chr[i]
    pos1 = pos[i]
    maf1 = maf[i]
    snp1 = colnames(X)[i]

    for(j in (i+1):ncol(X)) {

        if(!snps_to_test[j])
            next

        chr2 = chr[j]
        pos2 = pos[j]
        maf2 = maf[j]
        snp2 = colnames(X)[j]

        # Approximate test to avoid issues with machine precision
        r = suppressWarnings(cor.test(X[, i], X[, j])$estimate)
        if(is.na(r) || r > 0.999)
            next

        if(use_covariates) {
            f_cov = paste(paste(paste0('covariates[, ', 1:ncol(covariates), ']'),
                                collapse=' + '), '+')
        } else {
            f_cov = ''
        }
        f = paste('y ~', f_cov, 'X[, i] * X[, j]')

        glm_result = glm(f, family=fam, na.action=na.omit)
        cf = coefficients(glm_result)[term + 2]
        # Sometimes there is not enough variation to test for
        # an interaction, even after the above filters
        if(is.na(cf))
            next

        p  = coefficients(summary(glm_result))[term + 2, 4]
        N = length(glm_result$fitted.values)
        conv = as.numeric(glm_result$converged)

        cat(chr1, '\t', pos1, '\t', snp1, '\t', maf[i], '\t',
            chr2, '\t', pos2, '\t', snp2, '\t', maf[j], '\t',
            conv, '\t', N,    '\t', p,    '\t', cf,     '\n',
            sep='', file=outhandle)
    }
}
close(outhandle)


# GetCopies345VsUnauditedData.r
source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# P A R A M S
sPlotFile <- "copies345vsunaudited.png"
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , auditfrequency)}
fnSubset <- function(dfIn) {subset(dfIn, copies>=3 & copies<=5
                                    & lifem<=1000
                                    & auditfrequency==10000)}
sTitleLine <-   (   ""
                %+% "With regular auditing, only a few copies are required "
                %+% "to minimize losses over a wide range. "
                %+% "\nFailure to audit the collection is worse than keeping "
                %+% "\nonly a small number of audited copies "
                %+% "\n"
                %+% "\n(Copies=3,4,5 with annual auditing vs "
                %+% "copies=5 with no auditing, duration=10 years)"
                )
sLegendLabel <- "Number of\n  Audited\n  Copies"
lLegendItemLabels <- c("3", "4", "5")
sXLabel <- ("1MB sector half-life (megahours)"
            %+% "                           (lower error rate =====>)")
sYLabel <- ("permanent document losses (%)")
# Also change summarize function and ggplot(color=...).

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
newdat <- alldat.df %>% fnGroupBy() %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n()) %>%
fnSubset()
trows <- newdat

# P L O T   D A T A

gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct), color=factor(copies))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000)
                ,ybreaks=c(0.01,0.10,1.00,10,100)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.8,0.8))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

# Unaudited line separate.
undat = subset(alldat.df, auditfrequency==0 & copies==5 & lifem<=1000) %>%
fnGroupBy() %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n())
gp <- fnPlotAddLine(gp, undat, dotsize=6, linesize=1, lineshape="dotted")
gp <- gp + annotate(geom="text", x=6, y=11, label="5 copies with\nno auditing"
                    , color="black", size=7)
gp <- gp + annotate(geom="text", x=2.6, y=0.005, label="5 copies \nwith auditing"
                    , color="black", size=7)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


##CTE534_ClasificacionSupervisada=group
##Imagen=raster
##Vector=vector
##Usos=field Vector
##Color=string
##Pixel=number 10
##Directorio=string
##Data=output table
##showplots
library(tidyverse)

U <- Vector[[Usos]]

Ta <- data.frame(Us = U)
Ta <- data.frame(arrange(Ta, Us))

Data <- data.frame(table(Imagen[]), Uso = Ta$Us)#
Data$Area_m2 <- Data$Freq*Pixel*Pixel
Data$Area_ha <- Data$Freq*Pixel*Pixel/10000
Data$Porcentaje <- round(Data$Area_ha*100/sum(Data$Area_ha),2)
Data$Etiqueta <- paste(Data$Porcentaje, " %", sep="")

#Gráfico
bplt <- barplot(Data$Porcentaje)

setwd(Directorio)
png(width=1000)
barplot(Data$Porcentaje, col=Color, xlab="", ylab="Área Total (%)",
        names.arg=Ta$Us,
        main="Cobertura Vegetal y Uso del Suelo",
        ylim=c(0,40), cex.lab=1.2)
grid(lwd=1, col="black")
text(y= Data$Porcentaje, x= bplt, labels=as.character(Data$Etiqueta), xpd=TRUE, pos=3, cex=1.5)
box()
dev.off()

barplot(Data$Porcentaje, col=Color, xlab="", ylab="Área Total (%)",
        names.arg=Ta$Us,
        main="Cobertura Vegetal y Uso del Suelo",
        ylim=c(0,40), cex.lab=1.2)
grid(lwd=1, col="black")
text(y= Data$Porcentaje, x= bplt, labels=as.character(Data$Etiqueta), xpd=TRUE, pos=3, cex=1.5)
box()


ergebnisse = read.csv2("bin\\x64\\Release\\results.csv", colClasses = c(rep('integer', 2),rep('numeric',8)), sep=';',dec='.',row.names = NULL)
colnames(ergebnisse) = c("Size", "Iteration", "InitTran", "InitBatch", "InitInc", "MainTran", "MainBatch", "MainInc", "InitTGG", "MainTGG")
averages = aggregate(ergebnisse, list(ergebnisse$Size), mean)

size = averages$Size

pdf(file="init.pdf", width=8, height=4)
par(mar=c(4.3,4.0,0.3,0.3))
plot(size, averages$InitTGG, type="n", xlab="Number of states", ylab="Initial transformation [ms]", ylim=c(0.4,max(averages$InitTGG)), log="xy")
lines(size, averages$InitInc, col="blue")
points(size, averages$InitInc, pch=16, col="blue")
lines(size, averages$InitTGG, col="red")
points(size, averages$InitTGG, pch=2, col="red")
lines(size, averages$InitBatch, col="green")
points(size, averages$InitBatch, pch=8, col="green")
lines(size, averages$InitTran, col="orange")
points(size, averages$InitTran, pch=13, col="orange")
legend(10, max(averages$InitTGG), c("NMF Synchronizations (Incremental)", "NMF Synchronizations (Batch)", "NTL (Batch)", "eMoflon (Incremental)"), col=c('blue', 'green', 'orange', 'red'), pch=c(16, 8, 13, 2), bty='n', lty=1)
dev.off()

pdf(file="updates.pdf", width=8, height=4)
par(mar=c(4.3,4.0,0.3,0.3))
plot(size, averages$MainTGG, type="n", xlab="Number of states", ylab="Runtime for 20 changes [ms]", ylim=c(min(averages$MainInc), max(averages$MainTGG)), log="xy")
lines(size, averages$MainInc, col="blue")
points(size, averages$MainInc, pch=16, col="blue")
lines(size, averages$MainTGG, col="red")
points(size, averages$MainTGG, pch=2, col="red")
lines(size, averages$MainBatch, col="green")
points(size, averages$MainBatch, pch=8, col="green")
lines(size, averages$MainTran, col="orange")
points(size, averages$MainTran, pch=13, col="orange")
legend(10, max(averages$MainTGG), c("NMF Synchronizations (Incremental)", "NMF Synchronizations (Batch)", "NTL (Batch)", "eMoflon (Incremental)"), col=c('blue', 'green', 'orange', 'red'), pch=c(16, 8, 13, 2), bty='n', lty=1)
dev.off()


REBOL [
    Title: "Create charset maps"
    Author: "Gabriele Santilli"
]

encode-utf8: func [
    "Encode a code point in UTF-8 format"
    char [integer!] "Unicode code point"
] [
    if char <= 127 [
        return as-string to binary! reduce [char]
    ]
    if char <= 2047 [
        return as-string to binary! reduce [
            char and 1984 / 64 + 192
            char and 63 + 128
        ]
    ]
    if char <= 65535 [
        return as-string to binary! reduce [
            char and 61440 / 4096 + 224
            char and 4032 / 64 + 128
            char and 63 + 128
        ]
    ]
    if char > 2097151 [return ""]
    as-string to binary! reduce [
        char and 1835008 / 262144 + 240
        char and 258048 / 4096 + 128
        char and 4032 / 64 + 128
        char and 63 + 128
    ]
]

parse-hex: func [h] [to integer! debase/base next next h 16]

make-charset-map: func [url /local map] [
    url: read/lines url
    remove-each line url [any [empty? line line/1 = #"#"]]
    forall url [
        url/1: parse/all url/1 "^-"
        url/1/1: parse-hex url/1/1
        url/1/2: either empty? url/1/2 [63] [parse-hex url/1/2]
    ]
    map: array 256
    foreach line url [poke map line/1 + 1 as-binary encode-utf8 line/2]
    map
]

make-all: [
    write %charsets.txt ""
    foreach url [
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-3.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-4.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-5.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-6.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-7.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-8.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-9.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-10.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-11.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-13.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-14.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-15.TXT
        http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-16.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP874.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1250.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1251.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1253.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1254.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1255.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1256.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1257.TXT
        http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1258.TXT
    ] [
        name: second split-path url
        name: copy/part name find/last name #"."
        prin "."
        write/append %charsets.txt rejoin [
            name ": make-encoding " mold make-charset-map url
            newline newline
        ]
    ]
    print ""
]

halt


#!/usr/bin/Rscript

library(ncdf4)
library(raster)
library(rgdal)
require(zoo)

#############################
### FUNCTIONS
#############################

# Get list of species in the file
get_spec_list=function(input){
  spec=ncvar_get(nc=input,varid="name_fspec")
  nvar = nchar(spec)/4
  stseq=seq(from=1,to=nchar(spec),by=4)
  snpfn = function(st){substr(spec,st,st+3)}
  unlist(lapply(stseq,FUN=snpfn))
}

# Drill down a time series for given species and location
drill_spec=function(input,spec,lat,lon){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }
  odat=ncvar_get(nc=input,varid="cavg")
  lons=ncvar_get(input,"lon")
  lats=ncvar_get(input,"lat")
  if(lat < min(lat) | lat > max(lat) | lon < min(lon) | lon > max(lon)){
    stop("Coordinates provided are out of range of grid.")
  }
  tlon=which.min(abs(lons-lon))
  tlat=which.min(abs(lats-lat))
  odat=odat[tlon,tlat,vno,]
  odat
}

# Return a map raster for a given hour and species
rast_spec=function(input,spec,hour){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }
  if(hour > 24){
    stop(paste0("Hour must be between 1 and 24"))
  }
  odat=ncvar_get(nc=input,varid="cavg")
  lons=ncvar_get(input,"lon")
  lats=ncvar_get(input,"lat")
  lodiff=mean(diff(lons))
  ladiff=mean(diff(lats))

  odat=odat[,,vno,hour]
  rotm <- function(x) t(apply(x, 2, rev))
  odat=rotm(rotm(rotm(odat)))
  ra=raster(odat,xmn=min(lons)-(lodiff/2),xmx=max(lons)+(lodiff/2),ymn=min(lats)-(ladiff/2),ymx=max(lats)+(ladiff/2))
  proj4string(ra)="+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs "
  ra
}

# Return a 3D matrix for a given hour and species
cube_spec=function(input,spec){
  sl = get_spec_list(input)
  vno = which(sl %in% spec)
  if(length(vno)==0){
    stop(paste0("Chemical species ",spec," not found."))
  }

  odat=ncvar_get(nc=input,varid="cavg",c(1,1,vno,1),c(-1,-1,1,-1))

    odat
}

# Return a 3D matrix for a given hour and species
cube_met=function(input,spec){

  odat=ncvar_get(nc=input,varid=spec,c(1,1,1),c(-1,-1,-1))

  odat
}

cube_layer=function(input,spec,layer){

  odat=ncvar_get(nc=input,varid=spec,c(1,1,layer,1),c(-1,-1,-1,-1))

  odat
}

difun=function(x){rollmean(x,2)}

#########################
####  Examples ##########
#########################

# List of dates to access, should be today's date minus a few/plus a few?
# Will see what martin comes up with

date_list=c("05","06","07")
day_list=c("01","02","03")

# For each day
for(id in seq_along(date_list)){

  # To do: will need to download the file from Raijin, process, and delete and end of each loop
  # as files are ~ 12gb in size.

  # Define the file location
  tfile<-sprintf("vtas_201704%s_cb05_aer2_0.030dg_s4.nc",date_list[id])

  # SCP copy...

  # Load the net cdf
  data<-nc_open(tfile)

  #PM25
  datPM25 = cube_spec(data,"EC25")
  prcp = cube_met(data,"prcp")[,,2:25]
  temp_a = cube_layer(data,"temp_a",1)[,,2:25]
  pres = cube_layer(data,"pres",1)[,,2:25]

  # wind vectors

  u=ncvar_get(nc=input,varid="u_comp",c(1,1,1,1),c(-1,-1,-1,-1))
  u = apply(u,c(2,3),difun)
  v=ncvar_get(nc=input,varid="v_comp",c(1,1,1,1),c(-1,-1,-1,-1))
  v = apply(v,c(1,3),difun)
  v=aperm(v, c(2,1,3))
  ws = sqrt(u**2+v**2)
  wd=90-(atan2(v,u)*180/pi)
  wd[wd<0]=wd[wd<0]+360

  ws=ws[,,2:25]
  wd=wd[,,2:25]

  times = 0:23
  day = ncvar_get(data,"day")
  month = ncvar_get(data,"month")
  year = ncvar_get(data,"year")
  adate = as.numeric(as.POSIXct(sprintf("%d-%d-%d %d:00:00",year,month,day,times)))

  lats = ncvar_get(data,"lat")
  lons = ncvar_get(data,"lon")

  dimTime <- ncdim_def("time","seconds since 1970-1-1 00:00:00",adate,longname="time",unlim=TRUE)
  dimLat <- ncdim_def("lat","degrees_north",lats,longname="latitude")
  dimLon <- ncdim_def("lon","degrees_east",lons,longname="longitude")

  varEC25 <- ncvar_def("EC25","ugm3",list(dimLon,dimLat,dimTime),longname="PM25 Concentration",prec="float")
  varprcp <- ncvar_def("prcp","mm",list(dimLon,dimLat,dimTime),longname="Precipitation",prec="float")
  vartemp_a<- ncvar_def("temp_a","degK",list(dimLon,dimLat,dimTime),longname="Ambient Temp",prec="float")
  varpres<- ncvar_def("pres","hPa",list(dimLon,dimLat,dimTime),longname="Atmospheric Pressure",prec="float")
  var_ws<- ncvar_def("ws","m/s",list(dimLon,dimLat,dimTime),longname="Wind Speed",prec="float")
  var_wd<- ncvar_def("wd","degrees",list(dimLon,dimLat,dimTime),longname="Wind Direction",prec="float")

  # Create one file per day of modelling
  # With file name indicating day of sequence?
  new_file = nc_create(sprintf("test_%s.nc",day_list[id]),list(varEC25,varprcp,vartemp_a, varpres,var_ws,var_wd))

  ncatt_put(new_file,0,attname="CDI",attval="Climate Data Interface version 1.7.2 (http://mpimet.mpg.de/cdi")
  ncatt_put(new_file,0,attname="CDO",attval="Climate Data Operators version 1.7.2 (http://mpimet.mpg.de/cdo)")
  ncatt_put(new_file,0,attname="Conventions",attval="CF-1.4")

  ncvar_put(new_file,varEC25,datPM25)
  ncvar_put(new_file,varprcp,prcp)
  ncvar_put(new_file,vartemp_a,temp_a)
  ncvar_put(new_file,varpres,pres)
  ncvar_put(new_file,var_ws,ws)
  ncvar_put(new_file,var_wd,wd)

  nc_close(new_file)

  # Delete original ncdf

}

system("cdo mergetime test_*.nc /mnt/geoserver/data/aqfx/merge.nc")i
unlink(paste0("test_",day_list,".nc"))


#######################################################################
#  Compare how long it takes to compute a number of points when
#  they are spread out over a variable number of "days".
source('sraster.r')

nr_repeats = 10L
write("#points per day,window size,run number, user time[s],elapsed time[s],#clusters, #micro clusters", file="daysize_benchmark_results.csv")
write("#points per day,mean elapsed time[s],#clusters", file="mean_daysize_benchmark_results.csv")

timed_datafile <- "data/timed_data_10000.csv"
nr_points <- 500L*10000L
ws = list(
  1000L,
  500L,
  200L,
  100L,
  20L,
  10L,
  2L,
  1L
)

for (w in ws) {
  points_per_day <- as.integer(500L*(1000L/w))
  system2('python3', args = c('change_label.py', timed_datafile, as.character(points_per_day)))

  times <- c()
  clustereds <- c()
  for (run_number in 1:nr_repeats) {
    alg <- DSC_SRaster(p=3.5, window_size = w)

    stream <- DSD_ReadCSV(timed_datafile)
    t <- system.time({ update(alg, stream, nr_points) })
    close_stream(stream)
    times <- c(times, t[3])

    end_clusters <- NROW(get_centers(alg, type='macro'))
    clustereds <- c(clustereds, end_clusters)

    line <- sprintf("%d,%d,%d,%.3f,%.3f,%d", points_per_day, w, run_number, t[1], t[3], end_clusters)
    cat(paste(line, "\n"))
    write(line, file="daysize_benchmark_results.csv", append=TRUE)
  }

  avg_times <- lapply(times, mean)
  avg_clustereds <- lapply(clustereds, mean)

  mean_t = avg_times[[1]]
  mean_c = avg_clustereds[[1]]
  line <- sprintf("%d,%.3f,%d", points_per_day, mean_t, mean_c)
  write(line, file="mean_daysize_benchmark_results.csv", append=TRUE)
}
cat("Done!\n")


##' Creates a table of forecast scores
##'
##' @param forecasts data frame with scored forecasts
##' @param file filename, if to be saved into a file
##' @param coverage_levels coverage levels for assessing calibration
##' @param horizons forecast horizons to assess
##' @param common_creation_dates if TRUE, ensure only creation dates are assessed
##' @param format table format
##' @param ... any further parameters to pass to \code{kable}
##' @return table
##' @importFrom dplyr mutate filter group_by ungroup summarise rowwise select bind_rows arrange
##' @importFrom tidyr nest gather unite spread
##' @importFrom kableExtra kable kable_styling group_rows add_header_above save_kable
##' @author Sebastian Funk
scores_table <- function(forecasts, file,
                         coverage_levels = c(0.5, 0.9), horizons = c(7, 14),
                         common_creation_dates = FALSE,
                         format = "latex", ...) {

  scores <- list()

  if (common_creation_dates) {
    forecasts <- forecasts %>%
      mutate(nmodels = length(unique(model))) %>%
      ## ensure common creation_dates
      group_by(creation_date, value_desc) %>%
      filter(length(unique(model)) == nmodels) %>%
      ungroup() %>%
      select(-nmodels)
  }

  forecasts <- forecasts %>%
    mutate(horizon = as.integer(value_date - creation_date)) %>%
    filter(horizon %in% horizons) %>%
    group_by(model, value_desc) %>%
    mutate(n = length(unique(creation_date))) %>%
    ungroup() %>%
    filter(n > 2)

  scores[["calibration"]] <- forecasts %>%
    mutate(horizon = as.integer(value_date - creation_date)) %>%
    filter(interval %in% coverage_levels) %>%
    group_by(model, n, value_type, value_desc, horizon, interval) %>%
    summarise(coverage = mean(inside), .groups = "drop") %>%
    ungroup()

  bias_score <- function(x) {
    if (any(x$inside)) {
      min_int <- x %>%
        filter(inside == 1) %>%
        .$interval %>%
        min
    } else {
      min_int <- 1
    }

    median <- x %>%
      filter(interval == 0) %>%
      .$lower

    data <- x %>%
      .$data %>%
      unique

    return(((2 * (data < median) - 1) * min_int))
  }

  scores[["bias"]] <- forecasts %>%
    group_by(model, n, geography, value_date, creation_date, value_type, value_desc,
             horizon) %>%
    nest() %>%
    rowwise() %>%
    mutate(bias = bias_score(data)) %>%
    group_by(model, n, value_type, value_desc, horizon) %>%
    summarise(bias = mean(bias), .groups = "drop") %>%
    ungroup()

  scores[["sharpness"]] <- forecasts %>%
    mutate(sharpness = interval / 2 * (upper - lower)) %>%
    group_by(model, n, geography, value_date, creation_date,
             value_type, value_desc, horizon) %>%
    summarise(sharpness = sum(sharpness), .groups = "drop") %>%
    group_by(model, n, value_type, value_desc, horizon) %>%
    summarise(sharpness = mean(sharpness), .groups = "drop") %>%
    ungroup()

  scores[["wis"]] <- forecasts %>%
    group_by(model, n, geography, value_date, creation_date,
             value_type, value_desc, horizon) %>%
    summarise(n = unique(n), score = mean(score), .groups = "drop") %>%
    ungroup() %>%
    group_by(model, n, value_type, value_desc, horizon) %>%
    summarise(score = mean(score), .groups = "drop") %>%
    ungroup()

  scores[["mae"]] <- forecasts %>%
    filter(!is.na(ae)) %>%
    group_by(model, n, value_type, value_desc, horizon) %>%
    summarise(mae = mean(ae), .groups = "drop") %>%
    ungroup()

  tab <- lapply(scores, function(x) {
    x %>%
      select(-value_type) %>%
      gather(key, value, ncol(.))
  })
  tab[["calibration"]] <- tab[["calibration"]] %>%
    unite("key", key, interval)
  score_tab <- expand.grid(c("n", paste("coverage", coverage_levels, sep = "_"),
                             "bias", "sharpness", "score", "mae"),
                           c("7", "14"))
  levels <- sprintf('%s_%s', score_tab[, 2], score_tab[, 1])

  ptab <- bind_rows(tab) %>%
    unite("key", horizon, key) %>%
    mutate(key = factor(key, levels = levels)) %>%
    mutate(value = signif(value, 2),
           value = round(value, 2)) %>%
    spread(key, value) %>%
    arrange(value_desc, model)

  desc <- unique(ptab$value_desc)
  nmet <- (ncol(ptab) - 3) / 2

  col.names <-
    c("Model", "n", rep(c("Cov 0.5", "Cov 0.9", "Bias", "Sharp", "WIS", "MAE"),
                   times = 2))

  k <- kable(ptab %>% select(-value_desc),
             format,
             col.names = col.names,
             align=c('l|', 'r|', rep('r', nmet), '|r', rep('r', nmet - 1)),
             booktabs = TRUE,
             ...) %>%
    kable_styling(font_size = 5,
                  latex_options=c("hold_position"))

  per_group <- nrow(ptab) / length(desc)

  for (i in seq_along(desc)) {
    k <- k %>%
      group_rows(desc[i], (i - 1) * per_group + 1, i * length(per_group),
                 indent = FALSE)
  }

  k <-
    add_header_above(k, c(" " = 2,
                          "7 days ahead" = nmet, "14 days ahead" = nmet))

  if (!missing(file)) {
    save_kable(k, file, latex_header_includes = c("\\usepackage{fullpage}"))
  } else {
    print(k)
  }
}


# nzqr-jmh
# palisades dot lakes at gmail dot com
# version 2019-05-01
#-----------------------------------------------------------------
# libraries
#-----------------------------------------------------------------
require('ggplot2')
require('scales')
require('knitr')
require('kableExtra')
#-----------------------------------------------------------------
accumulator.colors <- c(
  'KahanAccumulator'='#a0430088',
  'KahanFmaAccumulator'='#a0331088',
  'ZhuHayesGCAccumulator'='#00bbcc88',
  'ZhuHayesAccumulator'='#0088cc88',
  'ZhuHayesNoGCAccumulator'='#0088cc88',
  'ZhuHayesGCBranch'='#3355cc88',
  'ZhuHayesBranch'='#3300cc88',
  'ZhuHayesNoGCBranch'='#3300cc88',
  'BigFloatAccumulator'='#d31b1c88',
  'RationalFloatAccumulator'='#d31b1c88',
  'DoubleAccumulator'='#c8000088',
  'DistilledAccumulator'='#0055aa88',
  'DoubleFmaAccumulator'='#c0040488'
)
#-----------------------------------------------------------------
accuracy.files <- function (
  parent.folder='output',
  benchmark=NULL,
  dt.pattern='2019[0-9]{4}-[0-9]{6}') {
  stopifnot(
    !is.null(parent.folder),
    !is.null(benchmark),
    !is.null(dt.pattern))

  data.folder <- paste(parent.folder,benchmark,sep='/')
  print(data.folder)
  pattern <- paste('[A-Za-z]+-[a-z]+-',dt.pattern,'.csv',sep='')
  files <- list.files(
    path=data.folder,pattern=pattern,full.names=TRUE)
  files }
#-----------------------------------------------------------------
read.accuracy <- function (
  parent.folder=paste('output',sep='/'),
  benchmarks=NULL,
  dt.pattern='[0-9]{8}-[0-9]{6}') {
  stopifnot(
    !is.null(parent.folder),
    !is.null(benchmarks),
    !is.null(dt.pattern))

  raw <- NULL
  for (b in benchmarks) {
    files <- accuracy.files(
      parent.folder=parent.folder,
      benchmark=b,
      dt.pattern=dt.pattern)
    for (f in files) {
      #print(f)
      tmp <- read.csv(file=f,as.is=TRUE)
      tmp$residual <- tmp$truth - tmp$est
      tmp$fresidual <- tmp$residual / max(tmp$truth,1)
      raw <- rbind(raw,tmp) } }

  raw$benchmark <-
    factor(x=raw$benchmark,
      levels=sort(unique(raw$benchmark)),
      ordered=TRUE)

  raw$generator <-
    factor(x=raw$generator,
      levels=sort(unique(raw$generator)),
      ordered=TRUE)

  colnames(raw)[which(names(raw) == 'algorithm')] <-
    'accumulator'
  raw$accumulator <-
    factor(x=raw$accumulator,
      levels=sort(unique(raw$accumulator)),
      ordered=TRUE)

  print(summary(raw))

  p <- 0.05
  data <- NULL
  for (b in sort(unique(raw$benchmark))) {
    for (g in sort(unique(raw$generator))) {
      for (a in sort(unique(raw$accumulator))) {
        for (d in sort(unique(raw$dim))) {
          i <-
            (g==raw$generator)&(b==raw$benchmark)&(a==raw$accumulator)&(d==raw$dim)
          #print(summary(i))
          tmp <- raw[i,]
          print(summary(tmp))
          qr <- quantile(x=tmp$residual,probs=c(0.05,0.50,0.95))
          qar <- quantile(x=abs(tmp$residual),probs=c(0.05,0.50,0.95))
          qfr <- quantile(x=tmp$fresidual,probs=c(0.05,0.50,0.95))
          qafr <- quantile(x=abs(tmp$fresidual),probs=c(0.05,0.50,0.95))
          r <- data.frame(
            generator=g,
            benchmark=b,
            accumulator=a,
            dim=d,
            residual05=qr[1],
            residual50=qr[2],
            residual95=qr[3],
            abs.residual05=qar[1],
            abs.residual50=qar[2],
            abs.residual95=qar[3],
            fresidual05=qfr[1],
            fresidual50=qfr[2],
            fresidual95=qfr[3],
            abs.fresidual05=qafr[1],
            abs.fresidual50=qafr[2],
            abs.fresidual95=qafr[3])
          data <- rbind(data,r) } } } }
  data$generator <-
    factor(x=data$generator,
      levels=sort(unique(data$generator)),
      ordered=TRUE)
  data$benchmark <-
    factor(x=data$benchmark,
      levels=sort(unique(data$benchmark)),
      ordered=TRUE)
  data$accumulator <-
    factor(x=data$accumulator,
      levels=sort(unique(data$accumulator)),
      ordered=TRUE)
  data }
#-----------------------------------------------------------------
accuracy.plot <- function(
  data=NULL,
  prefix=NULL,
  x='dim',
  ymin=NULL,
  y=NULL,
  ymax=NULL,
  group='accumulator',
  facet='benchmark',
  colors=accumulator.colors,
  scales='free_y',
  ylabel=NULL,
  xlabel='dim',
  width=36,
  #height=12,
  plot.folder='output') {
  stopifnot(
    !is.null(data),
    !is.null(prefix),
    !is.null(ymin),
    !is.null(y),
    !is.null(ymax),
    !is.null(ylabel),
    !is.null(plot.folder),
    !is.null(group),
    !is.null(facet),
    !is.null(colors))

  plot.file <- file.path(
    plot.folder,
    paste(prefix,'png',sep='.'))

  p <- ggplot(
      data=data,
      aes_string(x=x, ymin=ymin, y=y, ymax=ymax,
        group=group,fill=group,color=group))  +
    facet_wrap(as.formula(paste0('~',facet)),scales=scales) +
    theme_bw() +
    theme(plot.title = element_text(hjust = 0.5)) +
    #theme(
    #  axis.text.x=element_text(angle=-90,hjust=0,vjust=0.5),
    #  axis.title.x=element_blank()) +
    geom_ribbon(aes_string(ymin=ymin, ymax=ymax, fill=group)) +
    geom_line(aes_string(y = ymin)) +
    geom_line(aes_string(y = y)) +
    geom_line(aes_string(y = ymax)) +
    scale_fill_manual(values=colors) +
    scale_color_manual(values=colors) +
    scale_x_log10() + # breaks = (1000000*c(0.01,0.1,1,10))) +
    #scale_y_log10() + #limits=c(0.10,NA)) +
    ylab(ylabel) +
    xlab(xlabel) +
    ggtitle(prefix)
  #+ expand_limits(y=0)
  print(plot.file)
  ggsave(p ,
    device='png',
    file=plot.file,
    width=width,
    height=height,
    units='cm',
    dpi=300) }
#-----------------------------------------------------------------
read.runtimes <- function (
  folder=paste('output',sep='/'),
  prefix=NULL,
  baseline='DoubleAccumulator') {
  data.file <- paste(folder,paste(prefix,'csv',sep='.'),sep='/')
  data <- read.csv(file=data.file,as.is=TRUE)

  colnames(data)[which(names(data) == 'Param..dim')] <- 'dim'
  colnames(data)[which(names(data) == 'Score')] <- 'ms'
  colnames(data)[which(names(data) == 'Score.Error..99.9..')] <-
    'delta'
  data$ms.min <- data$ms - data$delta
  data$ms.max <- data$ms + data$delta

  colnames(data)[which(names(data) == 'Benchmark')] <-
    'benchmark'
  data$benchmark <-
    gsub('.bench','',data$benchmark,fixed=TRUE)
  data$benchmark <-
    gsub('nzqr.jmh.','',data$benchmark,fixed=TRUE)
  data$benchmark <-
    factor(x=data$benchmark,
      levels=sort(unique(data$benchmark)),
      ordered=TRUE)

  colnames(data)[which(names(data) == 'Param..accumulator')] <-
    'accumulator'
  data$accumulator <-
    gsub('nzqr.java.accumulators.','',data$accumulator,fixed=TRUE)
  data$accumulator <-
    gsub('nzqr.jmh.accumulators.','',data$accumulator,fixed=TRUE)
  data$accumulator <-
    factor(x=data$accumulator,
      levels=sort(unique(data$accumulator)),
      ordered=TRUE)

  colnames(data)[which(names(data) == 'Param..generator')] <-
    'generator'
  data$generator <-
    factor(x=data$generator,
      levels=sort(unique(data$generator)),
      ordered=TRUE)
  data <- subset(x=data,select=-c(Mode,Threads,Samples,Unit,delta))

  # add baseline accumulator column
  tmp <- data[data$accumulator==baseline,]
  data <- merge(data,tmp,
    by=c('benchmark','generator','dim'),
    suffixes=c('','.baseline'))
  data$relative.ms.min <- data$ms.min / data$ms.min.baseline
  data$relative.ms <- data$ms / data$ms.baseline
  data$relative.ms.max <- data$ms.max / data$ms.max.baseline
  data }

#-----------------------------------------------------------------
runtime.plot <- function(
  data=NULL,
  prefix=NULL,
  x='dim',
  y='ms',
  ymin='ms.min',
  ymax='ms.max',
  group='accumulator',
  rows='benchmark',
  cols='generator',
  colors=accumulator.colors,
  scales='fixed', #'free_y',
  ylabel='milliseconds',
  xlabel='dim',
  #width=30,
  height=10,
  plot.folder='output',
  xscale=scale_x_log10,
  yscale=scale_y_log10) {

  stopifnot(
    !is.null(data),
    !is.null(prefix),
    !is.null(plot.folder),
    !is.null(group),
    #!is.null(facet),
    !is.null(colors))

  nr <- length(unique(data[,rows]))
  nc <- length(unique(data[,cols]))
  width <- (height * nc) / nr

  print(width)

  plot.file <- file.path(
    plot.folder,
    paste(prefix,'png',sep='.'))

  p <- ggplot(
      data=data,
      aes_string(
        x=x, ymin=ymin, y=y, ymax=ymax,
        group=group,fill=group,color=group))  +
    facet_grid(facets=as.formula(paste(rows,'~',cols)),scales=scales) +
    theme_bw() +
    theme(plot.title = element_text(hjust = 0.5)) +
    #theme(
    #  axis.text.x=element_text(angle=-90,hjust=0,vjust=0.5),
    #  axis.title.x=element_blank()) +
    geom_ribbon(aes_string(ymin=ymin, ymax=ymax, fill=group)) +
    geom_line(aes_string(y = ymin)) +
    geom_line(aes_string(y = y)) +
    geom_line(aes_string(y = ymax)) +
    geom_point(aes_string(y = y)) +
    scale_fill_manual(values=colors) +
    scale_color_manual(values=colors) +
    ylab(ylabel) +
    xlab(xlabel) +
    ggtitle(paste('99.9% intervals for runtime',y))
  if (! is.null(xscale)) { p <- p + xscale(); }
  if (! is.null(yscale)) { p <- p + yscale(); }
  #if (scale_y_log10 != yscale) { p <- p + expand_limits(y=0); }
  print(plot.file)
  ggsave(p ,
    device='png',
    file=plot.file,
    width=width,
    height=height,
    units='cm',
    dpi=300) }
#-----------------------------------------------------------------
runtime.accuracy.plot <- function(
  data=NULL,
  prefix=NULL,
  x='ms',
  y=NULL,
  group='accumulator',
  facet='benchmark',
  colors=accumulator.colors,
  scales='free_y',
  ylabel=NULL,
  xlabel=x,
  width=36,
  height=12,
  plot.folder='output') {
  stopifnot(
    !is.null(data),
    !is.null(prefix),
    !is.null(y),
    !is.null(ylabel),
    !is.null(plot.folder),
    !is.null(group),
    !is.null(facet),
    !is.null(colors))

  plot.file <- file.path(plot.folder,paste(prefix,'png',sep='.'))

  p <-
    ggplot(data=data,aes_string(x=x,y=y))  +
    facet_wrap(as.formula(paste0('~',facet)),scales=scales) +
    theme_bw() +
    theme(plot.title = element_text(hjust = 0.5)) +
    geom_line(aes_string(group=group,color=group)) +
    scale_fill_manual(values=colors) +
    scale_color_manual(values=colors) +
    scale_x_log10() + # breaks = (1000000*c(0.01,0.1,1,10))) +
    #scale_y_log10() + #limits=c(0.10,NA)) +
    scale_y_sqrt() + #  would use log, but  there are zeros
    geom_line(aes(group=dim),color='#88888844') +
    ylab(ylabel) +
    xlab(xlabel) +
    ggtitle(prefix)

  print(plot.file)
  ggsave(plot=p, device='png',filename=plot.file,
    width=width, height=height,units='cm', dpi=300) }
#-----------------------------------------------------------------
html.table <- function(data,fname,n) {
  html.file <- file(
    description=file.path(
      plot.folder,
      paste(fname,'html',sep='.')),
    encoding='UTF-8',
    open='wb')
  writeLines(
    kable(
      data[order(data$accumulator),],
      format='html',
      digits=1,
      caption=paste('milliseconds for',n,'intersection tests'),
      row.names=FALSE,
      col.names = c('accumulator','0.05','0.50','0.95','mean')),
    con=html.file,
    sep='\n')
  close(html.file) }
#-----------------------------------------------------------------
md.table <- function(data,fname,n) {
  md.file <- file(
    description=file.path(
      plot.folder,
      paste(fname,'md',sep='.')),
    encoding='UTF-8',
    open='wb')
  writeLines(
    kable(
      data[order(data$benchmark,data$nmethods,data$accumulator),],
      format='markdown',
      digits=2,
      caption=paste('milliseconds for',n,'intersection tests'),
      row.names=FALSE,
      col.names = c('benchmark','accumulator','nmethods',
        '0.05','0.50','0.95','mean',
        'overhead 0.05','overhead 0.50','overhead 0.95','overhead mean',
        'ns per op','overhead ns per op')),
    con=md.file,
    sep='\n')
  close(md.file) }
#-----------------------------------------------------------------
quantile.log.log.plot <- function(
  data=NULL,
  fname=NULL,
  ymin='lower.q',
  y='median',
  ymax='upper.q',
  group=NULL,
  facet=NULL,
  colors=NULL,
  scales='fixed', #'free_y',
  ylabel='milliseconds',
  width=36,
  height=21,
  plot.folder=NULL) {
  stopifnot(
    !is.null(data),
    !is.null(fname),
    !is.null(plot.folder),
    !is.null(group),
    !is.null(facet),
    !is.null(colors))

  plot.file <- file.path(
    plot.folder,
    paste(fname,group,facet,ylabel,'quantiles','png',sep='.'))

  p <- ggplot(
      data=data,
      aes_string(
        x='nelements',
        ymin=ymin, y=y, ymax=ymax,
        group=group,
        fill=group,
        color=group))  +
    facet_wrap(as.formula(paste0('~',facet)),scales=scales) +
    theme_bw() +
    theme(plot.title = element_text(hjust = 0.5)) +
    theme(
      axis.text.x=element_text(angle=-90,hjust=0,vjust=0.5),
      axis.title.x=element_blank()) +
    geom_ribbon(aes_string(ymin = ymin, ymax = ymax, fill = group)) +
    geom_line(aes_string(y = ymin)) +
    geom_line(aes_string(y = y)) +
    geom_line(aes_string(y = ymax)) +
    scale_fill_manual(values=colors) +
    scale_color_manual(values=colors) +
    scale_x_log10(breaks = (1000000*c(0.01,0.1,1,10))) +
    scale_y_log10(limits=c(0.10,NA)) +
    ylab(ylabel) +
    ggtitle(paste('[0.05,0.50,0.95] quantiles for', ylabel)) +
    expand_limits(y=0);
  print(plot.file)
  ggsave(p ,
    device='png',
    file=plot.file,
    width=width,
    height=height,
    units='cm',
    dpi=300) }
#-----------------------------------------------------------------


#Function to read and plot survey residuals
# parameter start.year: first year on X-axis, default=0 (defined from data)
# parameter end.year: end year on X-axis, default=0 (defined from data)
#
# use over.all.max to set the maximum size of the reference buble. A value of 0 scales bubles individually

over.all.max<-6  # use over.all.max different from 0 to set bublesize
over.all.max<-2.5

use.ref.dot<-TRUE

plot.survey.residuals<-function(dev,nox=1,noy=1,Portrait=T,start.year=0,end.year=0,use.ref.dot=TRUE,add.title=TRUE,over.all.max=1.5) {

fleet.names<-Read.fleet.names()

file<-file.path(data.path,'fleet_info.dat')
finfo<-scan(file,comment.char = "#")

file<-file.path(data.path,'survey_residuals.out')
res<-scan(file,sep=',',comment.char = "#")

res[res==-99.9]<-NA
a<-res
a[a>99]<-NA
max.buble<-max(abs(a),na.rm=TRUE)

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

nsp<-nsp-first.VPA+1

ii<-nsp+2       #counter in finfo file
ir<-1       #counter in residual file
nox.noy<-nox*noy
plot.no<-0

years<-rep(0,2)
ages<-rep(0,2)

for (sp in 1:nsp) {

  nf<-finfo[sp+1] #no. of fleets
  print(paste("species:",sp,"Number of fleets:",nf))
    sp.name<-sp.names[sp]

  for (f in 1:nf) {

    years[1]<-finfo[ii]
    ii<-ii+1
    years[2]<-finfo[ii]
    ii<-ii+1
    alfa<-finfo[ii]
    ii<-ii+1
    beta<-finfo[ii]
    ii<-ii+1
    if (alfa==0 && beta==0 && years[2]>SMS.control@last.year.model) years[2]<-SMS.control@last.year.model+1  else years[2]<-min(years[2],SMS.control@last.year.model)

    ages[1]<-finfo[ii]
    ii<-ii+1
    ages[2]<-finfo[ii]

    print(paste("sp:",sp,"  fleet:",f,"  years:",years[1],years[2],"  ages:",ages[1],ages[2]))

    nyr<-years[2]-years[1]+1
    nag<-ages[2]-ages[1]+1
    plot.no<-plot.no+1

    if (plot.no%%nox.noy==0 || f==1){
     newplot(dev,nox,noy,Portrait=Portrait,filename=paste(sp,f,plot.no))
      par(mar=c(3,4,3,2))
      if (dev=="wmf") par(mar=c(2,4,2,2))
      plot.no<-0
    }

    tmp<-matrix(res[ir:(ir+(nag+3)*nyr-1)],ncol=nyr,nrow=nag+3)
    tmp<-matrix(tmp[4:(nag+3),],ncol=nyr,nrow=nag)
    tmp[tmp==-99.99]<-0
     print(tmp)
    xpos <- years[1]:years[2]
    ypos <- ages[1]:ages[2]
    title<- paste(sp.name," fleet:",f,sep="")
    title<- fleet.names[sp,f]
    #title<- paste(sp.name,": ",fleet.names[f],sep="")

    if (length(ypos)==1) {

        tmp2<-tmp
        tmp2[]<-0
        if (ages[1]>=1) {
          tmp<-rbind(tmp2,tmp,tmp2)
          ypos <- (ages[1]-1):(ages[2]+1)
        }
        if (ages[1]==0) {
          tmp<-rbind(tmp,tmp2)
          ypos <- (ages[1]):(ages[2]+1)
        }
    }

    if (over.all.max>0) residplot(tmp,xpos,ypos,main=title,refdot=use.ref.dot,start.year=start.year,end.year=end.year,maxn=over.all.max)
    else residplot(tmp,xpos,ypos,main=title,refdot=use.ref.dot,start.year=start.year,end.year=end.year)

    ii<-ii+5
    ir<-ir+nyr*(nag+3)
  }
}

cat("Max buble size=",max.buble,'\n')
cat("log(Survey observed CPUE) - log(expected CPUE). 'Red' positive, 'White' negative\n")
if (dev !='screen') cleanup()
}


model_evapotranspiration <- function (isWindVpDefined = 1,
         evapoTranspirationPriestlyTaylor = 449.367,
         evapoTranspirationPenman = 830.958){
    #'- Name: EvapoTranspiration -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Evapotranspiration Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * ExtendedDescription: According to the availability of wind and/or vapor pressure daily data, the
    #'            SiriusQuality2 model calculates the evapotranspiration rate using the Penman (if wind
    #'            and vapor pressure data are available) (Penman 1948) or the Priestly-Taylor
    #'            (Priestley and Taylor 1972) method
    #'            * ShortDescription: It uses to choose evapotranspiration of Penmann or Priestly-Taylor
    #'- inputs:
    #'            * name: isWindVpDefined
    #'                          ** description : if wind and vapour pressure are defined
    #'                          ** parametercategory : constant
    #'                          ** datatype : INT
    #'                          ** default : 1
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration of Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** default : 449.367
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: evapoTranspirationPenman
    #'                          ** description : evapoTranspiration of Penman
    #'                          ** datatype : DOUBLE
    #'                          ** variablecategory : rate
    #'                          ** default : 830.958
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: evapoTranspiration
    #'                          ** description : evapoTranspiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (isWindVpDefined == 1)
    {
        evapoTranspiration <- evapoTranspirationPenman
    }
    else
    {
        evapoTranspiration <- evapoTranspirationPriestlyTaylor
    }
    return (list('evapoTranspiration' = evapoTranspiration))
}


#!/usr/bin/Rscript

library(DESeq2)

# script arguments
args <- commandArgs(trailingOnly=T)
rda_to_load <- args[1]
rda_to_save <- args[2]

# loading
load(rda_to_load)
rlog <- data

# let DESeq do the PCA for us
pca <- DESeq2::plotPCA(rlog, intgroup="sample", ntop=1000, returnData=T)

# saving
data <- pca
save(data, file=rda_to_save)


library(Seurat)
library(clustree)
library(ggraph)

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

sig.list = readRDS("sig/sig.list.RDS")

res = fread("results/test_sig.genes_in_clusters_high_vs_low_responders.txt")

res = res %>% dplyr::filter(clustering!="K0", test.dir=="IN")
df.res = res %>%
  dplyr::mutate(signif = case_when(
    w.pv<=0.001 ~ "***",
    w.pv<=0.01 ~ "**",
    w.pv<=0.05 ~ "*",
    TRUE ~ ""
  ))

dn.fig = "figures/sig_test_clustree"
dir.create(dn.fig, showWarnings = F, recursive = T)

test.name = "SigScore"
for(s in names(sig.list)) {
  cat (s, "\n")
  df.nodes = df.res %>%
    dplyr::filter(test==test.name, sig==s) %>%
    dplyr::mutate(HL.score = -log10(w.pv), node = paste0(clustering,"C",cluster)) %>%
    dplyr::mutate(label_signif = paste0(cluster, signif)) %>%
    dplyr::select(node, t.stat, w.pv, signif, cluster, label_signif)

  # Get the graph layout
  layout <- clustree(h1@meta.data %>% dplyr::select(K1:K3), prefix = "K",
                     return = "layout")
  identical(layout$node, df.nodes$node)
  inode = match(layout$node, df.nodes$node)

  # Add the statistic column (or whatever you want to show)
  layout$clr <- df.nodes$t.stat[inode]
  layout$label <- df.nodes$signif[inode] # or label_signif

  # Plot the graph (modified from clustree.R)
  gg <- ggraph::ggraph(layout)

  # Add the edges
  gg <- gg + geom_edge_link(#arrow = arrow(length = unit(1.5 * 5, "points"), ends = "last"),
                            end_cap = circle(9.5 * 1, "points"),
                            start_cap = circle(9.5 * 1, "points"),
                            # aes_(colour = ~count,
                            aes_(
                                 alpha = ~in_prop,
                                 edge_width = ~is_core) ) +
    scale_edge_width_manual(values = c(1.5, 1.5),
                            guide = "none") +
    scale_edge_colour_gradientn(colours = viridis::viridis(256)) +
    scale_edge_alpha(limits = c(0, 1))

  # Add the node points (replace "statistic" with the column you want to show)
  gg <- gg + clustree:::add_node_points("clr", "size", 1, colnames(layout))

  # Add the node text
  gg <- gg + geom_node_text(aes_(label = ~label), size = 12,
                            colour = "black")

  # Plot theme
  gg <- gg + #scale_size(range = c(4, 15)) +
    ggraph::theme_graph(base_family = "",
                        plot_margin = ggplot2::margin(2, 2, 2, 2))
  gg +
    scale_color_gradient2(low="blue", mid="grey90", high="red", midpoint = 0,
                          breaks=c(-3,0,3), limits=c(-3,3), oob=scales::squish, name="T stat") +
    scale_size_continuous(range = c(5, 30)) +
    coord_flip() +
    scale_x_reverse() +
    scale_y_reverse() +
    guides(size="none", edge_alpha="none", edge_color="none")

  ggsave(glue::glue("{dn.fig}/clustree_{test.name}_P_high_vs_low_{s}.png"), w=3, h=15)
  ggsave(glue::glue("{dn.fig}/clustree_{test.name}_P_high_vs_low_{s}.pdf"), w=3, h=15, useDingbats=F)
}


# Figure S11B - WGCNA pathway enrichment

setwd("/media/yuri/Data/home1/GNI_data/infection/DataSciRep/")
load("org.Hs.core_paths.Rdat")

names(kegg_path) <- paste0("kegg:", names(kegg_path))
names(corum_core) <- paste0("complex:", names(corum_core))
corum_core$`complex:mitochondrial respiratory chain complex I assembly` <- NULL
core_paths <- c(corum_core, kegg_path)

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/")
load("COVID_WGCNA.Rdat")

hmap <- cor(datME)
idx <- stats::hclust(dist(hmap), method = "ward.D2")$order
idx <- rev(idx)

datME_sig <- datME
datME_sig <- datME_sig[,idx]
datME_sig <- apply(datME_sig, 2, function(x) t.test(x ~ phenotype)$p.value)
datME_sig <- p.adjust(datME_sig, "fdr")
datME_sig <- -log10(datME_sig)

datME_sig <- datME_sig[datME_sig >= -log10(0.05)]

sigME <- names(datME_sig <- datME_sig[datME_sig >= -log10(0.05)])
sigME <- gsub("ME", "", sigME)

################################################################################
# For explanetion of gene set enrichment see
# http://pedagogix-tagc.univ-mrs.fr/courses/ASG1/practicals/go_statistics_td/go_statistics_td_2015.html
N <- length(unlist(core_paths)[!duplicated(unlist(core_paths))])
m <- sapply(core_paths, length)
n <- N-m

sigME_ens <- lapply(sigME, function(module) {

  k <- sum(GeneNames[dynamicColors %in% module] %in% unlist(core_paths)[!duplicated(unlist(core_paths))])
  x <- sapply(core_paths, function(x) sum(x %in% GeneNames[dynamicColors %in% module]) )

  sig <- phyper(q = x -1, m=m, n=n, k=k, lower.tail=FALSE)
  sig <- p.adjust(sig, "fdr")
  res <- sig[sig < 0.001]

  if(length(res) > 0) {
    res <- data.frame(module = module, ensemble = names(res), fdr = -log10(res))
    res <- res[order(res$fdr, decreasing = T),]
    rownames(res) <- NULL
  } else {res <- NULL}

  res

})

sigME_ens <- do.call(rbind, sigME_ens)
sigME_ens <- sigME_ens[!duplicated(sigME_ens$ensemble),]

sigME_ens <- sigME_ens[nrow(sigME_ens):1,]
sigME_ens$fdr[sigME_ens$fdr > -log10(1e-10)] <- -log10(1e-10)
sigME_ens <- sigME_ens[nrow(sigME_ens):1,]

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

library(gplots)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")
pdf("FigureS11B.pdf", width=8, height=6.4)

par(mar=c(4,16,1,0.5))
barplot(sigME_ens[,'fdr'], horiz = T, names.arg = sigME_ens[,'ensemble'], col = col2hex(sigME_ens[,'module']),
      xlab = "-log10(fdr)", main = "WGCNA enrichment (fdr < 0.01)",las=1, cex.axis=0.7, cex.names = 0.7)

dev.off()


#' Maximization step using coordinate descent optimization.
#'
#' @param p List of parameters.
#' @param item_data Matrix or data frame of item responses.
#' @param pred_data Matrix or data frame of DIF and/or impact predictors.
#' @param mean_predictors Possibly different matrix of predictors for the mean
#' impact equation.
#' @param var_predictors Possibly different matrix of predictors for the
#' variance impact equation.
#' @param eout E step output, including matrix for item and impact equations,
#' in addition to theta values (possibly adaptive).
#' @param item_type Optional character value or vector indicating the type of
#' item to be modeled.
#' @param pen_type Character value indicating the penalty function to use.
#' @param tau_current A single numeric value of tau that exists within
#' \code{tau_vec}.
#' @param pen Current penalty index.
#' @param alpha Numeric value indicating the alpha parameter in the elastic net
#' penalty function.
#' @param gamma Numeric value indicating the gamma parameter in the MCP
#' function.
#' @param anchor Optional numeric value or vector indicating which item
#' response(s) are anchors (e.g., \code{anchor = 1}).
#' @param final_control Control parameters.
#' @param samp_size Sample size in data set.
#' @param num_responses Number of responses for each item.
#' @param num_items Number of items in data set.
#' @param num_quad Number of quadrature points used for approximating the
#' latent variable.
#' @param num_predictors Number of predictors.
#' @param num_tau Logical indicating whether the minimum tau value needs to be
#' identified during the regDIF procedure.
#' @param max_tau Logical indicating whether to output the maximum tau value
#' needed to remove all DIF from the model.
#'
#' @return a \code{"list"} of estimates obtained from the maximization step using univariate
#' Newton-Raphson (i.e., one step of coordinate descent)
#'
#' @importFrom foreach %dopar%
#' @keywords internal
#'
Mstep_cd <-
  function(p,
           item_data,
           pred_data,
           mean_predictors,
           var_predictors,
           eout,
           item_type,
           pen_type,
           tau_current,
           pen,
           alpha,
           gamma,
           anchor,
           final_control,
           samp_size,
           num_responses,
           num_items,
           num_quad,
           num_predictors,
           num_tau,
           max_tau) {

  # Set under-identified model to FALSE until proven TRUE.
  under_identified <- FALSE

  # Update theta and etable.
  theta <- eout$theta
  etable <- eout$etable

  # Last Mstep
  if(max_tau) id_max_z <- 0

  # Latent mean impact updates.
  for(cov in 1:ncol(mean_predictors)) {
    anl_deriv <- d_alpha(c(p[[num_items+1]],p[[num_items+2]]),
                             etable,
                             theta,
                             mean_predictors,
                             var_predictors,
                             cov=cov,
                             samp_size,
                             num_items,
                             num_quad)
    p[[num_items+1]][[cov]] <-
      p[[num_items+1]][[cov]] - anl_deriv[[1]]/anl_deriv[[2]]
  }

  # Latent variance impact updates.
  for(cov in 1:ncol(var_predictors)) {
    anl_deriv <- d_phi(c(p[[num_items+1]],p[[num_items+2]]),
                           etable,
                           theta,
                           mean_predictors,
                           var_predictors,
                           cov=cov,
                           samp_size,
                           num_items,
                           num_quad)
    p[[num_items+2]][[cov]] <-
      p[[num_items+2]][[cov]] - anl_deriv[[1]]/anl_deriv[[2]]
  }

  # Item response updates.
  if(final_control$parallel[[1]]) {
    parallel::clusterExport(final_control$parallel[[2]],
                            c("num_responses", "pred_data", "item_data",
                               "samp_size", "num_predictors", "num_quad", "num_items",
                               "prox_data", "item_type", "anchor", "pen_type",
                               "num_tau", "pen", "tau_vec", "alpha", "final_control",
                               "max_tau", "d_bernoulli_itemblock", "d_bernoulli_itemblock_proxy",
                               "grp_soft_threshold", "grp_firm_threshold", "soft_threshold",
                               "firm_threshold", "p", "eout", "inv_hess_diag", "tau_current",
                               "under_identified", "id_max_z"),
                            envir=environment())

    p_items <- foreach::foreach(item=1:num_items) %dopar% {
      # Get posterior probabilities.

      # Obtain E-tables for each response category.
      if(item_type[item] != "cfa") {
        etable_item <- lapply(1:num_responses[item], function(x) etable)
        for(resp in 1:num_responses[item]) {
          etable_item[[resp]][which(
            !(item_data[,item] == resp)), ] <- 0
        }
      }

      # Bernoulli responses.
      if(item_type[item] == "2pl") {

        # Intercept updates.
        anl_deriv <- d_bernoulli("c0",
                                 p[[item]],
                                 etable_item,
                                 theta,
                                 pred_data,
                                 cov=0,
                                 samp_size,
                                 num_items,
                                 num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_bernoulli("a0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   cov=0,
                                   samp_size,
                                   num_items,
                                   num_quad)
          p[[item]][[2]] <- p[[item]][[2]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)) {

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_bernoulli("c1",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     cov,
                                     samp_size,
                                     num_items,
                                     num_quad)
            z <- p[[item]][[2+cov]] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[2+cov]] <- ifelse(pen_type == "lasso",
                                         soft_threshold(z,alpha,tau_current),
                                         firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_bernoulli("a1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
              z <- p[[item]][[2+num_predictors+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[2+num_predictors+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }

          }

        }

        # Categorical.
      } else {

        # Intercept updates.
        anl_deriv <- d_categorical("c0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   thr=-1,
                                   cov=-1,
                                   samp_size,
                                   num_responses[[item]],
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Threshold updates.
        for(thr in 2:(num_responses[item]-1)) {
          anl_deriv <- d_categorical("c0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=thr,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[thr]] <- p[[item]][[thr]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_categorical("a0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=-1,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[num_responses[[item]]]] <-
            p[[item]][[num_responses[[item]]]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)){

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_categorical("c1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       thr=-1,
                                       cov,
                                       samp_size,
                                       num_responses[[item]],
                                       num_items,
                                       num_quad)
            z <- p[[item]][[num_responses[[item]]+cov]] -
              anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[num_responses[[item]]+cov]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_categorical("a1",
                                         p[[item]],
                                         etable_item,
                                         theta,
                                         pred_data,
                                         thr=-1,
                                         cov,
                                         samp_size,
                                         num_responses[[item]],
                                         num_items,
                                         num_quad)
              z <- p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

      }
      return(list(unlist(p[item]),id_max_z))
    }

    for(item in 1:num_items) {
      p[[item]] <- p_items[[item]][[1]]
    }

  } else {

    for (item in 1:num_items) {

      # Obtain E-tables for each response category.
      if(item_type[item] != "cfa") {
        etable_item <- lapply(1:num_responses[item], function(x) etable)
        for(resp in 1:num_responses[item]) {
          etable_item[[resp]][which(
            !(item_data[,item] == resp)), ] <- 0
        }
      }

      if(item_type[item] == "cfa") {

        # Intercept updates.
        anl_deriv <- d_mu_gaussian("c0",
                                   p[[item]],
                                   etable,
                                   theta,
                                   item_data[,item],
                                   pred_data,
                                   cov=NULL,
                                   samp_size,
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          a0_parms <- grep(paste0("a0_item",item,"_"),names(p[[item]]),fixed=T)
          anl_deriv <- d_mu_gaussian("a0",
                                     p[[item]],
                                     etable,
                                     theta,
                                     item_data[,item],
                                     pred_data,
                                     cov=NULL,
                                     samp_size,
                                     num_items,
                                     num_quad)
          p[[item]][[2]] <- p[[item]][a0_parms] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Residual updates.
        s0_parms <- grep(paste0("s0_item",item,"_"),names(p[[item]]),fixed=T)
        anl_deriv <- d_sigma_gaussian("s0",
                                      p[[item]],
                                      etable,
                                      theta,
                                      item_data[,item],
                                      pred_data,
                                      cov=NULL,
                                      samp_size,
                                      num_items,
                                      num_quad)
        p[[item]][s0_parms][[1]] <- p[[item]][s0_parms][[1]] -
          anl_deriv[[1]]/anl_deriv[[2]]
        if(p[[item]][s0_parms][[1]] < 0) p[[item]][s0_parms][[1]] <- 1

        if(!any(item == anchor)) {

          # Residual DIF updates.
          for(cov in 1:num_predictors) {
            s1_parms <-
              grep(paste0("s1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
            anl_deriv <- d_sigma_gaussian("s1",
                                          p[[item]],
                                          etable,
                                          theta,
                                          item_data[,item],
                                          pred_data,
                                          cov=cov,
                                          samp_size,
                                          num_items,
                                          num_quad)
            p[[item]][s1_parms][[1]] <- p[[item]][s1_parms][[1]] -
              anl_deriv[[1]]/anl_deriv[[2]]
          }

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors){

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            c1_parms <-
              grep(paste0("c1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
            anl_deriv <- d_mu_gaussian("c1",
                                       p[[item]],
                                       etable,
                                       theta,
                                       item_data[,item],
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
            z <- p[[item]][c1_parms] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][c1_parms][[1]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors){

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch"){
              a1_parms <-
                grep(paste0("a1_item",item,"_cov",cov),names(p[[item]]),fixed=T)
              anl_deriv <- d_mu_gaussian("a1",
                                         p[[item]],
                                         etable,
                                         theta,
                                         item_data[,item],
                                         pred_data,
                                         cov,
                                         samp_size,
                                         num_items,
                                         num_quad)
              z <- p[[item]][a1_parms] - anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][a1_parms][[1]] <- ifelse(pen_type == "lasso",
                                                 soft_threshold(z,alpha,tau_current),
                                                 firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

        # Bernoulli responses.
      } else if(item_type[item] == "2pl") {

        # Intercept updates.
        anl_deriv <- d_bernoulli("c0",
                                 p[[item]],
                                 etable_item,
                                 theta,
                                 pred_data,
                                 cov=0,
                                 samp_size,
                                 num_items,
                                 num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_bernoulli("a0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   cov=0,
                                   samp_size,
                                   num_items,
                                   num_quad)
          p[[item]][[2]] <- p[[item]][[2]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)) {

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_bernoulli("c1",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     cov,
                                     samp_size,
                                     num_items,
                                     num_quad)
            z <- p[[item]][[2+cov]] - anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[2+cov]] <- ifelse(pen_type == "lasso",
                                         soft_threshold(z,alpha,tau_current),
                                         firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_bernoulli("a1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       cov,
                                       samp_size,
                                       num_items,
                                       num_quad)
              z <- p[[item]][[2+num_predictors+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[2+num_predictors+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }

          }

        }

        # Categorical.
      } else {

        # Intercept updates.
        anl_deriv <- d_categorical("c0",
                                   p[[item]],
                                   etable_item,
                                   theta,
                                   pred_data,
                                   thr=-1,
                                   cov=-1,
                                   samp_size,
                                   num_responses[[item]],
                                   num_items,
                                   num_quad)
        p[[item]][[1]] <- p[[item]][[1]] - anl_deriv[[1]]/anl_deriv[[2]]

        # Threshold updates.
        for(thr in 2:(num_responses[item]-1)) {
          anl_deriv <- d_categorical("c0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=thr,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[thr]] <- p[[item]][[thr]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        # Slope updates.
        if(item_type[item] != "rasch") {
          anl_deriv <- d_categorical("a0",
                                     p[[item]],
                                     etable_item,
                                     theta,
                                     pred_data,
                                     thr=-1,
                                     cov=-1,
                                     samp_size,
                                     num_responses[[item]],
                                     num_items,
                                     num_quad)
          p[[item]][[num_responses[[item]]]] <-
            p[[item]][[num_responses[[item]]]] - anl_deriv[[1]]/anl_deriv[[2]]
        }

        if(!any(item == anchor)){

          p2 <- unlist(p)

          # Intercept DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("c1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            anl_deriv <- d_categorical("c1",
                                       p[[item]],
                                       etable_item,
                                       theta,
                                       pred_data,
                                       thr=-1,
                                       cov,
                                       samp_size,
                                       num_responses[[item]],
                                       num_items,
                                       num_quad)
            z <- p[[item]][[num_responses[[item]]+cov]] -
              anl_deriv[[1]]/anl_deriv[[2]]
            if(max_tau) id_max_z <- c(id_max_z,z)
            p[[item]][[num_responses[[item]]+cov]] <-
              ifelse(pen_type == "lasso",
                     soft_threshold(z,alpha,tau_current),
                     firm_threshold(z,alpha,tau_current,gamma))
          }

          # Slope DIF updates.
          for(cov in 1:num_predictors) {

            # End routine if only one anchor item is left on each covariate
            # for each item parameter.
            if(is.null(anchor) &
               sum(p2[grep(paste0("a1(.*?)cov",cov),names(p2))] != 0) >
               (num_items - 1) &
               alpha == 1 &&
               (length(final_control$start.values) == 0 || pen > 1) &&
               num_tau >= 10){
              under_identified <- TRUE
              break
            }

            if(item_type[item] != "rasch") {
              anl_deriv <- d_categorical("a1",
                                         p[[item]],
                                         etable_item,
                                         theta,
                                         pred_data,
                                         thr=-1,
                                         cov,
                                         samp_size,
                                         num_responses[[item]],
                                         num_items,
                                         num_quad)
              z <- p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] -
                anl_deriv[[1]]/anl_deriv[[2]]
              if(max_tau) id_max_z <- c(id_max_z,z)
              p[[item]][[length(p[[item]])-ncol(pred_data)+cov]] <-
                ifelse(pen_type == "lasso",
                       soft_threshold(z,alpha,tau_current),
                       firm_threshold(z,alpha,tau_current,gamma))
            }
          }
        }

      }

    }

  }

  if(max_tau) {
    if(final_control$parallel[[1]]) {
      id_max_z <- max(abs(sapply(1:num_items, function(items) p_items[[items]][[2]])))
    } else{
      id_max_z <- max(abs(id_max_z))
    }
    return(id_max_z)
  } else {
    return(list(p=p,
                under_identified=under_identified))
  }

}