## slices <- c(1210529,37000,344148,22500,12000,406544)
## slices <- slices[order(c(1210529,37000,344148,22500,12000,406544))]
## lbls <- c("Personnel","Travel","Consumables","Publication","Training","Indirect costs")
## lbls <- lbls[order(c(1210529,37000,344148,22500,12000,406544))]
## pct <- round(slices/sum(slices)*100)

## pie(pct,labels = lbls, col=rainbow(length(lbls)),clockwise=TRUE,radius = 0.5, cex = 1.5)
## df <- data.frame(lbls,slices)

## library(RColorBrewer)
## colors <- brewer.pal(7, name="BuGn")
## colors[2:7]

## library(ggplot2)
## bar <- ggplot(df, aes(x = "", y = pct, fill = lbls)) +
##     geom_bar(width = 1, stat = "identity", color = "white")
## pie <- bar+coord_polar("y",start=0)+scale_fill_manual(values = colors[2:7])+
##     theme_void()+
##     theme(legend.text=element_text(size=30),legend.title=element_blank())+
##     guides(fill=guide_legend(
##                  keywidth=0.7,
##                  keyheight=0.7,
##                  default.unit="inch")
##            )

##  png(filename = "Pie.png",
##          width = 700, height = 700, units = "px", pointsize = 12,
##      bg = "white")
## print(pie)
## dev.off()

## Using plotrix based on these examples:

## https://www.r-bloggers.com/how-to-draw-venn-pie-agram-multi-layer-pie-chart-in-r/
##https://stackoverflow.com/questions/26748069/ggplot2-pie-and-donut-chart-on-same-plot

library(plotrix)

total <- 213764
CG <- 118532
CHG <- total-CG
Genes.without.TEs <- 32307
Genes.without.TEs.CG <- 19106
Genes.without.TEs.CHG <- Genes.without.TEs - Genes.without.TEs.CG
InterGenes.without.TEs <- 93290
InterGenes.without.TEs.CG <- 50637
InterGenes.without.TEs.CHG <- InterGenes.without.TEs - InterGenes.without.TEs.CG
TEs.In.Genes <- 22031
TEs.In.Genes.CG <- 12994
TEs.In.Genes.CHG <- TEs.In.Genes - TEs.In.Genes.CG
TEs.In.InterGenes <- 66136
TEs.In.InterGenes.CG <- 35795
TEs.In.InterGenes.CHG <- TEs.In.InterGenes - TEs.In.InterGenes.CG
Genes <- Genes.without.TEs + TEs.In.Genes
InterGenes <- InterGenes.without.TEs + TEs.In.InterGenes

# parameter for pie chart
iniR=0.2 # initial radius
#colors=list(NO='white',total='black',mtRNA='#e5f5e0',rRNA='#a1d99b',genic=,intergenic='#fec44f',introns=',exons=,upstream='#ffeda0',downstream='#fee0d2',not_near_genes=)

png(filename = "Pie.png",
         width = 700, height = 700, units = "px", pointsize = 12,
      bg = "white")
#0 circle: blank
pie(1, radius=iniR, init.angle=90, col=c('white'), border = NA, labels='')

                                        #TEs
floating.pie(0,0, c(Genes.without.TEs,TEs.In.Genes,TEs.In.InterGenes,InterGenes.without.TEs), radius=4*iniR, startpos=pi/2, col=c("white",'#9ecae1','#fc9272',"white"),border = "white")

#1 circle: for genes and intergenes
floating.pie(0,0, c(Genes,InterGenes), radius=3*iniR, col=c('#3182bd','#d95f0e'),startpos=pi/2, border = "white")

floating.pie(0,0, c(Genes.without.TEs.CG,
                    Genes.without.TEs.CHG,
                    TEs.In.Genes.CHG,
                    TEs.In.Genes.CG,
                    TEs.In.InterGenes.CG,
                    TEs.In.InterGenes.CHG,
                    InterGenes.without.TEs.CHG,
                    InterGenes.without.TEs.CG
                    ), radius=2*iniR, col=c("lightgray","darkgray","darkgray","lightgray","lightgray","darkgray","darkgray","lightgray"),startpos=pi/2, border = "white")

legend(-3, 5*iniR, c("genic","intergenic","genic TEs","intergenic TEs","CG","CHG"), col=c('#3182bd','#d95f0e','#9ecae1','#fc9272',"lightgray","darkgray"), pch=19,bty='n', ncol=2,cex=2)

dev.off()


# Remove points from a scatter plot where density is really high
# @param x x-coordinates vector
# @param y y-coordinates vector
# @param resolution number of partitions for the x and y-dimensions.
# @param max.per.cell maximum number of points per x-y partition.
# @return index into the points that omits points from x-y partitions
# so that each has at most \code{max.per.cell} points.
scatter.thinning <- function(x,y,resolution=100,max.per.cell=100) {
    x.cell <- floor((resolution-1)*(x - min(x,na.rm=T))/diff(range(x,na.rm=T))) + 1
    y.cell <- floor((resolution-1)*(y - min(y,na.rm=T))/diff(range(y,na.rm=T))) + 1
    z.cell <- x.cell * resolution + y.cell
    frequency.table <- table(z.cell)
    frequency <- rep(0,max(z.cell, na.rm=T))
    frequency[as.integer(names(frequency.table))] <- frequency.table
    f.cell <- frequency[z.cell]

    big.cells <- length(which(frequency > max.per.cell))
    sort(c(which(f.cell <= max.per.cell),
           sample(which(f.cell > max.per.cell),
                  size=big.cells * max.per.cell, replace=F)),
         decreasing=F)
}

#' QQ plot for EWAS
#'
#' @param ewas.object Return object from \code{\link{meffil.ewas()}}.
#' @param sig.threshold P-value threshold for significance (Default: 1e-7).
#' @param sig.color Color for points corresponding to significant tests (Default: "red").
#' @param title Title for the plot (Default: "QQ plot").
#' @param xlab Label for the x-axis (Default: -log_10(expected p-values)).
#' @param ylab Label for the y-axis (Default: -log_10(observed p-values)).
#' @param lambda.method Method for calculating genomic inflation lambda.
#' Valid values are "median", "regression", or "robust" (Default: "median").
#' @return List of \code{\link{ggplot}} for each analysis in \code{ewas.object}.
#' @export
meffil.ewas.qq.plot <- function(ewas.object,
                                sig.threshold=1e-7,
                                sig.color="red",
                                title="QQ plot",
                                xlab=bquote(-log[10]("expected p-values")),
                                ylab=bquote(-log[10]("observed p-values")),
                                lambda.method="median") {
    stopifnot(is.ewas.object(ewas.object))

    sapply(names(ewas.object$analyses), function(name) {
        p.values <- sort(ewas.object$analyses[[name]]$table$p.value, decreasing=T)
        p.values[which(p.values < .Machine$double.xmin)] <- .Machine$double.xmin
        stats <- data.frame(is.sig=p.values < sig.threshold,
                            expected=-log(sort(ppoints(p.values),decreasing=T),10),
                            observed=-log(p.values, 10))
        lambda <- qq.lambda(p.values[which(p.values > sig.threshold)],
                            method=lambda.method)

        label.x <- min(stats$expected) + diff(range(stats$expected))*0.1
        label.y <- min(stats$expected) + diff(range(stats$observed))*0.9

        lambda.label <- paste("lambda == ", format(lambda$estimate,digits=3),
                              "%+-%", format(lambda$se, digits=3),
                              "~(", lambda.method, ")", sep="")

        selection.idx <- scatter.thinning(stats$observed, stats$expected,
                                          resolution=100, max.per.cell=100)

        lim <- range(c(0, stats$expected, stats$observed))
        sig.threshold <- format(sig.threshold, digits=3)

        (ggplot(stats[selection.idx,], aes(x=expected, y=observed)) +
         geom_abline(intercept = 0, slope = 1, colour="black") +
         geom_point(aes(colour=factor(sign(is.sig)))) +
         scale_colour_manual(values=c("black", "red"),
                             name="Significant",
                             breaks=c("0","1"),
                             labels=c(paste("p-value >", sig.threshold),
                                 paste("p-value <", sig.threshold))) +
         annotate(geom="text", x=label.x, y=label.y, hjust=0,
                  label=lambda.label,
                  parse=T) +
         xlim(lim) + ylim(lim) +
         xlab(xlab) + ylab(ylab) +
         coord_fixed() +
         ggtitle(paste(title, ": ", name, sep="")))
     }, simplify=F)
}

qq.lambda <- function(p.values, method="median", B=100) {
    stopifnot(method %in% c("median","regression","robust"))
    p.values <- na.omit(p.values)
    observed <- qchisq(p.values, df=1, lower.tail = FALSE)
    observed <- sort(observed)
    expected <- qchisq(ppoints(length(observed)), df=1, lower.tail=FALSE)
    expected <- sort(expected)

    lambda <- se <- NA
    if (method == "median")  {
        lambda <- median(observed)/qchisq(0.5, df=1)
        boot.medians <- sapply(1:B, function(i) median(sample(observed, replace=T)))
        se <- sd(boot.medians/qchisq(0.5,df=1))
    } else if (method %in% c("regression","robust")) {
        if (method == "regression")
            coef.table <- summary(lm(observed ~ 0 + expected))$coeff
        else
            coef.table <- summary(rlm(observed ~ 0 + expected))$coef
        lambda <- coef.table["expected",1]
        se <- coef.table["expected", "Std. Error"]
    }
    list(method=method, estimate=lambda, se=se)
}

#' Manhattan plot for EWAS
#'
#' @param ewas.object Return object from \code{\link{meffil.ewas()}}.
#' @param sig.threshold P-value threshold for significance (Default: 1e-7).
#' @param title Title for the plot (Default: "Manhattan plot").
#' @return \code{\link{ggplot}} showing the Manhattan plot.
#' @export
meffil.ewas.manhattan.plot <- function(ewas.object, sig.threshold=1e-7,
                                       title="Manhattan plot") {
    stopifnot(is.ewas.object(ewas.object))

    chromosomes <- paste("chr", c(1:22, "X","Y"), sep="")
    sapply(names(ewas.object$analyses), function(name) {
        chromosomes <- intersect(chromosomes, ewas.object$analyses[[name]]$table$chromosome)
        stats <- ewas.object$analyses[[name]]$table
        stats$chromosome <- factor(as.character(stats$chromosome), levels=chromosomes)
        stats$chr.colour <- 0
        stats$chr.colour[stats$chromosome %in% chromosomes[seq(1,length(chromosomes),2)]] <- 1
        p.values <- stats$p.value
        p.values[which(p.values < .Machine$double.xmin)] <- .Machine$double.xmin
        stats$stat <- -log(p.values,10) * sign(stats$coefficient)

        stats <- stats[order(stats$stat, decreasing=T),]

        chromosome.lengths <- sapply(chromosomes, function(chromosome)
                                     max(stats$position[which(stats$chromosome == chromosome)]))
        chromosome.lengths <- as.numeric(chromosome.lengths)
        chromosome.starts <- c(1,cumsum(chromosome.lengths)+1)
        names(chromosome.starts) <- c(chromosomes, "NA")
        stats$global <- stats$position + chromosome.starts[stats$chromosome] - 1

        selection.idx <- scatter.thinning(stats$global, stats$stat,
                                          resolution=100, max.per.cell=100)

        (ggplot(stats[selection.idx,], aes(x=position, y=stat)) +
         geom_point(aes(colour=chr.colour)) +
         facet_grid(. ~ chromosome, space="free_x", scales="free_x") +
         theme(strip.text.x = element_text(angle = 90)) +
         guides(colour=FALSE) +
         labs(x="Position",
              y=bquote(-log[10]("p-value") * sign(beta))) +
         geom_hline(yintercept=log(sig.threshold,10), colour="red") +
         geom_hline(yintercept=-log(sig.threshold,10), colour="red") +
         theme(axis.text.x = element_blank(), axis.ticks.x = element_blank()) +
         ggtitle(paste(title, ": ", name, sep="")))
    }, simplify=F)
}

#' Scatter plots for a CpG site in an EWAS
#'
#' @param ewas.object Return object from \code{\link{meffil.ewas()}}.
#' @param cpg CpG site to plot.
#' @param title Title of the plot (Default: \code{cpg}).
#' @param beta Matrix of methylation levels used to create the \code{ewas.object}.
#' @param \code{\link{ggplot}} object showing the scatterplots of DNA methylation vs the variable of interest
#' in the EWAS.  Each plot corresponds to a covariate set.
#' Methylation levels are in fact residuals from fitting a model with DNA methylation and the covariates.
#'
#' @export
meffil.ewas.cpg.plot <- function(ewas.object, cpg, beta, title=cpg) {
    stopifnot(is.ewas.object(ewas.object))
    stopifnot(is.matrix(beta) && cpg %in% rownames(beta))

    variable <- ewas.object$variable

    lapply(names(ewas.object$analyses), function(name) {
        ewas <- ewas.object$analyses[[name]]

        if (!all(rownames(ewas$design) %in% colnames(beta)))
            stop("EWAS samples do not match those in the beta argument (methylation matrix)")
        methylation <- beta[cpg,rownames(ewas$design)]

        covariates <- subset(data.frame(ewas$design), select=c(-variable,-intercept))
        if (ncol(covariates) == 0)
            covariates <- NULL
        cpg.plot(methylation, variable, covariates, title=paste(name, ": ", title, sep=""))
    })
}

