#' R tools to visualyze pivot ilo data frame
#'
#'
#' @param df, ilo tbl data frame.
#'
#'
#' @name pivot_ilo
#'
#'
#' @return pivot html table
#'
#' @examples
#' ## Not run:
#'
#' init_ilo()
#'
#'
#' ### quarterly time serie of female unemployed as from 2000 in united states
#'
#' X <- get_ilo(ref_area = 'AFG')
#' pivot_ilo(X)
#' ## End(**Not run**)
#' @export
pivot_ilo <- function(df)
{
    require(shiny)
    require(miniUI)
    #require(leaflet)
    #require(ggplot2)
    require(rpivotTable)
    ui <- miniPage(
		gadgetTitleBar("Shiny gadget example"),
			miniTabstripPanel(
				#miniTabPanel("Data", icon = icon("table"), miniContentPanel(DT::dataTableOutput("table"))),
				miniTabPanel("Pivot", icon = icon("th-list"), miniContentPanel(rpivotTable::rpivotTableOutput("pivot"))) #,
				#miniTabPanel("Parameters", icon = icon("sliders"),
				#	miniContentPanel(sliderInput("year", "Year", 1978, 2010, c(2000, 2010), sep = ""))),
				#miniTabPanel("Visualize", icon = icon("area-chart"),
				#	miniContentPanel(plotOutput("cars",  height = "100%"))),
				#miniTabPanel("Map", icon = icon("map-o"),
				#	miniContentPanel(padding = 0, leafletOutput("map", height = "100%")),
				#	miniButtonBlock(actionButton("resetMap", "Reset"))
				#	)
			)
		)
    server <- function(input, output, session) {
        #output$cars <- renderPlot({
         #   require(ggplot2)
          #  ggplot(cars, aes(speed, dist)) + geom_point()
        #})
        #output$map <- renderLeaflet({
         #   force(input$resetMap)
         #   leaflet(quakes, height = "100%") %>% addTiles() %>%
         #       addMarkers(lng = ~long, lat = ~lat)
        #})
        #output$table <- DT::renderDataTable({
         #   df
        #})
        output$pivot <- rpivotTable::renderRpivotTable({
            rpivotTable(data = df %>% select(	-contains("note"),
												-contains("info"),
												-contains("obs_status")),
						rendererName = "Table",
						rows = c("source", "indicator", "sex", "classif1", "classif2"),
						col = "time",
						aggregatorName = "Sum",
						vals = "obs_value", width = "100%", height = "500px")
        })
        observeEvent(input$done, {
            stopApp(TRUE)
        })
    }
    runGadget(shinyApp(ui, server), viewer = paneViewer())
}


#+setup, include=FALSE, cache=FALSE
library(knitr)
opts_chunk$set(fig.path='figure-pedv-cum/', fig.align='center', fig.show='hold')
options(replace.assign=TRUE,width=80)
Sys.setlocale("LC_TIME", "C") #Needed for identical()
Sys.setlocale("LC_COLLATE", "C")

#' ## Packages
#+
library(car)
library(c060)
library(geoR)
library(ggplot2)
library(glmnet)
library(Hmisc)
library(igraph)
library(maps)
library(plyr)
print(sessionInfo())
set.seed(4253)

#' ## Data loading
#'
#' Farm counts by operation types
#+
tmpf <- function(){
  censPath <- file.path('table-25-hogs-and-pigs-by-operation-type.csv')
  cens <- read.csv(censPath,strip.white=TRUE, na.strings='(D)',
                   stringsAsFactors=FALSE)
  # The introduction to the reports says '-' represents 0 and (D) means deleted for privacy
  tmpf <- function(x) {
      if(is.character(x)){
          ret <- ifelse(x=='-', 0, x)
          type.convert(ret)
      }else{
          x
      }
  }
  cens <- lapply(as.list(cens), tmpf)
  cens <- data.frame(cens)
  test <- cens$GEO %in% state.name
  ind <- grep('.*Farms|GEO|ITEM', colnames(cens))
  stateCounts <- cens[test, ind]

  key <- match(stateCounts$GEO, state.name)
  stateCounts$abb <- state.abb[key]

  test <- stateCounts$ITEM == "Total inventory \\ Farms with 1 to 24"
  smallFarms <- stateCounts[test,]
  test <- stateCounts$ITEM == "Total inventory"
  allFarms <- stateCounts[test,]

  stopifnot(allFarms$GEO == smallFarms$GEO)
  ind <- grep('.*Farms', colnames(allFarms))
  nonSmallFarms <- allFarms
  nonSmallFarms[,ind] <- allFarms[,ind] - smallFarms[,ind]
  nonSmallFarms$ITEM <- NULL

  nonSmallFarms
}
stateData <- tmpf()

#+
tmpf <- function(sd){
    ind <- grep('.*Farms', colnames(sd))
    dists <- sd[,ind]
    rownames(dists) <- sd$abb
    dists
}
dists <- tmpf(stateData)

#' County land areas
#+
data(county.fips, package='maps')
fp <- file.path('2013_Gaz_counties_national.txt')
rd <- read.delim(fp)
rd <- rd[, c('GEOID', 'ALAND')]

#' Hog counts by county
#+
tmpf <- function(){
  censPath <- file.path('table-12-hogs-and-pigs-by-county.csv')
  cens <- read.csv(censPath,strip.white=TRUE, na.strings='(D)',
                   stringsAsFactors=FALSE)
# The introduction to the reports says '-' represents 0 and (D) means deleted for privacy
  tmpf <- function(x) {
      if(is.character(x)){
          ret <- ifelse(x=='-', 0, x)
          type.convert(ret)
      }else{
          x
      }
  }
  cens <- lapply(as.list(cens), tmpf)
  cens <- data.frame(cens)
  test <- cens$STCOFIPS %in% county.fips$fips
  cens <- cens[test,]
  ind <- grep('farms, 2007)$', cens$ITEM)
  cens <- cens[ind,]
  cens
}
countyData <- tmpf()

#' ERS farm resource regions
#+
regs <- read.csv('reglink.csv', skip=2, colClasses=c(NA, NA, 'NULL', 'NULL'))

#' Derive state-level summaries of county-level data
#+
ctyTots <- ddply(countyData, 'STCOFIPS', summarize, totalFarms=sum(DATA), STFIPS=STFIPS[1],
                 smallFarms = sum(DATA["Inventory \\ Total hogs and pigs \\ Farms by inventory \\ 1 to 24 (farms, 2007)" == ITEM]))
ctyTots$nonSmallFarms <- with(ctyTots, totalFarms - smallFarms)
mg <- merge(ctyTots, rd, by.x='STCOFIPS', by.y='GEOID')
mg <- merge(regs, mg, by.x='Fips', by.y='STCOFIPS')
mg$kmsq <- mg$ALAND/1e6
mg$nonSmallDense <- mg$nonSmallFarms / mg$kmsq
stateCty <- ddply(mg, 'STFIPS', summarize, totNonSmall=sum(nonSmallFarms),
                  mDense=mean(nonSmallDense),
                  cmDense=mean(nonSmallDense[nonSmallFarms > 0]),
                  medDense=median(nonSmallDense), maxDense=max(nonSmallDense),
                  reg1=weighted.mean(ERS.resource.region==1, w=nonSmallFarms),
                  reg2=weighted.mean(ERS.resource.region==2, w=nonSmallFarms),
                  reg3=weighted.mean(ERS.resource.region==3, w=nonSmallFarms),
                  reg4=weighted.mean(ERS.resource.region==4, w=nonSmallFarms),
                  reg5=weighted.mean(ERS.resource.region==5, w=nonSmallFarms),
                  reg6=weighted.mean(ERS.resource.region==6, w=nonSmallFarms),
                  reg7=weighted.mean(ERS.resource.region==7, w=nonSmallFarms),
                  reg8=weighted.mean(ERS.resource.region==8, w=nonSmallFarms),
                  reg9=weighted.mean(ERS.resource.region==9, w=nonSmallFarms))
data(state.fips, package='maps')
key <- match(stateCty$STFIPS, state.fips$fips)
stateCty$abb <- state.fips$abb[key]

#' Case data
#+
caseData <- list()
dataDir <- file.path('.')
tmpf <- function(){
  fn <- file.path(dataDir, 'PEDvweeklyreport-state-age-cummulative-01-08-14.csv')
  ret <- read.csv(fn)
  manuallyChecked <- structure(
      list(State = structure(c(1L, 2L, 3L, 4L, 5L, 6L, 7L,
               8L, 9L, 10L, 11L, 12L, 13L, 14L, 15L, 16L, 17L, 18L, 19L, 20L,
               22L, 23L, 21L), .Label = c("CA", "CO", "IA", "IL", "IN", "KS",
                                   "KY", "MD", "MI", "MN", "MO", "NC", "NE", "NY", "OH", "OK", "PA",
                                   "SD", "TN", "TX", "UNKNOWN", "WI", "WY"), class = "factor"),
           Suckling = c(0L, 11L, 132L, 22L, 10L, 52L, 3L, 0L, 2L, 20L,
               2L, 100L, 0L, 2L, 11L, 55L, 4L, 1L, 0L, 6L, 2L, 1L, 1L),
           Nursery = c(1L, 6L, 149L, 10L, 12L, 14L, 0L, 0L, 3L, 42L,
               7L, 50L, 0L, 0L, 20L, 72L, 8L, 0L, 0L, 4L, 1L, 0L, 2L),
           Grower.Finisher = c(0L, 4L, 251L, 13L, 11L, 41L, 0L, 0L, 2L, 27L, 1L, 67L, 0L, 0L,
               10L, 45L, 11L, 0L, 6L, 12L, 1L, 0L, 1L),
           Sow.Boar = c(0L, 8L, 39L, 9L, 5L, 30L, 0L, 0L, 1L, 5L, 3L, 51L, 0L, 0L, 4L,
               37L, 2L, 0L, 0L, 0L, 0L, 0L, 0L),
           Unknown = c(0L, 1L, 108L, 17L, 20L, 8L, 1L, 1L, 1L, 112L, 5L, 38L, 5L, 0L, 14L, 31L,
               0L, 3L, 0L, 6L, 1L, 0L, 10L)),
      .Names = c("State", "Suckling", "Nursery", "Grower.Finisher", "Sow.Boar", "Unknown"),
      class = "data.frame", row.names = c(NA,-23L))
  stopifnot(identical(manuallyChecked, ret))
  nonreporting <- setdiff(state.abb, c(as.character(ret$State)))
  df <- data.frame(State=nonreporting, Suckling=0, Nursery=0, Grower.Finisher=0, Sow.Boar=0, Unknown=0)
  rbind(ret, df)
}
counts <- tmpf()

#' AK and HI are special cases. Let's just look at the coniguous 48
#' states.
#+
exclude <- c('AK', 'HI')
test <- !(counts$State %in% exclude)
counts <- counts[test,]
cts <- reshape(counts, v.names='cases', idvar='State', varying=2:6,
               direction='long', timevar='age', times=names(counts)[2:6])
ctsTot <- ddply(cts, 'State', summarize, cases=sum(cases))

#' Not a very strong relationship, but there is agreement in that
#' states not reporting any cases had much smaller changes in pig
#' litter

#' Shipment flows data
#+
flowMatGet <- function(){
    fp <- file.path('shipment-flows-origins-on-rows-dests-on-columns.csv')
    ep <- read.csv(fp, row.names=1)
    ep <- t(ep)
    key <- na.omit(match(unique(counts$State), colnames(ep)))
    ep <- ep[key, key]
    data.matrix(ep)
}
flowMat <- flowMatGet()

#' Calculate eigenvector centrality. All states except VT (no
#' outshipments) and CT (no inshipments) are in one strongly connected
#' compoent, so it doesn't seem necessary to bother with Katz
#' centrality or the like.
#+
vecGet <- function(symmetric=FALSE, normOutput=FALSE){
    getStateDist <- function(oddsInstate=9, pow=1, ep=flowMat){
        diag(ep) <- rowSums(ep) * 9
        ept <- ep^pow
        if(symmetric & normOutput){
            ret <- rowSums(ept)
            ret <- ret/sum(ret)
        } else {
            if(symmetric){
                ept <- (ept + t(ept))/2
            }
            if(normOutput){
                M <- t(ept)
                kout <- rowSums(M)
                kout <- ifelse(kout==0,1,kout)
                M <- M / kout
                ept <- t(M)
            }
            eig <- eigen(ept, symmetric=symmetric)
            ret <- eig$vector[,1]
            stopifnot(Im(ret)==0)
            ret <- Re(ret)
            names(ret) <- rownames(ep)
            ret <- ret/sum(ret)
        }
        ret
    }
    powers <- as.list(2^(-1*(0:4)))
    tmpf <- function(x) getStateDist(pow=x)
    vecs <- lapply(powers, tmpf)
    vecs <- do.call(rbind, vecs)
    vecs <- t(vecs)
    vecs <- data.frame(State=rownames(vecs), vecs)
    lab <- paste('isSym', symmetric, 'andIsNormed', normOutput, 'andPow', sep='')
    tmpf <- function(x) paste(lab, x, sep='')
    names(vecs)[-1] <- sapply(powers, tmpf)
    vecs
}
args <- expand.grid(symmetric=c(TRUE, FALSE), normOutput=c(TRUE, FALSE))
vecs <- list()
for(i in 1:nrow(args)){
    vecs[[i]] <- do.call(vecGet, args[i,])
}
vecs <- Reduce(merge, vecs)

#' Balance sheet data
#'
#' Hawaii has a dash for inshipments, which we will assumes means a
#' negligible number.
#'
#' We distribute the IdahoWashington row among ID and WA in proportion
#' to the number of nonsmall farms in those states.
#+
bal <- read.csv('state-hogBalanceSheetDec2011Dec2012.csv',
                na.strings='-', row.names=1, colClasses=c(state2='NULL'))
recWA <- recID <- bal['IdahoWashington',]
iWA <- which(stateCty$abb == 'WA')
iID <- which(stateCty$abb == 'ID')
pWA <- with(stateCty, totNonSmall[iWA]/(totNonSmall[iWA] + totNonSmall[iID]))
recWA <- recWA*pWA
recID <- recID*(1-pWA)
bal <- rbind(bal, "Washington"=recWA, "Idaho"=recID)
key <- match(rownames(bal), state.name)
bal$State <- state.abb[key]
bal <- bal[!is.na(bal$State),]
bal['Hawaii','inshipments'] <- 0

