#Beaucoup d'operations sont possibles en R sur les chaines, incluant des expressions régulieres.
#Voir l'aide des fonctions: gsub, strsplit, grep, ...
#ou http://www.duclert.org/Aide-memoire-R/Le-langage/Chaines-de-caracteres.php

library(tm)
#----------------------------------------------------------
#SUPPRESSION DES BALISES SCRIPT

#un texte peut parfois etre considere comme un vecteur ou une liste de lignes.
#La fonction suivante concatene toutes les lignes du texte en parametre et retourne
#une unique chaine de caracteres
merge<-function(t){
  PlainTextDocument(paste(t,collapse=""))
}

#Suppression des script s(<script .... </script>)
removeScript<-function(t){
  #découpage de la chaine en utilisant "<split"
  sp<-strsplit(as.character(t), "<script")[[1]]
  #pour chaque partie du split, le début (jusqu'a </script>) est supprimé
  vec<-sapply(1:length(sp),function(i) gsub(sp[i], pattern=".*</script>", replace=" "))
  #les élements du split nettoyés sont concaténés
  PlainTextDocument(paste(vec,collapse=""))
}

#Suppression de toutes les balises
removeBalises<-function(t){
  t1<-gsub("<[^>]*>", " ", t)
  #suppression des occurrences multiples d'espaces (ou de tabulations)
  PlainTextDocument(gsub("[ \t]+"," ",t1))
}

#Fonction de nettoyage permettant de récupérer uniquement le contenu textuel d'une page HTML
nettoyage<-function(corpus){
  corpus<-tm_map(corpus,merge)
  corpus<-tm_map(corpus,content_transformer(tolower))
  #on utilise content_tranformer pour forcer le traitement via tolower à renvoyer un PlainTextDocument
  corpus<-tm_map(corpus,removeScript)
  corpus<-tm_map(corpus,removeBalises)
  corpus<-tm_map(corpus, removeWords, words=stopwords('en'))
  corpus<-tm_map(corpus, removePunctuation)
  corpus<-tm_map(corpus, stemDocument, language='en')
  corpus<-tm_map(corpus, removeNumbers)
}

distance<-function(x,y){
  return((sqrt(sum((x-y)^2))))
}

distanceManhattan<-function(x,y){
  return(sum(abs(x-y)))
}

distanceMinKowski<-function(x,y){
  return((sum((x-y)^1.414))^1/1.414)
}

distanceJaccard<-function(x,y){
  return(jaccard(x,y))
}

jaccard <- function(x, y, center=FALSE, px=NULL, py=NULL) {
  if(length(x) != length(y)) {
    stop("Two fingerprints (x and y) must be of the same length.")
  }

  if(is.null(px) | is.null(py)){
    px <- mean(x)
    py <- mean(y)
  }

  sumxy <- sum(x & y)
  unionxy <- sum(x)+sum(y)-sumxy
  if(unionxy == 0) {
    j <- (px*py)/(px+py-px*py)
  } else {
    j <- sumxy/unionxy
  }
  if(center == FALSE) {
    return(j)
  } else {
    return(j - (px*py)/(px+py-px*py))
  }
}

dist_voisins<-function(vecteur,data){
  return(apply(data[,-ncol(data)],1,distanceJaccard,x=vecteur))
}

kppv<-function(vecteur, k, data){
  v<-dist_voisins(vecteur,data)
  return(order(v)[1:k])
}

classerKPPV<-function(vecteur, k, data) {
  vec<-kppv(vecteur, k, data)
  classes<-data[vec,ncol(data)]
  occ<-table(classes)
  return (names(occ)[which.max(occ)])
}

erreurKPPV<-function(k, data) {
  res<-sapply(1:nrow(data), function(i)classerKPPV(data[i,-ncol(data)],k,data[-i,]))
  return (1-sum((res==(data[,ncol(data)]))/nrow(data)))
}

corpus<-VCorpus(DirSource("training",recursive=TRUE))
corpusN<-nettoyage(corpus)
mat<-DocumentTermMatrix(corpusN)
vocab200<-findFreqTerms(mat, lowfreq = 200, highfreq = 800)
vocab200<-sort(append(vocab200, c("professor", "essay", "checklist", "hotlist", "table", "search")))
write.csv(vocab200, "vocab.csv", row.names = FALSE)
mat20<-DocumentTermMatrix(corpusN, list(dictionary=vocab200))
M<-as.matrix(mat20)

classes<-c(rep(1,150),rep(2,150),rep(3,150),rep(4,150),rep(5,150),rep(6,150),rep(7,150))
M<-cbind(M,classes)
write.csv(M, "data.csv", row.names = FALSE)
erreurKPPV(k=4, data=M)


# Use data.table library
library(data.table)
library(lubridate) # Speed up slow time parsing behavior.

per_capita_TED <- function(sum_11_mo) {
  year_adjusted_TED <- (sum_11_mo / 11) + sum_11_mo
  pop_PDX <- 1577456
  return(year_adjusted_TED / pop_PDX)
}

TED_summation <- function(tb_teds) {
  VOCa <- 1.4
  VOCb <- 10
  VOCt <- 1
  tb_teds[, AVOc := pct_auto * VOCa]
  tb_teds[, AVOb := pct_bus * VOCb]
  tb_teds[, AVOt := pct_truck * VOCt]
  tb_teds[, TED  := gp_TED_seg * (AVOc + AVOb + AVOt)]
  return(tb_teds)
}

total_excessive_delay <- function(tb_ted) {
  tb_ted[, TED_seg := ED * PK_HR]
  tb_ted.a <- tb_ted[, j = list(gp_TED_seg =  sum(TED_seg, na.rm = TRUE),
                                pct_auto   =  max(pct_auto),
                                pct_bus    =  max(pct_bus),
                                pct_truck  =  max(pct_truck)
                              ), by = Tmc]
  return(tb_ted.a)
}

peak_hr <- function(tb_pk) {
  tb_pk[, PK_HR := dir_aadt * `2015_15-min_Combined`]
  return(tb_pk)
}

excessive_delay <- function(tb_ed) {
  tb_ed[, ED := RSD / 3600]
  tb_ed[ED < 0, ED := 0]
  return(tb_ed)
}

RSD <- function(tb_rsd) {
  tb_rsd[, RSD := travel_time_seconds - SD]
  tb_rsd[RSD < 0, RSD := 0]
  return(tb_rsd)
}

segment_delay <- function(tb_sd) {
  tb_sd[, SD := (miles / TS) * 3600]
  return(tb_sd)
}

AADT_splits <- function(tb_spl) {
  tb_spl[, dir_aadt := aadt / faciltype]
  tb_spl[, aadt_auto := dir_aadt - (aadt_singl + aadt_combi)]
  tb_spl[, pct_auto := aadt_auto / dir_aadt]
  tb_spl[, pct_bus := aadt_singl / dir_aadt]
  tb_spl[, pct_truck := aadt_combi / dir_aadt]
  return(tb_spl)
}

threshold_speed <- function(tb_ts) {
  tb_ts[, TS := SPEED_LIMIT * .6]
  tb_ts[TS < 20 | is.na(TS), TS := 20]
  return(tb_ts)
}

###############################################################################
# Begin Main Script
###############################################################################

start.time <- Sys.time()

tb <- data.table(
  tmc_code = character(),
  measurement_tstamp = character(),
  speed = double(),
  average_speed = double(),
  reference_speed = double(),
  travel_time_seconds = double()
)

setwd("H:/map21/perfMeasures/phed/data")

drive_path <- "original_data/"
quarters <- c("2017Q1", "2017Q2", "2017Q3", "2017Q4")
folder_end <- "_TriCounty_Metro_15-min"
file_end <- "_NPMRDS (Trucks and passenger vehicles).csv"

for (q in quarters) {
  filename <- paste(q, folder_end, file_end, sep = "")
  path <- paste(q, folder_end, sep = "")
  full_path <- paste(path, filename, sep = "/")
  tb_temp <- fread(paste(drive_path, full_path, sep = ""))
  tb <- rbind(tb, tb_temp)
}

#tb <- fread("C:/Users/saavedrak/metro_work/PHED/Feb2017_test/Feb2017_test.csv")
# Filter out weekends:
tb <- tb[!(weekdays(ymd_hms(measurement_tstamp)) %in% c("Saturday", "Sunday"))]
# Extract hour from datetime timestamp:
tb[, pk_hr := hour(measurement_tstamp)]
tb_peak <- fread("peakingFactors_join_edit.csv")
# Convert text time to standalone integer hour.
tb_peak[, pk_hour := as.integer(hour(parse_date_time(startTime, orders="HM")))]
# Left join to main data file.
tb <- merge(x = tb, y = tb_peak, by.x = "pk_hr", by.y = "pk_hour",
            all.x = TRUE)
tb <- tb[pk_hr %in% c(6, 7, 8, 9, 10, 15, 16, 17, 18, 19)]
# Inner join with urban areas only
tb_urban <- fread("urban_tmc.csv")
tb <- merge(x = tb_urban, y = tb, by.x = "Tmc", by.y = "tmc_code")
# Merge metadata
tb_meta <- fread(
  "TMC_Identification_NPMRDS (Trucks and passenger vehicles).csv")
tb <- merge(x = tb, y = tb_meta, by.x = "Tmc", by.y = "tmc")
# Join HERE data
tb_here <- fread("HERE_OR_Static_TriCounty_edit.csv")
tb <- merge(x = tb, y = tb_here, by.x = "Tmc", by.y = "TMC_HERE", all.x = TRUE)

tb0 <- threshold_speed(tb)
tb1 <- AADT_splits(tb0)
tb2 <- segment_delay(tb1)
tb3 <- RSD(tb2)
tb4 <- excessive_delay(tb3)
tb5 <- peak_hr(tb4)
tb6 <- total_excessive_delay(tb5)
tb7 <- TED_summation(tb6)

result <- per_capita_TED(sum(tb6[, TED]))
print(result)

end.time <- Sys.time()
total.time <- end.time - start.time
print(total.time)


#Bray-Curtis community similarity ~ space across phyogenetic scales.
# for 16S taxonomic groups. not functional groups bc they don't sum to one.
rm(list=ls())
source('paths.r')
library(mgcv)

#Load data.----
d_all <- readRDS(NEON_phylo_fg_plot.site_obs_16S.path)
loc_all <- readRDS(dp1.10086.001_output.path)
#reorder and rename.
d_all <- d_all[1:5]
#d_all <- d_all[c('fg','phylum','class','order','family','genus')]
#names(d_all)[1] <- 'functional'
# read in obs table that links deprecatedVialID and geneticSampleID
map <- readRDS(core_obs_data.path)

#Generate Bray-Curtis similarity matrices and spatial matrices.----
sim <- list()
spa <- list()
for(k in 1:length(d_all)){
  #Grab tax/functional level.----
  d <- d_all[[k]]
  d <- d$core.fit
  loc <- loc_all

  #match up data, subset to mineral soil, drop stuff from identical locations.----
  map <- map[,c("deprecatedVialID", "geneticSampleID")]
  map$geneticSampleID <- gsub('-GEN','',map$geneticSampleID)
  d <- as.data.frame(d)
  d$deprecatedVialID <- rownames(d)
  d <- merge(d, map, by = "deprecatedVialID")
  rownames(d) <- d$geneticSampleID
  d$geneticSampleID <- NULL
  d$deprecatedVialID <- NULL
  #drop organic horizons. Generates zero distances.
  loc <- loc[loc$horizon == 'M',]
  loc$lat_lon <- paste0(loc$adjDecimalLongitude, loc$adjDecimalLatitude)
  drop <- loc[duplicated(loc$lat_lon),]$sampleID #drop some duplicated locations.
  loc <- loc[!(loc$sampleID %in% drop),]
  loc <- loc[loc$sampleID %in% rownames(d),]
  d <-   d[rownames(d) %in% loc$sampleID,]
  loc <- loc[order(match(loc$sampleID, rownames(d))),]

  #Generate spatial distance matrix.----
  tax.loc <- loc[,c('adjDecimalLongitude','adjDecimalLatitude')]
  tax.dist <- geosphere::distm(tax.loc)
  tax.dist <- tax.dist[lower.tri(tax.dist)]

  #Generate Bray-Curtis similarity matrix.----
  bray <- 1 - vegan::vegdist(d)
  bray <- as.matrix(bray)
  bray <- bray[lower.tri(bray)]

  #return output.----
  sim[[k]] <- bray
  spa[[k]] <- tax.dist
}
names(sim) <- names(d_all)
names(spa) <- names(d_all)

#plot the results!----
par(mfrow = c(3,3))
m.out <- list()
d.out <- list()
for(i in 1:length(sim)){
  y <- log10(sim[[i]])
  y <-      (sim[[i]])
  x <- log10(spa[[i]])

  #fit lines within scales.
  dat <- data.frame(y, x)
  #dat <- dat[sample(nrow(dat), 1000),]
  core.fit <- lm(y ~ x, dat[dat$x < 2,])
  plot.fit <- lm(y ~ x, dat[dat$x > 2 & dat$x < 4.8,])
  site.fit <- lm(y ~ x, dat[dat$x > 4.8,])
  glob.fit <- lm(y ~ x)
  #save slopes.
  m.out[[i]] <- c(coef(core.fit)[2], coef(plot.fit)[2], coef(site.fit)[2])
  d.out[[i]] <- m.out[[i]] - coef(glob.fit)[2]

  #plot similarity.
  group <- names(sim)[i]
  cat('plotting',group,'...\n')
  plot(y ~ x, cex = 0.1, ylab = NA, xlab = NA, data = dat, pch = 16, col = 'gray')
  mtext(group, side = 3, adj = 0.05)

  #plot line across scales.
  abline(lm(y ~ x), lwd = 1.5, col = 'black', lty = 3)

  #gam
  # cat('Fitting gam...\n')
  # x.gam <- seq(min(x), max(x), by = 0.1)
  # newdat <- data.frame(x.gam)
  # colnames(newdat) <- c('x')
  # mod.gam <- gam(y ~ s(x, k=-1))
  # gam.pred <- predict(mod.gam, newdata = newdat)
  # lines(smooth.spline(gam.pred ~ x.gam), lwd = 2, col = 'green')

  #plot lines within scales.
  x.core <- seq(0,2,by = 0.1)
  y.core <- coef(core.fit)[1] + coef(core.fit)[2] * x.core
  lines(smooth.spline(x.core, y.core), lwd = 2, col = 'purple')
  x.plot <- seq(2,4.8, by = 0.2)
  y.plot <- coef(plot.fit)[1] + coef(plot.fit)[2]*x.plot
  lines(smooth.spline(x.plot, y.plot), lwd = 2, col = 'purple')
  x.site <- seq(4.8, 6.45, by = 0.1)
  y.site <- coef(site.fit)[1] + coef(site.fit)[2]*x.site
  lines(smooth.spline(x.site, y.site), lwd = 2, col = 'purple')
}