cpg.plot <- function(methylation, variable, covariates=NULL, title="") {
    ## remove missing values
    idx <- which(!is.na(methylation) & !is.na(variable))
    if (length(idx) < 3) {
        warning("Not enough data points to plot CpG methylation.")
        return(NULL)
    }
    methylation <- methylation[idx]
    variable <- variable[idx]

    ## linear model fit
    if (is.null(covariates)) {
        fit <- lm(methylation ~ variable)
        base <- lm(methylation ~ 1)
    }
    else {
        covariates <- covariates[idx,,drop=F]
        fit <- lm(methylation ~ variable + ., data=covariates)
        base <- lm(methylation ~ ., data=covariates)
    }
    p.value.lm <- anova(fit,base)[2,"Pr(>F)"]

    stats.desc <- paste("variable\np[lm]= ", format(p.value.lm, digits=3), sep="")

    has.betareg <- all(c("lmtest", "betareg") %in% rownames(installed.packages()))
    if (has.betareg) {
        require("betareg")
        require("lmtest")

        ## beta regression model fit
        min.value <- 1e-20
        meth <- methylation
        meth[which(meth < min.value)] <- min.value
        meth[which(meth > 1-min.value)] <- 1-min.value

        if (is.null(covariates)) {
            fit <- betareg(meth ~ variable)
            base <- betareg(meth ~ 1)
        }
        else {
            fit <- betareg(meth ~ variable + ., data=covariates)
            base <- betareg(meth ~ ., data=covariates)
        }
        p.value.beta <- lrtest(fit, base)[2,"Pr(>Chisq)"]

        stats.desc <- paste(stats.desc, "; p[beta] = ", format(p.value.beta, digits=3), sep="")
    }
    y.axis.label <- "DNA methylation"
    if (!is.null(covariates)) {
        methylation <- residuals(base)
        y.axis.label <- "adjusted DNA methylation"
    }

    ## plot
    data <- data.frame(methylation=methylation, variable=variable)
    if (is.factor(variable) || length(unique(variable)) <= 20) {
        data$variable <- as.factor(data$variable)
        p <- (ggplot(data, aes(x=variable, y=methylation)) +
              geom_boxplot())
    } else {
        p <- (ggplot(data, aes(x=variable, y=methylation)) +
              geom_point() + geom_smooth(method=lm))
    }

    (p + ggtitle(title) +
     xlab(stats.desc) + ylab(y.axis.label))
}


#BZ July 2020- Work in progress
#Began to investigate potential alternate approaches to Harvest Control Rules / ref point
#using catch rates and potentially incorporating temperature
#explored using carstm temps and the bnam data series from BIO Oceanographers, likely bnam
#grids landings / catch rates & determines associated bottom temps for thos grids
#an example of simplistic (not using temp) catch rate reference points are provided at end of script
#Still requires investigation into how use of temp might better inform the ref points
#by accounting for temp effect, a clearer picture of catch rate may be possible for ref points

# -------------------------------------------------
# Part 1 -- import temperature grids from carstm

require(aegis)
require(aegis.bathymetry) #if doing a full refresh of logbook data
require(aegis.polygons)

#choose one, remembering that 4X season refers to start year
if (!exists("year.assessment")) {
  year.assessment=lubridate::year(Sys.Date())      # year.assessment
  year.assessment=lubridate::year(Sys.Date()) -1   # or year previous to current
}

#Choose one
#NB. The carstm temp approach is not fully functional. Left here in case to allow for future work if needed.
#BNAM yields higher spatial and temporal density data
#temp.model="carstm"
temp.model="bnam"

if (temp.model=="carstm"){
    p = bio.snowcrab::snowcrab_carstm( DS="parameters", assessment.years=1999:year.assessment )

    #Import grid dataframe (25km)- previously created
    sppoly = areal_units( p=p )  # to reload
    plot(sppoly)
    text(coordinates(sppoly), sapply(slot(sppoly, "polygons"), function(i) slot(i, "ID")), cex=0.5) #labels grid ID's
    spplot( sppoly, "au_sa_km2", main="AUID", sp.layout=p$coastLayout )

    #load carstm temperature data data layer (matches sppoloy grids)
    load("C:/bio.data/bio.snowcrab/modelled/temperature.carstm_inputs.snowcrab_assessment_25.rawdata.rdata") #data frame named M
}

# -------------------------------------------------
# Part 2 -- construct basic parameter list
p = bio.snowcrab::load.environment( year.assessment=year.assessment )

outfile=file.path(p$datadir,"assessments", lubridate::year(Sys.Date()), "4x")

#resolution of grids in km's, 25 matches the carstm assessment approach
if (temp.model=="carstm") p$pres=25
if (temp.model=="bnam") p$pres=10

# -------------------------------------------------
# Part 3 -- import fishery data for 4X

#res = get.fishery.stats.by.region( Reg="cfa4x") #for reference
# Uncomment following line to do a fresh logbook datadump
#redo.fishery.data(x, yrs=p$year.assessment) #can change to "yrs=1996:p$year.assessment" for more years

x = logbook.db( DS="logbook" ) #load logbook data
x=x[x$cfa %in% "cfa4x",]
x$year=x$yr #year offset for 4X, 2017-18 season -> 2017

#Grid the records to allow summing on grids
x = lonlat2planar( x,  proj.type=p$aegis_proj4string_planar_km )
g= spatial_grid(p,"planar.coords") #breaks into grid blocks (set by p$pres)
x$plon = grid_internal( x$plon, g$plon ) #fits lon values of data into grid
x$plat = grid_internal( x$plat, g$plat ) #fits lat values of data into grid
x$id=paste(x$plat, x$plon, sep=":")
rm(g)
xraw=x #xraw data frame contains all information for landings calculations

#need to clean data for catch rate calculations
x1=x[x$year<2007 & x$effort<61, ] #removes 200 trap (smaller, non-comparable cpue) complement
x2=x[x$year>2006, ] #Only large traps used from 2007 onwards
x=rbind(x1, x2)
rm(x1)
rm(x2)

#x = x [polygon_inside( x, region="isobath1000m"),]
x = x[ which(x$effort <= 201) ,] #200 traps is max, removes NA effort (confounding cpue)
x = x[ which(is.finite(x$landings)),] #landings- removes NA's

#Determine CPUE by license by year

yearly=aggregate(cbind(landings, effort)~licence + year, data=x, FUN="sum")
    yearly$cpue=yearly$landings/yearly$effort
    yearly= yearly[with(yearly, order(licence, year)),]

yearly.agg=aggregate(cpue~year, data=yearly, FUN="median")

year.tot=aggregate(landings~year, data=xraw, FUN="sum")
    year.tot= year.tot[with(year.tot, order(year)),]
year.tot=merge(year.tot, yearly.agg)

save(xraw, file=paste(outfile, "logs.rdata", sep="/") )
save(yearly, file=paste(outfile, "annual.by.license.rdata", sep="/") )
save(year.tot, file=paste(outfile, "annual.landings.rdata", sep="/") )

# can be moved to bio.snowcrab/ r in time
# left here for now to allow tweaking

timeseries.4x.cpue= function(x, avg="median"){ #fun can be median, mean, gm_mean
      plot(yearly$year[yearly$licence=="100201"], yearly$cpue[yearly$licence=="100201"], type="n", main="4X Catch Rates",
      ylim=c(0, 70), xlab="year", ylab="kg/trap")
      lics=unique(x$licence)
      for (l in lics){
          ly=yearly[yearly$licence==l,]
          points(ly$year, ly$cpue, pch=20)
          cols=c("chartreuse", "cyan", "firebrick1", "yellow", "steelblue", "tan", "lightcoral" )
          lines(ly$year, ly$cpue, col=sample(cols,1))
          }
      if (avg=="mean") x4=aggregate(cpue~year, data=yearly, FUN="mean")
      if (avg=="median") x4=aggregate(cpue~year, data=yearly, FUN="median")
      lines(x4$year, x4$cpue, lwd=4, col="red")
}

timeseries.4x.cpue(x)

#to export as csv for plotting elsewhere
if (0){
      x4=aggregate(cpue~year, data=yearly, FUN="median")
      x4$licence="median"
      x4=x4[,c("licence", "year", "cpue")]
      by.year=yearly[,c("licence", "year", "cpue")]
      by.year=rbind(by.year, x4)
      file=paste("C:/bio.data/bio.snowcrab/assessments/",year(Sys.Date()), "/4x/yearly.csv", sep="")
      write.csv(by.year, file=file)
}

# -------------------------------------------------
# Part 4 -- determine temperatures to model with catch rates for each year

#Determine which n grids contained the highest landings within a given year (season)
timeframe="recent" #can be changed to "all" if desired

    if (timeframe=="all") {
      grid.sums=aggregate(landings~id , data=xraw, FUN="sum")
    } else {
      grid.sums=aggregate(landings~id, data=xraw[xraw$year>(p$year.assessment- 6),], FUN="sum") #last 5 years
    }

#Choose one:
   tp= grid.sums[with(grid.sums,order(-landings)),]
   tp=tp[which(tp$id!="NA:NA"),] #removes unknown locations

#select number of grids to explore temps
if (p$pres==10) n=4 #67% of all 4X landings since 2014 came from four 10x10km grids
if (p$pres==25) n=2 #82% of all 4X landings since 2014 came from two 25x25km grids

top=tp[1:n,]

if (temp.model=="carstm"){
#Need a reference lat / long for each of those grids to determine the AUD to lookup temps

}

if (temp.model=="carstm") { #Determine AUID grid from M of each of the grids from X

  for (i in top$id){
    top$lat[top$id==i]=median(xraw$lat[xraw$id==i])
    top$lon[top$id==i]=median(xraw$lon[xraw$id==i])
  }

      crs_lonlat = sp::CRS(projection_proj4string("lonlat_wgs84"))
      top$AUID = over( SpatialPoints( top[, c("lon", "lat")], crs_lonlat ), spTransform(sppoly, crs_lonlat ) )$AUID # match each datum to an area
      #Warning- some near-shore 4X positions will fall outside the temperature grid structure.

      yrs=2001:p$year.assessment
      M=M[M$year>2000,]
      #M$dyri is in tenths of year
      #.05=Jan 18, .15=Feb 23, .25=Mar 30, .35=May 6, .45=Jun 11
      #.55=Jul 17, .65=Aug 22, .75=Sep 27, .85=Nov 2, .95=Dec 8

    h=(top$AUID[c(1:2)]) #smaller grids likely larger of grids here
    *my=M[M$AUID %in% h,]

    # Temp lookup from CARSTM assessment modelling
    #-----------------------------------------------------------
    pT = temperature_carstm(p=p, DS="parameters_override" )

    kk =  which( !is.finite(M[, pT$variabletomodel]))
    if (length(kk) > 0) {
      AD = temperature.db ( p=pT, DS="aggregated_data"  )  # 16 GB in RAM just to store!
      AD = AD[ which( AD$lon > p$corners$lon[1] & AD$lon < p$corners$lon[2]  & AD$lat > p$corners$lat[1] & AD$lat < p$corners$lat[2] ), ]
      # levelplot( eval(paste(p$variabletomodel, "mean", sep="."))~plon+plat, data=M, aspect="iso")

      AD$AUID = over( SpatialPoints( AD[, c("lon", "lat")], crs_lonlat ), spTransform(sppoly, crs_lonlat ) )$AUID # match each datum to an area
      AD$uid = paste(AD$AUID, AD$year, AD$dyear, sep=".")

       M_dyear_discret = discretize_data( M$dyear, pT$discretization$dyear )  # AD$dyear is discretized. . match discretization
      M$uid =  paste(M$AUID, M$year, M_dyear_discret, sep=".")

      oo = tapply( AD[, paste(pT$variabletomodel, "mean", sep="." )], AD$uid, FUN=median, na.rm=TRUE )

      jj = match( as.character( M$uid[kk]), as.character( names(oo )) )
      M[kk, pT$variabletomodel] = oo[jj ]
}
}