#' Derive sampling weights
#'
#' We are calculating sampling weights for each age class in each
#' state based on random sampling of the farms in each state and then
#' random sampling of the pigs on each sampled farm. Census data for
#' each state provides the number of operations of each type in each
#' state. The age distribution of pigs on each farm are calculated as
#' follows.
#'
#' Parameters taken from Stalder (2013) "Pork industry productivity analysis".
#+
agtGet <- function(){
    littersPerSowWeek <- 2.31/52
    meanLitter <- 10.3
    meanWeaningAge <- 21.5/7
    meanGoToFeederAge <- (21.5 + 46.0)/7
    meanSlaughterAge <- (21.5 + 46.0 + 121.5)/7
    sowBoarRatio <- 0
    nSow <- 100
    nBoar <- ifelse(sowBoarRatio > 0, nSow / sowBoarRatio, 0)
    nSowBoar <- nSow + nBoar
    flowRate <- nSow * littersPerSowWeek * meanLitter
    nSuckling <- flowRate * meanWeaningAge
    nNursery <- flowRate * (meanGoToFeederAge - meanWeaningAge)
    nFeeder <- flowRate * (meanSlaughterAge - meanGoToFeederAge)
    agt <- diag(c(nSuckling, nNursery, nFeeder, nSowBoar))
    agt
}
agt <- agtGet()

#' We've computed an age distribution based on the birth rate of sows
#' and the residence time in each production stage. We now create an
#' age distribution for each type of farm based on the age classes
#' present in that farm.
#+
M0 <- cbind(c(1, 0, 0, 1),
            c(1, 1, 1, 1),
            c(0, 0, 1, 0),
            c(1, 1, 0, 1),
            c(0, 1, 0, 0))
W <- agt %*% M0
N <- colSums(W)
W <- scale(W, center=FALSE, scale=N)
dists$Other.Farms <- NULL

#' Now sample weights are computed for each state using distribution
#' of farm types in each state.
#+
wts <- W %*% t(dists)
wts <- data.frame(age=c("Suckling", "Nursery", "Grower.Finisher", "Sow.Boar"),
             wts)
wts <- reshape(wts, v.names='samplingWeight', idvar='age', varying=2:51,
               direction='long', timevar='State', times=names(wts)[2:51])
rm(M0, W, N)

#' Merge predictors
#+
mg <- merge(wts, cts)
mg <- merge(mg, vecs)
mg <- merge(mg, bal)
mgAge <- mg
save(mgAge, file='mgAge.RData')

#' Merge in data on spatial density of farms
#+
mg <- merge(ctsTot, vecs)
mg <- merge(mg, bal)
mg <- merge(mg, stateCty, by.x='State', by.y='abb')
mg$l2CasesOffset <- log2(mg$cases + 0.5)

#' Compare total case counts with change in pig litter
#+
df2 <- read.csv('pigsPerLitterDecemberThruFebrurary2013and2014.csv')
df2$change <- with(df2, pigLitter2014 - pigLitter2013)
key <- match(df2$state, tolower(state.name))
df2$abb <- state.abb[key]
df2$percentDecrease <- df2$change/df2$pigLitter2013 * -100
foo <- df2[!is.na(df2$abb),]
ord <- order(foo$percentDecrease)
dotchart(foo$percentDecrease[ord], labels=foo$abb[ord], xlab='Percent decrease in litter size',
         ylab='State')
v <- df2$percentDecrease[df2$state=='united states']
abline(v=v)
mtext('U.S.', at=v)
v <- df2$percentDecrease[df2$state=='other states']
abline(v=v)
mtext('Other states', at=v)
#
foo <- mg[, c('State', 'cases', 'totNonSmall')]
foo <- merge(foo, df2, by.x='State', by.y='abb', all.x=TRUE)
mg <- merge(mg, df2[, c('abb', 'percentDecrease')], by.x='State', by.y='abb', all.x=TRUE)
#
foo$cumInc <- foo$cases/foo$totNonSmall
with(foo, plot(cumInc ~ percentDecrease, type='n',
               xlab='Percent decrease in litter rate',
               ylab='cases / farms', frame=FALSE))
with(foo, text(percentDecrease, cumInc, labels=State))
summary(lm(cumInc~percentDecrease, data=foo))
ct <- cor.test(foo$percentDecrease, foo$cumInc, method='spearman')
text(2, .6, paste('Spearman rho =', round(ct$estimate, 2)))
text(2, .55, paste('p =', round(ct$p.value, 3)))
dev.off()
#
foo$pdImp <- foo$percentDecrease
foo$pdImp[is.na(foo$pdImp)] <- df2$percentDecrease[df2$state == 'other states']
foo$anyCases <- foo$cases > 0
foo$manyCases <- foo$cases > 8
boxplot(pdImp~ manyCases, data=foo, xlab='More than 8 cases',
            ylab='Percent decrease in pig litter')

wilcox.test(pdImp ~ anyCases, data=foo)
wilcox.test(pdImp ~ manyCases, data=foo)

#' #' Add lat longs
#+
key <- match(mg$State, state.abb)
mg$stateLong <- state.center$x[key]
mg$stateLat <- state.center$y[key]

#' Add predictor based on mean number of cases in states with shared
#' borderline
#+
borderMatGet <- function(){
    nbEdgelist <- read.csv('state_neighbors_fips.txt', header=FALSE)
    g <- graph.data.frame(nbEdgelist, directed=FALSE)
    g <- simplify(g)
    key <- match(V(g)$name, state.fips$fips)
    abb <- state.fips$abb[key]
    V(g)$name <- as.character(abb)
    states <- levels(mg$State)
    vids <- which(V(g)$name %in% states)
    g2 <- induced.subgraph(g, vids)
    nhood <- as.matrix(get.adjacency(g2))
}
borderMat <- borderMatGet()
nbWeightGet <- function(M, flowTrans=identity, normFlows=TRUE){
    M <- flowTrans(M)
    if(!normFlows){
        ret <- (M)
    } else {
        N <- rowSums(M)
        N <- ifelse(N > 0, N, 1)
        ret <- M/N
    }
    ret
}
nbCasesGet <- function(..., caseTrans=function(x) log2(x + 0.5), symmetrize=FALSE){
    W <- nbWeightGet(...)
    avgc <- tapply(mg$cases, mg$State, mean)
    key <- match(colnames(W), names(avgc))
    avgc <- avgc[key]
    stopifnot(names(avgc) == colnames(W))
    if(symmetrize){
        W <- (W + t(W))/2
    }else{
        W <- t(W)
    }
    avgNbC <- W %*% avgc
    avgNbC <- caseTrans(avgNbC)
    data.frame(State=rownames(avgNbC), avgNbC=avgNbC)
}
foo <- nbCasesGet(M=borderMat, normFlows=TRUE)
names(foo)[2] <- 'carNbC'
mg <- merge(mg, foo)
tmpf <- function(y){
   ret <- nbCasesGet(M=flowMat, flowTrans=function(x) x^y, normFlows=FALSE)
   names(ret)[2] <- paste('casesFlowNb', y, sep='')
   ret
}
powers <- as.list(2^(-1*(0:4) ))
foo <- lapply(powers, tmpf)
for(i in seq_along(foo)){
    mg <- merge(mg, foo[[i]])
}
rm(powers, foo)

#' ## Analysis
#'
#' Examine colinearity
#'
#+ , fig.width=11.11, fig.height=11.11, out.width=800, out.height=800
getPreds <- function(df, transform=c('identity', 'log'),
                     predNames=c('totNonSmall', 'mDense',
'cmDense', 'medDense', 'maxDense', 'inventory2012', 'pigCrop',
'inshipments', 'marketings')){
    transform <- match.arg(transform)
    df <- df[, predNames]
    x <- data.matrix(df)
    bot <- min(x[x[,'medDense'] > 0, 'medDense']) / 2
    if(transform=='log'){
        x[, 'medDense'] <- x[,'medDense'] + bot
        log(x)
    } else {
        x
    }
}
x <- getPreds(df=mg, transform='id')
xlog <- getPreds(df=mg, transform='log')
scatterplotMatrix(xlog, transform=FALSE, cex.labels=1.5, pch=16,
                  col=c(palette()[3:2], rgb(0,0,0,0.25)), cex.axis=2)

#' Add in the eigenvector centrality predictors, exept for the one set
#' that predicts all of the cases in Vermont (i.e.,
#' isSymFALSEisNormedTRUE* predictors). Vermont only ships to itself,
#' so a random walk gets trapped there in those cases. Clearly that is
#' a bad model so we'll remove them.
#'
#+
getOtherPreds <- function(D, X){
    xEig <-  D[, grep('^isSym', colnames(D))]
    xEig <- xEig[, -grep("^isSymFALSEandIsNormedTRUE", colnames(xEig))]
    sel <- D[, grep('^reg|^casesFlowNb|^carNb', colnames(D))]
    ret <- data.matrix(cbind(X, sel, xEig))
    rownames(ret) <- as.character(D$State)
    ret
}
xx <- getOtherPreds(D=mg, X=x)
xxlog <- getOtherPreds(D=mg, X=xlog)

#' We have too many predictors for a scatterplot matrix to be
#' useful. Let's do PCA.
#+
pc <- prcomp(xx, scale=TRUE)
pve <- summary(pc)$importance[2,]
cve <- summary(pc)$importance[3,]
par(mfrow=c(1,2))
plot(pve, xlab='Principle component', ylab='PVE', type='o', col='blue')
plot(cve, xlab='Principle component', ylab='Cumulative PVE', type='o', col='blue')
par(mfrow=c(1,1))
biplot(pc)
biplot(pc, c(1,3))

#' The plot is crowded, but you can see that IA is extreme on PC1 and
#' an outlier on PC2. NC on the other hand, is extreme on PC1 and an
#' outlier on PC3.
#'
#' Next let's check the transformed-only data.
#+
pc <- prcomp(xxlog, scale=TRUE)
pve <- summary(pc)$importance[2,]
cve <- summary(pc)$importance[3,]
par(mfrow=c(1,2))
plot(pve, xlab='Principle component', ylab='PVE', type='o', col='blue')
plot(cve, xlab='Principle component', ylab='Cumulative PVE', type='o', col='blue')
par(mfrow=c(1,1))
biplot(pc)
biplot(pc, c(1,3))

#' The data is roughly three dimensional with most of the
#' variation in one dimension but the data seems more evenly spread
#' over the space and perhaps more likely to provide a useful model.
#'
#' Model of all cases
#+
alphas <- 0:5/5
tmpf <- function(alpha){
    cv.glmnet(x=xxlog, y=mg$l2CasesOffset, alpha=alpha)
}
cvsAll <- lapply(alphas, tmpf)

#' PCA of selected variables
#+
b <- drop(coef(cvsAll[[6]]))[-1]
pcAll1 <- prcomp(xxlog[, b>0], scale=TRUE)
biplot(pcAll1)

#' Check prediction error by alpha
#+
plot3Alphas <- function(fitList, alphas, which=4:6, ...){
 ## Adpated from http://www.stanford.edu/~hastie/glmnet/glmnet_alpha.html
 opar <- par(mfrow = c(2, 2))
 cv <- fitList[which]
 a <- alphas[which]
 tmpf <- function(x,y) {
     main <- substitute(expression(paste(alpha, '=', y)), list(y=y))
     plot(x, sub=main, ...)
 }
 invisible(mapply(tmpf, x=cv, y=a))
 ls <- lapply(cv, '[[', 'lambda.1se')
 plot(log(cv[[1]]$lambda), cv[[1]]$cvm, pch = 19, col = "red", xlab = "log(Lambda)",
         ylab = cv[[1]]$name, ...)
 abline(v=log(ls[[1]]), col="red")
 points(log(cv[[2]]$lambda), cv[[2]]$cvm, pch = 19, col = "grey")
 abline(v=log(ls[[2]]), col="grey")
 points(log(cv[[3]]$lambda), cv[[3]]$cvm, pch = 19, col = "blue")
 abline(v=log(ls[[3]]), col="blue")
 legend("topleft", legend = paste('alpha =', a), pch = 19,
           col = c("red", "grey", "blue"))
 par(opar)
}
plot3Alphas(cvsAll, alphas, ylim=c(0,10))

#' There's no alpha with a decisive predicition error advantage here.
#'
#' Some Diagnostics
#+
m <- cvsAll[[6]]
yhat <- predict(m, type='response', new=xxlog)
lmfit <- lm(mg$l2CasesOffset~0, offset=yhat)
layout(matrix(1:4, 2))
plot(lmfit, which=1:3)

#' The trend in the mean of the residuals and the small variance for
#' low predictions look a little troublesome and suggest we try a
#' hurdle model.
#'
#' Logistic regression for prob non-zero
#+
mg$anyCases <- factor(mg$cases > 0)
tmpf <- function(alpha){
    cv.glmnet(x=xxlog, y=mg$anyCases, alpha=alpha, family='binomial')
}
cvsBin <- lapply(alphas, tmpf)
lsBin <- lapply(cvsBin, '[[', 'lambda.1se')
mapply(function(x, y) x$cvm[which(x$lambda == y)], x=cvsBin, y=lsBin)
layout(matrix(1:6, ncol=3))
tmpf <- function(x,y) {
    main <- substitute(expression(paste(alpha, '=', y)), list(y=y))
    plot(x, sub=main)
}
invisible(mapply(tmpf, x=cvsBin, y=alphas))

#' Visualization of coefficients
#'
#+
coefplot <- function(fitList, preds, which=3:6){
  coefMat <- sapply(fitList, function(x) as.numeric(coef(x)))[-1,]
  rownames(coefMat) <- rownames(coef(fitList[[1]]))[-1]
  colnames(coefMat) <- paste('alpha', alphas, sep='')
  coefMat <- t(coefMat)
  par(mfrow=c(1,2),
      mar=c(20,4,1,1))
  barplot(coefMat[which,], beside=T, las=2, ylab='Coefficients')
  scales <- apply(preds, 2, sd)
  coefMatStd <- coefMat
  stopifnot(names(scales)==colnames(coefMat))
  for(i in 1:nrow(coefMatStd)){
      coefMatStd[i,] <- coefMatStd[i,] * scales
  }
  test <- abs(colSums(coefMatStd[which,])) > 0.01
  barplot(coefMatStd[which,test], beside=T, las=2, ylab='Standardized coefficients')
  par(mfrow=c(1,1),
      mar=c(5,4,4,1) + 0.1)

}
coefplot(cvsBin, xxlog, which=4:6)