#Now plot the slopes as a function of function/phylo scale.
#m.out is difference between local scale line and ovrall scale line. It didn't show much difference.
m.out <- do.call(rbind, m.out)
d.out <- do.call(rbind, d.out)
colnames(m.out) <- c('core','plot','site')
rownames(m.out) <- names(sim)
colnames(d.out) <- colnames(m.out)
rownames(d.out) <- rownames(m.out)
head_lab <- c('within plot','within site','between site')
d.out <- m.out

for(i in 1:ncol(d.out)){
  x <- 1:nrow(d.out)
  y <- d.out[,i]
  limy = c(min(d.out), max(d.out))
  plot(y ~ x, cex = 2.5, pch = 16, ylim = limy, ylab = NA, xlab = NA, bty='n', xaxt = 'n')
  lines(x, y, lty = 2)
  axis(1, labels = F)
  text(x=x,  y = min(d.out)*1.15, labels= rownames(d.out), srt=45, adj=1, xpd=TRUE)
  mtext(head_lab[i], side = 3, line = 2)

}

#outer labels.
mtext("log10(Bray-Curtis Similarity)", line = -2, side = 2, outer = T)
mtext("log10(meters)",side = 1, outer = T, line = -2)


#'@title calcKristPwr
#'
#' @description Calculate instantaneous main engine power (kW) using the
#' Kristensen 2016 updates of Harvald equations.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of
#'  numericals, kW) (maximum
#' continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'  \code{\link{calcSpeedUnitConversion}})
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param shipType Ship type (vector of strings, see \code{\link{calcShipType}}),
#' determined by Stat 5 code: \itemize{
#' \item"container.ship"
#' \item"bulk.carrier"
#' \item"tanker"
#' \item"general.cargo"
#' \item"vehicle.carrier"
#' \item"reefer"
#' \item"ro.ro"
#' \item"passenger"
#' \item"tug"
#' \item"misc"
#'}
#' @param lwl Waterline length (vector of numericals, m) (see
#' \code{\link{calclwl}})
#' @param breadth Moulded breadth (vector of numericals, m)
#' @param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#' @param Cb Maximum block coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCb}})
#' @param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#' @param dwt Ship maximum deadweight tonnage (vector of numericals, tonnage)
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10}
#' Can supply either a vector of numericals, a single number, or rely on the
#' default
#' @param shaftEff Shaft efficiency (dimensionless). Default = 0.98.
#'  Ratio of power delivered to the propeller and the brake power delivered by
#'  the engine. Can supply either a vector of numericals, a single number, or
#'  rely on the default
#' @param relRotationEff Relative rotational efficiency (dimensionless).
#'  Default = 1. Accounts for effect of rotational flow of water around propeller.
#'  Can supply either a vector of numericals, a single number, or rely on the
#'  default
#' @param seawaterTemp Sea water temperature. Default = 15 (degrees Celsius). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param pwrUpperBoundPercent Percent of total installed power at which
#' required power is capped. Default = 1, which indicates required power cannot
#' exceed \code{totalInstalledPwr}. Can supply either a vector of numericals, a
#' single number, or rely on the default
#' @param pwrLowerBoundPercent Percent of total installed power to act as lower
#' bound for required power. Default = 0.02, which indicates required power
#' cannot go below 2\% of \code{totalInstalledPwr}. Can supply either a vector
#' of numericals, a single number, or rely on the default
#' @param CmEquationType Type of equation to estimate the midship section
#' coefficient (see \code{\link{calcCm}}): \itemize{
#' \item"kristensen"
#' \item"benford"
#' \item"schneekluth"}
#' @param tankerBulkCarrierShipTypes Ship types specified in input
#' \code{shipTypes} to be modeled as tankers and bulk carriers.
#' @param tugShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as tugs
#' @param roroPaxShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as RORO and passenger ships
#' @param gCargoShipTypes Ship types specified in input \code{shipTypes} to be
#' modeled as general cargo
#' @param containerShipTypes Ship types specified in input \code{shipTypes} to
#' be modeled as container ships
#'
#' @details
#' Primary method from Kristensen (2013). Estimation of some inputs use
#' methodology from Rakke (2016).
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierShipTypes}, \code{tugShipTypes}, \code{roroPaxShipTypes},
#' \code{gCargoShipTypes}, \code{containerShipTypes} grouping parameters to
#' provide these ship type groupings. Any ship types not included in these groupings
#' will be considered as miscellaneous vessels.
#'
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' @return power (vector of numericals, kW)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'Kristensen, H. O. 2016. "Revision of statistical analysis and determination of
#'regression formulas for main dimensions of container ships based on data from
#'Clarkson."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship Emissions
#'Calculation from AIS." NTNU.}
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcCb}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcCm}}
#'\item \code{\link{calcShipType}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("Kristensen.Example", package="ShipPowerModel")}
#'}
#'
#' @family Kristensen Calculations
#'
#' @examples
#' calcKristPwr(
#' totalInstalledPwr=9363,
#' shipSpeed=10.8,
#' actualDraft=12.5,
#' maxDraft=13.6,
#' shipType="bulk.carrier",
#' lwl=218,
#' breadth=32.25,
#' maxDisplacement=80097,
#' Cb=0.8162717,
#' nProp=1,
#' dwt=70000,
#' serviceMargin=15,
#' shaftEff=0.98,
#' relRotationEff=1,
#' seawaterTemp=15,
#' seawaterDensity=1.025,
#' CmEquationType="kristensen"
#' )
#'
#' @export

calcKristPwr<-function(
  totalInstalledPwr,
  shipSpeed,
  actualDraft,
  maxDraft,
  shipType,
  lwl,
  breadth,
  maxDisplacement,
  Cb,
  nProp,
  dwt,
  serviceMargin=15,
  shaftEff=0.98,
  relRotationEff=1,
  seawaterTemp=15,
  seawaterDensity=1.025,
  pwrUpperBoundPercent=1,
  pwrLowerBoundPercent=0.02,
  CmEquationType="kristensen",
  tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
  tugShipTypes=c("service.tug","tug"),
  roroPaxShipTypes=c("passenger","ferry.pax","ferry.ro.pax","cruise","cruise.ed","yacht","ro.ro"),
  gCargoShipTypes=c("general.cargo"),
  containerShipTypes=c("container.ship")
){
#=============================================================
  #Inputs
  Cbw<-calcCbw(Cb, actualDraft, maxDraft)
  actualDisplacement<-calcActualDisp(Cb,
                                     Cbw,
                                     actualDraft,
                                     maxDraft,
                                     maxDisplacement)

  Cm<-calcCm(shipType,Cbw,maxDraft,actualDraft,CmEquationType,tankerBulkCarrierShipTypes,tugShipTypes,roroPaxShipTypes)

  Cp<-calcCp(Cm, Cbw,shipType, bounds="none", roroPaxContainerShipTypes=union(roroPaxShipTypes,containerShipTypes),gCargoShipTypes,tankerBulkCarrierShipTypes)

  propDiam<-calcPropDia(shipType, maxDraft,tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes),containerShipTypes)

  M<- calcShipM(actualDisplacement,lwl)

  froudeNum<- calcFroudeNum(shipSpeed,lwl)
#=============================================================
#Frictional Resistance
Cf<-calcCf(shipSpeed, lwl, seawaterTemp, seawaterDensity)
#=============================================================
#Wetted Surface Area
wettedSA<-calcKristWettedSA(shipType,
                            maxDisplacement,
                            maxDraft,
                            actualDraft,
                            lwl,
                            breadth,
                            Cbw,
                            seawaterDensity,
                            tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes),
                            containerShipTypes,
                            paxTugShipTypes=union(roroPaxShipTypes, tugShipTypes))

#==========================================
#Incremental Resistance
Ca<-calcKristCa(shipType,actualDisplacement,
                tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes),
                containerShipTypes)
#==========================================
#Air Resistance
Caa<-calcKristCaa(shipType,dwt,
                  tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes),
                  containerShipTypes)
#==========================================
#Residual Resistance
Cr<-calcKristCr(shipType,
                M,
                froudeNum,
                actualDraft,
                breadth,
                Cp,
                tankerBulkCarrierGCargoShipTypes=union(tankerBulkCarrierShipTypes,gCargoShipTypes))

#=============================================================
#Thrust Deduction Factor
t<-calcKristThrustFactor(
                    shipType,
                    breadth,
                    lwl,
                    Cbw,
                    propDiam,
                    M,
                    nProp,
                    tankerBulkCarrierShipTypes)
#=============================================================
#Wake Fraction
#*(1-t)/(1-w)= hull efficiency
w<-calcKristWakeFrac(shipType,
                breadth,
                lwl,
                Cbw,
                propDiam,
                M,
                nProp,
                tankerBulkCarrierShipTypes)
#==========================================================
#Total Resistance
R<-calcKristTotalRes(wettedSA,
                     Cf,
                     Cr,
                     Ca,
                     Caa,
                     seawaterDensity,
                     shipSpeed,
                     serviceMargin)
#==========================================================
# Open Water Efficiency
no<-calcOpenWaterEff(R,
                     t,
                     nProp,
                     w,
                     propDiam,
                     shipSpeed,
                     seawaterDensity)
#=============================================================
power<-calcResistanceShipPwr(R,shipSpeed, (1-t)/(1-w), no,totalInstalledPwr, shaftEff,relRotationEff, pwrUpperBoundPercent, pwrLowerBoundPercent)

return(power)
}


#' @title Calculate cluster stability for each cluster
#'
#' @param fs flowSet.
#' Assumed appropriately transformed and compensated (but not necessary scaled).
#' @param flowsom_orig output from FlowSOM::FlowSOM, as applied to original data.
#' @param scale logical. If \code{TRUE}, the variables are centred and scaled.
#' @param boot integer. Number of bootstrap samples to take.
#' @param seed integer. If not \code{NULL}, then the seed is set to this.
#' @param chnl character vector. Channels to use for clustering.
#' Same as \code{colsToUse} for \code{FlowSOM::FlowSOM}.
#' @param n_cluster integer. Number of clusters.
#' Same meaning as \code{nClus} for \code{FlowSOM::FlowSOM}.
#' @return A \code{tibble::tibble} with the following three
#'
#' @export
calc_cluster_stability <- function(fs,
                                   flowsom_orig,
                                   scale,
                                   seed = NULL,
                                   boot,
                                   chnl,
                                   n_cluster){

  # clusters for each original data point
  cluster_vec_orig <- as.numeric(
    flowsom_orig$metaclustering[flowsom_orig$map$mapping[, 1]]
   )

  # process data for FlowSOM
  # --------------------------
  flowsom_input_orig <- FlowSOM::ReadInput(
    input = fs,
    pattern = ".fcs",
    compensate = FALSE,
    spillover = NULL,
    transform = FALSE,
    toTransform = NULL,
    transformFunction = flowCore::logicleTransform(),
    scale = scale,
    silent = TRUE
  )

  stability_tbl_boot <- purrr::map_df(seq_len(boot), function(boot_ind) {

    if (!is.null(seed)) set.seed(seed)

    if (boot_ind %% 10 == 0) print(boot_ind)

    # get bootstrap sample
    flowsom_input_boot <- flowsom_input_orig
    ind_vec <- sample(seq_len(nrow(flowsom_input_orig$data)),
                      nrow(flowsom_input_orig$data),
                      replace = TRUE)

    flowsom_input_boot$data <- flowsom_input_orig$data[ind_vec, ]

    # build SOM
    flowsom_boot <- FlowSOM::BuildSOM(
      fsom = flowsom_input_boot,
      colsToUse = chnl,
      silent = TRUE,
      importance = NULL
    )

    # build mst
    flowsom_boot <- FlowSOM::BuildMST(
      flowsom_boot,
      silent = TRUE
    )

    # metaclustering
    cluster_lab_vec <- FlowSOM::metaClustering_consensus(
      data = flowsom_boot$map$codes,
      k = n_cluster,
      seed = 2 * seed
    )
    # cluster for each cell
    cluster_vec_boot <- cluster_lab_vec[flowsom_boot$map$mapping[, 1]]

    # clusters for each observations
    cluster_vec_orig_in_boot <- cluster_vec_orig[ind_vec]
    results_mat <- matrix(rep(-1, n_cluster^2), nrow = n_cluster)
    for (i in seq_len(n_cluster)) {
      for (j in seq_len(n_cluster)) {
        ind_orig <- which(cluster_vec_orig_in_boot == i)
        ind_boot <- which(cluster_vec_boot == j)
        n_intersect <- length(intersect(ind_boot, ind_orig))
        n_union <- length(union(ind_boot, ind_orig))
        jacc_coef <- n_intersect / n_union
        results_mat[i, j] <- jacc_coef
      }
    }

    results_vec <- vapply(
      seq_len(n_cluster),
      function(i) {
        max(results_mat[i, , drop = TRUE])
      },
      numeric(1)
    )

    seed <<- seed + 1

    out_tbl <- data.frame(t(as.matrix(results_vec)))
    colnames(out_tbl) <- paste0("cluster_", seq_len(n_cluster))
    out_tbl
  })

  stability_vec_summary <- vapply(seq_len(n_cluster), function(i) {
    mean(stability_tbl_boot[[i]])
  }, numeric(1))

  if (!requireNamespace("tibble", quietly = TRUE)) {
    install.packages("tibble")
  }

  tibble::tibble(
    cluster = seq_len(n_cluster),
    stability_mean = stability_vec_summary,
    stability_sample = lapply(seq_len(n_cluster), function(i) {
      stability_tbl_boot[[i]]
    })
  )

}