if (temp.model=="bnam") {
# Temp lookup from BNAM temperature modelling
  #-----------------------------------------------------------
source('C:/bio/bio.snowcrab/R/bnamR.r')

bnam=bnamR(redo=F)
bnam$year=substr(bnam$timeS, 1, 4)
bnam$m=substr(bnam$timeS, 6, 8)
months=unique(bnam$m)
renamed=c(1:12)
for (i in 1:length(months)){
  bnam$month[bnam$m==months[i]]=renamed[i]
}

#create a polygon for each "top" grid based on fishing positions within the grid

require(sp)
require(PBSmapping)

xyz=list()
u=unique(top$id)

for (i in 1:length(u)){
      t=top$id[i]
      grid=xraw[xraw$id==t,]
      inter=grid[,c("lat", "lon")]

      #add a category (required for later rasterizing/polygonizing)
      inter <- cbind(inter, cat = rep(1L, nrow(inter)),stringsAsFactors = FALSE)

      #convert to spatial points
      coordinates(inter) = ~lon + lat
      proj4string(inter) = CRS(projection_proj4string("lonlat_wgs84"))

      #determine bounding box of these points and convert to matrix
      bb=data.frame(inter@bbox)
      cds = matrix(c( bb[1,1], bb[2,1],
                      bb[1,2], bb[2,1],
                      bb[1,2], bb[2,2],
                      bb[1,1], bb[2,2],
                      bb[1,1], bb[2,1]),
                      ncol = 2, byrow = TRUE)
      #create a spatial polygon
      P1 = Polygon(cds)
      Ps = SpatialPolygons(list(Polygons(list(P1), ID = i)), proj4string=CRS(projection_proj4string("lonlat_wgs84")))
      PS=SpatialPolygons2PolySet(Ps) #Converts polygon to a PBSMapping Polyset
      PS$PID=i
      xyz[[i]]=PS
      if (i==length(u)) print("xyz is a list with n PBS:: PolySets as elements")
      }

#determine overlapping bnam polygons

hg=data.frame()

for (i in 1:n){
  df = findPolys(bnam$locsP,xyz[[i]])
  hg=rbind(df, hg)
  }

ahr = merge(hg,bnam$locsP,by='EID')

#extract bottom temps from bnam dataset
outbnam = list()
m=0
for(i in 1:length(u)){
  m=m+1
  h = subset(ahr,PID == i)
  k = bnam$bTs[which(bnam$bTs[,1] %in% h$EID),]
  if (length(unique(h$EID))==1) k=rbind(c(k))
  k=k[,2:ncol(k)]
  if (length(unique(h$EID))==1) k=rbind(c(k))
  #colnames(k)=bnam$timeS
  outbnam[[m]]=k
}

#average all temps grids by month
raw.temps=do.call(rbind,outbnam)
raw.temps= apply(raw.temps,2,mean)

#to plot temp time trends (with Loess smooth)
op = stl(ts(raw.temps,frequency=12, start=c(1990,1)),s.window=7)
plot(op)

temps= op$time.series[,2] #trend
#seasonality.temps= op$time.series[,1] #seasonal

Month=factor(cycle(temps), levels = 1:12, labels = month.abb)
temps=tapply(temps, list(year = floor(time(temps)), month = Month), c)

write.csv(temps,file=paste(outfile, '/bnam.climatology.csv', sep=''))

#write.csv(seasonality.smooth.temps,file=paste(outfile, '/bnam.seasonality.csv', sep=''))

#Merge fisheries data with temp data
yrs=as.character(year.tot$year)
cnames=levels(unique(Month))
year.tot[ , cnames]=NA

ti=data.frame()

for (y in yrs){
  t=ti
  ti=year.tot[year.tot$year==y,]
  for (m in levels(unique(Month))) {
    ti[,m]=temps[y,m]
      }
ti=rbind(t, ti)
all=ti
 }

#Object "all" now contains median landings and median catch rates by year with a mean bottom temp for each month imported from bnam
# -------------------------------------------------
# Part 5 -- model with catch rates with temperature
#.....

#Simple plotting of potential Ref Pts and HCR
#Uses lobster IFMP approach of bmsy=long term median catch rate, ref points are 40 and 80% of BMSY

bmsy=median(all$cpue)
plot(all$year, all$cpue, ylim=c(0,1.1*(max(all$cpue))), type="l", xlab="Year", ylab="CPUE (kg)", main="4X")
points(all$year,all$cpue, pch=16)
abline(h=0.4*bmsy, col="red", lwd=3)
abline(h=0.8*bmsy, col="yellow", lwd=3)
abline(h=bmsy)
text(x=min(as.numeric(all$year))+1, y=1.1*median(all$cpue), "BMSY")


rm(list = ls())
library(ggplot2)
library(gridExtra)
options(stringsAsFactors = FALSE)

args = commandArgs(trailingOnly=TRUE)

prefix<-args[1]
fasta_file<-args[2]

print(getwd())
print(prefix)
print(fasta_file)

count.hist<-read.table(paste0(prefix,".merged.rc.match.enh.mapped.barcode.ct.plothist"),header=FALSE)
flags<-read.table(paste0(prefix,".merged.rc.match.enh.mapped.barcode.ct.parsed"),header=FALSE)[,c(5,7)]
fasta<-read.table(fasta_file,header=FALSE)

#flags<-read.table("tmp.out2",header=FALSE)[,c(5,7)]

fasta<-data.frame("ID"=fasta[seq(1,nrow(fasta),2),],"seq"=fasta[seq(2,nrow(fasta),2),])
fasta[,"ID"]<-gsub("^>","",fasta[,"ID"])

parsed<-count.hist[which(count.hist$V2<quantile(count.hist$V2,.99)),]
maxb<-max(count.hist$V2)

plotA<-ggplot(parsed, aes(x=V2)) +
  geom_histogram(bins=200)+
  theme(legend.position="top") +
  xlab("Barcodes per Oligo") + ggtitle(paste0("Barcode Count - truncated, max: ",maxb)) +
  theme_bw() + theme(panel.grid.major = element_line(size = .25,colour = rgb(0,0,0,75,maxColorValue=255)), panel.grid.minor = element_blank())

xlim<-sum(quantile(count.hist$V3,0.99))
mean<-mean(count.hist$V3)
maxo<-max(count.hist$V3)

plotB<-ggplot(count.hist, aes(V3)) +
  stat_ecdf(geom = "step") +
  theme(legend.position="top") +
  coord_cartesian(xlim=c(0,xlim)) +
  geom_vline(xintercept=mean, linetype="solid", color = "red", size=0.5) +
  geom_vline(xintercept=mean*5, linetype="dashed", color = "red", size=0.5) +
  geom_vline(xintercept=mean/5, linetype="dashed", color = "red", size=0.5) +
  xlab("Per Oligo Seq Coverage") + ggtitle(paste0("Oligo Cov CDF - truncated, max: ",maxo)) +
  theme_bw() + theme(panel.grid.major = element_line(size = .25,colour = rgb(0,0,0,75,maxColorValue=255)), panel.grid.minor = element_blank())

parsed<-flags[flags$V5==0,]
parsed$V7<-as.numeric(parsed$V7)
plotC<-ggplot(parsed, aes(x=V7)) +
  geom_histogram()+
  theme(legend.position="top") +
  xlab("Error Rate for Passing Barcodes") + ggtitle("Oligo Error Rate") +
  theme_bw() + theme(panel.grid.major = element_line(size = .25,colour = rgb(0,0,0,75,maxColorValue=255)), panel.grid.minor = element_blank())

flag.ct<-data.frame(table(flags$V5))
colnames(flag.ct)<-c("Flag","Freq")
flag.ct$Flag<-as.character(flag.ct$Flag)
flag.ct[flag.ct$Flag==0,]$Flag<-"Passing"
flag.ct[flag.ct$Flag==2,]$Flag<-"Failed or No Mapping"
flag.ct[flag.ct$Flag==1,]$Flag<-"Conflict"

flag.ct$percent <- (flag.ct$Freq/sum(flag.ct$Freq)) * 100
flag.ct$row<-1

plotD<-ggplot(flag.ct, aes(x = row,y = Freq, fill = Flag)) +
  geom_bar(stat="identity") +
  theme_bw() + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +
  ggtitle("Sequence Mapping") +
  geom_text(aes(label = percent), position = position_stack(vjust = 0.5))

#length(readLines(paste0(prefix,".merged.extendedFrags.fastq")))
#length(readLines(paste0(prefix,".merged.notCombined_1.fastq")))
#length(readLines(paste0(prefix,".merged.rc.match")))

seen<-nrow(count.hist)
total<-nrow(fasta)
per<-round(seen/total,4)*100

grid.title<-paste0(prefix," - ",per,"% captured - ",seen,"/",total)

pdf(paste0(prefix,"_barcode_plots.pdf"), width = 10, height = 10) # Open a new pdf file
grid.arrange(plotA,plotB,plotC,plotD,top=grid.title)
dev.off()


#!/usr/bin/env Rscript

path <- NULL
args = commandArgs(trailingOnly=TRUE)
if (length(args) == 0) {
  stop("Please provide a path to NBA_ML repo", call.=FALSE)
} else if (length(args) == 1) {
  path <- args[1]
}

install.packages("foreign", repos="http://cran.us.r-project.org")
install.packages("ggplot2", repos="http://cran.us.r-project.org")
install.packages("dplyr", repos="http://cran.us.r-project.org")
install.packages("gridExtra", repos="http://cran.us.r-project.org")

library(foreign)
library(ggplot2)
library(gridExtra)
library(dplyr)

# change into NBA_ML direcotry
setwd(path)

#Best: Cleveland Cavaliers, Golden State Warriors, Atlanta Hawks, Houston Rockets, Chicago Bulls.
cleavland <- read.arff("arffs/teams/Cleveland_Cavaliers.arff")
golden_state <- read.arff("arffs/teams/Golden State_Warriors.arff")
atlanta <- read.arff("arffs/teams/Atlanta_Hawks.arff")
huston <- read.arff("arffs/teams/Houston_Rockets.arff")
chicago <- read.arff("arffs/teams/Chicago_Bulls.arff")

#Worst: New York Knicks, Minnesota Timberwolves, Philadelphia 76ers, Sacramento Kings
nyknicks <- read.arff("arffs/teams/New York_Knicks.arff")
minnesota <- read.arff("arffs/teams/Minnesota_Timberwolves.arff")
philadelphia <- read.arff("arffs/teams/Philadelphia_76ers.arff")
sacramento <- read.arff("arffs/teams/Sacramento_Kings.arff")

allTeams <- list(cleavland, golden_state, atlanta, huston, chicago, nyknicks, minnesota, philadelphia, sacramento)
teamNames <- c("Cleveland_Cavaliers", "Golden_State_Warriors", "Atlanta_Hawks", "Houston_Rockets", "Chicago_Bulls",
               "New_York_Knicks", "Minnesota_Timberwolves", "Philadelphia_76ers", "Sacramento_Kings")

multiplot <- function(..., plotlist=NULL, cols) {

  require(grid)
  # Make a list from the ... arguments and plotlist
  plots <- c(list(...), plotlist)
  numPlots = length(plots)

  # Make the panel
  plotCols = cols                          # Number of columns of plots
  plotRows = ceiling(numPlots/plotCols) # Number of rows needed, calculated from # of cols

  # Set up the page
  grid.newpage()
  pushViewport(viewport(layout = grid.layout(plotRows, plotCols)))
  vplayout <- function(x, y)
    viewport(layout.pos.row = x, layout.pos.col = y)

  # Make each plot, in the correct location
  for (i in 1:numPlots) {
    curRow = ceiling(i/plotCols)
    curCol = (i-1) %% plotCols + 1
    print(plots[[i]], vp = vplayout(curRow, curCol ))
  }
}

# Generate all plots
for (i in 1:length(allTeams)) {
  team <- allTeams[[i]]
  teamName <- teamNames[i]

  # Plot 3-pointers
  fg3_attmpt_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=fg3_attempted_total, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))
  fg3_made_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=fg3_made_total, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))

  # Calculate 2-pointers
  f2_attempted <- team$fg_attempted_total - team$fg3_attempted_total
  fg2_made <- team$fg_made_total - team$fg3_made_total

  # Plot 2-pointers
  fg2_attmpt_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=f2_attempted, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))
  fg2_made_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=fg2_made, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))

  # Plot all free throws
  ft_attmpt_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=ft_attempted_total, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))
  ft_made_plot <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=ft_made_total, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") +
    scale_color_manual(name = "Season Year", values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))

  # Game v. Total Players
  game_v_total_players <- ggplot(arrange(team, season_year, game_id), aes(x=1:length(team[,1]), y=total_players_accounted, color = cut(season_year, c(-Inf, 13, 14, 15, Inf)))) +
    geom_point() + geom_smooth() + xlab("Game Number") + ylab("Players per Game") + scale_color_manual(name = "Season Year",
    values = c("(-Inf,13]" = "#F8766D", "(13,14]" = "#00BFC4", "(14,15]" = "#619CFF"), labels = c('2013', '2014', '2015'))

  if (!file.exists("season_plots")) {
    dir.create(path = paste(getwd(), "/season_plots", sep = ""))
  }
  outfileName <- paste("season_plots/", teamName, ".tiff", sep = "")
  tiff(file = outfileName, width = 5200, height = 5200, units = "px", res = 420)
  multiplot(fg3_attmpt_plot, fg3_made_plot,
            fg2_attmpt_plot, fg2_made_plot,
            ft_attmpt_plot, ft_made_plot,
            game_v_total_players,
            cols = 2)
  dev.off()
}