#' Diagnostics for logistic fit
#+
mbin <- cvsBin[[6]]
yhatb <- predict(mbin, type='link', new=xxlog)
anyCasesInt <- as.integer(as.logical(mg$anyCases))
glmfit <- glm(anyCasesInt~0, offset=yhatb, family=binomial)
layout(matrix(1:4, 2))
plot(glmfit, which=1:3)
Ep <- residuals(glmfit, type='pearson')

#' Next let's check for outliers. Because of our tricky way of
#' producing glmfit, this will be a t-test on the deviance residuals
#' instead of the usual studentized residuals, but that seems unlikely
#' to be an issue.
#+
outlierTest(glmfit)

#' Bubble plot of residuals on U.S. map
#+
df <- data.frame(res=as.vector(Ep), x=mg$stateLong, y=mg$stateLat, state=mg$State)
all_states <- map_data("state")
p <- ggplot()
p <- p + geom_polygon(data=all_states, aes(x=long, y=lat, group = group),colour="white", fill="grey10" )
p <- p + geom_point(data=df, aes(x=x, y=y, size=abs(res)*2, color=as.factor(sign(res))))
p

#' The colors seem to go together somewhat, which means there may be
#' some spatial correlations.
#+
#' Get great circle distance
#+
cx <- df$x
cy <- df$y
E <- df$res
n <- length(cx)
centerDists <- matrix(nrow=n, ncol=n)

#' Calculates the geodesic distance between two points specified by radian latitude/longitude using the
#' Haversine formula (hf)
#' source: http://www.r-bloggers.com/great-circle-distance-calculations-in-r/
#+
gcd.hf <- function(long1, lat1, long2, lat2) {
      R <- 6371 # Earth mean radius [km]
        delta.long <- (long2 - long1)
        delta.lat <- (lat2 - lat1)
        a <- sin(delta.lat/2)^2 + cos(lat1) * cos(lat2) * sin(delta.long/2)^2
        c <- 2 * asin(min(1,sqrt(a)))
        d = R * c
        return(d) # Distance in km
  }
deg2rad <- function(deg) return(deg*pi/180)
getCenterDist <- function(state1,state2){
    long1 <- deg2rad(cx[state1])
    long2 <- deg2rad(cx[state2])
    lat1 <- deg2rad(cy[state1])
    lat2 <- deg2rad(cy[state2])
    gcd.hf(long1, lat1, long2, lat2)
}
for(i in seq_len(n)){
    for(j in seq_len(n)){
        centerDists[i,j] <- getCenterDist(i, j)
    }
}
colnames(centerDists) <- rownames(centerDists) <- df$state

#' Now lets find points on 2-d plane that satisfy distances
#+
loc <- cmdscale(centerDists)
x <- -loc[, 1]
y <- loc[,2]
plot(x, y, type='n', asp=1)
text(x, y, rownames(loc), cex=.6)

#' Now lets check for correlations in space
#+
sE <- E/sd(E)
vg <- variog(coords=loc, data=sE, max.dist=2000)
olsFit <- variofit(vg, cov.model='exponential')
likFit <- likfit(coords=loc, data=sE, cov.model='exponential', ini.cov.pars=c(.1, 194))
par(mfrow=c(1,1))
plot(vg)
lines(olsFit)
lines(likFit, lwd=2)

#' The densley packed, spatially autocorrelated states in the North
#' East might be exerting too much influence. Let's try to identify
#' groups of close states and combine their data into a single
#' observation.
#'
#+
clus <- hclust(as.dist(centerDists), method='single')
plot(clus)
abline(h=175)

#' If we cut the single-linkage tree at 175, it seems lead to sensible
#' groupings. So let's create a new data set with rows from those
#' states averaged together.
#+
groups <- cutree(clus, h=175)
tmpf <- function(x) names(groups)[groups==x]
groupL <- lapply(unique(groups), tmpf)
tmpf <- function(x){
  rows <- mg$State %in% x
  M <- data.matrix(mg[rows,-1])
  colMeans(M)
}
rowsAvg <- lapply(groupL, tmpf)
mgAvg <- do.call(rbind, rowsAvg)
rownames(mgAvg) <- sapply(groupL, paste, collapse='-')
mgAvg <- data.frame(mgAvg)
mgAvg[, 'anyCases'] <- factor(mgAvg[, 'cases'] > 0)

xlogAvg <- getPreds(df=mgAvg, transform='log')
xxlogAvg <- getOtherPreds(D=mgAvg, X=xlogAvg)
rownames(xxlogAvg) <- rownames(mgAvg)

mbinavg <- cv.glmnet(x=xxlogAvg, y=mgAvg$anyCases, alpha=1, family='binomial')
mbinavg0.8 <- cv.glmnet(x=xxlogAvg, y=mgAvg$anyCases, alpha=0.8, family='binomial')

cbind(drop(coef(mbin)), drop(coef(mbinavg)))
cbind(drop(coef(cvsBin[[5]])), drop(coef(mbinavg0.8)))

#' That weighting has resulted in minor changes to the estimated
#' coefficients and some changes to the selected variables. Notably,
#' median farm density has been selected when alpha=0.8 for the
#' averaged data, and inshipments has been selected instead of
#' eigenvector centrality when alpha=1.
#+
yhatavg <- predict(mbinavg, type='link', new=xxlogAvg)
anyCasesIntAvg <- as.integer(as.logical(mgAvg$anyCases))
glmfitavg <- glm(anyCasesIntAvg~0, offset=yhatavg, family=binomial)
layout(matrix(1:4, 2))
plot(glmfitavg, which=1:3)
Epavg <- residuals(glmfitavg, type='pearson')
sEpavg <- Epavg/sd(Epavg)
locAvg <- with(mgAvg, cbind(x=stateLong, y=stateLat))
vgavg <- variog(coords=locAvg, data=sEpavg, max.dist=2000)
plot(vgavg)

#' The variogram looks much better.
#'
#' Next we model the positive counts
#+
test <- as.logical(mgAvg$anyCases)
sub <- mgAvg[test, ]
subx <- xxlogAvg[test, ]
subl <- locAvg[test,]
alphas <- 0:5/5
tmpf <- function(alpha){
    cv.glmnet(x=subx, y=log(sub$cases), alpha=alpha, nfolds=5)
}
cvsPos <- lapply(alphas, tmpf)

#' The diagnostics
#+
m <- cvsPos[[6]]
yhat <- predict(m, type='response', new=subx)
lmfit <- lm(log(sub$cases)~0, offset=yhat)
layout(matrix(1:4, 2))
plot(lmfit, which=1:3)
Ep <- residuals(lmfit, type='pearson')
vg <- variog(coords=subl, data=Ep/sd(Ep), max.dist=2000)
olsFit <- variofit(vg, cov.model='exponential')
likFit <- likfit(coords=subl, data=Ep/sd(Ep), cov.model='exponential', ini.cov.pars=c(.01, 400))
plot(vg)
lines(olsFit)
lines(likFit, lwd=2)

#' There's a trend in the residuals vs fitted, but that's probably
#' just showing us that the shrinkage is protecting us from
#' overestimating the coefficients. The semivariogram looks good.
#'
#' Let's see if there are any concerning patterns in plots of the
#' residuals versus predictors.
#+
for(i in colnames(subx)){
    plot(Ep~subx[, i], main=i, pch=16, col=rgb(0,0,0,0.7), xpd=TRUE)
    text(subx[, i], jitter(Ep, amount=0.1), labels=sub$State)
}

#' It's a little surprising that the region 1 doesn't get selected,
#' but that's probably because it is correlated with population size.
#+
plot(reg1~inventory2012,data=mgAvg)
cor.test(mgAvg$reg1, mgAvg$inventory2012)

#' The eigenvector predictors often seem to be grouped together with
#' the balance sheet ones. That is to be expected, given that the
#' flows are derived in part from the balance sheet data. Perhaps it
#' is not worth presenting the eigenvector results, which will take a
#' while to properly describe and not really change the
#' conclusions. So, let's do a final round of fitting without them.
#'
#' ## Fits without eigenvector predictors
#+
xf <- xxlogAvg[, -grep('^isSym', colnames(xx))]
xfpc <- prcomp(xf, scale=TRUE)
summary(xfpc)
biplot(xfpc)
biplot(xfpc, choices=c(1,3))

#' Balance sheet and farm count contibutes primarily to the first PC
#' and to the third PC to a lesser extent. Several region variables
#' make the largest contributions to the second and third PCs. The second PC
#' comprises primarily neighboring cases, density, and region. There
#' should be some power to detect the effect of these variables
#' independent of the population-size variables in the first PC.
#'
#+
test <- as.logical(mgAvg$anyCases)
subxf <- xf[test, ]
alphas <- 0:5/5
tmpf <- function(alpha){
    cv.glmnet(x=subxf, y=log(sub$cases), alpha=alpha, nfolds=5)
}
cvsPosF <- lapply(alphas, tmpf)
plot3Alphas(cvsPosF, alphas)
coefplot(cvsPosF, subxf, which=4:6)

#' Diagnostics for case counts
#+
m <- cvsPosF[[5]]
yhatcf <- predict(m, type='response', new=subxf)
lmfit <- lm(log(sub$cases)~0, offset=yhatcf)
layout(matrix(1:4, 2))
plot(lmfit, which=1:3)
Ep <- residuals(lmfit, type='pearson')
Estd <- Ep/sd(Ep)
vg <- variog(coords=subl, data=Estd, max.dist=2000)
olsFit <- variofit(vg, cov.model='exponential')
likFit <- likfit(coords=subl, data=Estd, cov.model='exponential', ini.cov.pars=c(.01, 300))
plot(vg, xlab='distance')
lines(olsFit)
lines(likFit, lwd=2)
par(mfrow=c(1,1))

#' Logistic regression for prob non-zero
#+
alphas <- 0:5/5
tmpf <- function(alpha){
    cv.glmnet(x=xf, y=mgAvg$anyCases, alpha=alpha, family='binomial')
}
cvsBinF <- lapply(alphas, tmpf)
plot3Alphas(cvsBinF, alphas)
coefplot(cvsBinF, xf, which=4:6)

#' Diagnostics for probability non-zero
#+
m <- cvsBinF[[5]]
yhatb <- predict(m, type='link', new=xf)
glmfit <- glm(anyCasesIntAvg~0, offset=yhatb, family=binomial)
layout(matrix(1:4, 2))
plot(glmfit, which=1:3)
Ep <- residuals(glmfit, type='pearson')
sEp <- Ep/sd(Ep)
vg <- variog(coords=locAvg, data=sEp, max.dist=2000)
plot(vg)
likFit <- likfit(coords=locAvg, data=sEp, cov.model='exponential', ini.cov.pars=c(.01, 300))
lines(likFit)

#' Let's check deviance ratio to evaluate fit.
#'
#+
getFitStats <- function(x){
    lam <- x$lambda.1se
    ft <- x$glmnet.fit
    ind <- which(ft$lambda == lam)
    ind2 <- which(x$lambda==lam)
    res <- list(lambda=lam)
    res$a0 <- ft$a0[ind]
    res$dr <- ft$dev.ratio[ind]
    res$nzero <- x$nzero[ind]
    res$cvm <- x$cvm[ind2]
    res$cvsd <- x$cvsd[ind2]
    res$nobs <- ft$nobs
    res
}
mods <- list(loglog=cvsPosF, presence=cvsBinF)
tmpf <- function(x){
    foo <- sapply(x[5:6], getFitStats)
    foo <- t(foo)
    as.data.frame(foo)
}
stats <- lapply(mods, tmpf)
statsdf <- do.call(rbind, stats)
statsdf <- cbind(alpha=c(0.8, 1), statsdf)
statsdf <- round(data.matrix(statsdf), 2)

invisible(latex(statsdf, file='stats-table.tex'))

#' ## Stability selection
#'
#' Stability selection seems more appopriate for identifying important
#' variables than cross-validation. We will check for sensitivity to
#' alpha.

tmpf <- function(alpha,...){
    stabpath(alpha=alpha, weakness=1, steps=1000, size=0.632, ...)
}
tmpff <- function(spec){
    alphas <- c(0.01, 0.2, 0.5, 0.8, 1)
    names(alphas)=paste('alpha', format(alphas), sep='=')
    lapply(alphas, tmpf, y=spec$y, family=spec$family, x=spec$x)
}
specs <- list(cumCases=list(y=log(sub$cases), family='gaussian', x=subxf),
              anyCases=list(y=mgAvg$anyCases, family='binomial', x=xf))
par(mfrow=c(3,5))
res <- lapply(specs, tmpff)
stab <- lapply(res, function(x) lapply(x, plot, type='pcer', error=0.05))
tmpfff <- function(x) lapply(x, '[[', 'stable')
lapply(stab, tmpfff)

## get Descriptive stats

df1 <- data.frame(anyCases=specs$anyCases$y, specs$anyCases$x)
invisible(latex(describe(df1), file='stability-describe-df1.tex'))

df2 <- data.frame(cumCases=specs$cumCases$y, specs$cumCases$x)
invisible(latex(describe(df2), file='stability-describe-df2.tex'))

save.image('pedv-cum.RData')


#program gets single image from sharepoint server and plots in RGB colors

require(httr)

url <- "https://sharepoint_or_something.company_name.com/dir/dir/dir/username/Shared%20Documents/some_more_directory/20171201.png" # change this too
username <- "change_this"
password <- "change_this"

r <- GET(url, authenticate(username,password,type="any"), verbose())

atmos <- content(r, "parsed")

dim(atmos) # dimensions of an image

library(grid)
grid.raster(atmos) # plot in true colors


#!/usr/bin/env Rscript

#for conveniently drawing labels
line2user <- function(line, side) {
  lh <- par('cin')[2] * par('cex') * par('lheight')
  x_off <- diff(grconvertX(0:1, 'inches', 'user'))
  y_off <- diff(grconvertY(0:1, 'inches', 'user'))
  switch(side,
         `1` = par('usr')[3] - line * y_off * lh,
         `2` = par('usr')[1] - line * x_off * lh,
         `3` = par('usr')[4] + line * y_off * lh,
         `4` = par('usr')[2] + line * x_off * lh,
         stop("side must be 1, 2, 3, or 4", call.=FALSE))
}

#define color
numlev = 100 #number of colour levels
ndim = 2 #spatial dimensions for now
coulombcolor <- colorRampPalette(c("red","yellow","green","cyan","blue"),space = "rgb")(numlev)
errcolor <- colorRampPalette(c("red","white","blue"),space = "rgb")(numlev)