library(dplyr, warn.conflicts = FALSE)
library(utils)

# Annotations for VA example
#   Hardcoding column names currently.  Subsequent iterations are expected to take advantage of
# column use and name specification from spek.

setup <- function(data, spec){
  cat(paste("\nSETUP\n", names(data), "\n\n"), file=stderr())
}

## Helper functions
eval_obs_paucity <- function(doc, ndoc){
  c_obs <- sum(doc, ndoc)

  if( c_obs < 12 &
      dplyr::last(ndoc) < 6 &
      dplyr::last(doc) < 6 ){
    return(TRUE)
  }

  return(FALSE)
}

eval_negative_trend <- function(doc, ndoc){
  ratio <- doc/ndoc
  is_tail_ascending <- !is.unsorted(utils::tail(ratio,3), strictly=T)
  return(is_tail_ascending)
}

eval_negative_gap <- function(doc, ndoc){
  ratio <- doc/ndoc
  return(dplyr::last(ratio) < 0.9)
}

## Annotation functions
annotate_obs_paucity <- function(data, spek){
  data %>%
    group_by(id) %>%
    arrange(report_month) %>%
    summarize(obs_paucity = eval_obs_paucity(documented, not_documented))
}

annotate_negative_gap <- function(data, spek){
  data %>% group_by(id) %>%
    dplyr::filter(report_month == max(report_month)) %>%
    summarize(negative_gap = eval_negative_gap(documented, not_documented))
}

annotate_negative_trend <- function(data, spek){
  #cat(paste("\nnegTrend\n"), file=stderr())
  data %>%
    group_by(id) %>%
    arrange(report_month) %>%
    summarize(negative_trend = eval_negative_trend(documented, not_documented))
}


# Exercise 3

# setup code
library(tidyverse)

# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
kerry <- filter(unisex_data, name=="Kerry")

# label the two peak years in this plot
# Male: 1960, Female: 1971
# use annotate() - you can call it twice, or specify vectors for x and label params
# Hint: the y limits will adjust automatically to fit your annotations
ggplot(kerry, aes(year, n, color=sex)) +
  geom_line() +
  labs(title="Kerry", y="Number of Babies", x="") +
  annotate("text", x=c(1960, 1971), y=2400, label=c("1960", "1971"))

# BONUS: draw a line from the label to the peaks:
# do this with another annotate element to the plot: type "segment"
# You might want to shift your lables to accomodate the lines
# Bonus 2: change the label colors to match the lines: #f8766d and #00bfc4
# and further style the graph (I kept the line segments gray to avoid confusion
# with the actual lines)
ggplot(kerry, aes(year, n, color=sex)) +
  geom_line() +
  labs(title="Kerry", y="Number of Babies", x="") +
  annotate("text", x=c(1967, 1978), y=2400, label=c("1960", "1971"),
           color=c("#00bfc4", "#f8766d")) +
  annotate("segment", x=c(1960, 1971), xend=c(1963, 1974),
           y=c(2173, 2207), yend=2350, color="#999999") +
  theme_minimal()


#!/usr/bin/Rscript

library(topicmodels)
library(tm)

setwd("<working directory path name>") #set this to the working directory

df <-read.csv("final_dataset.csv", header=TRUE, sep =",", quote = "\"") #read in CSV file, one text per line. Note data is not included in the replication repository because of copyright issues
head(df)
m <- list(Content="text")
head(m)
myReader <- readTabular(mapping=m)
a <- VCorpus(DataframeSource(df), readerControl = list(reader = myReader)) #create corpus containing the text column, on line per document
#corp <- Corpus(x=newspaper_text, readerControl=list(reader=readTabular(mapping=m),language="en"))
a <- Corpus(VectorSource(df$text)) #$text points to the name of the column that contains the text (the name of the column is text)

#summary(a) #should tell you how many documents are in your corpus
#inspect(a[1:2]) #check the content of the first document in the corpus

a <- tm_map(a, content_transformer(tolower), mc.cores=1)
a <- tm_map(a, content_transformer(removePunctuation), mc.cores=1)
a <- tm_map(a, content_transformer(removeNumbers), mc.cores=1)
a <- tm_map(a, removeWords, stopwords("english"), mc.cores=1)

library(SnowballC) # needed for stemming function

a <- tm_map(a, stemDocument, lazy=TRUE)#, language = "english") # converts terms to tokens
a.dtm <- TermDocumentMatrix(a, control=list(minDocFreq = 2)) #convert to term document matrix, words have to be in at least minDocFreq to appear, I set it to 2, but you can change this.

a.dtm.sp <- removeSparseTerms(a.dtm, sparse=0.95) #remove sparse terms
a.dtm.sp.df <- as.data.frame(inspect(a.dtm.sp)) # convert document term matrix to data frame

require(topicmodels)

#Now we produce the model

lda60 <- LDA(a.dtm.sp.t.tdif,60) # generate a LDA model with 60 topics

get_terms(lda60, 20)

gamma <- lda60@gamma # create object containing posterior topic distribution for each document

g <- data.frame(gamma)
g$ID <- seq.int(nrow(g))
df$ID <- seq.int(nrow(df))

df_all <- merge(df, g, on="ID")

#######################
#Put output into various csv files
write.csv(df_all, file = "lda60_docdist.csv")
save.image("lda60.RData")


# I am assuming that you have used FileChange Dir to set the
#   appropriate working directory

tomato - read.table('tomato.txt',as.is=T,header=T)
#  header=T says that the first line contains variable names
#  as.is suppresses conversion of character strings to factors
#     It is not required to read the file.
#     I prefer to do that conversion explicitly when needed
#     Others prefer factors.

print(tomato)
#  print the contents of the data frame
#  If you are working at the console, you can omit the print()

tomato2 - tomato[tomato$group==1,]
#  subset the tomato data frame

print(summary(tomato2))
#  print a short summary of the data set from the console
#  if executing the file, need print(summary(tomato2))

# on-the fly subsetting, equivalent of where in SAS
print(summary(tomato[tomato$group==1,]))

# by group processing
by(tomato,tomato$group,summary)

# below are graphics produced using the base R package
#  the lattice package provides another approach

hist(tomato2$yield)
# a histogram of the tomato2 yield

par(mfrow=c(2,1))
by(tomato$yield,tomato$group,hist)
# histograms of both groups arranged one below the other

par(mfrow=c(1,1))
boxplot(split(tomato$yield,tomato$group))
#  a boxplot with groups side-by-side

plot(as.factor(tomato$group),tomato$yield)
# a dotplot of the observations in each group
# converting the group to a factor provides a nice plot
#   even if group is a character string
#

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/tomato.r


library(cellrangerRkit)
context('Subsampling')

pipestance_path <- system.file("extdata", "test_subsample",
                               package="cellrangerRkit")

set.seed(0)

gbm <- load_cellranger_matrix(pipestance_path)
gbm <- load_molecule_info(gbm)

gbm_ss <- subsample_gene_bc_matrix(gbm, 1000000)
test_that("subsampling returns orig matrix if target depth higher", {
  expect_equal(sum(gbm_ss), sum(gbm))
})

rpc <- get_mean_raw_reads_per_cell(gbm)

gbm_ss <- subsample_gene_bc_matrix(gbm, floor(rpc))
test_that("subsampling returns orig matrix at same depth", {
  expect_equal(sum(gbm_ss), sum(gbm))
})

gbm_ss <- subsample_gene_bc_matrix(gbm, floor(rpc/2))
test_that("subsampling to 1/2", {
  expect_true(abs(round(sum(gbm_ss)/sum(gbm),2) - 0.5) < 0.01)
})

gbm_ss <- subsample_gene_bc_matrix(gbm, floor(rpc/10))
test_that("subsampling to 1/10", {
  expect_true(abs(round(sum(gbm_ss)/sum(gbm),2) - 0.1) < 0.01)
})


<!-- DBSCAN_Martingale.R -->
library(dbscan)
minpts = 50
eps_max = 0.5
T = 5
realizations = 10

### realizations of the DBSCAN-Martingale ###
### requires as input a matrix x with the dataset to be clustered ###

realizations.DBSCAN_martingale = matrix(0, nrow = realizations, ncol = T)

principal.clustering.all = matrix(0, nrow = realizations, ncol = dim(x)[1])

for(r in 1:realizations) {

  number.of.clusters = c()

  ### generate 10 random numbers from the uniform distribution in [0, eps_max] ###
  random.epsilon = runif(T, min=0, max = eps_max)
  random.epsilon = sort(random.epsilon, decreasing = FALSE)

  dbscan.results.all = matrix(0,nrow=dim(x)[1],ncol=T)
  for(j in 1:T) dbscan.results.all[,j] = dbscan(x, random.epsilon[j], minpts)$cluster

  principal.clustering = dbscan.results.all[,1]

  for(j in 1:T) {
    if((principal.clustering%*%dbscan.results.all[,j])[1,1]==0) {
      b = max(principal.clustering)
      for(i in 1:length(dbscan.results.all[,j])) if(dbscan.results.all[i,j]!=0) dbscan.results.all[i,j] = dbscan.results.all[i,j] + b
      principal.clustering = principal.clustering + dbscan.results.all[,j]
    } else {
      h = c()
      clh = c()
      for(i in 1:length(principal.clustering)) {
        h = c(h,0)
        clh = c(clh,0)
      }
      for(i in 1:length(principal.clustering)) if(principal.clustering[i]==0 && dbscan.results.all[i,j] != 0) h[i]=dbscan.results.all[i,j]
      b = max(principal.clustering)
      u = 0
      if(max(h)>0) {
        for(j in 1:max(h)) if(sum(h==j)>=minpts+1) {
          u = u + 1
          clh[which(h==j)]= u
        }
        for(i in 1:length(principal.clustering)) if(clh[i]!=0) clh[i] = clh[i] + b
        principal.clustering = principal.clustering + clh
      }
    }
    number.of.clusters = c(number.of.clusters,max(principal.clustering))
  }

  principal.clustering.all[r,] = principal.clustering

  print(max(principal.clustering))
  print(r)

  realizations.DBSCAN_martingale[r,] = number.of.clusters
}

#realizations.DBSCAN_martingale[,T]

### number of clusters probability ###
table(realizations.DBSCAN_martingale[,T])/realizations

### probability distribution - barplot ###
barplot(table(realizations.DBSCAN_martingale[,T])/realizations, col = "blue", xlab = "clusters", ylab = "probability")


## @param point_matrix a matrix where each row is a n-dimensional point sampled. columns are muscles.
## @return val a list of histogramdatastructures
histogram_all_columns <- function(point_matrix, binwidth=0.02){
	iterator <- 1:ncol(point_matrix)
	lapply(
		iterator,
		function(i){
				hist(point_matrix[,i], breaks=seq(0,1,by=binwidth), plot=FALSE)
			}
	)
}

get_nth_element_from_all_sublists <- function(big_list, n) {
	lapply(big_list, function(sublist) {sublist[n]})
}

#by default, it gets only the length of the first sublist.
get_length_of_sublist <- function(big_list, n=1){
	return(ncol(big_list[[n]]))
}

get_nth_element_of_sublists <- function(list_of_sublists, n){
	lapply(list_of_sublists,
		function(x) {
			x[[n]]
			})
}

get_matrix_of_counts <- function(list_of_histograms_for_a_given_muscle){
	res <- lapply(list_of_histograms_for_a_given_muscle,
		function(x) {
			x$count
		})
	return(do.call(rbind,res)) #convert from list of vectors into matrix (index=>rownum)
}
library(fields)

plot_force_progression_map <- function(histogram_progression_matrix, log_the_values=FALSE){
	#force 0 to be pure black, and next to zero to be bright orange.
	color_ramp <- colorRampPalette(c("#27499b","#2d7cb0","#45afba","#90d0b2", "#eaf2c3", "#ffffff"))(99)
	color_ramp <- c("#000000", color_ramp) #append black as 0 for contrast
	if (log_the_values) {
		histogram_progression_matrix <- log10(histogram_progression_matrix + 1)
	}
	fields::image.plot(histogram_progression_matrix, col= color_ramp, axes=FALSE,xlab="",ylab="", horizontal=TRUE )
	axes(histogram_progression_matrix,0,1)
}

get_unix_time_string_now <- function()
	{return(as.character(as.numeric(Sys.time())))}

density_normalization <- function(list_of_histogram_matrices_count) {
	sample_size = sum(list_of_histogram_matrices_count[1,])
	return(list_of_histogram_matrices_count/sample_size)
}

#for many files in one directory
get_list_of_point_matrices <- function(filename_list, folder_path){
  list_of_point_matrices <- lapply(
   filename_list,
   function(i){
     read.csv(paste0(folder_path,i), header=FALSE)
   })
  return(list_of_point_matrices)
}

# here we are calculating the percent of explained variance for each principal component.
#To this plot, we will add a line that indicates the amount of variance each variable
# would contribute if all contributed the same amount.
# https://tgmstat.wordpress.com/2013/11/28/computing-and-visualizing-pca-in-r/#ref2
pca_muscle_solution_space <- function(filename, folder_path){
	dataset <- read.csv(paste0(folder_path,filename), header=FALSE)
	# log transform
	require(caret)
	number_of_muscles = length(dataset[1,])
	dataset.pca <- prcomp(dataset, retx=TRUE, center=TRUE, scale.=TRUE)
	sd <- dataset.pca$sdev
	loadings <- dataset.pca$rotation
	rownames(loadings) <- colnames(dataset)
	scores <- dataset.pca$x
	var <- sd^2
	var.percent <- var/sum(var) * 100
	dev.new()
	barplot(var.percent, xlab="PC", ylab="Percent Variance", main=filename, names.arg=1:length(var.percent), las=1, ylim=c(0,max(var.percent)), col="gray")
	abline(h=1/ncol(dataset)*100, col="red")
	print(loadings)
}