##' Create a toy individualised data set of seroprevalence
##'
##' @param n number of sample to generate per country
##' @param pos_eqi a named list of vectors of size 3, each name corresponding to the country represented, and the three elements of the vector corresponding to the proportion positive and equivocal (the reminder being negative)
##' @param survey.yr an integer vector: year(s) during which the seroprevalence studies occurred
##' @param lower.age.limits an integer vector: lower limits of the age groups for which to generate data
##' @return a data frame representing a toy data set of individual serology results, with columns \code{survey.yr} (the year of the survey), \code{country} (the country), \code{age1} (the lower limit of the age group) and \code{stdres} (the standardised result)
##' @author Sebastian Funk <sebastian.funk@lshtm.ac.uk>
##' @export
##' @examples
##'   ms.sero <- toy_sero_ds(survey.yr=2002, pos_eqi=list(Spain=c(0.8, 0.1), Ireland=c(0.9, 0)), lower.age.limits=seq(0, 70, by=5), n=100)
toy_sero_ds <- function(n, pos_eqi, survey.yr, lower.age.limits)
{
  if (length(survey.yr)==1) survey.yr <- rep(survey.yr, length(pos_eqi))

  df <- list()
  for (i in seq_len(length((pos_eqi))))
  {
      country <- names(pos_eqi)[i]
      df[[i]] <-
          data.frame(survey.yr = survey.yr[i],
                     country = country,
                     age1 = sample(lower.age.limits,
                                   size=n,
                                   replace=TRUE),
                     stdres = sample(x=c("POS", "EQI", "NEG"),
                                     size=n,
                                     prob=c(pos_eqi[[country]], 1-sum(pos_eqi[[country]])),
                                     replace=TRUE))
  }

  return(do.call(rbind, df))
}


# first make a a determenisti and stochastic forcast and save the results in for.det and for.sto
# load('run/FORECAST.RData'); for.det<-forecast; summary(for.det); summary(for.det[[1]]);
# load('run/FORECAST.RData'); for.sto<-forecast ;  summary(for.sto);  summary(for.sto[[1]]);

# N2013
N2013.sto<-lapply(for.sto,function(x){exp(apply(x$last.state.sim[,1:10],2,median))})
N2013.det<-lapply(for.det,function(x){exp(apply(x$last.state.sim[,1:10],2,median))})
N2013.det
matrix(unlist(N2013.sto),ncol=10,byrow=T)/matrix(unlist(N2013.det),ncol=10,byrow=T)

# N2014
N2014.sto<-lapply(for.sto,function(x){exp(apply(x$s1.state.sim[,1:10],2,median))})
N2014.det<-lapply(for.det,function(x){exp(apply(x$s1.state.sim[,1:10],2,median))})
N2014.det
matrix(unlist(N2014.sto),ncol=10,byrow=T)/matrix(unlist(N2014.det),ncol=10,byrow=T)

SSB2014.sto<-lapply(for.sto,function(x){(apply(x$s1.ssb.sim,2,median))})
SSB2014.det<-lapply(for.det,function(x){(apply(x$s1.ssb.sim,2,median))})
unlist(SSB2014.sto)/unlist(SSB2014.det)

for.det[[1]]$s2.ssb.sim

# N2015
N2015.sto<-lapply(for.sto,function(x){exp(apply(x$s2.state.sim[,1:10],2,median))})
N2015.det<-lapply(for.det,function(x){exp(apply(x$s2.state.sim[,1:10],2,median))})
N2015.det
round(matrix(unlist(N2015.sto),ncol=10,byrow=T)/matrix(unlist(N2015.det),ncol=10,byrow=T),4)

#WB herring
SSB2015.sto<-lapply(for.sto,function(x){median(x$s2.ssb.sim,2)})
SSB2015.det<-lapply(for.det,function(x){median(x$s2.ssb.sim,2)})

SSB2015.sto<-lapply(for.sto,function(x){(apply(x$s2.ssb.sim,2,median))})
SSB2015.det<-lapply(for.det,function(x){(apply(x$s2.ssb.sim,2,median))})

unlist(SSB2015.sto)/unlist(SSB2015.det)

# N2016
N2016.sto<-lapply(for.sto,function(x){exp(apply(x$s3.state.sim[,1:10],2,median))})
N2016.det<-lapply(for.det,function(x){exp(apply(x$s3.state.sim[,1:10],2,median))})
N2016.det
round(matrix(unlist(N2016.sto),ncol=10,byrow=T)/matrix(unlist(N2016.det),ncol=10,byrow=T),4)

SSB2016.sto<-lapply(for.sto,function(x){(apply(x$s3.ssb.sim,2,median))})
SSB2016.det<-lapply(for.det,function(x){(apply(x$s3.ssb.sim,2,median))})

#WB herring
SSB2016.sto<-lapply(for.sto,function(x){median(x$s3.ssb.sim,2)})
SSB2016.det<-lapply(for.det,function(x){median(x$s3.ssb.sim,2)})

round(unlist(SSB2016.sto)/unlist(SSB2016.det),4)

for.det[[1]]$s2.catch.sim
C2015.sto<-lapply(for.sto,function(x){(median(x$s2.catch.sim))})
C2015.det<-lapply(for.det,function(x){(median(x$s2.catch.sim))})
round(unlist(C2015.sto)/unlist(C2015.det),4)

#WB herring
SSB2015.sto<-lapply(for.sto,function(x){median(x$s2.ssb.sim,2)})
SSB2015.det<-lapply(for.det,function(x){median(x$s2.ssb.sim,2)})

# extract N 2015 from the first forecast option
matrix(unlist(N2015.sto),ncol=10,byrow=T)
N<-matrix(unlist(N2015.sto),ncol=10,byrow=T)[1,]
N

# just checing they are the same
for.sto[[1]]$ave.sw
for.det[[1]]$ave.sw

sum(for.sto[[1]]$ave.sw*for.sto[[1]]$ave.pm*N)   # the simple way
N %*% (for.sto[[1]]$ave.sw*for.sto[[1]]$ave.pm)  # the Anders way
SSB2015.sto[[1]]
SSB2015.sto[[1]] / sum(for.sto[[1]]$ave.sw*for.sto[[1]]$ave.pm*N)

sum(for.det[[1]]$ave.sw*for.sto[[1]]$ave.pm*N)   # the simple way
N %*% (for.sto[[1]]$ave.sw*for.sto[[1]]$ave.pm)  # the Anders way
SSB2015.det[[1]]
SSB2015.det[[1]] /sum(for.det[[1]]$ave.sw*for.sto[[1]]$ave.pm*N)

#The right way
lapply(for.det,function(x){apply(exp(x$s2.state.sim[,1:10])*rep(x$ave.sw*x$ave.pm,each=2),1,sum)})
SSB2015.det<-lapply(for.det,function(x){median(apply(exp(x$s2.state.sim[,1:10])*rep(x$ave.sw*x$ave.pm,each=2),1,sum))})

lapply(for.sto,function(x){apply(exp(x$s2.state.sim[,1:10])*rep(x$ave.sw*x$ave.pm,each=1000),1,sum)})
SSB2015.sto<-lapply(for.sto,function(x){median(apply(exp(x$s2.state.sim[,1:10])*rep(x$ave.sw*x$ave.pm,each=1000),1,sum))})

unlist(SSB2015.sto)/unlist(SSB2015.det)

# ###########################################
 library(MASS)

noSim<-30000
var1<-0.8
var2<-var1*0.75
var12<-0.1    # co-var
mu1<-4
mu2<-mu1/2
weight<-c(1,10)
sigma<-matrix(c(var1,var12,var12,var2),ncol=2)
logN<-mvrnorm(noSim, mu=c(mu1,mu2), Sigma=sigma)

plot(logN[,1],logN[,2])
hist(logN[,1])

N<-exp(logN)
N.median<-apply(N,2,median)
#N.median
if (noSim<=10) log(N.median)
if (noSim<=10) c(mu1,mu2)    # there is no bias in N
bio.deter<-exp(c(mu1,mu2))*weight
if (noSim<=10) bio.deter
bio.deter<-sum(bio.deter)
if (noSim<=10) bio.deter

if (noSim<=10) N
bio<-N*rep(weight,each=noSim)
if (noSim<=10) bio

bio<-apply(bio,1,sum)
if (noSim<=10) bio
bio.sto<-median(bio)

bio.sto/bio.deter
#######

# The same, but mu and variance and weight is the same for both of them

noSim<-1000000
sd1<-0.8
var1<-sd1**2
var2<-var1
var12<-var1/4    # co-var
mu1<-4
mu2<-mu1*1
weight<-c(1,1)
sigma<-matrix(c(var1,var12,var12,var2),ncol=2)
logN<-mvrnorm(noSim, mu=c(mu1,mu2), Sigma=sigma)

par(mfcol=c(2,2))
hist(logN[,1],xlab='logN1',main=paste("age 1, logN, mean:",round(mean(logN[,1]),4)))
abline(v=mean(logN[,1]),col='red')

hist(exp(logN[,1]),xlab='exp(logN1)',main=paste("age 1, exp(logN),median:",round(median(exp(logN[,1])),4),'\n exp(logN):',round(exp(mu1),4)))
abline(v=median(exp(logN[,1])),col='red')

hist(logN[,2],xlab='logN2',main=paste("age 2, logN, mean:",round(mean(logN[,2]),4)))
abline(v=mean(logN[,2]),col='red')

hist(exp(logN[,2]),xlab='exp(logN1)',main=paste("age 2, exp(logN),median:",round(median(exp(logN[,2])),4),'\n exp(logN):',round(exp(mu1),4)))
abline(v=median(exp(logN[,2])),col='red')

par(mfcol=c(1,1))

N<-exp(logN)
bio.deter<-exp(c(mu1,mu2))*weight
bio.deter<-sum(bio.deter)
bio.deter

bio<-N*rep(weight,each=noSim)
bio<-apply(bio,1,sum)
bio.sto<-median(bio)
hist(bio,main=paste('median bio:',round(bio.sto,4),'\n determ bio:',round(bio.deter,4),'\n ratio stock:determ',round(bio.sto/bio.deter,4)))
abline(v=bio.sto,col='red')

#######

neafc<-function(sd1=0.8,var2Fac=1,mu1=4,mu2Fac=1,noSim=100000,weight=c(1,10)){
  var1<-sd1*sd1
  var2<-var1*var2Fac
  var12<-var1/5    # co-var

  mu2<-mu1*mu2Fac
  sigma<-matrix(c(var1,var12,var12,var2),ncol=2)
  logN<-mvrnorm(noSim, mu=c(mu1,mu2), Sigma=sigma)
  N<-exp(logN)
  bio.sto<-N*rep(weight,each=noSim)
  bio.sto.corrected<-bio.sto # "corrected" later on

  bio.sto<-apply(bio.sto,1,sum)
  bio.sto<-median(bio.sto)

  #cat('\nbefore adjustement')
  #print(bio.sto.corrected)

  cor.fac<-exp(rep(0.5*c(var1,var2),each=noSim))
  #print(cor.fac)

  bio.sto.corrected<-bio.sto.corrected/cor.fac

  #cat('\nafter adjustement\n')
  #print(bio.sto.corrected)
   bio.sto.corrected<-apply(bio.sto.corrected,1,sum)
  #cat('\nsum after adjustement\n')
  #print(bio.sto.corrected)
  bio.sto.corrected<-mean( bio.sto.corrected)
  # cat('\nmean of sum after adjustement\n')
  #print(bio.sto.corrected)

  bio.deter<-sum(exp(c(mu1,mu2))*weight)

  return(list(dterm=bio.deter,stoch=bio.sto,stoch.corr=bio.sto.corrected))
}

sd1<-seq(0.1,1.0,0.05)
do.it<-function(i){neafc(sd1=sd1[i],mu2Fac=1,var2Fac=1,weight=c(1,1)) }
res<-lapply(1:length(sd1),do.it)

res<-matrix(unlist(res),ncol=3,byrow=T)
matplot(sd1,res,ylab='Absolute values') #abs values

matplot(sd1,res/rep(res[,1],each=3),ylab='Relativ to deterministic') #relative to deterministic values


#' Hexagonal heatmap of 2d bin counts
#'
#' Divides the plane into regular hexagons, counts the number of cases in
#' each hexagon, and then (by default) maps the number of cases to the hexagon
#' fill.  Hexagon bins avoid the visual artefacts sometimes generated by
#' the very regular alignment of [geom_bin2d()].
#'
#' @eval rd_aesthetics("geom", "hex")
#' @seealso [stat_bin2d()] for rectangular binning
#' @param geom,stat Override the default connection between `geom_hex()` and
#'   `stat_binhex()`.
#' @export
#' @inheritParams layer
#' @inheritParams geom_point
#' @export
#' @examples
#' d <- ggplot(diamonds, aes(carat, price))
#' d + geom_hex()
#'
#' \donttest{
#' # You can control the size of the bins by specifying the number of
#' # bins in each direction:
#' d + geom_hex(bins = 10)
#' d + geom_hex(bins = 30)
#'
#' # Or by specifying the width of the bins
#' d + geom_hex(binwidth = c(1, 1000))
#' d + geom_hex(binwidth = c(.1, 500))
#' }
geom_hex <- function(mapping = NULL, data = NULL,
                     stat = "binhex", position = "identity",
                     ...,
                     na.rm = FALSE,
                     show.legend = NA,
                     inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomHex,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomHex <- ggproto("GeomHex", Geom,
  draw_group = function(data, panel_params, coord, lineend = "butt",
                        linejoin = "mitre", linemitre = 10) {
    if (empty(data)) {
      return(zeroGrob())
    }

    # Get hex sizes
    if (!is.null(data$width)) {
      dx <- data$width[1] / 2
    } else {
      dx <- resolution(data$x, FALSE)
    }
    # Adjust for difference in width and height of regular hexagon. 1.15 adjusts
    # for the effect of the overlapping range in y-direction on the resolution
    # calculation
    if (!is.null(data$height)) {
      dy <- data$height[1] /  sqrt(3) / 2
    } else {
      dy <- resolution(data$y, FALSE) / sqrt(3) / 2 * 1.15
    }

    hexC <- hexbin::hexcoords(dx, dy, n = 1)

    n <- nrow(data)

    data <- data[rep(seq_len(n), each = 6), ]
    data$x <- rep.int(hexC$x, n) + data$x
    data$y <- rep.int(hexC$y, n) + data$y

    coords <- coord$transform(data, panel_params)

    ggname("geom_hex", polygonGrob(
      coords$x, coords$y,
      gp = gpar(
        col = coords$colour,
        fill = alpha(coords$fill, coords$alpha),
        lwd = coords$size * .pt,
        lty = coords$linetype,
        lineend = lineend,
        linejoin = linejoin,
        linemitre = linemitre
      ),
      default.units = "native",
      id.lengths = rep.int(6, n)
    ))
  },

  required_aes = c("x", "y"),

  default_aes = aes(
    colour = NA,
    fill = "grey50",
    size = 0.5,
    linetype = 1,
    alpha = NA
  ),

  draw_key = draw_key_polygon
)

# Draw hexagon grob
# Modified from code by Nicholas Lewin-Koh and Martin Maechler
#
# @param x positions of hex centres
# @param y positions
# @param size vector of hex sizes
# @param gp graphical parameters
# @keyword internal
#
# THIS IS NO LONGER USED BUT LEFT IF CODE SOMEWHERE ELSE RELIES ON IT
hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) {
  if (length(y) != length(x)) abort("`x` and `y` must have the same length")

  dx <- resolution(x, FALSE)
  dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15

  hexC <- hexbin::hexcoords(dx, dy, n = 1)

  n <- length(x)

  polygonGrob(
    x = rep.int(hexC$x, n) * rep(size, each = 6) + rep(x, each = 6),
    y = rep.int(hexC$y, n) * rep(size, each = 6) + rep(y, each = 6),
    default.units = "native",
    id.lengths = rep(6, n), gp = gp
  )
}