#read data
xyslice <- data.matrix(read.csv("slices/sliceXY.csv",header = FALSE))
xzslice <- data.matrix(read.csv("slices/sliceXZ.csv",header = FALSE))
yzslice <- data.matrix(read.csv("slices/sliceYZ.csv",header = FALSE))
truexyslice <- data.matrix(read.csv("slices/truesliceXY.csv",header = FALSE))
truexzslice <- data.matrix(read.csv("slices/truesliceXZ.csv",header = FALSE))
trueyzslice <- data.matrix(read.csv("slices/truesliceYZ.csv",header = FALSE))
fullxyslice <- data.matrix(read.csv("slices/fullsliceXY.csv",header = FALSE))
fullxzslice <- data.matrix(read.csv("slices/fullsliceXZ.csv",header = FALSE))
fullyzslice <- data.matrix(read.csv("slices/fullsliceYZ.csv",header = FALSE))
truefullxyslice <- data.matrix(read.csv("slices/truefullsliceXY.csv",header = FALSE))
truefullxzslice <- data.matrix(read.csv("slices/truefullsliceXZ.csv",header = FALSE))
truefullyzslice <- data.matrix(read.csv("slices/truefullsliceYZ.csv",header = FALSE))

#compute the error slices
xyerr    = xyslice-truexyslice
xyrelerr = xyerr/truexyslice
xzerr    = xzslice-truexzslice
xzrelerr = xzerr/truexzslice
yzerr    = yzslice-trueyzslice
yzrelerr = yzerr/trueyzslice
fullxyerr    = fullxyslice-truefullxyslice
fullxyrelerr = fullxyerr/truefullxyslice
fullxzerr    = fullxzslice-truefullxzslice
fullxzrelerr = fullxzerr/truefullxzslice
fullyzerr    = fullyzslice-truefullyzslice
fullyzrelerr = fullyzerr/truefullyzslice

#custom max and min function, needed or else NA reports -Infty
my.max <- function(x) ifelse( !all(is.na(x)), max(x, na.rm=T), NA)
my.min <- function(x) ifelse( !all(is.na(x)), min(x, na.rm=T), NA)
#for plotting the fitted and the real slices on the same scale, 0 = green (else you cannot compare)
#old method
#xycol     = max(my.max(abs(xyslice)),my.max(abs(truexyslice)))
#xzcol     = max(my.max(abs(xzslice)),my.max(abs(truexzslice)))
#yzcol     = max(my.max(abs(yzslice)),my.max(abs(trueyzslice)))
#new method
xycol     = my.max(abs(truexyslice))
xzcol     = my.max(abs(truexzslice))
yzcol     = my.max(abs(trueyzslice))
xycol     = c(-xycol,    xycol)
xzcol     = c(-xzcol,    xzcol)
yzcol     = c(-yzcol,    yzcol)

#clamp slices to min and max values of the color ranges (else it gets drawn in white)
xyslice        [xyslice         < xycol[1]] <- xycol[1]
xyslice        [xyslice         > xycol[2]] <- xycol[2]
fullxyslice    [fullxyslice     < xycol[1]] <- xycol[1]
fullxyslice    [fullxyslice     > xycol[2]] <- xycol[2]
truefullxyslice[truefullxyslice < xycol[1]] <- xycol[1]
truefullxyslice[truefullxyslice > xycol[2]] <- xycol[2]
xzslice        [xzslice         < xzcol[1]] <- xzcol[1]
xzslice        [xzslice         > xzcol[2]] <- xzcol[2]
fullxzslice    [fullxzslice     < xzcol[1]] <- xzcol[1]
fullxzslice    [fullxzslice     > xzcol[2]] <- xzcol[2]
truefullxzslice[truefullxzslice < xzcol[1]] <- xzcol[1]
truefullxzslice[truefullxzslice > xzcol[2]] <- xzcol[2]
yzslice        [yzslice         < yzcol[1]] <- yzcol[1]
yzslice        [yzslice         > yzcol[2]] <- yzcol[2]
fullyzslice    [fullyzslice     < yzcol[1]] <- yzcol[1]
fullyzslice    [fullyzslice     > yzcol[2]] <- yzcol[2]
truefullyzslice[truefullyzslice < yzcol[1]] <- yzcol[1]
truefullyzslice[truefullyzslice > yzcol[2]] <- yzcol[2]

# clamp the relative error slices (relative error ranges from -100 % to 100 %)
    xyrelerr[    xyrelerr < -1] <- -1
    xyrelerr[    xyrelerr >  1] <-  1
    xzrelerr[    xzrelerr < -1] <- -1
    xzrelerr[    xzrelerr >  1] <-  1
    yzrelerr[    yzrelerr < -1] <- -1
    yzrelerr[    yzrelerr >  1] <-  1
fullxyrelerr[fullxyrelerr < -1] <- -1
fullxyrelerr[fullxyrelerr >  1] <-  1
fullxzrelerr[fullxzrelerr < -1] <- -1
fullxzrelerr[fullxzrelerr >  1] <-  1
fullyzrelerr[fullyzrelerr < -1] <- -1
fullyzrelerr[fullyzrelerr >  1] <-  1

# clamp the absolute error slices
    xyerr[    xyerr < xycol[1]] <- xycol[1]
    xyerr[    xyerr > xycol[2]] <- xycol[2]
    xzerr[    xzerr < xzcol[1]] <- xzcol[1]
    xzerr[    xzerr > xzcol[2]] <- xzcol[2]
    yzerr[    yzerr < yzcol[1]] <- yzcol[1]
    yzerr[    yzerr > yzcol[2]] <- yzcol[2]
fullxyerr[fullxyerr < xycol[1]] <- xycol[1]
fullxyerr[fullxyerr > xycol[2]] <- xycol[2]
fullxzerr[fullxzerr < xzcol[1]] <- xzcol[1]
fullxzerr[fullxzerr > xzcol[2]] <- xzcol[2]
fullyzerr[fullyzerr < yzcol[1]] <- yzcol[1]
fullyzerr[fullyzerr > yzcol[2]] <- yzcol[2]

#plots without border
png(filename = "comparison.png",
      width = 1200, height = 1800, units = "px", pointsize = 12,
      bg = "white",  res = NA)
op <- par(mfrow=c(6,4),mar=c(3,4,3,3))