plot_histogram_matrices <- function(list_of_histogram_matrices){
	require(rgl)
	open3d()
	mat <- t(matrix(1:8,ncol=4))
	layout3d(mat, sharedMouse = TRUE)
	for (i in 1:7) {
	  next3d()
	  plot_histogram_matrix_3d(list_of_histogram_matrices[[i]], 100)
	  next3d()

	}
	highlevel(integer())
}

plot_histogram_matrices_same_fig <- function(list_of_histogram_matrices){
	require(rgl)
	open3d()
	mat <- t(matrix(1:8,ncol=4))
	layout3d(mat, sharedMouse = TRUE)
	for (i in 1:7) {
	  plot_histogram_matrix_3d(list_of_histogram_matrices[[i]], 100)
	}
	highlevel(integer())
}


BNP_DIR = "/Users/jtobin/projects/bnp"
CRP_SRC = paste(BNP_DIR, "chinese-restaurant-process/src/crp.r", sep = "/")

require(dplyr)
source(CRP_SRC)

frequencies = function(restaurant) {
  summarised =
    restaurant %>%
    group_by(table) %>%
    summarise(n = sum(customers)) %>%
    mutate(freq = n / sum(n))
  summarised$freq
  }

# FIXME (jtobin): this is not correct
crf = function(n, a, a1) {
  g0 = frequencies(crp(n, a))
  h0 = function() { sample(g0, size = 1) }
  g1 = frequencies(crp(n, a1))
  g2 = frequencies(crp(n, a1))
  list(g1 * g0, g2 * g0)
  }


rm(list=ls())
args <- commandArgs(trailingOnly = TRUE)	#get the arguments from the command line
if (length(args) < 5) {
	stop('Your input arguments is wrong!\n
		args1:\t co_as file\n
		args2:\t test col: 1,2,3\n
		args3:\t ctrl col: 4,5,6\n
		args4:\t out file\n
		args5:\t out directory\n'
	)
} else {
	infile <- args[1]
	test <- args[2]
	ctrl <- args[3]
	outfile <- args[4]
	outdir <- args[5]
}

test <- strsplit(test,",")[[1]]
ctrl <- strsplit(ctrl,",")[[1]]

# print(as.numeric(test)[2])

setwd(outdir)
Data <- read.delim(file=infile,header=T,stringsAsFactors=FALSE)
Pvalue <-c()
Tvalue <-c()
m <-c()
n <-c()

# print(!is.na(as.numeric(Data[2,13])))

for (i in 1:nrow(Data)) {
  x <-c()
  y <-c()
  xnum <- 0
  ynum <- 0
  for (j in as.numeric(test)) {
    if(!is.na(as.numeric(Data[i,j]))){
      x <- c(x,as.numeric(Data[i,j]))
      xnum <- xnum+1
    }
  }
  for (j in as.numeric(ctrl)) {
    if(!is.na(as.numeric(Data[i,j]))){
      y <- c(y,as.numeric(Data[i,j]))
      ynum <- ynum+1
    }
  }
#  m<-c(m,c(x))
#  n<-c(n,c(y))

  xres<-summary(x)
  yres<-summary(y)

  if(!is.null(x) && !is.null(y) && xnum>1 && ynum>1 && (xres["Min."]!=xres["Max."] || yres["Min."]!=yres["Max."])){
  # if(!is.null(x) && !is.null(y) && xnum>1 && ynum>1 ){
    result <- t.test(x,y,var.equal = TRUE)
    Pvalue <- c(Pvalue,result$p.value)
    Tvalue <- c(Tvalue,result$statistic)
  }else{
    Pvalue <- c(Pvalue,1)
    Tvalue <- c(Tvalue,0)
  }
}

FDR <- p.adjust(Pvalue,method = "BH")

Data <- cbind(Data,Pvalue)
Data <- cbind(Data,Tvalue)
Data <- cbind(Data,FDR)
head(Data)
write.table(Data,file=outfile,row.names=F,append=F,quote=F,sep='\t')


#' Retrieve a U.S. county composite map, optionally with a projection
#'
#' The \code{proj} parameter is intende to simplify usage for those using base
#' plotting. If anything but \code{longlat} is specified the composite map
#' will be pre-projected to those
#'
#' This is what's in the SPDF \code{@data} slot:
#'
#' \preformatted{
#' Observations: 3,143
#' Variables: 9
#' $ fips        (chr) "01001", "01009", "01017", "01021", "01033", "01045", "01051",...
#' $ state_fips  (chr) "01", "01", "01", "01", "01", "01", "01", "01", "01", "01", "0...
#' $ county_fips (chr) "001", "009", "017", "021", "033", "045", "051", "065", "079",...
#' $ name        (chr) "Autauga", "Blount", "Chambers", "Chilton", "Colbert", "Dale",...
#' $ lsad        (chr) "County", "County", "County", "County", "County", "County", "C...
#' $ census_area (dbl) 594.436, 644.776, 596.531, 692.854, 592.619, 561.150, 618.485,...
#' $ state       (chr) "Alabama", "Alabama", "Alabama", "Alabama", "Alabama", "Alabam...
#' $ iso_3166_2  (chr) "AL", "AL", "AL", "AL", "AL", "AL", "AL", "AL", "AL", "AL", "A...
#' $ population  (dbl) 54590, 57466, 34228, 43611, 54451, 50129, 79330, 15750, 34148,...
#' }
#'
#' A reference GeoJSON file isprovided in the following location (i.e. you can use
#' it in any mapping program):
#'
#' \preformatted{
#' system.file("extdata/composite_us_counties.geojson.gz", package="albersusa")
#' }
#'
#' @param proj if anything but \code{longlat} is specified, the shapefile will
#'        be pre-projected before being returned
#' @export
#' @examples
#' library(sp)
#'
#' plot(counties_composite())
#' plot(counties_composite("laea"))
counties_composite <- function(proj=c("longlat", "laea", "lcc", "eqdc", "aeqd")) {

  # us <- readOGR(system.file("extdata/composite_us_counties.geojson", package="albersusa"),
  #               "OGRGeoJSON",
  #               stringsAsFactors=FALSE,
  #               verbose=FALSE)

  cty <- readRDS(system.file("extdata/counties.rda", package="albersusa"))
  # saveRDS(cty, "inst/extdata/counties.rda", version = 2)

  proj <- match.arg(proj, c("longlat", "laea", "lcc", "eqdc", "aeqd"))

  if (proj != "longlat") {

    proj <- switch(proj,
                   laea=us_laea_proj,
                   lcc=us_lcc_proj,
                   eqdc=us_eqdc_proj,
                   aeqd=us_aeqd_proj)

    cty <- sp::spTransform(cty, sp::CRS(proj))

  }

  cty

}


get_new_data <- TRUE

if (get_new_data) {

  myfilters <- matrix(data=c("CSV file (*.csv)", "*.csv", "All files (*.*)", "*.*"), nrow=2, ncol=2,
                      byrow=TRUE)

  val_filename <- choose.files(default="SWB_daily_MEAN_values.csv",
                               caption="Choose the daily values report file you wish to plot",
                               multi=FALSE,
                               filters=myfilters,
                               index=1)

  val_filename_base <- choose.files(default="SWB_daily_MEAN_values.csv",
                                    caption="Choose the daily values report file you wish to compare against",
                                    multi=FALSE,
                                    filters=myfilters,
                                    index=1)

  setwd( dirname(val_filename) )

  titleTxt <- winDialogString(message="Enter the title you wish to use in the plots",
                              default="SWB daily values comparisons")
  cex.main=1.0

  v_in<-read.csv(val_filename, header=TRUE, as.is=TRUE, row.names=NULL, skip=2)
  v_base<-read.csv(val_filename_base, header=TRUE, as.is=TRUE, row.names=NULL, skip=2)

  v_in$Date<-as.Date(v_in$Date,format="%m/%d/%Y")
  v_in$Year <- format(v_in$Date, format="%Y")

  v_base$Date<-as.Date(v_base$Date,format="%m/%d/%Y")
  v_base$Year <- format(v_base$Date, format="%Y")

  # ensure vector lengths are the same, assuming the date ranges are comparable
  v_base <- v_base[v_base$Date %in% v_in$Date, ]

}

pdf(file = "SWB_mass_balance_comparison_plot.pdf",width = 11, height = 8.5)
layout(matrix(c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16), nrow=4 , ncol=4, byrow = TRUE))

for (i in sort(unique(v_in$Year))) {

  vb <- subset(v_in,v_in$Year==i)
  vbb <- subset(v_base,v_base$Year==i)

  par(mar = c(0,0,2,0))
  plot(1,1,type = "n",frame.plot = FALSE,axes = FALSE)
  u <- par("usr")
  text(1,u[4],labels = paste(titleTxt, ": ",i, sep=""),col = "blue",pos = 1, cex=2)

  for (j in 2:ncol(vb)) {

    y<-vb[ ,j ]

    if ( any(colnames(vbb)==colnames(vb)[j] ) ) {
      x<-as.vector( unlist( vbb[which(colnames(vbb)==colnames(vb)[j] ) ]  ) )
      title_txt <- colnames(vb)[j]

      par(mar=c(3,6,3,3))
      plot(y~x, xlab="",ylab="", main=title_txt,col="blue")
      abline(b=1,a=0,col="red")
      box(lwd=1.5)

    }

  }

}

dev.off()


library(tidyverse)
library(dplyr)
library(readr)
library(ggplot2)
library(ggthemes)

cf_state <- read_csv("DONT MERGE/State_Campaign_Finance_Data.csv")
cf_state <- as_tibble(cf_state)

cf_state <- select(cf_state, -c(1,2,3,5,6,8)) #delete unnecessary columns

cf_state$contribution_amount <- "Total_$"/100000

cf_state <- cf_state %>% mutate(contribution_amount = `Total_$`/1000000)
#Write campaign contributions in $millions

cf_state <- cf_state %>% mutate(cf_state, contrib_senate = case_when(
  `General_Office`== "State Senate" ~ `contribution_amount`
)) #gen new var which contains contributions to State Senate Only

cf_state <- cf_state %>% mutate(cf_state, contrib_house = case_when(
  `General_Office`== "State House/Assembly" ~ `contribution_amount`
)) #gen new var which contains contributions to State House/Assembly Only

cf_state <- cf_state %>%
  filter(cf_state, Election_Year = 1999 & Election_Year = 2001) %>%
  select(cf_state, c(1,2,3,4,5,6,7,8,9))

cf_state <- cf_state[!(cf_state$Election_Year==1999 | cf_state$Election_Year==2001
                     | cf_state$Election_Year==2003 | cf_state$Election_Year==2005
                     | cf_state$Election_Year==2007 | cf_state$Election_Year==2009
                     | cf_state$Election_Year==2011 | cf_state$Election_Year==2013
                     | cf_state$Election_Year==2015),]
#drop non-election years

ggplot(data=cf_state, aes(x=Election_Year, y=contrib_house)) +
  geom_bar(stat="identity") + theme_minimal() +
  labs(y = "Campaign Contributions (Million USD)" , x = "Election Years") +
  ggtitle("Campaign Contributions to \n State House/Assembly Candidates \n by Year Totals (1998-2014)")

ggsave("PS6a_Chaudhry.png")

ggplot(data=cf_state, aes(x=Election_Jurisdiction, y=contrib_house)) +
  geom_bar(stat="identity") + theme_minimal() +
  labs(y = "Campaign Contributions (Million USD)" , x = "State") +
  ggtitle("Campaign Contributions \n to State House/Assembly Candidates \n by States Totals (1998-2014)") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, size = 6))

ggsave("PS6b_Chaudhry.png")

ggplot(data=cf_state,aes(x=Election_Year, y=contrib_house)) +
  geom_jitter(aes(color=(Election_Jurisdiction=="CA"))) + theme_minimal() +
  labs(y = "Campaign Contributions (Million USD)" , x = "Election Years") +
  ggtitle("Campaign Contributions to \n State House/Assembly Candidates \n by CA vs Other Stats")

ggsave("PS6c_Chaudhry.png")


all.prop.point.estimate <- function (u1,u2) {
	###Confidence interval of LogP
	for ( coef.i in 1:nrow(prop_coef) ){
        	prop.name <- rownames(prop_coef)[coef.i]
        	logk.conf.mat <- paste(prop.name, "_conf.mat",sep="")
        	for (ramda.i in 1:No.ramda){
                	eval(parse(text=paste( logk.conf.mat," <<- ", ramda.mat.box[coef.i,1],"*u1 + ",ramda.mat.box[coef.i,2],"*u2 + ",ramda.mat.box[coef.i,3], sep="" )))
                	eval(parse(text=paste( prop.name, " <<- ", ramda.me.box[coef.i,1],"*median(u1) + ",ramda.me.box[coef.i,2],"*median(u2) + ",ramda.me.box[coef.i,3], sep="" )))
                	if (all( is.nan(logk.conf.mat) )==F){
                        	eval(parse(text=paste( prop.name, ".upper <<- quantile(",logk.conf.mat,",c(0.975) )",sep="")))
                        	eval(parse(text=paste( prop.name, ".lower <<- quantile(",logk.conf.mat,",c(0.025) )",sep="")))
                	} else {
                        	eval(parse(text=paste( prop.name, ".upper <<- NaN",sep="")))
                        	eval(parse(text=paste( prop.name, ".lower <<- NaN",sep="")))
                	}
        	}
	}
	cat( "Calculated:" )
	cat( "logP.upper "," logP.lower"," logP_conf.mat", sep="")
	writeLines(sep="\n","")

	cat("Calculated:" )
	cat( rownames(prop_coef) )
	writeLines(sep="\n","")
}