# list all input files in popmap
ind_list <- scan("popmap.txt", what="character")
species <- unique(paste(sapply(strsplit(ind_list, "_"), "[[", 1), sapply(strsplit(ind_list, "_"), "[[", 2), sep="_"))
species_all <- paste(sapply(strsplit(ind_list, "_"), "[[", 1), sapply(strsplit(ind_list, "_"), "[[", 2), sep="_")

# define parameters
# species order = cossypha, crithagra, melaenornis, parophasma, turdus, zosterops
# gen time = 2 * age of sexual maturity in closely-related species from genomics.senescence.info/species
# age of sex. maturity for each = one year
# method citation = doi: 10.1016/j.cub.2015.03.047
gen <- 2
mu <- c(2.23024e-9, 2.061943e-9, 2.151193e-9, 2.074098e-9, 2.122962e-9, 2.294e-9)* gen # needs to be per generation
# species number (number per each species)
# 5, 5, 6, 3, 6, 5
mu <- c(rep(mu[1], 5), rep(mu[2], 5), rep(mu[3], 6), rep(mu[4], 3), rep(mu[5], 6), rep(mu[6], 5))
min_age <- 000
max_age <- 500000
plotting_age_range <- 1000 # years for x axis

# loop through each output directory
output <- list()
for(a in 1:length(ind_list)) {

	# identify main output file
	a_main <- paste("output/", ind_list[a], ".final.txt", sep="")

	# read in main file
	a_rep <- read.table(a_main, sep="\t", header=T)
	# rearrange main file for plotting lines
	for(d in 1:nrow(a_rep)) {
		if(d == 1) {
			a_rep2 <- rbind(c(a_rep[d,2], a_rep[d,4]), c(a_rep[d,3], a_rep[d,4]))
		} else {
			a_rep2 <- rbind(a_rep2, c(a_rep[d,2], a_rep[d,4]), c(a_rep[d,3], a_rep[d,4]))
		}
	}
	a_rep <- a_rep2
	# scale by mutation rate
	a_rep[,1] <- a_rep[,1] / mu[a] * gen
	a_rep[,2] <- (1 / a_rep[,2]) / (2 * mu[a])
	# remove very young and old time frames prone to error
	a_rep <- a_rep[a_rep[,1] >= min_age & a_rep[,1] <= max_age,]
	# scale by plotting age range and pop size range
	a_rep <- a_rep / plotting_age_range
	# add to output list
	output[[a]] <- a_rep

}

# define current pop sizes
current_pop <- c()
for(a in 1:length(output)) {
	current_pop <- c(current_pop, output[[a]][1,2])
}

# harmonic mean of pop sizes from most recent to 200k years ago
harmonic_pop <- c()
for(a in 1:length(output)) {
	out_rep <- output[[a]]

	# define time series
	time_series <- seq(from=as.integer(out_rep[2,1])+1, to=200, by=1)
	# time series pops
	time_pops <- c()
	for(b in 1:length(time_series)) {
		time_pops <- c(time_pops, out_rep[time_series[b] < out_rep[,1],][1,2])
	}
	# harmonic mean of this individual
	harm_rep <- length(time_pops) / sum((1 / time_pops))

	# add to output element
	harmonic_pop <- c(harmonic_pop, harm_rep)
}

# define output
output <- data.frame(individual=as.character(ind_list), current_pop=as.numeric(current_pop), harmonic_pop=as.numeric(harmonic_pop))

#write output
write.table(output, file="pop_sizes.txt", sep="\t", row.names=F, quote=F)


# ---
# jupyter:
#   jupytext:
#     formats: ipynb,R:percent
#     text_representation:
#       extension: .R
#       format_name: percent
#       format_version: '1.2'
#       jupytext_version: 1.2.4
#   kernelspec:
#     display_name: 'R: ABCD'
#     language: R
#     name: ir-abcd
# ---

# %% [markdown]
# # model.r - generates tables.
#

# %% [markdown]
# ## Setup

# %%

# %% [markdown]
# ## 1: Characteristics of study participants across ASD and non-ASD groups

# %%
# Characteristics of participants in full sample
table_1_all <- abcd_frame %>%
    select(
        age_years,
        scrn_asd,
        prodromal_summary_score,
        prodromal_distress_score,
        sex,
        race_white_only,
        race_black_only,
        race_other_expanded,
        ethnicity_latinx,
        income_to_needs,
        fh_psychosis,
        trauma_score,
        delayed_speech,
        maternal_age_at_birth,
        paternal_age_at_birth,
        tb_cardsort,
        tb_picture,
        tb_flanker,
        tb_pattern,
        tb_list) %>%
    skim()  %>%
    filter(stat == "top_counts" | stat == "mean" | stat == "sd") %>%
    select(-c(type, level, formatted)) %>%
    mutate(value = round(value,2)) %>%
    write_excel_csv(here("r","output","table_1","table_1_full_sample.csv"))

# %%
# Characteristics of participants grouped by ASD vs non-ASD
table_1_grouped <- abcd_frame %>%
    select(
        age_years,
        scrn_asd,
        prodromal_summary_score,
        prodromal_distress_score,
        sex,
        race_white_only,
        race_black_only,
        race_other_expanded,
        ethnicity_latinx,
        income_to_needs,
        fh_psychosis,
        trauma_score,
        delayed_speech,
        maternal_age_at_birth,
        paternal_age_at_birth,
        tb_cardsort,
        tb_picture,
        tb_flanker,
        tb_pattern,
        tb_list
    ) %>%
    group_by(scrn_asd) %>%
    skim() %>%
    filter(stat == "top_counts" | stat == "mean" | stat == "sd") %>%
    select(-c(type, level, formatted)) %>%
    mutate(value = round(value,2)) %>%
    write_excel_csv(here("r","output","table_1","table_1_grouped_sample.csv"))

# %%
# Between-group comparisons of continuous variables
table_1_t_tests <- tibble()

for (variable_name in colnames(select(abcd_continuous, -c(scrn_asd)))) {
    variable_t <-
        t.test(abcd_continuous[[variable_name]] ~ abcd_continuous[['scrn_asd']]) %>%
        tidy() %>%
        mutate(variable_name = variable_name)
    table_1_t_tests <- table_1_t_tests %>% bind_rows(variable_t)
}

adjusted_p_from_t <- p.adjust(table_1_t_tests[['p.value']], method = "BH")

table_1_t_tests <- table_1_t_tests %>%
    cbind(adjusted_p_from_t) %>%
    write_excel_csv(here("r","output","table_1","table_1_continuous_t_tests.csv"))

# %%
# Between-group comparisons of categorical variables
table_1_chisq_tests <- tibble()

for (variable_name in colnames(select(abcd_categorical, -c(scrn_asd)))) {
    variable_chisq <-
        chisq.test(
            abcd_categorical[[variable_name]],
            abcd_categorical[['scrn_asd']],
            correct = FALSE) %>%
        tidy() %>%
        mutate(variable_name = variable_name)
    table_1_chisq_tests <- table_1_chisq_tests %>% bind_rows(variable_chisq)
}

adjusted_p_from_chisq <- p.adjust(table_1_chisq_tests[['p.value']], method = "BH")

table_1_chisq_tests <- table_1_chisq_tests %>%
    cbind(adjusted_p_from_chisq) %>%
    write_excel_csv(here("r","output","table_1","table_1_categorical_chisq_tests.csv"))

# %% [markdown]
# ## 2: Predictors of continuous PQ-BC distress score

# %%
predictors_of_continuous_prodromal_distress_score <- lmerTest::lmer(
    prodromal_distress_score ~
        scrn_asd +
        sex +
        rescale(interview_age) +
        race_white_only +
        race_black_only +
        ethnicity_latinx +
        fh_psychosis +
        rescale(trauma_score) +
        rescale(income_to_needs) +
        rescale(tb_cardsort) +
        rescale(tb_list) +
        rescale(tb_pattern) +
        (1 | site_id_l / rel_family_id),
    control=lmerControl(optimizer='bobyqa', optCtrl=list(maxfun=2e5)),
    data = abcd_frame)

# %%
predictors_of_continuous_prodromal_distress_score %>%
    tidy(conf.int=TRUE, conf.method = "Wald") %>%
    arrange(desc(estimate)) %>%
    filter(effect=='fixed') %>%
    write_excel_csv(here("r","output","table_2","table_2_model_parameters.csv")) %>%
    mutate_at(vars(-c(p.value, group, effect, term)), round, 2) %>%
    write_excel_csv(here("r","output","table_2","table_2_model_parameters_rounded.csv"))

# %% [markdown]
# ## 3: Predictors of PQ-BC distress score above 2 SD cutoff

# %%
predictors_of_prodromal_distress_above_cutoff <- glmer(
    binary_distress_psychosis ~
        scrn_asd +
        sex +
        race_white_only +
        race_black_only +
        ethnicity_latinx +
        rescale(trauma_score) +
        rescale(interview_age) +
        rescale(income_to_needs) +
        rescale(tb_cardsort) +
        rescale(tb_list) +
        rescale(tb_pattern) +
        fh_psychosis +
        (1 | site_id_l / rel_family_id),
    control=glmerControl(optimizer='bobyqa', optCtrl=list(maxfun=2e5)),
    family=binomial(link='logit'),
    data = abcd_frame)

# %%
summary(predictors_of_prodromal_distress_above_cutoff)

# %%
predictors_of_prodromal_distress_above_cutoff %>%
    tidy(
        exponentiate = TRUE,
        conf.int = TRUE,
        conf.method = "Wald") %>%
    filter(effect=='fixed') %>%
    arrange(desc(estimate)) %>%
    write_excel_csv(here("r","output","table_3","table_3_model_parameters.csv")) %>%
    mutate_at(vars(-c(p.value, group, effect, term)), round, 2) %>%
    write_excel_csv(here("r","output","table_3","table_3_model_parameters_rounded.csv"))

# %% [markdown]
# ## S1: Missingness by variable

# %%
n_all_participants <- abcd_frame_full %>% nrow()
n_all_participants

# %%
n_retained_participants <- abcd_frame %>% nrow()
n_retained_participants

# %%
n_excluded_participants <- n_all_participants - n_retained_participants
n_excluded_participants

# %%
percentage_retained <- n_retained_participants/n_all_participants*100
round(percentage_retained,2)

# %%
# Characteristics of excluded vs included participants
table_s1 <- abcd_frame_full %>%
    select(
        age_years,
        scrn_asd,
        prodromal_summary_score,
        prodromal_distress_score,
        sex,
        race_white_only,
        race_black_only,
        race_other_expanded,
        ethnicity_latinx,
        n_in_household,
        household_income,
        income_to_needs,
        fh_psychosis,
        trauma_score,
        delayed_speech,
        maternal_age_at_birth,
        paternal_age_at_birth,
        tb_cardsort,
        tb_picture,
        tb_flanker,
        tb_pattern,
        tb_list) %>%
#    group_by(complete_data) %>%
    skim() %>%
    filter(stat == "complete" | stat == "missing") %>%
    select(-c(type, level, formatted)) %>%
    pivot_wider(names_from = stat, values_from = value) %>%
    mutate(percent_complete = round((complete / (missing + complete) * 100), 2)) %>%
    rename(n_missing = missing, n_complete = complete) %>%
    arrange(desc(percent_complete))

# %%
table_s1 %>% write_excel_csv(here("r","output","table_s1","table_s1.csv"))