#plot xyslice
image(truexyslice,zlim=xycol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("True ESP", font=2, cex=2, side = 3, line = 0, outer = FALSE)
mtext("XY plane", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(xyslice,zlim=xycol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("Fitted ESP", font=2, cex=2, side = 3, line = 0, outer = FALSE)
image(xyrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
mtext("Relative Error", font=2, cex=2, side = 3, line = 0, outer = FALSE)
image(xyerr,zlim=xycol,xlab='',ylab='',axes=FALSE,col=errcolor)
mtext("Absolute Error", font=2, cex=2, side = 3, line = 0, outer = FALSE)

#plot fullxyslice
image(truefullxyslice,zlim=xycol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("XY plane - full", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(fullxyslice,zlim=xycol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
image(fullxyrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
image(fullxyerr,zlim=xycol,xlab='',ylab='',axes=FALSE,col=errcolor)

#plot xzslice
image(truexzslice,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("XZ plane", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(xzslice,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
image(xzrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
image(xzerr,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=errcolor)

#plot fullxzslice
image(truefullxzslice,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("XZ plane - full", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(fullxzslice,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
image(fullxzrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
image(fullxzerr,zlim=xzcol,xlab='',ylab='',axes=FALSE,col=errcolor)

#plot yzslice
image(trueyzslice,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("YZ plane", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(yzslice,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
image(yzrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
image(yzerr,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=errcolor)

#plot fullyzslice
image(truefullyzslice,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
mtext("XZ plane - full", font=2, cex=2, side = 2, line = 1,outer = FALSE)
image(fullyzslice,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=coulombcolor)
image(fullyzrelerr,zlim=c(-1,1),xlab='',ylab='',axes=FALSE,col=errcolor)
image(fullyzerr,zlim=yzcol,xlab='',ylab='',axes=FALSE,col=errcolor)


#' @title which.quantile
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  which.quantile = function( x, probs, inside=TRUE ) {
    qnts = quantile( x, probs=probs, na.rm=TRUE )

    if ( inside ) {
      return( which(x < qnts[2]  & x > qnts[1] ) )
    } else {
      return( which(x > qnts[2]  | x < qnts[1] ) )
    }
  }


#' Dates of different days within isoweekyears
#'
#' @format
#' \describe{
#' \item{yrwk}{Isoweek-isoyear.}
#' \item{mon}{Date of Monday.}
#' \item{tue}{Date of Tuesday.}
#' \item{wed}{Date of Wednesday.}
#' \item{thu}{Date of Thursday.}
#' \item{fri}{Date of Friday.}
#' \item{sat}{Date of Saturday.}
#' \item{sun}{Date of Sunday.}
#' }
"days"

# Creates the norway_locations data.table
gen_days <- function() {
  . <- NULL
  yrwk <- NULL
  day <- NULL
  mon <- NULL
  tue <- NULL
  wed <- NULL
  thu <- NULL
  fri <- NULL
  sat <- NULL
  sun <- NULL

  days <- data.table(day = seq.Date(as.IDate("2000-01-01"), as.IDate("2030-01-01"), by = "days"))
  days[, yrwk := format.Date(day, format = "%G-%V")]
  days <- days[, .(mon = as.IDate(min(day))), by = .(yrwk)]
  days[, tue := mon + 1]
  days[, wed := mon + 2]
  days[, thu := mon + 3]
  days[, fri := mon + 4]
  days[, sat := mon + 5]
  days[, sun := mon + 6]
  days <- days[yrwk >= "2000-01"]

  return(days)
}


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

Slopes <- function(dataset,start,end,period) {
# Given an ALSFRS dataset, computes the ALSFRS slope between start and end,
# as defined by timing flag
#
# Args:
#	dataset generated by GetAlsfrsData
#	start - the start time in months
#	end - the end time in months
#	period - when p, calculates past slopes: ie, slope based on first
#			visit >= specified start month and last visit <=
#			specified end month, using alsfrs.delta as time measure
#			- when f, calculates future slopes: ie, slope based on first
#			visit > specified start and end months, using delta.ref as time
#			measure
#
# Returns:
#	a dataframe with columns for subject.id and the corresponding slope
#
# Example usage:
#	for future slopes: future.slopes<-Slopes(alsfrs.data,3,12,"f")
#	for past slopes: past.slopes<-Slopes(alsfrs.data,0,3,"p")

	# Get slope components
	slope.data<-SlopeComponents(dataset,start,end,period)

	# Calculate slopes
	slopes<-(slope.data$last.score-slope.data$first.score)/
		(slope.data$last.date-slope.data$first.date)

	return(slopes)
}
SlopeComponents <- function(dataset,start,end,period) {
	# Given an ALSFRS dataset, computes the slope components, ie the first and last
	# scores and dates given the time period desired
	#
	# Args:
	#	dataset generated by GetAlsfrsData
	#	start - the start time in months
	#	end - the end time in months
	#	period - when p, calculates past slopes: ie, slope based on first
	#			visit >= specified start month and last visit <=
	#			specified end month, using alsfrs.delta as time measure
	#			- when f, calculates future slopes: ie, slope based on first
	#			visit > specified start and end months, using delta.ref as time
	#			measure
	#
	# Returns:
	#	a dataframe with columns for subject.id, first.score, first.date, last.score,
	# 	and last.date
	#
	# Example usage:
	#	for future slopes: future.slopes<-SlopeComponents(alsfrs.data,3,12,"f")
	#	for past slopes: past.slopes<-SlopeComponents(alsfrs.data,0,3,"p")

	# Get vector of all unique subject.ids
	subjects<-unique(dataset$subject.id)
	# run CleanDelta to get rid of rows where ten questions have not been
	# answered, deltas equal to NA, and convert deltas to months
	dataset<-CleanDelta(dataset)
	# Get indices for first and last visits if calculating past slopes
	if (period == "p") {
		ind.all<-PastIndex(dataset,start,end)
		# Merge with vector of all subject ids to make sure each subject id
		# has a corresponding slope, even if it is NA
		ind.all<-merge(subjects,ind.all,by.x=1,by.y="subject.id",all=TRUE)
		first.ind<-ind.all$ind.start
		last.ind<-ind.all$ind.end
	}
	# Get indices for first and last visits if calculating future slopes
	else if (period == "f") {
		# Run DeltaRef if it has not already been run on the dataset
		if (!any(colnames(dataset)=="delta.ref")) {
			dataset<-DeltaRef(dataset)
		}
		ind.start<-FutureIndex(dataset,start)
		ind.end<-FutureIndex(dataset,end)
		ind.all<-merge(ind.start,ind.end,by="subject.id")
		colnames(ind.all)<-c("subject.id","ind.start","ind.end")
		# Merge with vector of all subject ids to make sure each subject id
		# has a corresponding slope, even if it is NA
		ind.all<-merge(subjects,ind.all,by.x=1,by.y="subject.id",all=TRUE)
		first.ind<-ind.all$ind.start
		last.ind<-ind.all$ind.end
	}
	else {
	print("Specify f or p")
	}
	#Get the ALSFRS scores
	dataset<-AlsfrsScore(dataset)
	#Get first and last scores and dates for slope calculation
	first.score<-dataset$alsfrs.score[first.ind]
	first.date<-dataset$months[first.ind]
	last.score<-dataset$alsfrs.score[last.ind]
	last.date<-dataset$months[last.ind]
	slope.data<-data.frame(subject.id=subjects,first.score,first.date,last.score,
		last.date)
	return(slope.data)
}

CleanDelta<-function(dataset) {
	# Given an ALSFRS dataset, drops rows where not all ten questions have
	# been answered, drops all rows where alsfrs.delta = NA, and converts
	# alsfrs.delta to months.
	#
	# Args:
	#	dataset generated by GenAlsfrsData
	#
	# Returns:
	#	the original dataset cleaned of ten questions and NAs, with an
	# 	additional column months, which is alsfrs.delta in months.

	alsfrs.questions<-GetAlsfrsQuestions()
	# mark all rows with ten questions scored
	ten.questions<-rowSums(!is.na(dataset[,which(colnames(dataset)
		%in% alsfrs.questions)]))>=10
	# drop all records without ten questions scored
	dataset<-dataset[ten.questions,]
	# drop all rows where alsfrs.delta = NA
	dataset<-dataset[!is.na(dataset$alsfrs.delta),]
	# convert delta to months
	months<-DaysToMonths(dataset$alsfrs.delta)
	dataset<-cbind(dataset,months)
	return(dataset)
}

DeltaRef <- function(dataset) {
	# Given an ALSFRS dataset on which CleanDelta has been run,
	# identifies the reference visit, that is, the row that corresponds
	# to the first time all ten questions are answered, and then calculates
	# the difference between each visit and the reference visit  in months.
	#
	# Args:
	#	dataset generated by GenAlsfrsData on which CleanDelta has been run
	#
	# Returns:
	#	the original dataset with an additional column "delta.ref" of the
	#	difference between the time of each visit and the time of the reference
	# 	visit in months.

	# mark first row of new subject_id
	unique<-!duplicated(dataset$subject.id)
	# Create a matrix with a column of subject ids and column of corresponding
	# reference visit time in months
	ref.visit<-cbind(dataset$subject.id[unique],dataset$months[unique])
	colnames(ref.visit)<-c("subject.id","ref.month")
	# Merge ref.visit and dataset so that row operations can be performed
	dataset<-merge(dataset,ref.visit,by="subject.id")
	cols<-colnames(dataset)
	dataset<-cbind(dataset,(dataset$months-dataset$ref.month))
	colnames(dataset)<-c(cols,"delta.ref")
	# Compute difference in months from reference date and return
	return(dataset)
}

PastIndex<-function(dataset,start,end) {
	# Given an ALSFRS dataset, finds indices corresponding to the desired visits
	# to calculate future slopes
	#
	# Args:
	#	dataset: a dataset generated by GenAlsfrsData on which CleanDelta has
	#	been run
	#	start: time in months for start date
	#	end: time in months for end date
	#
	# Returns:
	#	a matrix with a column of subject ids, a column of indices corresponding
	# 	to the starting visit and a column of indices corresponding to the ending
	# 	visit for each subject id.

	# Find all indices that correspond to visit that occurs after specified
	# start month
	ind<-which(dataset$alsfrs.delta>=start)
	unique<-!duplicated(dataset$subject.id[ind])
	ind.start<-ind[unique]
	ind.start<-cbind(dataset$subject.id[ind.start],ind.start)
	colnames(ind.start)<-c("subject.id","ind.start")

	# Find all indices that correspond to visits that occur before specified
	# end month
	ind<-which(dataset$months<=end)
	# Mark changes in subject id in vector created from indices
	unique<-!duplicated(dataset$subject.id[ind])
	unique<-which(unique==TRUE)
	ind.end<-c(ind[unique-1],ind[length(ind)])
	ind.end<-cbind(dataset$subject.id[ind.end],ind.end)
	colnames(ind.end)<-c("subject.id","ind.end")

	# Merge start and end indices with subject ids
	ind.all<-merge(ind.start,ind.end,by="subject.id",all=TRUE)
	colnames(ind.all)<-c("subject.id","ind.start","ind.end")
	return(ind.all)
}

FutureIndex<-function(dataset,month) {
	# Given an ALSFRS dataset, finds indices corresponding to the desired visits
	# to calculate future slopes
	#
	# Args:
	#	dataset: a dataset generated by GenAlsfrsData, on which CleanDelta and
	#	DeltaRef have been run
	#	month: time in months for start or end measure

	# Returns:
	#	a matrix with a column of subject ids and a column of indices corresponding
	# 	to the desired visit

	# Find last visit for each subject id
	# Create a vector of row indices corresponding to final visit of each
	# subject.id
	ind<-c(1:length(dataset$delta.ref))
	ind.final<-c(ind[which(diff(dataset$delta.ref==0)==1)],length(dataset$delta.ref))
	# Combine with subject id vector to create matrix with both
	ind.final<-cbind(dataset$subject.id[ind.final],ind.final)
	colnames(ind.final)<-c("subject.id","ind.final")

	# Find first visit after 'month' months
	# Find indices corresponding to first row of new subject and all visits > 'month'
	# months after the reference visit
	ind<-which(dataset$delta.ref>month)
	unique<-!duplicated(dataset$subject.id[ind])
	ind.month<-ind[unique]
	ind.month<-cbind(dataset$subject.id[ind.month],ind.month)
	colnames(ind.month)<-c("subject.id","ind.month")

	# Combine last visit and 'month' visit to get visit indices
	ind.visit<-merge(ind.final,ind.month,all=TRUE,by="subject.id")
	# Replace 'month' visit with last visit when value is NA
	ind.NA<-which(is.na(ind.visit$ind.month))
	ind.visit$ind.month[ind.NA]<-ind.visit$ind.final[ind.NA]
	return(ind.visit[,colnames(ind.visit)!="ind.final"])
}


  cleanup()
Portrait<-T                 # graphical output orientation
include.terminal.year <- F          # plot terminal year (last assessment year +1) as well?
include.last.assess.year.recruit <- F          # plot recruits terminal year as well?

first.year<- 1974                #first year on plot, negative value means value defined by data
last.year<- 2200             #last year on plot
incl.M2.plot<-T
incl.reference.points<-T
splitLine<-F
OperatingModel<-F; redefine.scenario.manually<-FALSE

output.dir<-data.path
op.dir<-data.path
if (OperatingModel==T & redefine.scenario.manually==T)  {
   scenario<-"test";
   output.dir<-data.path
   op.dir<-file.path(data.path,"HCR_1_deter_adjust_test_01_HCR1_0_Rec0__2030")
   #op.dir<-data.path
} else if (OperatingModel==T & redefine.scenario.manually==FALSE) {
     output.dir<-scenario.dir
   op.dir<-scenario.dir
}

if (makeAllGraphs) output.dir<-StockSummary.dir

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

my.dev<-'screen'   # output device:  'screen', 'wmf', 'png', 'pdf'
my.dev<-'png'

palette("default")
if (makeAllGraphs)  my.dev<-'png'
#cleanup()
file.name<-'plot_summary'

#dev<-"dummy"
if (incl.M2.plot) { nox<-3; noy<-2;} else { nox<-2; noy<-2;}
noxy<-nox*noy

ref<-Read.reference.points()

Init.function()

if (!OperatingModel) dat<-Read.summary.data(extend=include.terminal.year,read.init.function=F)
if (OperatingModel) {
  dat1<-Read.summary.data(extend=F,read.init.function=F)

  dat<-Read.summary.data(dir=op.dir,infile="op_summary.out",read.init.function=F)
  if (SMS.control@no.areas >1) {
    dat$N.bar<-dat$N*(1-exp(-dat$Z))/dat$Z
    dat$DM<-dat$M*dat$N.bar
    dat$DM1<-dat$M2*dat$N.bar
    dat$DM2<-dat$M2*dat$N.bar
    dat$DF<-dat$F*dat$N.bar
    dat$DZ<-dat$Z*dat$N.bar
    dat$Nwest<-dat$N*dat$west
    dat$Cweca<-dat$C*dat$weca

    dat<-aggregate(cbind(DM,DM1,DM2,DF,DZ,N,C,Nwest,Cweca,Yield,CWsum,BIO,SSB)~Species+Year+Quarter+Species.n+Age,sum,na.rm=T,data=dat)
    dat$Z<- -log((dat$N-dat$DZ)/dat$N)
    dat$M<-dat$DM/dat$DZ*dat$Z
    dat$M1<-dat$DM1/dat$DZ*dat$Z
    dat$M2<-dat$DM2/dat$DZ*dat$Z
    dat$F<-dat$DF/dat$DZ*dat$Z

    dat$weca<-dat$Cweca/dat$C
    dat[is.na(dat$weca),'weca']<-0
    dat$west<-dat$Nwest/dat$N
   }

  dat$N.bar<-dat$N*(1-exp(-dat$Z))/dat$Z
  dat$C<-NULL
  dat$N_dist<-NULL
  dat$Area<-NULL
  dat1<-subset(dat1,select=c(Species,Year,Quarter,Species.n,Age,M1,M2,M,F,Z,N,N.bar,west,weca,Yield,CWsum,BIO,SSB))
  dat <-subset(dat, select=c(Species,Year,Quarter,Species.n,Age,M1,M2,M,F,Z,N,N.bar,west,weca,Yield,CWsum,BIO,SSB))

  dat<-rbind(dat1,dat)
}
#tapply(dat$Yield,list(dat$Year,dat$Species),sum)

dat<-subset(dat,Year<=last.year )
#(subset(dat,Year==2011 & Species=='Cod'))
if (first.year>0) dat<-subset(dat,Year>=first.year )
if (incl.M2.plot) {
  dat<-data.frame(dat,deadM1=dat$M1*dat$N.bar*dat$west,deadM2=dat$M2*dat$N.bar*dat$west,deadM=dat$M*dat$N.bar*dat$west)
 }

if (F) {
  a<-subset(dat,Species=='Sprat' & Age %in% c(1,2) & Year>2015)
  subset(a,Year==2016,select=c(Quarter,Age,F,M2,Z))
  aggregate(F/2~Year,sum,data=a) # mean F (sum of F)
}

plotfile<-function(dev='screen',out) {
  if (dev=='screen') X11(width=11, height=8, pointsize=12)
  if (dev=='wmf') win.metafile(filename = file.path(output.dir,paste(out,'.wmf',sep='')), width=8, height=10, pointsize=12)
  if (dev=='png') png(filename =file.path(output.dir,paste(out,'.png',sep='')), width = 1400, height = 1000,units = "px", pointsize = 25, bg = "white")
  if (dev=='pdf') pdf(file =file.path(output.dir,paste(out,'.pdf',sep='')), width = 8, height = 10,pointsize = 12,onefile=FALSE)
}

for (sp in (first.VPA:nsp)){
    sp.name<-sp.names[sp]
    discard<-SMS.control@discard[sp-first.VPA+1]==1

    plotfile(dev=my.dev,out=paste(file.name,'_',sp.name,sep=''));
    par(mfcol=c(nox,noy))

    par(mar=c(3,4,3,2))

    s<-subset(dat,Species.n==sp)
    av.F.age<-SMS.control@avg.F.ages[sp-first.VPA+1,]
    s1<-subset(s,s$Age>=av.F.age[1] & s$Age<=av.F.age[2])
    FI<-tapply(s1$F,list(s1$Year),sum)/(av.F.age[2]-av.F.age[1]+1)

    if (F) {
      print(sp.name)
      print(max(FI[as.character(2050:2070)]))
    }

    s1<-subset(s,weca>=0 )

    Yield<-tapply(s1$Yield,list(s1$Year),sum)/1000
    SOP<-tapply(s1$CWsum,list(s1$Year),sum)/1000
    if (discard)  catch<-rbind(SOP-Yield,Yield) else catch<-Yield
    s1<-subset(s,Quarter==1)
    ssb<-tapply(s1$SSB,list(s1$Year),sum)/1000
    s2<-subset(s,Age==fa & Quarter==SMS.control@rec.season)
    rec<-tapply(s2$N,list(s2$Year),sum)/1000000
    year<-as.numeric(unlist(dimnames(ssb)))
    year.ssb<-year

    if(include.terminal.year){
     #Truncate the final year from key parameters
     year<- year[-length(year)]
     FI <- FI[-length(FI)]
    }
    if(!include.last.assess.year.recruit) rec <- rec[-length(rec)]

    barplot(catch,space=1,xlab='',ylab='1000 tonnes',main=paste(sp.name,ifelse(discard,',  Yield and discard',',  Catch'),sep=''),ylim=c(0,max(SOP)))
    if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')

    #plot recruits
    #plot(year,rec,type='h',lwd=5,xlab='',ylab='billions',main=paste('Recruitment age',fa),ylim=c(0,max(rec)))
    barplot(rec,space=1,xlab='',ylab='billions',main=paste('Recruitment age',fa),ylim=c(0,max(rec)))
    if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')
    F.max<-max(FI,ref[sp,"Flim"])

    #cat(sp.name,round(min(FI),2),round(quantile(FI,0.1),2),round(max(FI),2),'\n')
    #print(year)
    #print(FI)
    plot(year,FI,type='b',lwd=3,xlab='',ylab='',main="Fishing mortality",ylim=c(0,F.max))
    if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')
   # tmp<-paste('(',av.F.age[1],'-',av.F.age[2],')',sep='')
   # plot(year,FI,type='l',lwd=3,xlab='',ylab='',main=expression(bar(F)),ylim=c(0,F.max))

    if (incl.reference.points) if (ref[sp,"Flim"]>0) abline(h=ref[sp,"Flim"],lty=2,lwd=2)
    if (incl.reference.points) if (ref[sp,"Fpa"]>0) abline(h=ref[sp,"Fpa"],lty=3,lwd=2)
    grid()

    Blim<-ref[sp,"Blim"]/1000; Bpa<-ref[sp,"Bpa"]/1000
    SSB.max<-max(ssb,Bpa)
    plot(year.ssb,ssb,type='b',lwd=3,xlab='',ylab='1000 tonnes',main='SSB',ylim=c(0,SSB.max))
    if (incl.reference.points) if (Blim>0) abline(h=Blim,lty=2,lwd=2)
    if (incl.reference.points) if (Bpa>0) abline(h=Bpa,lty=3,lwd=2)
    if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')

    grid()
    if (incl.M2.plot) {
      deadM1<-tapply(s$deadM1,list(s$Year),sum)/1000
      deadM2<-tapply(s$deadM2,list(s$Year),sum)/1000
      deadM1<-deadM1[1:length(SOP)]
      deadM2<-deadM2[1:length(SOP)]
      barplot(rbind(SOP,deadM1,deadM2),space=1,main='Biomass removed\ndue to F, M1 and M2',ylab='1000 tonnes')
      if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')
      b<-tapply(s$M2,list(s$Year,s$Age),sum)
      b<-b[1:length(SOP),]
      if (sum(b,na.rm=T)>=0.01) {
        y<-as.numeric(dimnames(b)[[1]])
        plot(y,b[,1],main=paste("M2 at age"),xlab="",ylab='M2',
                type='l',lwd=1.5,ylim=c(0,max(b,na.rm=T)))
        for (a in (2:(dim(b)[2]))) if(max(b[,a],na.rm=T)>0.001) lines(y,b[,a],lty=a,col=a,lwd=2)
        if (splitLine) abline(v=SMS.control@last.year.model,lty=2, col='red')
      }
     }
     if (my.dev %in% c('png','wmf','pdf')) cleanup()
}


commandArgs()

for (e in commandArgs()) {
  ta = strsplit(e,"=",fixed=TRUE)
  if(! is.na(ta[[1]][2])) {
    temp = ta[[1]][2]
    if(substr(ta[[1]][1],nchar(ta[[1]][1]),nchar(ta[[1]][1])) == "I") {
      temp = as.integer(temp)
    }
    if(substr(ta[[1]][1],nchar(ta[[1]][1]),nchar(ta[[1]][1])) == "N") {
      temp = as.numeric(temp)
    }
    assign(ta[[1]][1],temp)
    cat("assigned ",ta[[1]][1]," the value of |",temp,"|\n")
  } else {
    assign(ta[[1]][1],TRUE)
    cat("assigned ",ta[[1]][1]," the value of TRUE\n")
  }
}

N <- as.matrix(read.table("nSpets.txt"))
extensionLength <- as.numeric(extensionLengthStr)
genomeLength <- as.numeric(genomeLengthStr)
genomeCoverageRatio <- as.numeric(genomeCoverageRatioStr)

data <- as.matrix(read.table("data.txt"))
nRows <- length(data[,1])
lambdaGlobal <- array(N*2*extensionLength / (genomeLength*genomeCoverageRatio), c(nRows,1))
lambda10K <- (data[,2] - data[,1])*2*extensionLength/10000;
lambda20K <- (data[,3] - data[,1])*2*extensionLength/20000;
lambdaTemp <- array(0, c(nRows,3))
lambdaTemp[,1] <- lambdaGlobal
lambdaTemp[,2] <- lambda10K
lambdaTemp[,3] <- lambda20K
lambda <- apply(lambdaTemp, 1, max)
x <- ppois(data[,1]-1, lambda, lower.tail = FALSE)
fdr <- p.adjust(x, "BH")
x <- sapply(x, function(a){if(a<0.005){b = as.numeric(format(a, scientific = T, digits = 3))}else{b = round(a, 2)}})
fdr<- sapply(fdr, function(a){if(a<0.005){b = as.numeric(format(a, scientific = T, digits = 3))}else{b = round(a, 2)}})
#x <- as.numeric(format(x, scientific = F))
#fdr <- as.numeric(format(x, scientific = F))
a <- matrix(1, nRows, 2)
a[,1] = x
a[,2] = fdr
write.table(a, file="result.txt", sep = "\t", row.names = FALSE, col.names = FALSE)


# ==================================================================================================
# This file is part of the CLBlast project. The project is licensed under Apache Version 2.0. This
# project uses a tab-size of two spaces and a max-width of 100 characters per line.
#
# Author(s):
#   Cedric Nugteren <www.cedricnugteren.nl>
#
# This file implements the performance script for the Xgemv routine
#
# ==================================================================================================

# Includes the common functions
args <- commandArgs(trailingOnly = FALSE)
thisfile <- (normalizePath(sub("--file=", "", args[grep("--file=", args)])))
source(file.path(dirname(thisfile), "common.r"))

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

# Settings
routine_name <- "xgemv"
parameters <- c("-n","-m","-incx","-incy","-layout",
                "-num_steps","-step","-runs","-precision")
precision <- 32

# Sets the names of the test-cases
test_names <- list(
  "multiples of 256",
  "multiples of 256 (+1)",
  "around n=m=2K",
  "multiples of 256 [rotated]",
  "multiples of 256 (+1) [rotated]",
  "strides (n=2K)"
)

# Defines the test-cases
test_values <- list(
  list(c(256, 256, 1, 1, 102, 16, 256, num_runs, precision)),
  list(c(256+1, 256+1, 1, 1, 102, 16, 256, num_runs, precision)),
  list(c(2*kilo, 2*kilo, 1, 1, 102, 16, 1, num_runs, precision)),
  list(c(256, 256, 1, 1, 101, 16, 256, num_runs, precision)),
  list(c(256+1, 256+1, 1, 1, 101, 16, 256, num_runs, precision)),
  list(
    c(2*kilo, 2*kilo, 1, 1, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 2, 1, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 4, 1, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 8, 1, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 1, 2, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 1, 4, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 1, 8, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 2, 2, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 4, 4, 102, 1, 0, num_runs, precision),
    c(2*kilo, 2*kilo, 8, 8, 102, 1, 0, num_runs, precision)
  )
)

# Defines the x-labels corresponding to the test-cases
test_xlabels <- list(
  "vector sizes (n)",
  "vector sizes (n)",
  "vector sizes (n)",
  "vector sizes (n)",
  "vector sizes (n)",
  "increments/strides for x and y"
)

# Defines the x-axis of the test-cases
test_xaxis <- list(
  c("n", ""),
  c("n", ""),
  c("n", ""),
  c("n", ""),
  c("n", ""),
  list(1:10, c("x1y1", "x2y1", "x4y1", "x8y1", "x1y2", "x1y4", "x1y8", "x2y2", "x4y4", "x8y8"))
)

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

# Start the script
main(routine_name=routine_name, precision=precision, test_names=test_names, test_values=test_values,
     test_xlabels=test_xlabels, test_xaxis=test_xaxis, metric_gflops=FALSE)

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


##FbF-Gráficos=group
##showplots
##Layer=vector
##Tipodegrafico=selection barras;polar
##Eje_x=Field Layer
##Eje_y=Field Layer
##TipodeColor=selection viridis;infierno;plasma;magma
##Titulo=string
##Subtitulo=string
##Fuente=string

library(tidyverse)
library(ggplot2)

titulo = Titulo
subtitulo= Subtitulo
fuente = Fuente

df = Layer %>% st_set_geometry(NULL)
topdf = df %>%
  arrange(df[[Eje_y]]) %>%
  head(10)

if (Tipodegrafico==0){
  plot_top = topdf %>%
    ggplot(
      aes(
        x = reorder(topdf[[Eje_x]],topdf[[Eje_y]]),
        y = topdf[[Eje_y]])) +
    geom_bar(stat = "identity",aes(fill =topdf[[Eje_y]])) +
    coord_flip() +
    labs(
      title = titulo,
      subtitle = subtitulo,
      caption = fuente,
      x = '',
      y = '')

}else{
  plot_top = topdf %>%
    ggplot(
      aes(
        x = reorder(topdf[[Eje_x]],topdf[[Eje_y]]),
        y = topdf[[Eje_y]])) +
    geom_bar(stat = "identity",aes(fill =topdf[[Eje_y]]))+
    coord_polar() +
    labs(
      title = titulo,
      subtitle = subtitulo,
      caption = fuente,
      x = '',
      y = '')

}

if(TipodeColor==0){
  final = plot_top +
  scale_fill_viridis_c(option = "viridis") %>%
    suppressMessages()
}else if(TipodeColor==1){
  final = plot_top +
    scale_fill_viridis_c(option = "inferno") %>%
    suppressMessages()
}else if(TipodeColor==2){
  final = plot_top +
    scale_fill_viridis_c(option = "plasma") %>%
    suppressMessages()
}else{
  final = plot_top +
    scale_fill_viridis_c(option = "magma") %>%
    suppressMessages()
}

PLOT= final +
  theme(
    legend.position = "none",
    axis.text.x = element_text(size=12),
    axis.text.y = element_text(size=12),
    axis.title.x = element_text(size=12),
    axis.title.y = element_text(size=12)
    )
PLOT

PLOT= final +
  theme(
    legend.position="none")
PLOT


directories = list.files('./test-cases')

for (benchmark in directories) {
	directory = paste('./test-cases', benchmark, sep='/')
	files = list.files(directory,recursive=1,pattern='Reasoner-Results-')

	if (!identical(benchmark, "scalability"))
		next

	comparison = paste(directory, 'scalability-processing.pdf',sep='/')
	pdf(comparison)

	total = length(files)
	colours = rainbow(total)
	names = c(1:total)

	count = 1
	for (f in files)
	{
		file = paste(directory, f, sep='/')
		data = read.csv(file, header=T)
		data = data[order(data[1]),]

		name = unlist( strsplit(f, "Results-"))[2]
		name = substr(name, 1, nchar(name) - 4)
		names[count] = name
		print(name)

		if (count == 1)
			plot(1, type='n', xlim=c(1,length(data[,1])), ylim=c(0,180000),
				 xlab='(x * 50 + 1) ^ 2 logical axioms', ylab='Correctly processed time')

		#print(file)
		#print(data$Correctly.Processed.Time)

		data$Correctly.Processed.Time[data$Correctly.Processed.Time == 0] = NA
		lines(data$Correctly.Processed.Time, type='o', col=colours[count], lwd=2)
		#data$Execution.Time[data$Execution.Time > 180000] = 180000
		#lines(data$Execution.Time, type='o', col=colours[count], lwd=2)
		count = count + 1
	}
	print(names)

 	legend("topleft", legend = names, col=colours, pch=1) # optional legend

	dev.off()
}


help("distributions")


library(gganimate)
library(dplyr)
library(tidyverse)
library(reshape2)
library(ggthemes)
library(gifski)
library(av)

confirmedCases= read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv')
deathCases= read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv')
recoveredCases= read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_recovered_global.csv')

set system locale for date conversion purpose
Sys.setlocale("LC_TIME", "English")

#convert data sets into columns and remove unwanted columns

confirmedCases<-confirmedCases%>%select(-c(Lat,Long))%>%melt(id=c('Country/Region','Province/State'))
confirmedCases<-confirmedCases%>%group_by(`Country/Region`,variable)%>%summarise(Confirmed=sum(value))

deathCases<-deathCases%>%select(-c(Lat,Long))%>%melt(id=c('Country/Region','Province/State'))
deathCases<-deathCases%>%group_by(`Country/Region`,variable)%>%summarise(Deaths=sum(value))

recoveredCases<-recoveredCases%>%select(-c(Lat,Long))%>%melt(id=c('Country/Region','Province/State'))
recoveredCases<-recoveredCases%>%group_by(`Country/Region`,variable)%>%summarise(Recovered=sum(value))

# rename table columns
colnames(confirmedCases)<-c("Country","Date","Confirmed")
colnames(deathCases)<-c("Country","Date","Death")
colnames(recoveredCases)<-c("Country","Date","Recovered")

# merge all atbles together

mergedCases<-merge(confirmedCases,deathCases, by.y=c("Country","Date"))
mergedCases<-merge(mergedCases,recoveredCases, by.y=c("Country","Date"))

# convert factors to date format

mergedCases$Date<-as.Date(mergedCases$Date,"%m/%d/%y")

# summarize cases by date
df1<-mergedCases %>% group_by(Date) %>% summarise_at(c("Confirmed","Recovered","Death"),sum)

# stack columns together and add state columns to each case
df2 <- data.frame(Date=rep(df1$Date, 3),
                  act_noact=c(df1$Confirmed, df1$Death,df1$Recovered),
                  State=rep(c("Confirmed","Deaths", "Recovered"), each=nrow(df1)))

# retrieve last update date for title
lastDate<-max(df1$Date)

# define plot object
p <- ggplot(df2, aes(x=Date, y=act_noact, group=State, color=State)) +
  geom_line() +
  geom_segment(aes(xend=max(Date), yend = act_noact), linetype=2, colour='blue') +
  geom_point(size = 3) +
  geom_text(aes(x = max(Date)+.1, label = sprintf("%5.0f", act_noact)), hjust=-0.5) +
  transition_reveal(Date) +
  view_follow(fixed_y = TRUE)+
  coord_cartesian(clip = 'off') +
  xlab("Day") +
  ylab("Number of cases") + ggtitle(paste("                 @Ahmad_Almekdad
                                          Evolution of corona_cases over time as of ",lastDate)) +
  enter_drift(x_mod = -1) + exit_drift(x_mod = 1) +
  theme_classic() +
  theme(legend.position = c(0.2, 0.8))+
  theme(panel.border = element_blank(),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        axis.line = element_line(colour = "black"),
        plot.margin = margin(5.5, 40, 5.5, 5.5))

# create animation gif file
animate(p, fps=5,renderer = gifski_renderer("coronaplot04.gif"))


#' @useDynLib curand R_getseed
getseed = function()
{
  date = as.integer(Sys.Date())
  time = as.numeric(Sys.time())*100000
  pid = as.integer(Sys.getpid())

  .Call(R_getseed, date, time, pid)
}


#---
#title: "Analyzing Age structures in IC"
#author: "Youen Vermard"
#date: '`r date()`'
#output: pdf_document
#---

#### ONLY PIECE TO BE CHANGED working directories
wd <- "~/git/ices-dk/interCatchSummary/"
output_wd <- "~/git/ices-dk/interCatchSummary/"

#This documet uses Table 2 from CatchAndSampleDataTables.txt from the InterCatch outputs to describe the raising procedures that were made.

### libraries
library(data.table)
library(gplots)
library(pander);library(captioner)
library(lattice)
#initialise les fonctions pour légender tables et figures

### read the data
test <- scan(paste(wd,"CatchAndSampleDataTables.txt",sep=""),what='character',sep='\t')
table2 <- test[(which(test=="TABLE 2.")+3):length(test)]
tmp<-table2[-c(1:56)]

table2_bis<-data.frame(matrix(tmp,ncol=27,byrow=T), stringsAsFactors =F)
colnames(table2_bis) <- table2[1:27]
table2_bis <- data.table(table2_bis)
table2_bis <- table2_bis[,CATON:=as.numeric(as.character(CATON))]
table2_bis <- table2_bis[,CANUM:=as.numeric(as.character(CANUM))]
table2_bis <- table2_bis[,WECA:=as.numeric(as.character(WECA))]
table2_bis <- table2_bis[,AgeOrLength:=as.numeric(as.character(AgeOrLength))]

table2_bis <- table2_bis[,Area:=as.factor(Area)]
table2_bis <- table2_bis[,Fleet:=factor(Fleet)]
table2_bis <- table2_bis[,Season:=factor(Season)]
table2_bis <- table2_bis[,Country:=factor(Country)]

table2_bis <- table2_bis[,id:=paste(Stock,Country,Area,Season,Fleet)]

table2_bis[Area=="IIIaN                                                       ",'Area'] <- "IIIaN"

colnames(table2_bis)[colnames(table2_bis)=='CATONRaisedOrImported'] <- 'RaisedOrImported'

## simple stats on imported data
		SummaryReport <- table2_bis[,list(CATON=sum(CANUM*WECA)/1000000), by=c('CatchCategory','RaisedOrImported')]
		SummaryReport <- SummaryReport[, perc:=round(CATON/sum(CATON)*100), by='CatchCategory']
		SummaryReport <- SummaryReport[order(CatchCategory),]

		SOP <- table2_bis[,list(SOP=sum(CANUM*WECA)/1000, CATON=sum(unique(CATON))), by=c('CatchCategory')]
		SOP <-SOP[,list(SOP=SOP/CATON), by=c('CatchCategory')]

		SampledOrEstimated <- table2_bis[,list(CATON=sum(CANUM*WECA/1000000)), by=c('CatchCategory','RaisedOrImported','SampledOrEstimated')]
		SampledOrEstimated <- SampledOrEstimated[, perc:=round(CATON/sum(CATON)*100), by='CatchCategory']
		SampledOrEstimated <- SampledOrEstimated[order(CatchCategory, perc, decreasing=T),]

		SampledOrEstimatedArea <- table2_bis[,list(CATON=sum(CANUM*WECA/1000000)), by=c('CatchCategory','RaisedOrImported','SampledOrEstimated','Area')]
		SampledOrEstimatedArea <- SampledOrEstimatedArea[, perc:=round(CATON/sum(CATON)*100), by=c('CatchCategory','Area')]
		SampledOrEstimatedArea <- SampledOrEstimatedArea[order(Area, CatchCategory,perc, decreasing=T),]

		### landings with associated discards

	landingsWithAssociatedDiscards <- table2_bis[,list(CATON=sum(CANUM*WECA/1000000)), by=c('id','RaisedOrImported','CatchCategory')]
	tmp <-  landingsWithAssociatedDiscards[(RaisedOrImported=="Imported_Data" & CatchCategory=="Discards")  , id]
	landingsWithAssociatedDiscards <- landingsWithAssociatedDiscards[id%in%tmp & CatchCategory=="Landings", sum(CATON)]/table2_bis[CatchCategory=="Landings",sum(CANUM*WECA/1000000)]

		## summary of the catch per gear
		table2_bis <- table2_bis[, Gear:=substr(table2_bis$Fleet,1,3)]
		summCatchPerGear <- table2_bis[, list(sumCatch=sum(CANUM*WECA/1000000)), by=c('Stock','Gear')]
		summCatchPerGear <- summCatchPerGear[, percCatch:=sumCatch/sum(sumCatch)*100, by=c('Stock')]
		summCatchPerGear <- summCatchPerGear[ order(percCatch,decreasing=T),]

### Age Structure

listVAR <- c("CatchCategory",'RaisedOrImported',"SampledOrEstimated","Country","Area","Season","Fleet")

## By Sex

listVAR <- c("CatchCategory",'RaisedOrImported',"SampledOrEstimated","Country","Area","Season","Fleet","Sex")

#table2_bis <- table2_bis[CANUM>0,]

AgeStrucSex <- table2_bis[,meanAge:=weighted.mean(AgeOrLength,CANUM, na.rm=T), by=c(listVAR)]

plotFunction <- function(AgeStrucSexLan,Estim,Sampled){
	if(unique(AgeStrucSexLan$AgeOrLengthType)=="Lngt") AgeTit <- "Length" else AgeTit <- "Age"
				plotTitle <- paste("Mean", AgeTit, "in the", catchCat, "by", Var, sep=" ")

	Formula <-paste('meanAge~',Var, sep="")

	boxplot(eval(parse(text=Formula)), data=AgeStrucSexLan,
             boxwex = 0.25, at = which(pos%in%unique(AgeStrucSexLan[,which(colnames(Sampled)==Var)])) + 0.3,
             col = "red",
             main = plotTitle,
             xlab = "",
             ylab = paste("Mean ",AgeTit, sep=""),
             xlim = c(0.5, length(unique(AgeStrucSexLan[,which(colnames(Sampled)==Var)]))+.5), ylim = c(min(AgeStrucSexLan$AgeOrLength), max(AgeStrucSexLan$AgeOrLength)), yaxs = "i", xaxt='n')
	boxplot(eval(parse(text=Formula)), data=Estim, add=TRUE,
             boxwex = 0.25, at = which(pos%in%unique(Estim[,which(colnames(Sampled)==Var)])),
             col = "orange")
	boxplot(eval(parse(text=Formula)), data=Sampled, add=TRUE,
             boxwex = 0.25, at = which(pos%in%unique(Sampled[,which(colnames(Sampled)==Var)])) - 0.3,
             col = "yellow", xaxt='n')
  legend(1, max(AgeStrucSexLan$AgeOrLength), c("Imported", "Raised", "All"),
            fill = c("yellow", "orange", "red"))
	}

plotFunctionMeanWeight <- function(AgeStrucSexLan=AgeStrucSexLan,Estim=Estim,Sampled=Sampled){
	if(unique(AgeStrucSexLan$AgeOrLengthType)=="Lngt") AgeTit <- "Length" else AgeTit <- "Age"
				plotTitle <- paste("Mean", AgeTit, "in the", catchCat, "by", Var, sep=" ")

AgeStrucSexLan <- data.frame(AgeStrucSexLan)
AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)] <- factor(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])
pos <- levels(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])

Estim <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Estimated_Distribution'),]
Estim[,which(colnames(Estim)==Var)] <- factor(Estim[,which(colnames(Estim)==Var)])

Sampled <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Sampled_Distribution'),]
Sampled[,which(colnames(Sampled)==Var)] <- factor(Sampled[,which(colnames(Sampled)==Var)])

	Formula <-paste('WECA~',Var, sep="")

	boxplot(eval(parse(text=Formula)), data=AgeStrucSexLan,
             boxwex = 0.25, at = which(pos%in%unique(AgeStrucSexLan[,which(colnames(Sampled)==Var)])) + 0.3,
             col = "red",
             main = plotTitle,
             xlab = "",
             ylab = paste("Mean ",AgeTit, sep=""),
             xlim = c(0.5, length(unique(AgeStrucSexLan[,which(colnames(Sampled)==Var)]))+.5), ylim = c(min(AgeStrucSexLan$WECA), max(AgeStrucSexLan$WECA)), yaxs = "i", xaxt='n')
	boxplot(eval(parse(text=Formula)), data=Estim, add=TRUE,
             boxwex = 0.25, at = which(pos%in%unique(Estim[,which(colnames(Sampled)==Var)])),
             col = "orange")
	boxplot(eval(parse(text=Formula)), data=Sampled, add=TRUE,
             boxwex = 0.25, at = which(pos%in%unique(Sampled[,which(colnames(Sampled)==Var)])) - 0.3,
             col = "yellow", xaxt='n')
  legend(1, max(AgeStrucSexLan$WECA), c("Imported", "Raised", "All"),
            fill = c("yellow", "orange", "red"))
}

## export SOP table
#write.csv(SOP, file=paste0(output_wd,"SOP.csv"), row.names=F)

#Raised and imported datas

##Raised discards

#In InterCatch, the first step consists in raising the discards volumes for strats with landings and no discards associated. These discards are called in the following table 'Raised_Discards'. The data called 'Imported_Data' are landings or discards volumes imported into InterCatch with or without length/age structure.

#The proportion of Landings with Discards associated (same strata) is **`r paste(round(landingsWithAssociatedDiscards*100), 'percent')`**

write.csv(c("Landings with discards associated in percent",round(landingsWithAssociatedDiscards*100)), file=paste0(output_wd,"landingsWithAssociatedDiscards.csv"), row.names=F)

#The volumes (and associated proportion) of landings and discards imported  (Imported_Data) or raised (Raised_Discards) are described in the following table.

write.csv(SummaryReport, file=paste0(output_wd,"Imported_Raised_discards.csv"), row.names=F)

##Total catch per gear

#The following table gives a summary of the catch (Landings+discards(imported+raised)) per gear (3 first letters of the metier)

write.csv(summCatchPerGear, file=paste0(output_wd,"Catch_Per_Gear.csv"), row.names=F)
##Length/Age distribution

#For the imported landings/discards and the raised discards without age distribution, the length or age distribution is then computed using the defined allocation scheme. *Sampled_distribution* means that the data (ladings or discards) were input with age/length distribution. *Estimated_distribution* means that the inputed/raised valoumes were estimated using the allocation scheme.

#In the following tables, CATON=WECA*CANUM/1000000 (in tonnes)

write.csv(SampledOrEstimated, file=paste0(output_wd,"Sampled_Estimated_L_D.csv"), row.names=F)

write.csv(SampledOrEstimatedArea, file=paste0(output_wd,"Sampled_Estimated_L_D_PerArea.csv"), row.names=F)

##Impact of the raising on the age/length structure

#Once the samples imported or raised are identified, it is possible to check the impact of the allocation scheme on the mean age/length of the final age/length distribution of the stock.
#The following figures compare the mean age (computed as the weighted mean of the age per strata("CatchCategory",'RaisedOrImported',"SampledOrEstimated","Country","Area","Season","Fleet","Sex")) of the estimated stratas compared to the imported ones and the final distribution. Each individual included in the boxplot corresponds to the weighted mean age of a strata.

###Global mean age

AgeStrucSexLan <- AgeStrucSex
png(filename=paste0(output_wd,"MeanAgeCatchCat.png"))
par(las=2)

		boxplot(meanAge~CatchCategory, data=AgeStrucSexLan,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$CatchCategory)) + 0.3,
             col = "red",
             main = "Mean Age per Catch Category",
             xlab = "",
             ylab = "Mean Age",
             xlim = c(0.5, length(unique(AgeStrucSexLan$CatchCategory))+.5), ylim = c(min(AgeStrucSexLan$AgeOrLength), max(AgeStrucSexLan$AgeOrLength)), yaxs = "i")
		boxplot(meanAge~CatchCategory, data=AgeStrucSexLan[SampledOrEstimated=='Estimated_Distribution',], add=TRUE,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$CatchCategory)),
             col = "orange")
		boxplot(meanAge~CatchCategory, data=AgeStrucSexLan[SampledOrEstimated=='Sampled_Distribution',], add=TRUE,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$CatchCategory)) - 0.3,
             col = "yellow")
    legend(1, max(AgeStrucSexLan$AgeOrLength), c("Imported", "Raised", "All"),
            fill = c("yellow", "orange", "red"))
dev.off()

###Mean Age per sex
var <- "Landings"
AgeStrucSexLan <- AgeStrucSex[CatchCategory==var,]
png(filename=paste0(output_wd,"MeanAge",var,"_Sex.png"))
par(las=2)
		boxplot(meanAge~Sex, data=AgeStrucSexLan,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$Sex)) + 0.3,
             col = "red",
             main = "Mean Age in the Landings",
             xlab = "",
             ylab = "Mean Age",
             xlim = c(0.5, length(unique(AgeStrucSexLan$Sex))+.5), ylim = c(min(AgeStrucSexLan$AgeOrLength), max(AgeStrucSexLan$AgeOrLength)), yaxs = "i")
		boxplot(meanAge~Sex, data=AgeStrucSexLan[SampledOrEstimated=='Estimated_Distribution',], add=TRUE,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$Sex)),
             col = "orange")
		boxplot(meanAge~Sex, data=AgeStrucSexLan[SampledOrEstimated=='Sampled_Distribution',], add=TRUE,
             boxwex = 0.25, at = 1:length(unique(AgeStrucSexLan$Sex)) - 0.3,
             col = "yellow")
    legend(1, max(AgeStrucSexLan$AgeOrLength), c("Imported", "Raised", "All"),
            fill = c("yellow", "orange", "red"))
dev.off()

###Mean Age per area

catchCat <- "Landings"
Var <- "Area"
png(filename=paste0(output_wd,"MeanAge",catchCat,Var,".png"))

AgeStrucSexLan <- AgeStrucSex[CatchCategory==catchCat,]
AgeStrucSexLan <- data.frame(AgeStrucSexLan)
AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)] <- factor(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])
pos <- levels(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])

Estim <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Estimated_Distribution'),]
Estim[,which(colnames(Estim)==Var)] <- factor(Estim[,which(colnames(Estim)==Var)])

Sampled <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Sampled_Distribution'),]
Sampled[,which(colnames(Sampled)==Var)] <- factor(Sampled[,which(colnames(Sampled)==Var)])
par(las=2)
plotFunction(AgeStrucSexLan,Estim,Sampled)
dev.off()

###Mean Age per fleet

catchCat <- "Landings"
Var <- "Fleet"
png(filename=paste0(output_wd,"MeanAge",catchCat,Var,".png"))

AgeStrucSexLan <- AgeStrucSex[CatchCategory==catchCat,]
AgeStrucSexLan <- data.frame(AgeStrucSexLan)
AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)] <- factor(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])
pos <- levels(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])

Estim <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Estimated_Distribution'),]
Estim[,which(colnames(Estim)==Var)] <- factor(Estim[,which(colnames(Estim)==Var)])

Sampled <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Sampled_Distribution'),]
Sampled[,which(colnames(Sampled)==Var)] <- factor(Sampled[,which(colnames(Sampled)==Var)])
par(las=2, mar=c(15,4,4,5))
plotFunction(AgeStrucSexLan,Estim,Sampled)
dev.off()
###Resulting age structure

#The following plot shows the percentage of each age/length for the sampled strata, estimated and the final age structure for the landing and discard fractions.

listVAR <- c("CatchCategory","SampledOrEstimated")

AgeStrucSexProp <- AgeStrucSex[,list(sumCANUM=sum(CANUM)), by=c(listVAR,'AgeOrLength')]
AgeStrucSexProp <- AgeStrucSexProp[,propCanum:=sumCANUM/sum(sumCANUM), by=listVAR]

listVAR <- c("CatchCategory")
AgeStrucSexProp2 <- AgeStrucSex[,list(sumCANUM=sum(CANUM)), by=c(listVAR,'AgeOrLength')]
AgeStrucSexProp2 <- AgeStrucSexProp2[,propCanum:=sumCANUM/sum(sumCANUM), by=listVAR]
AgeStrucSexProp2$SampledOrEstimated <- "Final Distribution"

AgeStrucSexProp<- rbind(AgeStrucSexProp,AgeStrucSexProp2)

png(filename=paste0(output_wd,"AgeStruc.png"))
xyplot(propCanum~AgeOrLength|CatchCategory,groups = SampledOrEstimated, data=AgeStrucSexProp,auto.key = list(space = "right", points = TRUE, lines = FALSE))
dev.off()
##Mean weight at age/length

#the catchAndSampleData also provide the weight at age per strata for the Sampled/Estimated stratas.
#One would also want to check the sampled/estimated and resulting weight at length/age. This is produced in the following graph, each boxplot representing the distribution of the weight at age/length for the different stratas.

catchCat <- "Landings"
Var <- "AgeOrLength"

AgeStrucSexLan <- AgeStrucSex[CatchCategory==catchCat,]
AgeStrucSexLan <- data.frame(AgeStrucSexLan)
AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)] <- factor(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])
pos <- levels(AgeStrucSexLan[,which(colnames(AgeStrucSexLan)==Var)])