inputfile="pahtest2-bintree-serializer-postprocess-PAH(0.006s).csv"

psl<-read.csv(inputfile, header=TRUE)
# 7th colunm is mass of individual PAH (u)
c<-psl[7]
# remove the NA form c before calculation
c<-c[!is.na(c)]
# calculate the average size of the ten largest particle.
mea<-mean(c)

#write.table(mea,"pahtest2/stats.csv",na = "",append=FALSE,row.names = FALSE,quote = FALSE,sep = ",",col.names="median")
write.table(mea,"stats.csv",na = "",append=FALSE,row.names = FALSE,quote = FALSE,sep = ",",col.names="median")


# Plots to show sensitivity analysis of inversion with varying levels of noise
# using a convex hull as presented in:
#
# Clewley, D. 2012. Retreival of Forest Structure and Biomass From Radar Data using
# Backscatter Modelling and Inversion. PhD Thesis. Aberystwyth University.
#
# The plots are skewed towards outliers but provide a simple way of identifying a bias in inversion results.

library(spatstat)

# Read in results for different levels of noise
# Each file contains input (true) and inverted values.
inFile0_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults0.csv"))
inFile1_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults1.csv"))
inFile5_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults5.csv"))
inFile10_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults10.csv"))
inFile15_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults15.csv"))
inFile20_2dCG = as.data.frame(read.csv("bgl_2dCGtest_InvResults20.csv"))

pdf(file="bgl_2DataCG.pdf", width=13, height=7)
layout(matrix(1:2, nrow=1))
par(mar=c(6, 6, 0.5, 0.5))
par(font.lab=2)
par(cex.axis=1.5)
par(cex.lab=1.5)
legendText = c("0% (data points)", "1%", "5%", "10%", "15%", "20%" )
legendSymb = c(21,"","","","","")
legendCol = c(rgb(0,1,0,0),rgb(0,1,0,1), rgb(0,0.5,0,1),rgb(1,1,0,1),rgb(1,0.7,0,1),rgb(1,0,0,1))
legendColBg = c(rgb(0,1,0,0),rgb(0,1,0,0.5), rgb(0,0.5,0,0.5),rgb(1,1,0,0.5),rgb(1,0.7,0,0.5),rgb(1,0,0,0.5))
pchCol = c("black",rgb(0,0,0,0),rgb(0,0,0,0),rgb(0,0,0,0),rgb(0,0,0,0),rgb(0,0,0,0))

# Canopy depth
plot(inFile20_2dCG$realCDepth, inFile20_2dCG$eCDepth, type="n", xlab="Canopy Depth (m)", ylab="Estimated Canopy Depth (m)", xlim=c(0,3), ylim=c(0,3))

plot(convexhull.xy(cbind(inFile20_2dCG$realCDepth, inFile20_2dCG$eCDepth)), col=rgb(1,0,0,0.1), border=rgb(1,0,0,1),  add=TRUE)
plot(convexhull.xy(cbind(inFile15_2dCG$realCDepth, inFile15_2dCG$eCDepth)), col=rgb(1,0.7,0,0.1), border=rgb(1,0.7,0,1), add=TRUE)
plot(convexhull.xy(cbind(inFile10_2dCG$realCDepth, inFile10_2dCG$eCDepth)), col=rgb(1,1,0,0.1), border=rgb(1,1,0,1),  add=TRUE)
plot(convexhull.xy(cbind(inFile5_2dCG$realCDepth, inFile5_2dCG$eCDepth)), col=rgb(0,0.5,0,0.1), border=rgb(0,0.5,0,1), add=TRUE)
plot(convexhull.xy(cbind(inFile1_2dCG$realCDepth, inFile1_2dCG$eCDepth)), col=rgb(0,1,0,0.1), border=rgb(0,1,0,1), add=TRUE)
points(inFile0_2dCG$realCDepth, inFile0_2dCG$eCDepth, pch=21)
lines(seq(0,10),seq(0,10), lty=2)
legend("topleft", legendText, pch=21, col=pchCol, border=legendCol, fill=legendColBg, bty="n", cex=1.5)

# Canopy Density
plot(inFile20_2dCG$realCDens, inFile20_2dCG$eCDens, type="n", xlab=expression(bold(paste("Canopy Density (crowns ",m^-2,")"))), ylab=expression(bold(paste("Estimated Stem Density (stems ",m^-2,")"))), xlim=c(0,2), ylim=c(0,2))

plot(convexhull.xy(cbind(inFile20_2dCG$realCDens, inFile20_2dCG$eCDens)), col=rgb(1,0,0,0.1), border=rgb(1,0,0,1),  add=TRUE)
plot(convexhull.xy(cbind(inFile15_2dCG$realCDens, inFile15_2dCG$eCDens)), col=rgb(1,0.7,0,0.1), border=rgb(1,0.7,0,1), add=TRUE)
plot(convexhull.xy(cbind(inFile10_2dCG$realCDens, inFile10_2dCG$eCDens)), col=rgb(1,1,0,0.1), border=rgb(1,1,0,1),  add=TRUE)
plot(convexhull.xy(cbind(inFile5_2dCG$realCDens, inFile5_2dCG$eCDens)), col=rgb(0,0.5,0,0.1), border=rgb(0,0.5,0,1), add=TRUE)
plot(convexhull.xy(cbind(inFile1_2dCG$realCDens, inFile1_2dCG$eCDens)), col=rgb(0,1,0,0.1), border=rgb(0,1,0,1), add=TRUE)
points(inFile0_2dCG$realCDens, inFile0_2dCG$eCDens, pch=21)
lines(seq(0,2,by=0.1),seq(0,2,by=0.1), lty=2)

dev.off()


table(replicate(1000, runs.test(factor(sign(one.ts())))$p.value < 0.05))


year.assessment = 2019

p = bio.snowcrab::load.environment( year.assessment=year.assessment )

# 11 hrs with these settings
ncpus = parallel::detectCores()
stmv_clusters = list(
  scale=rep("localhost", ncpus),
  interpolate=rep("localhost", ncpus)
)

p = snowcrab_stmv(
  p=p,
  project_class="stmv",
  stmv_variables=list(Y="snowcrab.large.males_abundance"),
  selection=list(
    type = "biomass",
    biologicals=list(
      sex=0, # male
      mat=1, # do not use maturity status in groundfish data as it is suspect ..
      spec_bio=bio.taxonomy::taxonomy.recode( from="spec", to="parsimonious", tolookup=2526 ),
      len= c( 95, 200 )/10, #  mm -> cm ; aegis_db in cm
      ranged_data="len"
    ),
    survey=list(
      data.source = c("snowcrab"),
      yr = p$yrs      # time frame for comparison specified above
    )
  ),
  DATA = 'snowcrab_stmv( p=p, DS="stmv_inputs" )',
  stmv_global_modelengine ="gam",
  stmv_global_family = gaussian(link="log"),
  stmv_local_modelengine = "twostep",
  stmv_twostep_time = "gam",
  stmv_twostep_space = "fft",
  stmv_fft_filter="matern",  #  matern, krige (very slow), lowpass, lowpass_matern
  stmv_gam_optimizer = c("outer", "bfgs") ,
  stmv_distance_statsgrid = 3, # resolution (km) of data aggregation (i.e. generation of the ** statistics ** ),
  stmv_distance_scale = c( 25, 35, 45 ), #likely must be over 30km, so 50 +/- 20km, should likely match the setting in ~ line 256
  stmv_clusters = stmv_clusters
)

if (0) {

  p$stmv_global_modelformula = formula( paste(
    ' snowcrab.large.males_abundance',
    ' ~ s( t, k=3, bs="ts") + s( tsd, k=3, bs="ts") + s( degreedays, k=3, bs="ts") ',
    ' + s( log(z), k=3, bs="ts") + s( log(dZ), k=3, bs="ts") + s( log(ddZ), k=3, bs="ts") ',
    ' + s( substrate.grainsize, k=3, bs="ts")  ',
    ' + s(pca1, bs="ts") + s(pca2, bs="ts")  '
  ))

  p$stmv_global_modelformula = formula( paste(
    ' snowcrab.large.males_abundance',
    ' ~ s( t, k = 4, bs="ts") + s( tmax, k = 4, bs="ts") + s( degreedays, k = 4, bs="ts") ',
    ' + s( log(z), k=4, bs="ts") + s( log(dZ), k=4, bs="ts") + s( log(ddZ), k=4, bs="ts") ',
    ' + s( substrate.grainsize, k=4, bs="ts") + s(pca1, k=4, bs="ts") + s(pca2, k=4, bs="ts")   '
  ))

  p = stmv_variablelist(p=p)  # decompose into covariates, etc

  o = snowcrab_stmv(p=p, DS="input_data" )  # create fields for

  global_model = gam(
    formula=p$stmv_global_modelformula,
    family=p$stmv_global_family,
    data = o,
    weights=o$wt,
    optimizer= p$stmv_gam_optimizer,
    na.action="na.omit"
  )

}

#Run the following line if you want to use maptools rather than GADMTools for mapping coastline
# p$DATA = 'snowcrab_stmv( p=p, DS="stmv_inputs", coastline_source="mapdata.coastPolygon" )'

# range( INP$snowcrab.large.males_abundance )
# [1]   14.3 6675.0

# o = snowcrab_stmv(p=p, DS="stmv_inputs" )  # create fields for

#--------------------------------------------------------------
# Run the process
#--------------------------------------------------------------

stmv( p=p, runmode=c("globalmodel", "interpolate" )  ) #  for a clean start

snowcrab_stmv( p=p, DS="predictions.redo" ) # warp predictions to other grids (if any)
snowcrab_stmv( p=p, DS="stmv.stats.redo" ) # warp stats to other grids (if any)
snowcrab_stmv( p=p, DS="complete.redo" )
snowcrab_stmv( p=p, DS="baseline.redo" )
snowcrab_stmv( p=p, DS="map.all" )

global_model = stmv_global_model( p=p, DS="global_model")
summary( global_model )

par(mar=c(1,1,1,1)) #change plot margins for Rstudio
plot(global_model)

# 2018 results
# Family: gaussian
# Link function: log
#
# Formula:
# snowcrab.large.males_abundance ~ s(t, k=3, bs="ts") + s(tsd,
#     k=3, bs="ts") + s(tmax, k=3, bs="ts") + s(degreedays,
#     k=3, bs="ts") + s(log(z), k=3, bs="ts") + s(log(dZ),
#     k=3, bs="ts") + s(log(ddZ), k=3, bs="ts") + s(substrate.grainsize,
#     k=3, bs="ts") + s(pca1, k=3, bs="ts") + s(pca2, k=3,
#     bs="ts")
#
# Parametric coefficients:
#             Estimate Std. Error t value Pr(>|t|)
# (Intercept)   6.7468     0.0204     330   <2e-16
#
# Approximate significance of smooth terms:
#                              edf Ref.df     F p-value
# s(t)                        1.91      2  73.0 < 2e-16
# s(tsd)                      2.00      2  14.0 8.3e-07
# s(tmax)                     1.91      2  11.7 1.4e-06
# s(degreedays)               1.36      2  45.4 < 2e-16
# s(log(z))                   1.91      2 174.7 < 2e-16
# s(log(dZ))                  1.93      2  20.9 3.8e-10
# s(log(ddZ))                 1.95      2  61.5 < 2e-16
# s(substrate.grainsize) 1.99      2  51.0 < 2e-16
# s(pca1)                     2.00      2 100.4 < 2e-16
# s(pca2)                     1.94      2  95.3 < 2e-16
#
# R-sq.(adj) =  0.232   Deviance explained = 23.4%
# GCV = 6198.2  Scale est. = 6182      n = 7640

# -------------------------------------------------------------------------------------
# STEP TWO commercial presence /absence
#--------------------------------------------------------------------------------------

# presence-absence
# this takes about 40 hrs ... and 5-6 GB /process
# year.assessment = 2018

p = bio.snowcrab::load.environment( year.assessment=year.assessment )
ncpus = parallel::detectCores()

p = bio.snowcrab::snowcrab_parameters(
  p=p,
  project_class="stmv",
  stmv_variables=list(Y="snowcrab.large.males_presence_absence"),
  selection=list(
    type = "presence_absence",
    biologicals = list(
      sex=0, # male
      mat=1, # do not use maturity status in groundfish data as it is suspect ..
      spec_bio=bio.taxonomy::taxonomy.recode( from="spec", to="parsimonious", tolookup=2526 ),
      len= c( 95, 200 )/10, #  mm -> cm ; aegis_db in cm
      ranged_data="len"
    ),
    survey=list(
      data.source = c("snowcrab", "groundfish"),  # add groundfish data too
      drop.unreliable.zeros.groundfish.data=TRUE, # esp from 1970 to 1999 measurement of invertebrates was sporatic .. zero-values are dropped as they are unreliable
      yr = p$yrs      # time frame for comparison specified above
    )
  ),
  DATA = 'snowcrab_stmv( p=p, DS="stmv_inputs" )',
  aegis_project_datasources = c("speciescomposition" ), # c("speciescomposition", "speciesarea", "sizespectrum", "condition", "metabolism", "biochem")
  stmv_global_family = binomial( link="logit" ),
  stmv_global_modelengine ="gam",
  stmv_local_modelengine = "twostep",
  stmv_twostep_time = "gam",
  stmv_twostep_space = "fft",
  stmv_fft_filter="matern",  #  matern, krige (very slow), lowpass, lowpass_matern
  stmv_gam_optimizer=c("outer", "bfgs") ,
  stmv_distance_statsgrid = 3, # resolution (km) of data aggregation (i.e. generation of the ** statistics ** ),
  stmv_distance_scale = c( 25, 35, 45 ), #likely must be over 30km, so 50 +/- 20km, should likely match the setting in ~ line 256
  stmv_clusters = list( scale=rep("localhost", ncpus), interpolate=rep("localhost", ncpus) )
)