# %% [markdown]
# ## S2: Item-level PQ-BC distress score comparisons

# %%
# Characteristics of participants grouped by ASD vs non-ASD
table_s2_frame <- abcd_frame %>%
    select(
        scrn_asd,
        prodromal_1b_y,
        prodromal_2b_y,
        prodromal_3b_y,
        prodromal_4b_y,
        prodromal_5b_y,
        prodromal_6b_y,
        prodromal_7b_y,
        prodromal_8b_y,
        prodromal_9b_y,
        prodromal_10b_y,
        prodromal_11b_y,
        prodromal_12b_y,
        prodromal_13b_y,
        prodromal_14b_y,
        prodromal_15b_y,
        prodromal_16b_y,
        prodromal_17b_y,
        prodromal_18b_y,
        prodromal_19b_y,
        prodromal_20b_y,
        prodromal_21b_y)

# get item-level summary stats before running between-group comparisons

table_s2_frame %>%
    group_by(scrn_asd) %>%
    skim() %>%
    filter(stat == "mean" | stat == "sd") %>%
    select(-c(type, level, formatted)) %>%
    mutate(value = round(value,2)) %>%
    write_excel_csv(here("r","output","table_s2","table_s2_summary_stats.csv"))

table_s2_anovas <- tibble()

for (variable_name in colnames(select(table_s2_frame, -c(scrn_asd)))) {
    variable_anova <-
        aov(table_s2_frame[[variable_name]] ~ table_s2_frame[['scrn_asd']]) %>%
        tidy() %>%
        mutate(variable_name = variable_name)
    table_s2_anovas <- table_s2_anovas %>% bind_rows(variable_anova)
}

adjusted_p_from_anova <- p.adjust(table_s2_anovas[['p.value']], method = "BH")

table_s2_anovas <- table_s2_anovas %>%
    cbind(adjusted_p_from_anova) %>%
    write_excel_csv(here("r", "output", "table_s2", "table_s2_anovas.csv"))

# %% [markdown]
# ## S3: Predictors of parent-reported ASD

# %%
# Validity check: are the predictors of ASD what one would expect?
# MLM does not converge - so using GEE here.

predictors_of_asd <- geeglm(
    unfactor(scrn_asd) ~
        unfactor(sex) +
        race_white_only +
        race_black_only +
        droplevels(ethnicity_latinx) +
        delayed_speech +
        rescale(interview_age) +
        rescale(income_to_needs) +
        rescale(maternal_age_at_birth) +
        rescale(paternal_age_at_birth),
    family=binomial(link='logit'),
    id = rel_family_id,
    data = abcd_frame)

# %%
summary(predictors_of_asd)

# %%
predictors_of_asd %>%
    tidy(
        exponentiate = TRUE,
        conf.int = TRUE,
        conf.method = "Wald") %>%
    mutate(statistic = sqrt(statistic)) %>% # wald to Z
    arrange(desc(estimate)) %>%
    write_excel_csv(here("r","output","table_s3","table_s3_model_parameters.csv")) %>%
    mutate_at(vars(-c(p.value, term)), round, 2) %>%
    write_excel_csv(here("r","output","table_s3","table_s3_model_parameters_rounded.csv"))

# %%
predict_asd_frame <- predict_asd %>%
    tidy(exponentiate=TRUE, conf.int=TRUE) %>%
    mutate(statistic = sqrt(statistic)) # wald to z

# %%
# Total scores
range(abcd_frame$prodromal_summary_score)
round(mean(abcd_frame$prodromal_summary_score),2)
round(sd(abcd_frame$prodromal_summary_score),2)

# %%
# Distress scores
range(abcd_frame$prodromal_distress_score)
round(mean(abcd_frame$prodromal_distress_score),2)
round(sd(abcd_frame$prodromal_distress_score),2)

# %%
# Number of participants who meet the 2 SD / top 5% cutoff
abcd_frame %>% filter(binary_distress_psychosis==1) %>% nrow()

# %%
# Number of ASD participants who meet the cutoff
abcd_frame %>% filter(binary_distress_psychosis==1 & scrn_asd==1) %>% nrow()

# %%
# Extent to which summary and distress scores correlate
round(cor(abcd_frame$prodromal_summary_score, abcd_frame$prodromal_distress_score),2)


read_ames_radiosonde <- function(filename)
{
  #print(paste("Opening file", filename))
  # Open the connection so that it stays open for the whole time
  f <- file(filename, open="rt")

  #print(filename)

  daily_result <- data.frame(timestamp=rep(as.POSIXct("1970-01-01 00:00:00"), 62), pwc=rep(NA, 62))

  # Read the first line, if it is character(0) then we've got EOF
  # so exit
  hdr_line = readLines(f, n=1)
  if (identical(hdr_line, character(0))) break

  # Parse the header
  header <- strsplit(hdr_line, " +")
  nlines = as.numeric(header[[1]][1])

  # Read the data lines under this header into a temp variable
  # so we can skip to the next header
  temp <- readLines(f, n=nlines-1)

  i = 1

  # Loop indefinitely
  while (1)
  {
    dateline = readLines(f, n=1)
    #print(dateline)
    #browser()
    #print(dateline)
    if (identical(dateline, character(0))) break

    dateline <- str_replace(dateline, ":99", ":00")
    timestamp = strptime(dateline, "%Y%m%d %H:%M")
    #browser()

    params_line = strsplit(readLines(f, n=1), " +")
    n_levels = as.numeric(params_line[[1]][1])

    wmo_id = as.numeric(readLines(f, n=1))
    #print(wmo_id)
    station_name = readLines(f, n=1)
    station_country = readLines(f, n=1)

    main_data = readLines(f, n=n_levels)
    main_data_str = paste(main_data, sep="", collapse="\n")

    if (main_data_str == "")
    {
      next()
    }

    t = textConnection(main_data_str)

    df <- read.table(t)
    names(df) <- c("level_number", "pressure", "altitude", "air_temperature", "dew_point_temperature", "wind_dir", "wind_speed")

    df[] <- lapply(df, function(x) {replace(x, x == 9999999.0, NA)})

    df$dew_point_temperature <- df$dew_point_temperature - 273.15
    df$pressure = df$pressure / 100
    df$e <- 6.11 * 10^(  (7.5*df$dew_point_temperature) / (237.7 + df$dew_point_temperature)  )
    df$mixing_ratio <- 621.97 * (  df$e / (df$pressure - df$e)   )

    #browser()

    # Remove rows with an NA in the mixing ratio
    df <- df[!is.na(df$mixing_ratio),]

    if (nrow(df) < 5)
    {
      close(t)
      next
    }

    pwc <- integral(df$pressure, df$mixing_ratio)$value / 100

    # Any PWC over 60 or less than 0 is obviously an error so skipped
    # (reference to http://www.springerreference.com/docs/html/chapterdbid/30434.html
    # which says max over equator is 44 - so not going to be over 60 in UK!)
    if (pwc > 60 || pwc < 0 )
    {
      close(t)
      next
    }

    daily_result[i,]$timestamp = timestamp
    daily_result[i,]$pwc = pwc
    daily_result[i,]$wmo_id = wmo_id

    #daily_result[i,] = c(as.POSIXct(date+time, origin=as.POSIXct("1970-01-01 00:00:00")), pwc)
    i = i+1
    close(t)
  }
  close(f)
  #browser()
  daily_result = na.exclude(daily_result)
  daily_result = daily_result[!duplicated(daily_result$timestamp),]

  ts <- daily_result$timestamp

  daily_result$timestamp <- NULL

  if (nrow(daily_result) > 0)
  {
    daily_result$wmo_id = wmo_id
  }

  #browser()

  #z <- as.zoo(daily_result, order.by = ts)
  z <- zoo(daily_result, order.by = ts)

  return(z)
}


# @created: 08/08/21
# @modified: 12/08/21
# @author: Hakim Benkirame, Yoann Pradat
#
#     CentraleSupelec
#     MICS laboratory
#     9 rue Juliot Curie, Gif-Sur-Yvette, 91190 France
#
# Simulate multi-omics data with known clusters.

suppressPackageStartupMessages(library(argparse))
suppressPackageStartupMessages(library(InterSIM))

# functions ============================================================================================================

write_table_with_index_header <- function(data, file, sep="\t") {
    write.table(cbind(probe=row.names(data),data), file, sep = sep,
                append = FALSE, quote = FALSE, row.names = FALSE, col.names = TRUE)
}

simulated_data_generation <- function(out.folder, num.clusters, clusters.size="heterogeneous", predefined=TRUE) {

    # Number of clusters
    num.clusters <- as.numeric(num.clusters)
    # Size of the effect
    effect <- 2.5

    # Sample proportions per clusters defined here are those used for the paper
    prop_predefined <- list(
        "heterogeneous" = list(
            "5" = c(0.35, 0.13, 0.19, 0.08, 0.25),
            "10" = c(0.20, 0.10, 0.07, 0.10, 0.15, 0.13, 0.10, 0.08, 0.05, 0.02),
            "15" = c(0.10,0.08,0.04,0.03,0.12,0.03,0.10,0.03,0.05,0.02,0.1,0.2,0.03,0.02,0.05)
        ),
        "equal" = list(
            "5" = c(0.25,0.2,0.2,0.2,0.15),
            "10" = c(0.15,0.1,0.1,0.1,0.1,0.1,0.05,0.1,0.1,0.1),
            "15" = c(0.07,0.07,0.07,0.06,0.07,0.07,0.07,0.06,0.07,0.06,0.07,0.06,0.07,0.06,0.07)
        )
    )

    # Check provided parameter (clusters.size) against allowed values
    if(! clusters.size %in% names(prop_predefined)) {
        print(paste0("ERROR: clusters.size can only assume value : ",
                     paste0(names(prop_predefined), collapse=","),
                     " found : ", clusters.size))
    }

    if(predefined) {
        if(! as.character(num.clusters) %in% names(prop_predefined[[clusters.size]])) {
            print(paste0("ERROR: num.clusters can only assume value : ",
                         paste0(names(prop_predefined[[clusters.size]]), collapse=","),
                         " found : ",
                         num.clusters))
        }
        prop <- prop_predefined[[clusters.size]][[as.character(num.clusters)]]
        prop[1] <- 1-sum(prop[-1])
    }
    else {
        if(clusters.size == "equal") {
            equals <- rep(1, num.clusters)
            prop <- equals/sum(equals)
            # - slightly imbalanced
            delta <- 0.05*prop[1]
            prop[1] <- prop[1]+delta
            prop[num.clusters] <- prop[num.clusters]-delta
            # - sum is 1
            prop <- round(prop, digits = 10)
            prop[1] <- 1-sum(prop[-1])
        }
        else {
            random <- runif(n = num.clusters, min = 0, max = 1)
            prop <- random/sum(random)
        }
    }

    # Simulate data based on provided parameters
    cat(paste("--cluster proportions: ", paste(prop, collapse=" "), "\n"))
    sim.D <- InterSIM(n.sample=1000, cluster.sample.prop=prop,
                      delta.methyl=effect, delta.expr=effect, delta.protein=effect,
                      p.DMP=0.25, p.DEG=NULL, p.DEP=NULL,
                      do.plot=FALSE, sample.cluster=TRUE, feature.cluster=TRUE)

    # Export simulations as tables
    write.table(sim.D$clustering.assignment, paste(out.folder, "clusters.txt", sep="/"), sep="\t")
    write_table_with_index_header(t(sim.D$dat.methyl), paste(out.folder, "methyl.txt", sep="/"))
    write_table_with_index_header(t(sim.D$dat.expr), paste(out.folder, "gene_exp.txt", sep="/"))
    write_table_with_index_header(t(sim.D$dat.protein), paste(out.folder, "protein.txt", sep="/"))
}

# parameters ===========================================================================================================
parser <- ArgumentParser(description='Simulate.')
parser$add_argument("--n_clusters", type="integer", default=32, help="Numer of cluster to simulate")
parser$add_argument("--clusters_size", type="character", default="heterogeneous",
                    help="Parameter for defining cluster proportions.")
parser$add_argument("--random_state", type="integer", default=123, help="Seed for random generator.")
parser$add_argument("--output", type="character", default="InterSIM/", help="Paths to output directory.")
parser$add_argument('--log', type="character", help='Path to log file.')
args <- parser$parse_args()

dir.create(args$output, showWarnings=F)

# log file
log <- file(args$log, open="wt")
sink(log)
sink(log, type="message")

print(args)

# Run ==================================================================================================================
set.seed(args$random_state)

cat("-simulating data...\n")
simulated_data_generation(out.folder=args$output,
                          num.clusters=args$n_clusters,
                          clusters.size=args$clusters_size,
                          predefined=TRUE)
cat("ok!\n")


library(hdfmat)

f = tempfile()
n = "mydata"
type = "double"

nr = 3
nc = 5
x = matrix(1:(nr*nc), nr, nc)
storage.mode(x) = type

h = hdfmat::hdfmat(f, n, nr, nc, type)
h$fill(x)

test = h$read()
truth = x

stopifnot(all.equal(test, truth))

h$close()
unlink(f)


library(tidyverse)

results_cpu <- read_csv('./results_cpu.csv') %>% rename(obs=X1, nb=nk)
results_jit <- read_csv('./results_jit.csv') %>% rename(obs=X1, nb=nk)
results_gpu <- read_csv('./results_gpu.csv') %>% rename(obs=X1, nb=nk)