Estim <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Estimated_Distribution'),]
Estim[,which(colnames(Estim)==Var)] <- factor(Estim[,which(colnames(Estim)==Var)])

Sampled <- AgeStrucSexLan[which(AgeStrucSexLan$SampledOrEstimated=='Sampled_Distribution'),]
Sampled[,which(colnames(Sampled)==Var)] <- factor(Sampled[,which(colnames(Sampled)==Var)])
Areas <- unique(AgeStrucSexLan$Area)

png(filename=paste0(output_wd,"MeanWeight",catchCat,Var,".png"))
par(las=2, mfrow=c(1, length(Areas)))
for(i in Areas){
	plotFunctionMeanWeight(AgeStrucSexLan=AgeStrucSexLan[AgeStrucSexLan$Area==i,],Estim=Estim[Estim$Area==i,],Sampled=Sampled[Sampled$Area==i,])

	}
dev.off()
#The outliers (more than 3 times the standard deviation) are extracted and can be investigated from the following table.

catchCat <- "Landings"

AgeStrucSexLan <- data.table(AgeStrucSexLan[AgeStrucSexLan$RaisedOrImported=="Imported_Data" & AgeStrucSexLan$CatchCategory==catchCat,])
AgeStrucSexLan <- AgeStrucSexLan[,AverageWtSize:=mean(WECA), by=list(RaisedOrImported,AgeOrLength,Area)]
AgeStrucSexLan <- AgeStrucSexLan[,stdWECA:=sd(WECA), by=list(RaisedOrImported,AgeOrLength,Area)]