if (0) {

  p$stmv_global_modelformula = formula( paste(
    ' snowcrab.large.males_abundance',
    ' ~ s( t, k=3, bs="ts") + s( tsd, k=3, bs="ts") + s( degreedays, k=3, bs="ts") ',
    ' + s( t, tsd, degreedays, bs="ts")  ',
    ' + s( log(z), k=3, bs="ts") + s( log(dZ), k=3, bs="ts") + s( log(ddZ), k=3, bs="ts") ',
    ' + s( log(z), log(dZ), log(ddZ),  bs="ts") ',
    ' + s( substrate.grainsize, k=3, bs="ts")  ',
    ' + s(pca1, k=3, bs="ts") + s(pca2, k=3, bs="ts") + s(pca1, pca2, k=8, bs="ts")     '
  ))

  p$stmv_global_modelformula = formula( paste(
    ' snowcrab.large.males_abundance',
    ' ~ s( t, k = 4, bs="ts") + s( tmax, k = 4, bs="ts") + s( degreedays, k = 4, bs="ts") ',
    ' + s( log(z), k=4, bs="ts") + s( log(dZ), k=4, bs="ts") + s( log(ddZ), k=4, bs="ts") ',
    ' + s( substrate.grainsize, k=4, bs="ts") + s(pca1, k=4, bs="ts") + s(pca2, k=4, bs="ts")   '
  ))

  o = snowcrab_stmv(p=p, DS="input_data" )  # create fields for

  global_model = gam(
    formula=p$stmv_global_modelformula,
    family=p$stmv_global_family,
    data = o,
    weights=o$wt,
    optimizer= p$stmv_gam_optimizer,
    na.action="na.omit"
  )

}

# p$DATA = 'snowcrab_stmv( p=p, DS="stmv_inputs", coastline_source="mapdata.coastPolygon" )'
# o = snowcrab_stmv(p=p, DS="stmv_inputs" )  # create fields for

stmv( p=p, runmode=c("globalmodel", "interpolate" ) ) # no global_model and force a clean restart

snowcrab_stmv( p=p, DS="predictions.redo" ) # warp predictions to other grids
snowcrab_stmv( p=p, DS="stmv.stats.redo" ) # warp stats to other grids
snowcrab_stmv( p=p, DS="complete.redo" )
snowcrab_stmv( p=p, DS="baseline.redo" )
snowcrab_stmv( p=p, DS="map.all" )

global_model = stmv_global_model( p=p, DS="global_model")
summary( global_model )

par(mar=c(1,1,1,1)) #change plot margins for Rstudio
plot(global_model, all.terms=TRUE, trans=bio.snowcrab::inverse.logit, seWithMean=TRUE, jit=TRUE, rug=TRUE )

# Family: binomial
# Link function: logit
#
# Formula:
# snowcrab.large.males_presence_absence ~ s(t, k=3, bs="ts") +
#     s(tsd, k=3, bs="ts") + s(tmax, k=3, bs="ts") + s(degreedays,
#     k=3, bs="ts") + s(log(z), k=3, bs="ts") + s(log(dZ),
#     k=3, bs="ts") + s(log(ddZ), k=3, bs="ts") + s(substrate.grainsize,
#     k=3, bs="ts") + s(pca1, k=3, bs="ts") + s(pca2, k=3,
#     bs="ts")
#
# Parametric coefficients:
#             Estimate Std. Error z value Pr(>|z|)
# (Intercept)   0.0302     0.0349    0.87     0.39
#
# Approximate significance of smooth terms:
#                              edf Ref.df Chi.sq p-value
# s(t)                        1.99      2  336.7 < 2e-16
# s(tsd)                      2.00      2   35.3 2.0e-08
# s(tmax)                     1.98      2   59.9 7.0e-14
# s(degreedays)               1.99      2  188.4 < 2e-16
# s(log(z))                   2.00      2 1282.7 < 2e-16
# s(log(dZ))                  1.99      2   68.7 9.1e-16
# s(log(ddZ))                 1.98      2  224.4 < 2e-16
# s(substrate.grainsize) 1.98      2  394.4 < 2e-16
# s(pca1)                     2.00      2  932.6 < 2e-16
# s(pca2)                     2.00      2 1291.8 < 2e-16
#
# R-sq.(adj) =   0.62   Deviance explained = 56.2%
# UBRE = -0.58807  Scale est. = 1         n = 36031
#

# collect all predictions into a single file and return:
# year.assessment=2017

#------------------------------------------------------------------------------
# STEP THREE- Predict biomass by weighting +/- with probabilities
#------------------------------------------------------------------------------

p = bio.snowcrab::load.environment( year.assessment=year.assessment )
p = snowcrab_stmv(
  p=p,
  project_class="stmv",
  stmv_variables = list(Y="snowcrab.large.males_abundance"),
  selection=list(
    type = "biomass",
    biologicals=list(
      sex=0, # male
      mat=1, # do not use maturity status in groundfish data as it is suspect ..
      spec_bio=bio.taxonomy::taxonomy.recode( from="spec", to="parsimonious", tolookup=2526 ),
      len= c( 95, 200 )/10, #  mm -> cm ; aegis_db in cm
      ranged_data="len"
    ),
    survey=list(
      data.source = c("snowcrab"),
      yr = p$yrs,      # time frame for comparison specified above
      drop.unreliable.zeros.groundfish.data=TRUE # esp from 1970 to 1999 measurement of invertebrates was sporatic .. zero-values are dropped as they are unreliable
    )
  )
)

interpolation.db( DS="fishable.biomass.redo", p=p  ) # combine habitat and abundance info and map
K = interpolation.db( DS="fishable.biomass.timeseries", p=p  )
if (0){
  str(K)
  table.view( K )
  plot( total ~ yr, K[K$region=="cfanorth", ], type="b")
  plot( total ~ yr, K[K$region=="cfasouth", ], type="b")
  plot( total ~ yr, K[K$region=="cfa4x", ], type="b")
}

interpolation.db( DS="fishable.biomass.map", p=p  )

figure.timeseries.snowcrab.habitat(p=p) # /bio.data/bio.snowcrab/assessments/2016/timeseries/interpolated/snowcrab.habitat.sa.png

figure.timeseries.snowcrab.habitat.temperatures(p=p) # /bio.data/bio.snowcrab/assessments/2016/timeseries/interpolated/mean.bottom.temp.snowcrab.habitat.png

### --------- prediction success:
set = snowcrab_stmv(p=p, DS="input_data" )

S = set[ , c("plon", "plat") ]

ii = array_map( "xy->1", S, gridparams=p$gridparams )
bs = bathymetry_db(p=p, DS="baseline")
bb = array_map( "xy->1", bs, gridparams=p$gridparams )
im = match(  ii, bb )
it = match( set$yr, p$yrs )

bm = interpolation.db( DS="fishable.biomass", p=p  )
spred = bm$m[cbind(im, it)]  # approximate match (ignoring seasonality)

summary ( lm(log(spred)~log(snowcrab.large.males_abundance), data=set, na.actio="na.omit" ) )
plot(log(spred)~log(snowcrab.large.males_abundance), data=set )
cor(log(spred),log(set$snowcrab.large.males_abundance), use="complete.obs")

# Call:
# lm(formula = log(spred) ~ log(snowcrab.large.males_abundance),
#     data = set, na.action = "na.omit")
#
# Residuals:
#     Min      1Q  Median      3Q     Max
# -2.3039 -0.5507  0.0589  0.6056  2.1379
#
# Coefficients:
#                                     Estimate Std. Error t value Pr(>|t|)
# (Intercept)                          5.17806    0.03824   135.4   <2e-16
# log(snowcrab.large.males_abundance)  0.19035    0.00599    31.8   <2e-16
#
# Residual standard error: 0.795 on 5030 degrees of freedom
#   (2223 observations deleted due to missingness)
# Multiple R-squared:  0.167,	Adjusted R-squared:  0.167
# F-statistic: 1.01e+03 on 1 and 5030 DF,  p-value: <2e-16
#
# R> plot(log(spred)~log(snowcrab.large.males_abundance), data=set )
# R> cor(log(spred),log(set$snowcrab.large.males_abundance), use="complete.obs")
# [1]  0.4269

# determine presence absence(Y) and weighting(wt)
#      set$weekno = floor(set$julian / 365 * 52) + 1
#      set$dyear = floor(set$julian / 365 ) + 1

## END

  # figures and tables related to fishery indices

#Pick whichever year reference below is correct (most often year.assessment...-1)
if (!exists("year.assessment")) {
    year.assessment=lubridate::year(Sys.Date())
    year.assessment=lubridate::year(Sys.Date()) - 1
  }
  p = bio.snowcrab::load.environment( year.assessment=year.assessment )

# ------------------------------------------
# Time-series: all interpolated data estimated from interpolated analysis
# BZ R0.mass is likely the only variable required

  figure.interpolated.results( p, outdir=file.path( p$annual.results, "timeseries",  "interpolated" ), alt.zero.y=T )

# ------------------------------------------
# Time-series: immature male numerical abundance estimates from interpolated analysis (broken down by instar)
  figure.immature.male( p, outdir=file.path( p$annual.results, "timeseries", "interpolated" ) )

 # ------------------------------------------
# Time-series: immature male skip-moulter numerical abundance estimates from interpolated analysis (broken down by instar)
  figure.immature.skipmoulter.male( p, outdir=file.path( p$annual.results,  "timeseries", "interpolated" ) )

# ------------------------------------------
# Time-series: mature CC12 male numerical abundance estimates from interpolated analysis (broken down by instar)
  figure.mature.CC12.male( p, outdir=file.path( p$annual.results,  "timeseries", "interpolated" ) )

# ------------------------------------------
# Time-series: mature CC34 male numerical abundance estimates from interpolated analysis (broken down by instar)
  figure.mature.CC34.male( p, outdir=file.path( p$annual.results, "timeseries", "interpolated" ) )

# ------------------------------------------
# Time-series: mature CC5 male numerical abundance estimates from interpolated analysis (broken down by instar)
  figure.mature.CC5.male( p, outdir=file.path( p$annual.results, "timeseries",  "interpolated" ) )

# ------------------------------------------
# Time-series: Exploitation rate
  figure.exploitation.rate( p, outdir=file.path( p$annual.results, "timeseries",  "interpolated" ) )
  figure.exploitation.rate( p, outdir=file.path( p$annual.results, "timeseries",  "interpolated" ), CFA4X.exclude.year.assessment=F )

# ------------------------------------------
# Time-series: Generic plots of all interpolated data
  # figure.timeseries.interpolated( p, outdir=file.path( p$annual.results, "timeseries",  "interpolated" ) )

# ------------------------------------------
# Time-series: Habitat variations (surface area of snow crab habitat)

# p$model.type = "gam.full" # choose method for habitat model :
# p$model.type = "gam.simple" # choose method for habitat model :  no longer used

p$habitat.threshold.quantile = 0.05 # quantile at which to consider zero-valued abundance
p$prediction_dyear = 9/12 # predict for ~ Sept 1
figure.timeseries.snowcrab.habitat( p=p)

# ------------------------------------------
# Time-series: Habitat variations (mean temperature of snow crab habitat)
figure.timeseries.snowcrab.habitat.temperatures( p=p)

# ------------------------------------------
# Fecundity estimated indirectly via total number of females of primi and muli and applying mean egg production from allometric estimate
  fecundity.indirect( p=p,  outdir=file.path( p$annual.results, "timeseries", "survey" ) )

# ------------------------------------------
# Fecundity estimated directly via interpolation and individual-based fecundity estimate
  figure.timeseries.fecundity( p=p, outdir=file.path( p$annual.results, "timeseries",  "interpolated"  ) )

# Tables for the SSR/RESDOC
# ---------------------------------------------
  # Tables of CC from trawl surveys > 95mmCW

  outvars = c("yr", "region", "vars", "total", "lbound", "ubound")
  yy = c(1999:p$year.assessment)
  rr = c("cfasouth", "cfanorth", "cfa4x")
  vv = c( "totno.male.com.CC1", "totno.male.com.CC2", "totno.male.com.CC3",
          "totno.male.com.CC4", "totno.male.com.CC5" )

  p$runindex = list(y=yy, v=vv )

  L = interpolation.db( DS="interpolation.simulation", p=p )

  L$vars = as.character(L$vars)

  for (y in yy) {
  for (r in rr) {
    i = which( L$yr==y & L$region==r )
#    isum = sum(L$total[i], na.rm=T)
    L[i, c("total", "lbound", "ubound")] =round(  L[i, c("total", "lbound", "ubound")], 4)
  }}

  scale.factor = 1e2
  L[, c("total", "lbound", "ubound")] = L[, c("total", "lbound", "ubound")] * scale.factor
  L$vars = factor(x=L$vars, levels=vv, ordered=T)

  Mn = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfanorth"),], drop.unused.levels = T ) / scale.factor
  dimnames(Mn)$vars = c(1:5)

  Ms = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfasouth"),], drop.unused.levels = T ) / scale.factor
  dimnames(Ms)$vars = c(1:5)

  Mx = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfa4x"),], drop.unused.levels = T ) / scale.factor
  dimnames(Mx)$vars = c(1:5)

 (Mnp = round(Mn/rowSums(Mn)*100,2))
 (Msp = round(Ms/rowSums(Ms)*100,2))
 (Mxp = round(Mx/rowSums(Mx)*100,2))

  latex( Mnp, file="", title="", label="table.CC.north.trawl", rowlabel="Year", cgroup="Carapace condition", na.blank=T, caption="Carapace condition of crab larger than 95 mm CW (percent by number) over time for N-ENS from trawl surveys. The transition from a spring to a fall survey occurred in 2002/2003.")

  latex(Msp, file="", title="", label="table.CC.south.trawl", rowlabel="Year", cgroup="Carapace condition", na.blank=T, caption="Carapace condition of crab larger than 95 mm CW (percent by number) over time for S-ENS from trawl surveys. The transition from a spring to a fall survey occurred in 2002/2003.")

  latex(Mxp, file="", title="", label="table.CC.4x.trawl", rowlabel="Year", cgroup="Carapace condition", na.blank=T, caption="Carapace condition (percent by number) over time for CFA 4X from trawl surveys.")