master <- bind_rows(results_cpu, results_jit, results_gpu)

table <- master %>%
  spread(key='target', value='time') %>%
  select(obs, nb, cpu, jit, gpu)

statistics <- master %>%
  mutate(time = na_if(time, 0)) %>%
  group_by(target, nb) %>%
  summarize(
    avg_time = mean(time, na.rm=TRUE),
    std_time = sd(time, na.rm=TRUE),
    min_time = min(time, na.rm=TRUE),
    q25_time = quantile(time, 0.25, na.rm=TRUE),
    q50_time = quantile(time, 0.50, na.rm=TRUE),
    q75_time = quantile(time, 0.75, na.rm=TRUE),
    max_time = max(time, na.rm=TRUE)
  )

statistics %>% ggplot(aes(x=nb)) +
  geom_ribbon(aes(ymin=min_time, ymax=max_time, fill=target), alpha=0.3) +
  geom_line(aes(y=avg_time, color=target)) +
  labs(color="Function", fill="Function") +
  xlab('Number of gridpoints on state space') +
  ylab('VFI time (seconds)')
ggsave('./slides/img/benchmarks.pdf', width=20, height=8, units='cm')

statistics %>% ggplot(aes(x=nb)) +
  geom_ribbon(aes(ymin=min_time, ymax=max_time, fill=target), alpha=0.3) +
  geom_line(aes(y=avg_time, color=target)) +
  coord_trans(y='log10') +
  labs(color="Function", fill="Function") +
  xlab('Number of gridpoints on state space') +
  ylab('VFI time (seconds, log scale)')
ggsave('./slides/img/benchmarks-logscale.pdf', width=20, height=8, units='cm')

# statistics %>%
#   filter(nb == 100 | nb == 1000) %>%
#   arrange(nb, desc(target)) %>%
#   as.data.frame() %>%
#   stargazer::stargazer(out='./summary_results.tex', type='text', align=TRUE,
#                        summary=FALSE, rownames=FALSE, digits=5)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assessment of body mass effects
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list = ls()) # clears workspace
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(mgcv) # for 'gam'
library(jtools) # for interact_plot
library(RColorBrewer)
library(ggplot2)
library(plyr)
library(corrplot)
library(ppcor) # partial corr
library(xtable) # for latex table export
source('R/FracFeed-Functions.r') # Convenience functions
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
load('Data/FracFeed_DataPhylo.Rdata')
#####################################################################
pdf(
  'Output/Plots/FracFeed-AllomScale_VarCors.pdf',
  height = 20,
  width = 20
)
pairs(fdat[, c('fF', 'TAlog', 'SAlog', 'BMlog')], pch = 21, cex = 1)
dev.off()

pdf(
  'Output/Plots/FracFeed-AllomScale_VarCors_v2.pdf',
  height = 5,
  width = 5
)
corrplot(
  cor(fdat[, c('fF', 'TAlog', 'SAlog', 'BMlog')],
      use = 'pairwise.complete.obs'),
  method = 'ellipse',
  order = 'AOE',
  type = 'lower',
  tl.pos = "d"
)
corrplot(
  cor(fdat[, c('fF', 'TAlog', 'SAlog', 'BMlog')],
      use = 'pairwise.complete.obs'),
  add = TRUE,
  method = 'number',
  order = 'AOE',
  type = 'upper',
  tl.pos = "d",
  cl.pos = "n"
)
dev.off()

datNA <- fdat[, c('BMlog', 'SAlog', 'TAlog')]
datNA <- datNA[complete.cases(datNA),]

pdf(
  'Output/Plots/FracFeed-AllomScale_VarPCors.pdf',
  height = 5,
  width = 5
)
pairs(datNA, pch = 21, cex = 1)
dev.off()

pdf(
  'Output/Plots/FracFeed-AllomScale_VarPCors_v2.pdf',
  height = 5,
  width = 5
)
corrplot(
  pcor(datNA, method = 'pearson')$estimate,
  method = 'ellipse',
  order = 'AOE',
  type = 'lower',
  tl.pos = "d"
)
corrplot(
  pcor(datNA, method = 'pearson')$estimate,
  add = TRUE,
  method = 'number',
  order = 'AOE',
  type = 'upper',
  tl.pos = "d",
  cl.pos = "n"
)
dev.off()

################################################
# General model specifications
# (justified in GAM_robustness)
################################################
# quasibinomial(link='logit')
fam <- quasibinomial(link = 'logit')

# To get actual used sample size (after dropped rows)
# (needed for determining BIC-like gamma penalty)
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE + TG + BMlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML')
gamma <- log(nrow(fit$model)) / 2

############################################
# Base model w/ log10(Body Mass) included
# Note: This drops some taxonomic groups too
############################################

fit.BM1 <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE + TG + BMlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

nrow(fit$model)
nrow(fdat[fit$na.action, ])

incl <- fdat[-fit$na.action, ]
nrow(incl)
length(unique(incl$Consumer.identity))

# plot(fit,residuals=F,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch='.',pages=1)
summary(fit)

# Conclusion:
# No log-mass effect (but see below) -- all sucked up by Taxon Group effects
# Southern high-latitude and 1940-50's trends affected
# Ecosystem affected a little

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Repeat without TG
# (which will be correlated with BM)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit.BM2 <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE + s(BMlog),
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

nrow(fit$model)
nrow(fdat[fit$na.action, ])

# plot(fit,residuals=F,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch='.',pages=1)
summary(fit)

# Conclusion:
# Year effect restored
# Latitude effect only restored if EE is not included
# Body mass effect significant
# Diet richness linearized
# TA effect reduced (a little less positive)
# SA effect increased (a lot more negative)

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Compare to (base) model lacking both TG and BM
# but applied to the reduced BM data set
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    TAlog + SAlog + Eco + EE,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = subset(fdat, !is.na(BM)),
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

nrow(fit$model)
nrow(fdat[fit$na.action, ])

# plot(fit,residuals=F,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch='.',pages=1)
summary(fit)

# Conclusion:
# It's partly the reduced data set...
# TA effect closer to base model on full data set lacking BM
# SA effect even more negative than full dataset lacking BM and than reduced data set containing BM.

####################################################
# Investigate relationships between BM and TA and SA
####################################################
Pal <- 'Spectral'
nPal <- 6
colPal <- colorRampPalette(brewer.pal(nPal, Pal))

SBTreg = lm(SAlog ~ BMlog * TAlog, data = fdat)
summary(SBTreg)
names(SBTreg$coefficients) <-
  c('Intercept', 'Body mass', 'Temporal scale', 'Mass x Time')
tab.out <- summary(SBTreg)

setwd('Figures/Supp/')
print(
  xtable(
    tab.out,
    type = "latex",
    caption = 'Summary table for the linear least squares regression of spatial scale on predator body mass and temporal scale and their interaction. Residual standard error: 1.177 on 1305 degrees of freedom. Multiple R$^2$: 0.452,	Adjusted R$^2$: 0.451 F-statistic: 359.6 on 3 and 1305 DF, p-value: $<$ 2.2 x 10$^{-16}$.',
    label = 'tab:lm_SBTreg'
  ),
  file = "FracFeed-Tab-lm_SpaceMassTime.tex",
  table.placement = 'H'
)
setwd('../../')

pdf('Output/Plots/FracFeed-FigS-SA_BM+TA.pdf',
    height = 3,
    width = 5)  # repeated in main text figure
interact_plot(
  SBTreg,
  pred = 'TAlog',
  modx = 'BMlog',
  modx.values = seq(-2, 6, 2),
  interval = T,
  legend.main = 'log Body mass (g)',
  color.class = 'Qual1',
  vary.lty = F,
  x.label = 'Temporal scale',
  y.label = 'Spatial scale'
)
dev.off()

pdf('Output/Plots/FracFeed_SA_BM+TA.pdf',
    height = 3,
    width = 5)
interact_plot(
  SBTreg,
  pred = 'TAlog',
  modx = 'BMlog',
  modx.values = seq(-2, 6, 2),
  interval = T,
  legend.main = 'log Body mass (g)',
  color.class = Pal,
  vary.lty = F,
  x.label = 'Temporal scale',
  y.label = 'Spatial scale',
  linearity.check = T,
  plot.points = T,
  jitter = 0.2,
  point.size = 0.3
)
dev.off()

# op<-par(pty='s')
#   cols<-colPal(nPal)[as.numeric(cut(fdat$BMlog,breaks = nPal+1))]
#   plot(jitter(fdat$TAlog,2),jitter(fdat$SAlog),pch=21,cex=0.5,col=cols,bg=cols)
# par(op)

# Conclusion:
# For BM ~ 1g there is no relationship between TA and SA
# For BM < 1g there is a negative relationship between TA and SA
# For BM ~ 1g there is a positive relationship between TA and SA
# (Effect of BM on SA is only via its interaction with TA)

###############################################################
# Does incorporating 2-way SA*TA interaction in GAM make a difference? (full data set)
fit.2wInt <- fit <- gam(
  (FSc / TSc) ~
    TG + s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    Eco + EE + TAlog * SAlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)

# Concl:  There is no 2-way interaction. But...

###############################################################
# Does incorporating 3-way BM*SA*TA interaction in GAM make a difference?
fit.BM.3wInt <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    Eco + EE + TAlog * SAlog * BMlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)
# plot(fit,residuals=F,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch='.',pages=1)

# Yes, strong support the main, two-way and three-way effects of TA, SA and BM.
# Now all main effects are negative,
# two-way interactions are positive
# and three-way interaction is negative.
# Other than "loss" of southern-latitude decrease (which comes largely from including EE, see above), the effects of the remaining variables remains largely unchanged.

# Export summary tables
p.out <- summary(fit)$p.table
p.out[, 1:3] <- round(p.out[, 1:3], 2)
p.out[, 4] <- round(p.out[, 4], 3)
p.out[p.out[, 4] < 10 ^ -3, 4] <- '< 0.001'

rownames(p.out) <- sub('Eco', '', rownames(p.out))
rownames(p.out) <- sub('EE', '', rownames(p.out))
rownames(p.out) <- sub('TG', '', rownames(p.out))
rownames(p.out) <-
  sub('TAlog:SAlog:BMlog', 'Time x Space x Mass', rownames(p.out))
rownames(p.out) <- sub('SAlog:BMlog', 'Space x Mass', rownames(p.out))
rownames(p.out) <- sub('TAlog:SAlog', 'Time x Space', rownames(p.out))
rownames(p.out) <- sub('TAlog:BMlog', 'Time x Mass', rownames(p.out))
rownames(p.out) <- sub('BMlog', 'Body mass', rownames(p.out))
rownames(p.out) <- sub('TAlog', 'Temporal scale', rownames(p.out))
rownames(p.out) <- sub('SAlog', 'Spatial scale', rownames(p.out))

s.out <- summary(fit)$s.table
s.out[, 1:3] <- round(s.out[, 1:3], 2)
s.out[, 4] <- round(s.out[, 4], 3)
s.out[s.out[, 4] < 10 ^ -3, 4] <- '< 0.001'

setwd('Figures/Supp/')
print(
  xtable(
    p.out,
    type = "latex",
    caption = 'Estimated effects (log-odds) of the parametric terms in the secondary statistical model for the fraction of feeding individuals including predator body mass and its interactions with spatial and temporal scale. Deviance explained = 51.8, adj-$R^2$ = 0.568, n = 1082.',
    label = 'tab:gam_scale3way_p'
  ),
  file = "FracFeed-Tab-GAM_scale_ptable.tex",
  table.placement = 'H'
)

print(
  xtable(
    s.out,
    type = "latex",
    caption = 'Estimated effects of the smooth terms in the secondary statistical model for the fraction of feeding individuals including predator body mass and its interactions with spatial and temporal scale. $tWS$ refers to the days since the last winter solsctice, $Lat$ refers to latitude, $DRlog$ refers to minimum diet richness, and $Year$ refers to the year of the survey',
    label = 'tab:gam_scale3way_s'
  ),
  file = "FracFeed-Tab-GAM_scale_stable.tex",
  table.placement = 'H'
)
setwd('../../')

#~~~~~~~~~~~~~~~~~~~~~~~
# Plot 3-way interaction
#~~~~~~~~~~~~~~~~~~~~~~~
# Compute predictions ("baseline" for other variables)
BMrng <- range(fdat$BMlog[!is.na(fdat$BMlog)], na.rm = T)
predTA <- unique(na.omit(fdat[, c('TA', 'TAlog')]))
predTA <- predTA[order(predTA$TAlog), ]
predSA <- unique(na.omit(fdat[, c('SA', 'SAlog')]))
predSA <- predSA[order(predSA$SAlog), ]

pred <- expand.grid(
  Eco = 'Marine',
  EE = 'Ectotherm',
  tWS = 180,
  Lat = 0,
  DRlog = 0,
  Year = 2015,
  TAlog = predTA$TAlog,
  SAlog = predSA$SAlog,
  BMlog = seq(BMrng[1], BMrng[2], 1)
)
pred <- merge(pred, predTA, all.x = T)
pred <- merge(pred, predSA, all.x = T)
pred$LO <- predict(fit.BM.3wInt, pred)
pred$BM <- 10 ^ pred$BMlog
pred$SA <-
  factor(pred$SA, labels = gsub("([0-9])([A-z])", "\\1 \\2", sort(unique(pred$SA))))