write.csv(AgeStrucSexLan[WECA>AverageWtSize+3*stdWECA | WECA<AverageWtSize-3*stdWECA   ,c('Country','Fleet','CatchCategory','WECA','AverageWtSize','AgeOrLength','Area'), with=F], file=paste0(output_wd,"export_outliers.csv"), row.names=F)


#' @export
#' @title Reduce Cardinal dataset's coordinates to minimum
#' @description reduceCardinalCoord is used to set the minimum y and x coordinate values in a Cardinal dataset to zero.
#' @param cardinaldata an object of class "MSImageSet"
#' @return cardinaldata

reduceCardinalCoord <- function(cardinaldata){

  #grab coordinate data
  df <- coord(cardinaldata)[1:2]
  #placeholder if there is no samplename
  df$sample <- "placeholder"
  #split by sample
  dfs <- split(df, df$sample)

  #loop through samples and reduce each's coordinates
  for(i in 1:length(dfs)){
    #store original x & y coordinates
    dfs[[i]]$origx <- dfs[[i]]$x
    dfs[[i]]$origy <- dfs[[i]]$y

    #reduced coordinates
    dfs[[i]]$x <- dfs[[i]]$x - (min(dfs[[i]]$x) - 1)
    dfs[[i]]$y <- dfs[[i]]$y - (min(dfs[[i]]$y) - 1)

  }

  #recombine sample split dataframe
  df <-do.call(rbind, dfs)

  #store old coordinate values and add new to cardinal dataset
  cardinaldata$origx <- df$origx
  cardinaldata$origy <- df$origy
  cardinaldata$x     <- df$x
  cardinaldata$y     <- df$y

  #regenerate the necessary cardinal metadata

  cardinaldata <- regeneratePositions(cardinaldata)

  return(cardinaldata)

}