# ---------------------------------------------
  # Tables of fishable biomass from trawl surveys

  outvars = c("yr", "region", "vars", "total", "lbound", "ubound")
  yy = c(1999:p$year.assessment)
  rr = c("cfasouth", "cfanorth", "cfa4x")
  vv = c( "totmass.male.com", "R0.mass", "R0.no", "R1.no", "R2.no", "R3.no", "totno.male.imm", "totno.male.com.CC1to2", "totno.male.com.CC3to4",
          "totno.male.com.CC5" )

  p$runindex = list(y=yy, v=vv )

  L = interpolation.db( DS="interpolation.simulation", p=p )
  # L = K[K$yr %in% yy & K$vars %in% vv & K$region %in% rr, outvars]
  L$vars = as.character(L$vars)

  for (y in yy) {
  for (r in rr) {
    i = which( L$yr==y & L$region==r )
#    isum = sum(L$total[i], na.rm=T)
    L[i, c("total", "lbound", "ubound")] =round(  L[i, c("total", "lbound", "ubound")], 4)
  }}

   scale.factor = 1
  L[, c("total", "lbound", "ubound")] = L[, c("total", "lbound", "ubound")] * scale.factor
  L$vars = factor(x=L$vars, levels=vv, ordered=T)

  Mn = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfanorth"),], drop.unused.levels = T ) / scale.factor
  dimnames(Mn)$vars = vv

  Ms = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfasouth"),], drop.unused.levels = T ) / scale.factor
  dimnames(Ms)$vars = vv

  Mx = xtabs(formula=total~yr+vars, data=L[which(L$region=="cfa4x"),], drop.unused.levels = T ) / scale.factor
  dimnames(Mx)$vars = vv

  options(width=240)
  options(digits=1)
  Mn
  Ms
  Mx

  latex(Mn, file="", title="", label="table.stats.north.trawl", rowlabel="Year", cgroup="Various statistics", na.blank=T, caption="Various statistics of crab for N-ENS from trawl surveys. ")

  latex(Ms, file="", title="", label="table.stats.south.trawl", rowlabel="Year", cgroup="Various statistics", na.blank=T, caption="Various statistics for S-ENS from trawl surveys. ")

  latex(Mx, file="", title="", label="table.stats.4x.trawl", rowlabel="Year", cgroup="Various statistics", na.blank=T, caption="Various statistics for CFA 4X from trawl surveys.")


library(caret) # include library

dataset = "00_measurement/signalp-alone_y_pred.tsv"
dt <- read.table(dataset, header = TRUE, sep="\t")  # load table

# extract file name, for naming output and rowname
f_name <- paste0(tools::file_path_sans_ext(dataset))

# define variable for confusion matrix
lvs = c("secreted","other")
actual = factor(dt$y_true, levels = lvs)
pred = factor(dt$y_pred, levels = lvs)

# calculate confusion matrix
eval_indices <- confusionMatrix(pred, actual)

# convert to tables
conf_matrix <- as.data.frame(eval_indices$table)
eval_table <- t(as.data.frame(eval_indices$byClass, row.names = NULL))
rownames(eval_table) <- f_name

# ---------- calculate FDR -------------------
False.Discovery.Rate <- 1 - eval_table[3]
eval_table <- data.frame(eval_table,False.Discovery.Rate)

# --------- calculate MCC ----------
library(mccr)
mcc_sp_alone <- mccr(dt$mcc_y_true,dt$mcc_y_pred)
mcc_to_table <- as.data.frame(mcc_sp_alone)
colnames(mcc_to_table) <- "MCC"

# merge eval table with MCC
eval_table <- data.frame(eval_table,mcc_to_table)

# export tables
f1 <- write.table(eval_table,file = sprintf("%s_evaluation_table.tsv",f_name),
                  sep="\t",eol = "\n")
f2 <- write.table(conf_matrix,file = sprintf("%s_confusion_matrix.tsv",f_name),
                  sep ="\t",eol = "\n")