pred.d <- data.frame(
  Eco = 'Marine',
  EE = 'Ectotherm',
  tWS = 180,
  Lat = 0,
  DRlog = 0,
  Year = 2015,
  TAlog = fit.BM.3wInt$model$TAlog,
  SAlog = fit.BM.3wInt$model$SAlog,
  BMlog = fit.BM.3wInt$model$BMlog
)
pred.d <- merge(pred.d, predTA, all.x = T)
pred.d <- merge(pred.d, predSA, all.x = T)
pred.d$LO <- predict(fit.BM.3wInt, pred.d)
pred.d$BM <- 10 ^ pred.d$BMlog
pred.d$SA <-
  factor(pred.d$SA, labels = gsub("([0-9])([A-z])", "\\1 \\2", sort(unique(pred.d$SA))))

# Save for 'FinalFigures'
save(pred, pred.d, file = 'Output/Allometry/FracFeed_AllomFigPreds.Rdata')

# ~~~~~~~~~~~~~~~
trans <- function(x) {
  (x / 2) + 3.75
}
yorig <- seq(-4, 2, 2)
yat <- trans(yorig)

pred <- subset(pred, TAlog < 4)

pdf('Output/Plots/FracFeed_LO-BMxSAbyTA.pdf',
    height = 1.5,
    width = 8)
p <- ggplot(pred.d, aes(
  x = BM,
  y = LO,
  color = SA,
  group = SA
)) +
  geom_line(aes(
    x = BM,
    y = LO,
    color = SA,
    group = SA
  )) +
  geom_line(data = pred,
            aes(
              x = BM,
              y = LO,
              color = SA,
              group = SA
            ),
            alpha = 0.2) +
  facet_grid( ~ TA) +
  theme_bw() +
  theme(
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    legend.text = element_text(size = 9),
    legend.key.height = unit(0.7, "line"),
    axis.text = element_text(size = 7),
    axis.title = element_text(size = 11)
  ) +
  labs(x = 'Body mass (kg)',
       y = expression(atop("Fraction feeding", (italic(
         "log-odds"
       )))),
       color = "Spatial scale") +
  scale_x_log10(
    limits = 10 ^ c(-2, 6),
    breaks = scales::trans_breaks("log10", function(x)
      10 ^ x),
    labels = scales::trans_format("log10", scales::math_format(10 ^
                                                                 .x))
  )
print(p)
dev.off()

pdf('Output/Plots/FracFeed_LO-BMxTAbySA.pdf',
    height = 1.5,
    width = 8)
p <- ggplot(pred.d, aes(
  x = BM,
  y = LO,
  color = TA,
  group = TA
)) +
  geom_line(aes(
    x = BM,
    y = LO,
    color = TA,
    group = TA
  )) +
  geom_line(data = pred,
            aes(
              x = BM,
              y = LO,
              color = TA,
              group = TA
            ),
            alpha = 0.2) +
  facet_grid( ~ SA) +
  theme_bw() +
  theme(
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    legend.text = element_text(size = 9),
    legend.key.height = unit(0.7, "line"),
    axis.text = element_text(size = 7),
    axis.title = element_text(size = 11)
  ) +
  labs(x = 'Body mass (kg)',
       y = expression(atop("Fraction feeding", (italic(
         "log-odds"
       )))),
       color = "Temporal scale") +
  scale_x_log10(
    limits = 10 ^ c(-2, 6),
    breaks = scales::trans_breaks("log10", function(x)
      10 ^ x),
    labels = scales::trans_format("log10", scales::math_format(10 ^
                                                                 .x))
  )
print(p)
dev.off()

###############################################################
# Does incorporating BM*EE interaction make a difference?
fit.BM.4wInt <- fit <- gam(
  (FSc / TSc) ~
    s(tWS, bs = 'cc') + s(Lat) + s(DRlog) + s(Year) +
    Eco + EE * BMlog + TAlog * SAlog * BMlog,
  family = fam,
  weights = TSc,
  knots = list(tWS = c(0, 365)),
  data = fdat,
  na.action = 'na.omit',
  method = 'REML',
  gamma = gamma
)

summary(fit)

# No evidence for EE*BM effect

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


# Benjamini-Hochberg procedure

bh_apply <- function(data, alpha=0.05, time_windows=list(c(300, 500), c(600, 1000))) {
        tws <- time_windows
        dt <- data[, lapply(.SD, mean), by=list(Timestamp, Electrode), .SDcols=colnames(data)[grep("pval", colnames(data))]]
        for (i in colnames(dt)[grep("pval", colnames(dt))]) {
                dt[, paste0("sig_", i)] <- rep(FALSE, nrow(dt))
                for (j in tws) {
                        signi <- (p.adjust(dt[Timestamp >= j[1] & Timestamp <= j[2], ..i][[1]], method='fdr') < alpha)
                        indi <- which(dt$Timestamp >= j[1] & dt$Timestamp <= j[2])
                        dt[indi, paste0("sig_", i) := signi]
                }
        }

        cols <- c("Timestamp", "Electrode", colnames(dt)[grep("sig", colnames(dt))])
        merge(data, dt[,..cols], by=c("Timestamp", "Electrode"))
}

bh_apply_bonf <- function(data, alpha=0.05, time_windows=list(c(300, 500), c(600, 1000))) {
        tws <- time_windows
        dt <- data[, lapply(.SD, mean), by=list(Timestamp, Electrode), .SDcols=colnames(data)[grep("pval", colnames(data))]]
        for (i in colnames(dt)[grep("pval", colnames(dt))]) {
                dt[, paste0("sig_", i)] <- rep(FALSE, nrow(dt))
                for (j in tws) {
                        signi <- (p.adjust(dt[Timestamp >= j[1] & Timestamp <= j[2], ..i][[1]], method='none') < alpha)
                        indi <- which(dt$Timestamp >= j[1] & dt$Timestamp <= j[2])
                        dt[indi, paste0("sig_", i) := signi]
                }
        }

        cols <- c("Timestamp", "Electrode", colnames(dt)[grep("sig", colnames(dt))])
        merge(data, dt[,..cols], by=c("Timestamp", "Electrode"))
}

bh_apply_sepelec <- function(data, alpha=0.05, time_windows=list(c(300, 500), c(600, 1000))) {
        tws <- time_windows
        elecs <- c("Fz", "Cz", "Pz")
        dt <- data[, lapply(.SD, mean), by=list(Timestamp, Electrode), .SDcols=colnames(data)[grep("pval", colnames(data))]]
        for (i in colnames(dt)[grep("pval", colnames(dt))]) {
                dt[, paste0("sig_", i)] <- rep(FALSE, nrow(dt))
                for (j in tws) {
                        for (e in elecs) {
                                signi <- (p.adjust(dt[Timestamp >= j[1] & Timestamp <= j[2] & Electrode == e, ..i][[1]], method='fdr') < alpha)
                                indi <- which(dt$Timestamp >= j[1] & dt$Timestamp <= j[2] & dt$Electrode == e)
                                dt[indi, paste0("sig_", i) := signi]
                        }
                }
        }

        cols <- c("Timestamp", "Electrode", colnames(dt)[grep("sig", colnames(dt))])
        merge(data, dt[,..cols], by=c("Timestamp", "Electrode"))
}

bh_apply_poolall <- function(data, alpha=0.05, time_windows=list(c(300, 500), c(600, 1000))) {
        tws <- time_windows
        elecs <- c("Fz", "Cz", "Pz")
        dt <- data[, lapply(.SD, mean), by=list(Timestamp, Electrode), .SDcols=colnames(data)[grep("pval", colnames(data))]]
        for (i in colnames(dt)[grep("pval", colnames(dt))]) {
                dt[, paste0("sig_", i)] <- rep(FALSE, nrow(dt))
                        signi <- (p.adjust(dt[(Timestamp >= 300 & Timestamp <= 500) | (Timestamp >= 600 & Timestamp <= 1000), ..i][[1]], method='fdr') < alpha)
                        indi <- which((dt$Timestamp >= 300 & dt$Timestamp <= 500) | (dt$Timestamp >= 600 & dt$Timestamp <= 1000))
                        dt[indi, paste0("sig_", i) := signi]
        }

        cols <- c("Timestamp", "Electrode", colnames(dt)[grep("sig", colnames(dt))])
        merge(data, dt[,..cols], by=c("Timestamp", "Electrode"))
}

bh_none <- function(data, alpha=0.05, time_windows=list(c(300, 500), c(600, 1000))) {
        tws <- time_windows
        elecs <- c("Fz", "Cz", "Pz")
        dt <- data[, lapply(.SD, mean), by=list(Timestamp, Electrode), .SDcols=colnames(data)[grep("pval", colnames(data))]]
        for (i in colnames(dt)[grep("pval", colnames(dt))]) {
                dt[, paste0("sig_", i)] <- rep(FALSE, nrow(dt))
                signi <- dt[(dt$Timestamp >= 300 & dt$Timestamp <= 500) | (dt$Timestamp >= 600 & dt$Timestamp <= 1000),..i] < alpha
                indi <- which((dt$Timestamp >= 300 & dt$Timestamp <= 500) | (dt$Timestamp >= 600 & dt$Timestamp <= 1000))
                dt[indi, paste0("sig_", i) := signi]
        }

        cols <- c("Timestamp", "Electrode", colnames(dt)[grep("sig", colnames(dt))])
        merge(data, dt[,..cols], by=c("Timestamp", "Electrode"))
}

bh_identify_cutoff <- function(pvals, alpha = 0.05)
{
        pvals <- sort(pvals)     # sort ascending
        m     <- length(pvals)   # number of hypotheses
        k     <- 1               # k iterator
        for (k in seq(1:m)){
                if (pvals[k] >= k/m * alpha) {
                        break()
                }
        }
        # while (pvals[k] < (k / m) * alpha)
        #         k <- k + 1
        return(pvals[k])
}

bh_plot <- function(pvals, alpha = 0.05)
{
        pvals <- sort(pvals)    # sort ascending
        m     <- length(pvals)  # number of hypothesis
        ks    <- seq(1, length(pvals), 1)
        plot(pvals ~ ks)
        abline(0, alpha / m)
}


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     14.10.2019
#modificado: 27.10.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")

## 1. Scatterplots
?mpg

#table
print(mpg)

#scatterplot
fnam <- "../results/visualization/scatterplot1.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=mpg) +
  geom_point(mapping=aes(x=displ,y=hwy))
dev.off()

#multiple scatterplot
fnam <- "../results/visualization/scatterplot2.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=mpg) +
  geom_point(mapping=aes(x=displ,y=hwy,color=class))
dev.off()

#smoothplot
fnam <- "../results/visualization/scatterplot3.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=mpg) +
  geom_smooth(mapping=aes(x=displ,y=hwy))
dev.off()

#multiple smoothplot
fnam <- "../results/visualization/scatterplot4.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=mpg) +
  geom_smooth(mapping=aes(x=displ,y=hwy,color=class))
dev.off()

## 2. Barplots
?diamonds
print(diamonds)

#barplot
fnam <- "../results/visualization/barplot1.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut))
dev.off()

#barplot (proportions)
fnam <- "../results/visualization/barplot2.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut,y=..prop..,group=1))
dev.off()

#stacked barplot
fnam <- "../results/visualization/barplot3.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut,fill=clarity))
dev.off()

#stacked barplot (proportions)
fnam <- "../results/visualization/barplot4.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut,fill=clarity),position="fill")
dev.off()

#clustered barplot
fnam <- "../results/visualization/barplot5.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_bar(mapping=aes(x=cut,fill=clarity),position="dodge")
dev.off()

## 3. Boxplot
?diamonds
print(diamonds)

#boxplot 1
fnam <- "../results/visualization/boxplot1.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_boxplot(mapping=aes(y=carat))
dev.off()

#boxplot 2
fnam <- "../results/visualization/boxplot2.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_boxplot(mapping=aes(x=cut,y=carat))
dev.off()

## 4. Histograms
?diamonds
print(diamonds)

#histogram 1
fnam <- "../results/visualization/histogram1.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_histogram(mapping=aes(x=carat))
dev.off()

#histogram 2
fnam <- "../results/visualization/histogram2.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_histogram(mapping=aes(x=carat),binwidth=0.01)
dev.off()

#histogram 3
fnam <- "../results/visualization/histogram3.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_freqpoly(mapping=aes(x=carat),binwidth=0.01)
dev.off()

#histogram 4
fnam <- "../results/visualization/histogram4.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_freqpoly(mapping=aes(x=carat,color=cut),binwidth=0.1)
dev.off()

#histogram 5
fnam <- "../results/visualization/histogram5.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_freqpoly(mapping=aes(x=carat,y=..density..,color=cut),binwidth=0.1)
dev.off()

#histogram 6
fnam <- "../results/visualization/histogram6.tiff"
tiff(file=fnam,units="in",width=6,height=4,res=300,compression="lzw")
ggplot(data=diamonds) +
  geom_freqpoly(mapping=aes(x=carat,y=..density..),binwidth=0.1) +
  geom_density(mapping=aes(x=carat),color="red")
dev.off()