.libPaths(c('C:/Users/cflfcl/AppData/Roaming/ApsimInitiative/ApsimX/rpackages', .libPaths()))
library('sensitivity', lib.loc = 'C:/Users/cflfcl/AppData/Roaming/ApsimInitiative/ApsimX/rpackages')
params <- c("ResidueWt","CN2","Cona","U","ResidueCNR","SWCon","DUL")
apsimMorris<-morris(model=NULL
 ,params #string vector of parameter names
 ,25 #no of paths within the total parameter space
 ,design=list(type="oat",levels=21,grid.jump=10)
 ,binf=c(0,70,3,1,40,0.1,0.2611) #min for each parameter
 ,bsup=c(5000,85,9,9,120,0.5,0.5) #max for each parameter
 ,scale=T
 )
apsimMorris$X <- read.csv("C:/Users/cflfcl/AppData/Local/Temp/parameters627a2b0d-1458-4336-8b38-9e768d33c51a.csv")
values = read.csv("C:/Users/cflfcl/AppData/Local/Temp/apsimvariable627a2b0d-1458-4336-8b38-9e768d33c51a.csv")
allEE <- data.frame()
allStats <- data.frame()
for (columnName in colnames(values))
{
 apsimMorris$y <- values[[columnName]]
 tell(apsimMorris)
 ee <- data.frame(apsimMorris$ee)
 ee$variable <- columnName
 ee$path <- c(1:25)
 allEE <- rbind(allEE, ee)
 mu <- apply(apsimMorris$ee, 2, mean)
 mustar <- apply(apsimMorris$ee, 2, function(x) mean(abs(x)))
 sigma <- apply(apsimMorris$ee, 2, sd)
 stats <- data.frame(mu, mustar, sigma)
 stats$param <- params
 stats$variable <- columnName
 allStats <- rbind(allStats, stats)
}
write.csv(allEE,"C:/Users/cflfcl/AppData/Local/Temp/ee627a2b0d-1458-4336-8b38-9e768d33c51a.csv", row.names=FALSE)
write.csv(allStats, "C:/Users/cflfcl/AppData/Local/Temp/stats627a2b0d-1458-4336-8b38-9e768d33c51a.csv", row.names=FALSE)


###########################################################################
#CoxRegression
#This will load our input files into variables so we can run the cox regression.
###########################################################################

LineGraph.loader <- function(
	input.filename,
	output.file="LineGraph",
	graphType=""
)
{
 	######################################################
	#We need this package for a str_extract when we take text out of the concept.
	library(stringr)
	library(plyr)
	library(ggplot2)
	library(Cairo)
	######################################################

	######################################################
	#Read the line graph data.
	line.data<-read.delim(input.filename,header=T)

	#We need to convert the value column from a factor to a numeric.
	#finalData$VALUE <- as.numeric(levels(finalData$VALUE))[as.integer(finalData$VALUE)]

	#Aggregate the data to get rid of patient numbers. We add a standard error column so we can use it in the error bars.
	dataOutput <- ddply(line.data, .(CONCEPT_PATH,GROUP_VAR),
	  summarise,
	  MEAN 		= mean(VALUE),
	  SD 		= sd(VALUE),
	  SE 		= sd(VALUE)/sqrt(length(VALUE)),
	  MEDIAN 	= median(VALUE)
	)

	#Adjust the column names.
	colnames(dataOutput) <- c('TIMEPOINT','GROUP','MEAN','SD','SE','MEDIAN')

	#Use a regular expression trim out the timepoint from the concept.
	#dataOutput$TIMEPOINT <- str_extract(dataOutput$TIMEPOINT,"Week [0-9]+")
	dataOutput$TIMEPOINT <- str_extract(dataOutput$TIMEPOINT,"(\\\\.+\\\\.+\\\\)+?$")

	#Convert the timepoint field to a factor.
	dataOutput$TIMEPOINT <- factor(dataOutput$TIMEPOINT)

	#Convert the group field to a factor.
	dataOutput$GROUP <- factor(dataOutput$GROUP)
	######################################################

	######################################################
	#Plotting the line.

	#Depending on the graph type, we create a different graph.
	if(graphType=="MERR")
	{
		limits <- aes(ymax = MEAN + SE, ymin = MEAN - SE)

		p <- ggplot(
			data=dataOutput,
			aes(x=TIMEPOINT,
				y=MEAN,
				group=GROUP,
				colour=GROUP
				)
			)

	}

	if(graphType=="MSTD")
	{
		limits <- aes(ymax = MEAN + SD, ymin = MEAN - SD)

		p <- ggplot(
			data=dataOutput,
			aes(x=TIMEPOINT,
				y=MEAN,
				group=GROUP,
				colour=GROUP
				)
			)

	}

	if(graphType=="MEDER")
	{
		limits <- aes(ymax = MEDIAN + SE, ymin = MEDIAN - SE)

		p <- ggplot(
			data=dataOutput,
			aes(x=TIMEPOINT,
				y=MEDIAN,
				group=GROUP,
				colour=GROUP
				)
			)
	}

	p <- p + geom_line(size=1.5) + geom_errorbar(limits,width=0.2) + scale_colour_brewer()

	#This sets the color theme of the background/grid.
	p <- p + theme_bw();

	#Set the text options for the axis.
	p <- p + theme(axis.text.x = theme_text(size = 17,face="bold",angle=5));
	p <- p + theme(axis.text.y = theme_text(size = 17,face="bold"));

	#Set the text options for the title.
	p <- p + theme(axis.title.x = theme_text(vjust = -.5,size = 20,face="bold"));
	p <- p + theme(axis.title.y = theme_text(vjust = .35,size = 20,face="bold",angle=90));

	#Set the legend attributes.
	p <- p + theme(legend.title = theme_text(size = 20,face="bold"));
	p <- p + theme(legend.text = theme_text(size = 15,face="bold"));
	p <- p + theme(legend.title=theme_blank())

	p <- p + geom_point(size=4);

	#This is the name of the output image file.
	imageFileName <- paste(output.file,".png",sep="")

	#This initializes our image capture object.
	CairoPNG(file=imageFileName, width=1200, height=600,units = "px")

	#Printing actually puts the plot in the image.
	print(p)

	#Turn of the graphics device to save the image.
	dev.off()
	######################################################
}


library(caret)

data_train <- read.csv('./data/processed/processed_train.csv')

# Create custom indices
my_folds <- createMultiFolds(y = data_train$brand, k = 10, times = 3)


# Run posterior forecasts to make predictions

# Set up
source('2019-06-19-jsa-type-ch2/init/init_a.r')

# Parameters
set.seed(420) # for reproducibility
ftime <- as.numeric(25)

# Script

print(paste0(Sys.time(), " --- making forecasts"))

# Load data
files <- dir(
    dir_model_folder,
    pattern = 'count_info.data.R',
    full.names = TRUE
)

data <- read_rdump(files)

# Load zero inflated fits
load(paste0(dir_model_folder, "fit.data"))
zips <- fit; rm(fit)

# Simulate the forecast
forecast <- mclapply(1:1000, mc.cores=1, function(ii) {
	posterior_forecast(data = data, ftime = ftime, model = zips)
})

# Save forecast
save(forecast, file = paste0(dir_model_folder, "forecast.data"))
rm(data, zips, forecast)


pdf_file<-"pdf/maps_cities_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=7)

par(omi=c(0,0,0.5,0),mai=c(0.5,0,0.5,0),mfcol=c(1,2),family="Lato Light",
	las=1)
library(maptools) # also loads sp for over
library(rgdal) # for spTransform

# Prepare chart and import data

flib<-rgb(0,139,0,120,maxColorValue=255)
fpol<-rgb(139,0,0,120,maxColorValue=255)

to_myProj<-"+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +over +no_defs"

from_myProj<-"+proj=tmerc +lat_0=49 +lon_0=-2 +k=0.999601272 +x_0=400000 +y_0=-100000 +ellps=airy +towgs84=375,-111,431,0,0,0,0 +units=m +no_defs"
myShapeFile<-"myData/london/greater_london_const_region.shp"
myLon_adminD<-readShapeSpatial(myShapeFile,proj4string=CRS(from_myProj))
myLon_adminD <- spTransform(myLon_adminD, CRS=CRS(to_myProj))

# Create chart and other elements

plot(myLon_adminD,col=rgb(139,139,139,60,maxColorValue=255),border="white")
lon_osm<-readShapeSpatial("myData/london/london.osm-amenities.shp")
proj4string(lon_osm)<-proj4string(myLon_adminD)
inside1<-!is.na(over(lon_osm,myLon_adminD)) & lon_osm@data$type == "library"
inside2<-!is.na(over(lon_osm,myLon_adminD)) & lon_osm@data$type == "police"
points(lon_osm[inside1[ ,1],],col=flib,pch=15,cex=1.25,lwd=0)
points(lon_osm[inside2[ ,1],],col=fpol,pch=19,cex=1.25,lwd=0)

legend("bottomright",c("library","police"),col=c(flib,fpol),pch=c(15,19),bty="n",pt.cex=1.5,cex=1.5)
mtext(side=3,"In London ...",cex=1.5,col=rgb(64,64,64,maxColorValue=255))
mtext(side=1,"OSM-Data: metro.teczno.com/",adj=1,cex=0.85)
mtext(side=1,"adm. Borders: parlvid.mysociety.org:81/os/",adj=0.1,cex=0.85)

# Import data and prepare chart

from_myProj<-"+proj=lcc +lat_1=40.66666666666666 +lat_2=41.03333333333333 +lat_0=40.16666666666666 +lon_0=-74 +x_0=300000 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=us-ft +no_defs"
myShapeFile<-"myData/newyork/nybb.shp"
myNy_adminD<-readShapeSpatial(myShapeFile,proj4string=CRS(from_myProj))
myNy_adminD <- spTransform(myNy_adminD, CRS=CRS(to_myProj))

# Create chart

plot(myNy_adminD,col=rgb(139,139,139,60,maxColorValue=255),border="white")

# Import data and other elements

ny_osm<-readShapeSpatial("myData/newyork/new-york.osm-amenities.shp")
proj4string(ny_osm)<-proj4string(myNy_adminD)
inside1<-!is.na(over(ny_osm,myNy_adminD)) & ny_osm@data$type == "library"
inside2<-!is.na(over(ny_osm,myNy_adminD)) & ny_osm@data$type == "police"
points(ny_osm[inside1[ ,1],],col=flib,pch=15,cex=1.25,lwd=0)
points(ny_osm[inside2[ ,1],],col=fpol,pch=19,cex=1.25,lwd=0)

# Titling

mtext(side=3,"... and in New York",cex=1.5,col=rgb(64,64,64,maxColorValue=255))
mtext(side=3,"'Amenities' in OpenStreetMap",outer=T,cex=2,family="Lato Black")
mtext(side=1,"adm. Borders: www.nycgov/html/dcp/html/bytes/dwndistricts.shtml",adj=0.9,cex=0.85)
dev.off()