#' MCO automation function : Parallelized approach
#'
#' This function allows to select by informational criteria and various tests results (Durbin-Watson, Shapiro-Wilks, Breush-Pagan, F-test) one or a serie of different models allowing for best performance in-sample. The function uses parallelised approach with doParallel package.
#'
#' @param datax A data.frame of explicative variables to be studied of length equal to explicative variable vector
#' @param dependent A dependent variable vector
#' @param laglim The model allows to automatically convert the dataset in order to study lagged dependecies
#' @param plim The critical value for tests results (default value 0.1)
#' @param limit A maximum number of models to be selected in each category
#' @param study.t0 A logical value indicating whether the t0 period should be taken into account
#' @param varlim A maximal number of variables to make combinations of (large number significantly increases computation time, each supplementary variable increases the tyme by 2)
#' @param valid LOGICAL, indicates whether the crossvalidation procedure should be applied during the model selection
#' @param part The part of the sample to be used for crossvalidation (by default 15%)
#'
#' @return A list of selected models estimated with OLS with additional performance information
#' \describe{
#'  \item{choices}{A data.frame containing information for selected models testing results}
#'  \item{models}{A list of models in order as they figure in choices dataframe}
#'  \item{univariate}{Results of first stage univariate model testing for selected variables}
#' }
#' @keywords MCOanalyse
#' @export
#' @examples
#' MCOanalyse(data, dependent,
#'      laglim = 5, plim = 0.1, limit = 2,
#'      study.t0 = TRUE, folds = 10, varlim = 10)
#' @import tidyverse
#' @import parallel
#' @import doParallel
#' @import foreach
#' @import filehash
#' @import lmtest
#' @import mctest
#'
MCOanalyse = function(datax, # Dataframe with ALL variables
        # Must start from t = 0 to t = n
        # head - t0, tail - tn
        # If needed to account for lagged dependent, include it
    dependent, # Name of the dependent variable
    laglim = 2, # Lag limit
    plim = 0.1, # Probability trashhold for tests
    limit = 1, # Number of models selected limit
    study.t0 = FALSE, # If the model should account for t0
    varlim = 10, # Maximum variables number to study
        # Highter is this number, highter is complexity and time : t = t0*2^n
        ## Avec t0 le temps d'execution pour carlim = 1
        # Advised not to use more than 10
        # (15? ~ 2 hours computing time)
    valid = TRUE, # If the models should be cross validated
    part = 0.15 # Number of crossvalidation folds
    ) {
# # Testing
# df = read.csv("./groupe_residentiel/data/derived_data/df3.csv")
# dependent = df[,8]
# datax = log(df[,c(14:18)])
# rm(df)
# laglim = 3 # Lag limit
# plim = 0.1 # Probability trashhold for tests
# limit = 5
# study.t0 = FALSE
# varlim = 8
    #################
    # Parallelisation
    cat("Stage 1 \n")
    # Get cores
    ncores = detectCores()
    registerDoParallel(ncores)
    # clust = makeCluster(ncores)
    # registerDoSNOW(clust)
    #####################
    # Database recreation
    # Taking lags into account
    cat("Stage 2 \n")
    # Taking into accoun t0
    if (study.t0 == TRUE) {
        # For defined lag order
        if (laglim != 0) {
            database = datax
            for (i in 1:laglim) {
                cat(i, "\n")
                databaseX = datax %>%
                    mutate_all(function(x) lag(x, i))
                names(databaseX) =
                    paste0("l", i, "_", names(datax))
                database = cbind(database, databaseX)
                rm(databaseX)
            }
            rm(datax) ; gc()
        # Only t0 data study
        } else {
            database = datax
            rm(datax) ; gc()
        }
    # No taking into account t0
    } else {
        # Defined lag order
        if (laglim != 0) {
            # First lag base creation
            cat(1, "\n")
            database = datax %>%
                    mutate_all(function(x) lag(x, n = 1))
            names(database) =
                    paste0("l", 1, "_", names(datax))
            # More than 1 lag account
            if (laglim > 1) {
                for (i in 2:laglim) {
                    cat(i, "\n")
                    databaseX = datax %>%
                        mutate_all(function(x) lag(x, n = i))
                    names(databaseX) =
                        paste0("l", i, "_", names(datax))
                    database = cbind(database, databaseX)
                    rm(databaseX)
                }
            }
            rm(datax) ; gc()
        # Extra case for conflicts
        } else {
            cat("No laglim defined,
                proceeding with t0 period study \n")
            database = datax
            rm(datax) ; gc()
        }
    }
    #####################################
    # Univariate selection over many lags
    # Loop
    tbase = foreach (i = 1:ncol(database),
        .combine = rbind) %dopar% {
        # Data
        X = database[,i]
        # Model
        summar = summary(lm(dependent ~ X)) # %>%
            #summary()
        data.frame(n = i,
                p.tstat = summar$coeff[2,4],
                r2 = summar$r.squared,
                p.fstat = pf(summar$fstat[1],
                    summar$fstat[2],
                    summar$fstat[3],
                    lower.tail=FALSE),
                varname = colnames(database)[i])
    }
    # Selection of variables by varlim
    ## univar_tbase = tbase
    univar_tbase = tbase %>%
        filter(p.tstat < plim &
            p.fstat < plim)
    rm(tbase) ; gc()
    univar_tbase = univar_tbase %>%
        arrange(-r2)  %>%
        head(varlim)
    vars = as.integer(univar_tbase$n)
    # Complexity reduction achieved
    #######################
    # Database recreation 2
    database = database[,vars]
    ##############
    # Combinations
    cat("Stage 3 \n")
    # Combinations storage
    dbCreate("DataBase")
    Base = dbInit("DataBase")
    Base$combin = vector("list", length = ncol(database))
    # Loop
    Base$combin = foreach (i = 1:ncol(database)) %dopar% {
        # cat(i, "\n")
        combn(length(names(database)), i,
            simplify = TRUE)
    }
    # Load DB
    dbLoad(Base)
    # Count possible models
    nmodels = 0
    for (i in 1:length(Base$combin)) {
        nmodels = nmodels + ncol(Base$combin[[i]])
    }
    ########################
    # Models and performance
    cat("Stage 4 \n")
    model = list()
    # Results frames
    # Model results
    cat("Stage 4.1 \n")
    if (valid == TRUE) {
        resbase = data.frame(n = NA, i = NA, j = NA,
            rse = NA, r2 = NA, mse = NA,
            p.fstat = NA,
            p.dw = NA, p.sw = NA, p.bp = NA, k2.fg = NA)[-1,]
    } else {
        resbase = data.frame(n = NA, i = NA, j = NA,
            rse = NA, r2 = NA,
            p.fstat = NA,
            p.dw = NA, p.sw = NA, p.bp = NA, k2.fg = NA)[-1,]
    }
    # Loop modelisation
    cat("Stage 4.2 \n")
    # x = 1 # Counter
    if (valid == TRUE) {
        # Cross-validation
        for (i in 1:length(Base$combin)) {
            # Iteration number
            cat("i = ", i, "\n")
            # Combination preselection
            # Variable combinations
            Vars = Base$combin[[i]] # May cause memory overuse
            Varnames = colnames(database)
            # Limits
            varlength = ncol(Base$combin[[i]])
            rowlength = nrow(database)
            # Select study part
            study =
            foreach (k = 1:as.integer(rowlength*part)) %do% {
                sample(rowlength,
                    as.integer(rowlength*(1-part)))
            }
            # Data
            resbaseX =
            foreach (j = 1:varlength,
                .packages = c("foreach"),
                .combine = rbind,
                .inorder = FALSE #,
                # .options.snow = opts
                ) %dopar% {
                # Crossvalidation
                mods = foreach (k = 1:length(study),
                .packages = c("lmtest", "mctest"),
                .combine = rbind
                ) %do% {
                    # Study
                    X = data.frame(database[study[[k]],Vars[,j]])
                    colnames(X) = Varnames[Vars[,j]]
                    Y = data.frame(dependent[study[[k]]])
                    colnames(Y) = "y"
                    df = cbind(Y, X)
                    rm(Y, X)
                    # Modelisation
                    model = lm(y ~ ., df)
                    # Test out of sample
                    Xt = as.data.frame(database[-study[[k]],Vars[,j]])
                    colnames(Xt) = Varnames[Vars[,j]]
                    Yt = data.frame(O = dependent[-study[[k]]],
                        P = predict(model, newdata = Xt))
                    Yt = na.omit(Yt)
                    rm(Xt)
                    r2t = mean((Yt$O - Yt$P)^2)
                    # Summary
                    summar = summary(model)
                    # fgts = ifelse((length(Vars)-1) > 1,
                    #     omcdiag(df[,-1], df[,1])$odiags[2,1], 0)
                    # Output
                    data.frame(
                        sup_rse = summar$sigma,
                        sup_r2 = summar$r.squared,
                        sup_se = r2t,
                        sup_p.fstat = pf(summar$fstat[1],
                            summar$fstat[2],
                            summar$fstat[3],
                            lower.tail=FALSE),
                        sup_p.dw = dwtest(model,
                            alternative = "two.sided")$p.value,
                        sup_p.sw = shapiro.test(model$res)$p.value,
                        sup_p.bp = bptest(model)$p.value,
                        sup_k2.fg = ifelse((ncol(df)-1) > 1,
                            omcdiag(df[,-1], df[,1])$odiags[2,2], 0))
                }
                # Results
                ## Performance
                data.frame(n = NA,
                    i = i, j = j,
                    rse = mean(mods$sup_rse),
                    r2 = mean(mods$sup_r2),
                    mse = mean(mods$sup_se),
                    p.fstat = mean(mods$sup_p.fstat),
                    p.dw = mean(mods$sup_p.dw),
                    p.sw = mean(mods$sup_p.sw),
                    p.bp = mean(mods$sup_p.bp),
                    k2.fg = mean(mods$sup_k2.fg))
            }
            resbase = rbind(resbase, resbaseX)
        }
    } else {
        # No crossvalidation
        for (i in 1:length(Base$combin)) {
            # Iteration number
            cat("i = ", i, "\n")
            # Combination preselection
            # Variable combinations
            Vars = Base$combin[[i]] # May cause memory overuse
            # Limits
            varlength = ncol(Base$combin[[i]])
            rowlength = nrow(database)
            Varnames = colnames(database)
            # Data
            resbaseX =
            foreach (j = 1:varlength,
                .packages = c("lmtest", "mctest"),
                .combine = rbind,
                .inorder = FALSE #,
                # .options.snow = opts
                ) %dopar% {
                # Explicative variables
                X = data.frame(database[,Vars[,j]])
                colnames(X) = Varnames[Vars[,j]]
                Y = data.frame(dependent)
                colnames(Y) = "y"
                df = cbind(Y, X)
                rm(Y, X)
                # Modelisation
                model = lm(y ~ ., df)
                # Sumary
                summar = summary(model)
                # Results
                ## Performance
                data.frame(n = NA,
                    i = i, j = j,
                    rse = summar$sigma,
                    r2 = summar$r.squared,
                    p.fstat = pf(summar$fstat[1],
                        summar$fstat[2],
                        summar$fstat[3],
                        lower.tail=FALSE),
                    p.dw = dwtest(model,
                        alternative = "two.sided")$p.value,
                    p.sw = shapiro.test(model$res)$p.value,
                    p.bp = bptest(model)$p.value,
                    k2.fg = ifelse((ncol(df)-1) > 1,
                        omcdiag(df[,-1], df[,1])$odiags[2,2], 0))
            }
            resbase = rbind(resbase, resbaseX)
        }
    }
    #####################
    # Choice and analysis
    cat("Stage 5 \n")
    # Aux
    crit = list()
    types = list()
    # Optimal
    crit[[1]] = "p.fstat < plim &
        p.dw > plim &
        p.sw < plim &
        p.bp > plim &
        k2.fg < plim"
    types[[1]] = "optimal"
    # Autocorrelation
    crit[[2]] = "p.fstat < plim &
        p.dw <= plim &
        p.sw < plim &
        p.bp > plim &
        k2.fg < plim"
    types[[2]] = "autocor"
    # Non-normality
    crit[[3]] = "p.fstat < plim &
        p.dw > plim &
        p.sw < plim &
        p.bp <= plim &
        k2.fg < plim"
    types[[3]] = "non.norm"
    # Heteroscedastisity
    crit[[4]] = "p.fstat < plim &
        p.dw > plim &
        p.sw >= plim &
        p.bp > plim &
        k2.fg < plim"
    types[[4]] = "heterosk"
    # Multicollinearity
    crit[[5]] = "p.fstat < plim &
        p.dw > plim &
        p.sw < plim &
        p.bp > plim &
        k2.fg >= plim"
    types[[5]] = "multicol"
    # Autocorrelation and non-normality
    crit[[6]] = "p.fstat < plim &
        p.dw <= plim &
        p.sw < plim &
        p.bp <= plim &
        k2.fg < plim"
    types[[6]] = "autocor_non.norm"
    # Autocorrelation and heteroscedasticity
    crit[[7]] = "p.fstat < plim &
        p.dw <= plim &
        p.sw >= plim &
        p.bp > plim &
        k2.fg < plim"
    types[[7]] = "autocor_heterosk"
    # Autocorrelation and multicollinearity
    crit[[8]] = "p.fstat < plim &
        p.dw <= plim &
        p.sw < plim &
        p.bp > plim &
        k2.fg >= plim"
    types[[8]] = "autocor_multicol"
    # Non-normality and Heterockedasticity
    crit[[9]] = "p.fstat < plim &
        p.dw > plim &
        p.sw >= plim &
        p.bp <= plim &
        k2.fg < plim"
    types[[9]] = "non.norm_hetero"
    # Non-normality and Multicollinearity
    crit[[10]] = "p.fstat < plim &
        p.dw > plim &
        p.sw < plim &
        p.bp <= plim &
        k2.fg >= plim"
    types[[10]] = "non.norm_multicol"
    # Heteroscedastisity and Multicollinearity
    crit[[11]] = "p.fstat < plim &
        p.dw > plim &
        p.sw >= plim &
        p.bp > plim &
        k2.fg >= plim"
    types[[11]] = "hetero_multicol"
    # Eval results
    if (valid == TRUE) {
        results = foreach (s = 1:length(crit),
            .packages = "tidyverse",
            .combine = rbind) %dopar% {
            plim = plim
            resbase %>%
                dplyr::filter(eval(parse(text = crit[[s]]))) %>%
                arrange(mse) %>%
                head(limit) %>%
                mutate(type = types[[s]])
        }
        results = results %>%
            arrange(mse) %>%
            mutate(m = 1:nrow(results))
    } else {
        results = foreach (s = 1:length(crit),
            .packages = "tidyverse",
            .combine = rbind) %dopar% {
            plim = plim
            resbase %>%
                dplyr::filter(eval(parse(text = crit[[s]]))) %>%
                arrange(r2) %>%
                tail(limit) %>%
                mutate(type = types[[s]])
        }
        results = results %>%
            arrange(-r2) %>%
            mutate(m = 1:nrow(results))
    }
    # Remove aux
    rm(resbase) ; gc(full = TRUE)
    #########################
    # Selected models storage
    # Loop
    model = foreach (k = 1:nrow(results)) %dopar% {
        # Explicative variables
        vars = Base$combin[[results$i[k]]][,results$j[k]]
        # Explicative variables
        X = data.frame(database[,vars])
        colnames(X) = Varnames[vars]
        Y = data.frame(dependent)
        colnames(Y) = "y"
        df = cbind(Y, X)
        rm(Y, X)
        # Models
        model[[k]] = lm(y ~ ., df)
    }
    #################
    # Remove database
    rm(Base)
    unlink("DataBase")
    # Close cluster
    stopImplicitCluster() ; gc()
    # stopCluster(clust) ; gc()
    ##################
    # Output reduction
    ret = list(choices = results,
        models = model,
        univariate = univar_tbase)
    return(ret)
}


fn.pb = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_PB.DC_SLEDAI_corr_score_PG234_lowDA.txt")
fn.pb.low = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_PB.DC_ge_sig_score_subjects.txt")

df.pb = fread(fn.pb)
df.pb.low = fread(fn.pb.low)

PG.group.names = c("SLE patients with plasmablast\nsignature during flare", "Other SLE patients")

df = inner_join(df.pb, df.pb.low, by="SUBJECT") %>%
  dplyr::filter(PG %in% 2:4) %>%
  mutate(PG = factor(PG)) %>%
  mutate(PG.group = ifelse(PG %in% 2:4, PG.group.names[1], PG.group.names[2])) %>%
  mutate(PG2 = ifelse(PG %in% 2:3, "2/3", ifelse(PG %in% 4, "4", "other"))) %>%
  mutate(PG = factor(PG), PG2 = factor(PG2), PG.group = factor(PG.group, levels=PG.group.names))

cc = cor.test(df$PB_score_mean, df$PB_SLEDAI_corr_score, method="pearson")
df.cc = data.frame(label=sprintf("r = %.3f\np = %.2g",cc$estimate,cc$p.value),
                   x=-Inf, y=Inf)
df.cc2 = df %>% split(.$PG2) %>%
  map(~cor.test(.$PB_score_mean, .$PB_SLEDAI_corr_score, method="pearson")) %>%
  map_df(~data.frame(label=sprintf("r = %.3f\np = %.2g",.$estimate,.$p.value),
                     x=-Inf, y=Inf)) %>%
  mutate(PG2 = levels(df$PG2) %>% factor())

PG2.clr = c("steelblue", "grey80")

p = ggplot(df, aes(PB_score_mean, PB_SLEDAI_corr_score)) +
  geom_point(shape=21, size=3, aes(fill=PG2), col="white") + #geom_smooth(aes(group=1),method="lm") +
  scale_fill_manual(values = PG2.clr, guide="none") +
  geom_text(data=df.cc, aes(label=label), x=-Inf, y=Inf, vjust=1.5, hjust=-0.1, col="black") +
  geom_hline(yintercept=0) + geom_vline(xintercept=0) + theme_bw() + theme(legend.key = element_blank()) +
  xlab("Mean PB score at low DA") +
  ylab("DA-associated\nchange in plasmablasts") +
  ggtitle("SLE patients with plasmablast\nsignature during flare") +
  theme_bw()
p
fn.fig = file.path(PROJECT_DIR, "figure_generation", "SLE_PB.DC.corr_vs_PB.mean.score_PG234")
ggsave(paste0(fn.fig,".png"), w=2.6,h=3)
ggsave(paste0(fn.fig,'.pdf'), w=2.6,h=3)


library(reshape)
require(seqinr)
require(phangorn)
mafft<-function(filename="ncrna.fa", outname="ncrna_aligned.fa"){
	command<-paste("mafft --maxiterate 1000 --localpair --quiet --inputorder ", filename, " > ", outname, sep="" )
	system(command)
	#fas<-read.fasta(outname)
	#fas
}

closest<-function(x,y){
	out<-c()
	for(i in 1:length(x)){
		temp<- which.min(abs(y-x[i]))
		out<-c(out,temp)
	}
out
}

extend<-function(x){
	while(length(x)>length(unique(x))){
		x[duplicated(x)]<-x[duplicated(x)]+1
	}
x
}

wd<-getwd()
d<-list.dirs( recursive=FALSE)
dis<-list()
for(i in 1:length(d)){
	setwd(d[i])

	load("refined_GLASSgo_table.Rdata")
	coor<-coor2
	fasta<-c()
	positions<-seq(1,nrow(coor))
	for(j in 1:length(positions)){
		fasta<-c(fasta, paste(">",coor[positions[j],"fin"],sep=""))
		fasta<-c(fasta, as.character(coor[positions[j],"sequence"]))
	}
	write.table(fasta, file="temp_fasta", row.names=F, col.names=F, quote=F)
	mafft(filename="temp_fasta")

	dat<-read.phyDat("ncrna_aligned.fa", format="fasta", type="DNA")
	dm <- dist.ml(dat, model="F81")
	treeNJ <- NJ(dm)
	fit = pml(treeNJ, data=dat)
	fitJC <- optim.pml(fit, model = "GTR")
	fit2<-fitJC
	fitJC<-fit2
	lab<-fitJC$tree$tip.label
	lab2<-lab
	#m <- as.matrix(dm)
	p<-cophenetic(fitJC$tree)
	temp<-p[,1]
	#names(temp)<-colnames(m)
	dis[[i]]<-temp

	num2<-25

	su<-summary(p[,1])

	su2<-p[which(p[,1]<su[4])]
	names(su2)<-rownames(p)[which(p[,1]<su[4])]
	su3<-p[which(p[,1]>=su[4])]
	names(su3)<-rownames(p)[which(p[,1]>=su[4])]

	su2<-sort(su2)
	clos<-su2[1:4]
	su2<-su2[5:length(su2)]
	num<-length(su2)*1.5
	if(num>60){
		num<-60
	}
	su2<-(log(su2))
	su2<-su2+abs(min(su2))
	su2<-sqrt(su2)
	#plot(sort(su2))
	#md<-max(dis[[i]])
	md<-max(su2)-min(su2)
	cu<-md/num
	rcu<-rep(cu,num)
	rcu<-min(su2)+cumsum(rcu)
	#rcu<-(rcu)
	#plot(sort(su2))
	#abline(h=(rcu))

	#rcu<-(rcu)^(1/10)

	#out<-c(clos,dis[[i]][closest(rcu,su2)])
	out<-c(clos,su2[closest(rcu,su2)])
	out<-unique(names(out))
	#out<-unique(out)
	out<-match(out,names(dis[[i]]))

	#out<-match(names(out), lab2)
	#out<-unique(out)
	m<-min(num2,length(out))
	out<-out[1:m]

	outn<-names(dis[[i]])[out]
	#out<-extend(out)
	#out<-out[1:num2]
	print(length(out))
	lab<-match(lab,coor2[,"fin"])
	lab<-coor2[lab,"nam2"]
	fitJC$tree$tip.label<-lab
	out2<-match(names(su3), lab2)
	ooi<-match(rownames(p)[1],lab2)

	colo<-rep("1",length(lab))
	colo[out]<-"deepskyblue2"
	colo[out2]<-"orangered2"
	colo[ooi]<-"olivedrab3"
	pdf("tree.pdf")
	plot(midpoint(fitJC$tree), tip.color=colo,cex=0.30, main=gsub("\\./","",d[i]))
	add.scale.bar()
	dev.off()

	# command<-paste("clustalo -i ", "temp_fasta", " --distmat-out=distmatout.txt --full --output-order=input-order --use-kimura --force --max-hmm-iterations=-1", sep="")
	# system(command)
	# na<-grep(">", fasta)
	# na<-gsub(">","",fasta[na])
	# temp<-read.delim("distmatout.txt",sep="",header=F, , skip=1)
	# unlink("distmatout.txt")
	# unlink("temp_fasta")
	# temp<-temp[,2:ncol(temp)]
	# colnames(temp)<-na
	# rownames(temp)<-na
	setwd(wd)
}

names(dis)<-d


context("likelihood ratio test")

test_that("100 samples, 2 components, same as glm.nb", {
    f1 = runif(100)
    f2 = 1 - f1
    c1 = stats::rnbinom(n=100, size=10, mu=1000)
    c2 = stats::rnbinom(n=100, size=20, mu=10)
    both = round(f1 * c1 + f2 * c2)

#    ctl = MASS::glm.nb(both ~ 0 + f1 + f2)
#    stat = coef(summary(ctl))[,'z value']

    mf = model.frame(both ~ 0 + f1 + f2)
    terms = attr(mf, "terms")
    x = model.matrix(terms, mf)
    y = model.response(mf)
    res = lrt(x, y, reduced="f1")

    # expect same coefficients, max 15% diff stat due to diff fitting
    expect_true(res$statistic > 100)
})