#############################################################################
##
## Indirection - phase 2: output gating
## Role/filler recall task
## 2017 Mike Jovanovich
##
## In this version OG sees WM after it has been update by IG within a timestep.
## The action selection if this version simply checks if WM_out outputs only
## the correct filler
##
#############################################################################

## Usage
# Rscript outputgate.r 1 100000 3 10 3 C C D F F SG

#############################################################################
## Parameter initialization
#############################################################################

source('hrr.r')
source('sentenceSets.r')
require(methods)
require(Matrix)

## Build args dictionary
argnames <- list('seed','ntasks','nstripes','nfillers','nroles','state_cd','sid_cd','interstripe_cd',
  'use_sids_input','use_sids_output','gen_test')
args <- commandArgs(trailingOnly = TRUE)

## Set the seed for repeatability
set.seed(as.integer(args[which(argnames=='seed')]))

## Length of the HRRs
n <- 1024
## Number of possible fillers
nfillers <- as.integer(args[which(argnames=='nfillers')])
## Number of possible roles
nroles <- as.integer(args[which(argnames=='nroles')])
## Number of WM stripes
nstripes <- as.integer(args[which(argnames=='nstripes')])

## Define conj/disj scheme
state_cd <- args[which(argnames=='state_cd')]
sid_cd <- args[which(argnames=='sid_cd')]
interstripe_cd <- args[which(argnames=='interstripe_cd')]

## Identity vectors
hrr_z <- rep(0,n)
hrr_o <- rep(0,n)
hrr_o[1] <- 1

# Set this according to conj. disj. scheme;
if( interstripe_cd == 'D' ) {
    hrr_i <- hrr_z
} else {
    hrr_i <- hrr_o
}

## Filler vectors
## Fillers don't have friendly names, only indexes
## To index: [,filler]
fillers <- replicate(nfillers,hrr(n,normalized=TRUE))
wm_fillers <- replicate(nfillers,hrr(n,normalized=TRUE))
f_fillers <- paste('f',1:nfillers,sep='') # Friendly names

## Role vectors
## Roles don't have friendly names, only indexes
## To index: [,role]
roles <- replicate(nroles,hrr(n,normalized=TRUE))

## Stripe ID (SID) vectors
## To index: [,sid]
sids <- replicate(nstripes,hrr(n,normalized=TRUE))
use_sids_input <- args[which(argnames=='use_sids_input')] == 'T'
use_sids_output <- args[which(argnames=='use_sids_output')] == 'T'

## Op code vectors
## To index: [,1] for store, [,2] for retrieve
ops <- replicate(2,hrr(n,normalized=TRUE))

## Op code vectors
## To index: [,1] go, [,2] no go
gono <- replicate(2,hrr(n,normalized=TRUE))

## TD weight vectors
## A suffix of '_m' indicates relation to the maintenance layer NN
## To index: [,stripe]
W_m <- replicate(nstripes,hrr(n,normalized=TRUE))
W_o <- replicate(nstripes,hrr(n,normalized=TRUE))

## Action weight vectors
## There are 'nfillers' output units for this network
## Each output unit should come to represent the desired filler
## To index: [,output_unit]
W_a <- replicate(nfillers,hrr(n,normalized=TRUE))

## TD parameters
default_reward <- 0.0
success_reward <- 1.0
bias_m <- 1.0
bias_o <- 1.0
bias_a <- 1.0
gamma_m <- 1.0
gamma_o <- 1.0
gamma_a <- 1.0
lambda_m <- 0.9
lambda_o <- 0.9
lrate_m <- 0.1
lrate_o <- 0.1
lrate_a <- 0.1
epsilon_m <- .025
epsilon_o <- .025

## Task parameters
max_tasks <- as.integer(args[which(argnames=='ntasks')])
cur_task <- 1
cur_block_task <- 1
block_tasks_correct <- 0

## Get training and test sets
train_set_size <- 200
test_set_size <- 100

## Choose testing protocol
if( args[which(argnames=='gen_test')] == 'SG' ) {
    sets <- standardGeneralization(nroles,nfillers,train_set_size,test_set_size)
} else if( args[which(argnames=='gen_test')] == 'SA' ) {
    sets <- spuriousAnticorrelation(nroles,nfillers,train_set_size,test_set_size)
} else if( args[which(argnames=='gen_test')] == 'FC' ) {
    sets <- fullCombinatorial(nroles,nfillers,train_set_size,test_set_size)
} else if( args[which(argnames=='gen_test')] == 'NF' ) {
    sets <- novelFiller(nroles,nfillers,train_set_size,test_set_size)
}

#############################################################################
## selectAction:
##
## This function handles action selection. To keep things simple, there must
## be only one WM_out filler, otherwise a -1 action is returned.
##
#############################################################################
selectAction <- function() {
    action <- -1
    for( i in 1:nstripes ) {
        if( f_stripes_o[i] != 'I' )
            ## if there are more than one fillers return -1
            if( action != -1 )
                return(-1)
            else
                action <- as.integer(substr(f_stripes_o[i],2,nchar(f_stripes_o[i])))
    }
    return (action)
}

#############################################################################
## getState: Returns role/op combo
#############################################################################
getState <- function(o,r) {
    ## Encode state (role,op)
    if( state_cd == 'C' ) {
        state <- convolve(ops[,o],roles[,r])
    } else {
        state <- cnorm(ops[,o] + roles[,r])
    }
    #state <- roles[,r]
    return (state)
}

#############################################################################
## inputGate:
##
## This function handles input gating for a single timestep/operation in the task.
## At each timestep a stripe can either retain its contents or update with the
## provided filler.
##
## Multiple stripes update in a single timestep.
##
#############################################################################
inputGate <- function(state,f=-1) {

    ## Get NN output unit values
    ## Note that state_wm is for the previous timestep
    ## We will return this to use in the eligibility trace
    #state_wm <- convolve(state,cur_wm_m)

    ## This is state_wm convolved with both the go and no go hrrs
    #state_wm_gono <- apply(gono,2,convolve,state_wm)
    state_gono <- apply(gono,2,convolve,state)

    ## Build to matrix of eligility trace vectors that will be returned
    ## for TD updates; default to no go
    #elig <- replicate(nstripes,state_wm_gono[,2])
    elig <- replicate(nstripes,state_gono[,2])
    vals <- rep(0.0,nstripes)
    open <- rep(FALSE,nstripes)

    ## Determine if open or close value is better
    for( i in 1:nstripes ) {
        #temp_vals <- (apply(state_wm_gono,2,nndot,W_m[,i]) + bias_m)
        temp_vals <- (apply(state_gono,2,nndot,W_m[,i]) + bias_m)
        vals[i] <- max(temp_vals)

        ## Epsilon soft policy
        r <- runif(1)
        if( r < epsilon_m ) {
            ## Pick a random open or close state
            r <- runif(1)
            if( r > .5 ) {
                #elig[,i] <- state_wm_gono[,1]
                elig[,i] <- state_gono[,1]
                open[i] <- TRUE
                vals[i] <- temp_vals[1]
            } else {
                vals[i] <- temp_vals[2]
            }
        } else if( temp_vals[1] > temp_vals[2] ) {
            #elig[,i] <- state_wm_gono[,1]
            elig[,i] <- state_gono[,1]
            open[i] <- TRUE
        }
    }

    ## Update WM_m contents
    ## We are convolving the fill with the appropriate SID
    for( i in 1:nstripes ) {
        if( open[i] ) {
            if( f == -1 ) {
                stripes_m[,i] <- hrr_i
                stripes_mo[,i] <- hrr_i
                f_stripes_m[i] <- 'I'
            } else {
                if( sid_cd == 'C' ) {
                    if( use_sids_input )
                        stripes_m[,i] <- convolve(fillers[,f],sids[,i])
                    if( use_sids_output )
                        stripes_mo[,i] <- convolve(fillers[,f],sids[,i])
                } else {
                    if( use_sids_input )
                        stripes_m[,i] <- cnorm(fillers[,f]+sids[,i])
                    if( use_sids_output )
                        stripes_mo[,i] <- cnorm(fillers[,f]+sids[,i])
                }
                if( !use_sids_input )
                    stripes_m[,i] <- fillers[,f]
                if( !use_sids_output )
                    stripes_mo[,i] <- fillers[,f]
                f_stripes_m[i] <- f_fillers[f]
            }
        }
    }

    ## Get updated wm representation
    if( interstripe_cd == 'D' ) {
        wm <- cnorm(apply(stripes_m,1,sum))
        if( is.nan(wm[1]) )
            wm <- hrr_o
    } else {
        wm <- mconvolve(stripes_m)
    }

    return(list(
        wm = wm,
        elig = elig,
        vals = vals,
        stripes_m = stripes_m,
        stripes_mo = stripes_mo,
        f_stripes_m = f_stripes_m
    ))
}

#############################################################################
## outputGate:
##
## This function handles output gating for a single timestep/operation in the task.
## Each PFC stripe can either output its contents or not.
##
#############################################################################
outputGate <- function(state) {

    ## Start with a blank slate
    stripes_o <- replicate(nstripes,hrr_i)
    f_stripes_o <- replicate(nstripes,'I')

    ## Get NN output unit values
    ## Note that state_wm is for the previous timestep
    ## We will return this to use in the eligibility trace
    #state_wm <- convolve(state,cur_wm_m)

    ## This is state_wm convolved with both the go and no go hrrs
    #state_wm_gono <- apply(gono,2,convolve,state_wm)
    state_gono <- apply(gono,2,convolve,state)

    ## Build to matrix of eligility trace vectors that will be returned
    ## for TD updates; default to no go
    #elig <- replicate(nstripes,state_wm_gono[,2])
    elig <- replicate(nstripes,state_gono[,2])
    vals <- rep(0.0,nstripes)
    open <- rep(FALSE,nstripes)

    ## Determine if open or close value is better
    for( i in 1:nstripes ) {

        #temp_vals <- (apply(state_wm_gono,2,nndot,W_o[,i]) + bias_o)
        temp_vals <- (apply(state_gono,2,nndot,W_o[,i]) + bias_o)
        vals[i] <- max(temp_vals)

        ## Epsilon soft policy
        r <- runif(1)
        if( r < epsilon_o ) {
            ## Pick a random open or close state
            r <- runif(1)
            if( r > .5 ) {
                #elig[,i] <- state_wm_gono[,1]
                elig[,i] <- state_gono[,1]
                open[i] <- TRUE
                vals[i] <- temp_vals[1]
            } else {
                vals[i] <- temp_vals[2]
            }
        } else if( temp_vals[1] > temp_vals[2] ) {
            #elig[,i] <- state_wm_gono[,1]
            elig[,i] <- state_gono[,1]
            open[i] <- TRUE
        }
    }

    ## Update WM_o contents
    ## We are convolving the fill with the appropriate SID
    for( i in 1:nstripes ) {
        if( open[i] ) {
            stripes_o[,i] <- stripes_mo[,i]
            f_stripes_o[i] <- f_stripes_m[i]
        }
    }

    ## Get updated wm representation
    if( interstripe_cd == 'D' ) {
        wm <- cnorm(apply(stripes_o,1,sum))
        if( is.nan(wm[1]) )
            ## Change this depending on how we want 'nothing' to look for action selection
            #wm <- hrr_o
            wm <- hrr_z
    } else {
        wm <- mconvolve(stripes_o)
    }

    return(list(
        wm = wm,
        elig = elig,
        vals = vals,
        f_stripes_o = f_stripes_o
    ))
}

## Continue until we hit the max_tasks, or we have a block success rate of 95%
while( cur_task <= max_tasks ) {

    ## Setup 200 task blocks
    if( cur_task %% 200 == 1 ) {
        if( block_tasks_correct/200 >= .95 )
            break
        cur_block_task <- 1
        block_tasks_correct <- 0
    }

    #############################################################################
    ## Initialization and task setup
    #############################################################################

    reward <- default_reward
    elig_m <- replicate(nstripes,rep(0,n)) # There is an elig. trace for each BG input gate
    elig_o <- replicate(nstripes,rep(0,n)) # There is an elig. trace for each BG output gate
    prev_val_m <- rep(0.0,nstripes)     # prev. timestep values for maintenance NN output layer units
    prev_val_o <- rep(0.0,nstripes)     # prev. timestep values for output NN output layer units
    cur_wm_m <- hrr_o
    cur_wm_o <- hrr_o

    ## Fill stripes with identity vector
    stripes_m <- replicate(nstripes,hrr_i)  # Input layer stripes (hrrs)
    stripes_mo <- replicate(nstripes,hrr_i)  # Output layer stripes (hrrs); these are same as above, but with no SID
    f_stripes_m <- replicate(nstripes,'I')  # Friendly name for stripe contents of input WM layer
    f_stripes_o <- replicate(nstripes,'I')  # Friendly name for stripe contents of output WM layer

    #############################################################################
    ## Store fillers
    #############################################################################

    ## Choose a sentence at random from the sample set
    s_f <- sets$train_set[sample(train_set_size,1),]

    ## Permute the sentence so that roles are not always presented in the same order
    p <- sample(nroles,nroles,replace=FALSE)

    for( t in 1:nroles ) {
        #cat(sprintf('t=%d\n',t)) #debug

        state <- getState(1,p[t])

        #############################################################################
        ## Input gating
        #############################################################################

        ## Update WM input layer global variables
        ig <- inputGate(state,s_f[p[t]])
        cur_wm_m <- ig$wm
        stripes_m <- ig$stripes_m
        stripes_mo <- ig$stripes_mo
        f_stripes_m <- ig$f_stripes_m

        #############################################################################
        ## Output gating
        #############################################################################

        ## Update WM output layer global variables
        og <- outputGate(state)
        cur_wm_o <- og$wm
        f_stripes_o <- og$f_stripes_o

        #############################################################################
        ## Neural network and TD training for this trial
        #############################################################################

        ## INPUT GATE
        error <- (reward + gamma_m * ig$vals) - prev_val_m
        for( i in 1:nstripes ) {
            W_m[,i] <- W_m[,i] + lrate_m * error[i] * elig_m[,i]
            elig_m[,i] <- cnorm(lambda_m * elig_m[,i] + ig$elig[,i])
        }
        prev_val_m <- ig$vals

        ## OUTPUT GATE
        error <- (reward + gamma_o * og$vals) - prev_val_o
        for( i in 1:nstripes ) {
            W_o[,i] <- W_o[,i] + lrate_o * error[i] * elig_o[,i]
            elig_o[,i] <- cnorm(lambda_o * elig_o[,i] + og$elig[,i])
        }
        prev_val_o <- og$vals

    }
    #cat(sprintf('t=%d\n',t+1)) #debug

    #############################################################################
    ## Query for roles
    #############################################################################

    ## Permute the sentence so that roles are not always queried in the same order
    nqueries <- 1
    p <- sample(nroles,nqueries,replace=FALSE)
    correct_trial <- rep(0,nqueries)

    for( t in 1:nqueries ) {
        state <- getState(2,p[t])

        #############################################################################
        ## Input gating
        #############################################################################

        ## Update WM input layer global variables
        ig <- inputGate(state)
        cur_wm_m <- ig$wm
        stripes_m <- ig$stripes_m
        stripes_mo <- ig$stripes_mo
        f_stripes_m <- ig$f_stripes_m

        #############################################################################
        ## Output gating
        #############################################################################

        ## Update WM output layer global variables
        og <- outputGate(state)
        cur_wm_o <- og$wm
        f_stripes_o <- og$f_stripes_o

        #############################################################################
        ## Action selection
        #############################################################################

        ac <- selectAction()

        #############################################################################
        ## Neural network and TD training for this trial
        #############################################################################

        ## INPUT GATE
        error <- (reward + gamma_m * ig$vals) - prev_val_m
        for( i in 1:nstripes ) {
            W_m[,i] <- W_m[,i] + lrate_m * error[i] * elig_m[,i]
            elig_m[,i] <- cnorm(lambda_m * elig_m[,i] + ig$elig[,i])
        }
        prev_val_m <- ig$vals

        ## OUTPUT GATE
        error <- (reward + gamma_o * og$vals) - prev_val_o
        for( i in 1:nstripes ) {
            W_o[,i] <- W_o[,i] + lrate_o * error[i] * elig_o[,i]
            elig_o[,i] <- cnorm(lambda_o * elig_o[,i] + og$elig[,i])
        }
        prev_val_o <- og$vals

        ## Determine correctness
        ## The trial is correct of the selected action matches the filler that
        ## was paired with the requested role.
        if( ac == s_f[p[t]] )
            correct_trial[t] <- 1

        #############################################################################
        ## Absorb reward
        #############################################################################
        if( t == nqueries ) {

            ## Reward if entire sequence is correct
            ## Update block correct tally
            if( sum(correct_trial) == nqueries ) {
                block_tasks_correct <- block_tasks_correct + 1
                reward <- success_reward
            } else {
                reward <- default_reward
            }

            ## Input NN
            error <- reward - ig$vals
            for( i in 1:nstripes ) {
                W_m[,i] <- W_m[,i] + lrate_m * error[i] * elig_m[,i]
            }

            ## Output NN
            error <- reward - og$vals
            for( i in 1:nstripes ) {
                W_o[,i] <- W_o[,i] + lrate_o * error[i] * elig_o[,i]
            }
        }
    }

    #############################################################################
    ## Output prints
    #############################################################################

    #if( FALSE ) {
    if( cur_task %% 200 == 0 ) {
        cat(sprintf('Tasks Complete: %d\n',cur_task))
        cat(sprintf('Block Accuracy: %.2f\n',(block_tasks_correct/200)*100))

        ## Only printing final request state here
        cat('Input WM Layer: \t')
        cat(f_stripes_m)
        cat('\n')
        cat('Output WM Layer: \t')
        cat(f_stripes_o)
        cat('\n')
        cat(sprintf('Requested Role: %d\n',p[t]))
        cat(sprintf('Correct Action: %d\n',s_f[p[t]]))
        cat('\n')
    }

    #############################################################################
    ## Task wrapup
    #############################################################################

    ## Increment task tally
    cur_task <- cur_task + 1
}

## Print final results
#cat(sprintf('%d\n',cur_task))
cat(sprintf('Final Block Accuracy: %.2f\n',(block_tasks_correct/200)*100))

#############################################################################
## Generalization Test
#############################################################################
if(TRUE) {
    novel_tasks_correct <- 0
    for( i in 1:test_set_size ) {
        correct_trial <- rep(0,nqueries)

        #############################################################################
        ## Store fillers
        #############################################################################

        ## Retrieve novel sentence from the test set
        ## We aren't training here so no need to permute
        s_f <- sets$test_set[i,]

        ## Permute the sentence so that roles are not always presented in the same order
        p <- sample(nroles,nroles,replace=FALSE)

        ## Do a 'Store' for each filler
        ## Action selection can be skipped here
        ## Do not do any training
        for( t in 1:nroles ) {
            state <- getState(1,p[t])

            ig <- inputGate(state,s_f[p[t]])
            cur_wm_m <- ig$wm
            stripes_m <- ig$stripes_m
            stripes_mo <- ig$stripes_mo
            f_stripes_m <- ig$f_stripes_m

            og <- outputGate(state)
            cur_wm_o <- og$wm
            f_stripes_o <- og$f_stripes_o
        }

        ## Do a 'Retrieve' input gate, output gate, and select action
        p <- sample(nroles,nqueries,replace=FALSE)
        for( t in 1:nqueries ) {

            ## We can only query role 1 for the FC test
            ## consequently, nqueries must be set to 1
            state <- if(args[which(argnames=='gen_test')] == 'FC') getState(2,1) else getState(2,p[t])
            answer <- if(args[which(argnames=='gen_test')] == 'FC') s_f[1] else s_f[p[t]]

            ig <- inputGate(state)
            cur_wm_m <- ig$wm
            stripes_m <- ig$stripes_m
            stripes_mo <- ig$stripes_mo
            f_stripes_m <- ig$f_stripes_m

            og <- outputGate(state)
            cur_wm_o <- og$wm
            f_stripes_o <- og$f_stripes_o

            ac <- selectAction()
            if( ac == answer )
                correct_trial[t] <- 1
        }

        ## Determine if entire sequence is correct
        ## Not sure if we'll want to modify protocol above to train for this
        if( sum(correct_trial) == nqueries )
            novel_tasks_correct <- novel_tasks_correct + 1
    }

    ## Print final results
    cat(sprintf('Generalization Accuracy: %d\n',novel_tasks_correct))
    #cat(sprintf('%d\n',novel_tasks_correct))
} ## End generalization test


# GetShockData_high_span3.r
#                                       RBLandau 20180129
# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/shocks/high/span3")
#
# For copies=3,4,5,6: what are the failure rates at shock span3?
#

source("./DataUtil.r")
source("./PlotUtil.r")

# G E T   D A T A
if (exists("results")) {rm(results)}
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.shockallcopies <- as.data.frame(fndfGetShockData(results))
dat.shockall <- dat.shockallcopies[dat.shockallcopies$copies>=3
                & dat.shockallcopies$copies<=6,]

# S U B S E T S

if (nrow(dat.shockall) > 0)
{
    source("./ShockLowPlots.r")

    # freq 2yr dur 6mo
    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==5000
                        & dat.shockall$shockimpact==50,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=6, nSpan=3, nImpact=50)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur6mo_span3_impact50.png")

    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==5000
                        & dat.shockall$shockimpact==90,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=6, nSpan=3, nImpact=90)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur6mo_span3_impact90.png")

    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==5000
                        & dat.shockall$shockimpact==100,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=6, nSpan=3, nImpact=100)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur6mo_span3_impact100.png")

    # freq 2yr dur 12mo
    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==10000
                        & dat.shockall$shockimpact==50,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=12, nSpan=3, nImpact=50)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur12mo_span3_impact50.png")

    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==10000
                        & dat.shockall$shockimpact==90,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=12, nSpan=3, nImpact=90)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur12mo_span3_impact90.png")

    dat.shockspan3 <- dat.shockall[dat.shockall$shockspan==3
                        & dat.shockall$shockfreq==20000
                        & dat.shockall$shockmaxlife==10000
                        & dat.shockall$shockimpact==100,]
    gp <- fnPlotShock1(dat.shockspan3, nFreq=2, nDuration=12, nSpan=3, nImpact=100)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_copvar_freq2yr_dur12mo_span3_impact100.png")

}

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

#END


#### add.ctd()
# Function adds CTD downcast values to a UVP cast. Parameters copied are manually specified in the loop
# below. Several interpolation methods are show. Only copies if the downcast datetime agrees with the
# UVP datetime to within 30 minutes.
add.ctd = function(MasterList, ctd, verbose = FALSE) {
  if (verbose) {
    cat(paste('  Adding CTD data to', MasterList$Files$File, '.\n'))
  }

  ## Add the cast time
  ctd.times = unique(ctd$Time)
  dt = abs(as.numeric(difftime(MasterList$meta$Time, ctd.times, units = 'mins'))) ## Calc time between current cast and possible ctd.times

  if (min(dt) < 30) {
    l = which(ctd$Time == ctd.times[which.min(dt)])

    #Adding cycle to the metadata because this is a more convenient file to do
    #it with than the ecotaxa metadata
    MasterList$meta$Cycle = as.numeric(unique(gsub("[^0-9\\.]", "", ctd$Cycle[l[1]])))

    #### Option 1
    ## No interpolation - Just copy all of the data
    temp1 = data.frame(Depth = ctd$Depth[l],
                       S = ctd$Salinity[l],
                       T = ctd$Temperature[l],
                       Fl = ctd$Fluorescence.V[l],
                       O2 = ctd$Oxygen.uM[l],
                       Trans = ctd$Transmission[l])

    #### Option 3
    ## Interpolated to the same depth as the bin (and averaged)
    depths = MasterList$Flux$Depth
    temp3 = data.frame(Depth = depths, S = NA, T = NA, Fl = NA, O2 = NA, Trans = NA)

    for (j in 1:nrow(temp3)) {
      if (j == 1) {
        k = which(ctd$Depth[l] <= depths[j])
      } else {
        k = which(ctd$Depth[l] <= depths[j] & ctd$Depth[l] > depths[j-1])
      }
      temp3$S[j] = mean(ctd$Salinity[l[k]])
      temp3$T[j] = mean(ctd$Temperature[l[k]])
      temp3$Fl[j] = mean(ctd$Fluorescence.V[l[k]])
      temp3$O2[j] = mean(ctd$Oxygen.uM[l[k]])
      temp3$Trans[j] = mean(ctd$Transmission[l[k]])
    }

    ## Save Data
    MasterList$ctd$ctd.raw = temp1
    MasterList$ctd$ctd.inter = temp3

  } else {
    warning(paste0('Warning: no CTD cast available for UVP cast: ', MasterList[i]))
    MasterList$ctd = NA
    MasterList$meta$Cycle = NA
  }
  if (verbose) {
    cat('!! Done with CTD.\n')
  }

  ## Return
  MasterList
}

#### add.export()
# Function to merge UVP cast object with dataframes (usually loaded from an excel file) containing sediment
# trap or thorium export values. Column names are hardcoded below.Values are matched by datetime stamps.
add.export = function(MasterList, thorium, sedtrap) {

  l = which(sedtrap$Deployment.Time < MasterList$meta$Time & sedtrap$Recovery.Datetime > MasterList$meta$Time)

  if (length(l) > 0) {
    MasterList$export$sedtrap = sedtrap[l,]
  }

  ## Add Thorium data based on closest match to cast time.
  dt = abs(as.numeric(difftime(MasterList$meta$Time, thorium$Collection.Datetime, units = 'hours')))
  k = which(thorium$Collection.Datetime == thorium$Collection.Datetime[which.min(dt)])

  if (length(k) >  0) {
    MasterList$export$thorium = thorium[k,]
  }

  ## Return
  MasterList
}

#### add.export.fp()
# Function to merge UVP cast with a dataframe contianing FP observations. Entries are binned using the same bins
# as the UVP data.
add.export.fp = function(cruise, fp) {
  for (cast in 1:length(cruise)) {
    cruise[[cast]]$export$fp = NA

    l = which(fp$studyName == cruise[[cast]]$meta$Cruise & fp$Cycle == cruise[[cast]]$meta$Cycle)

    ## there are FP observations
    if (length(l) > 0) {

      ## Depths of those observations
      depths = unique(fp$Depth[l])

      ## Copy first row of Flux df for template, set depths
      cruise[[cast]]$export$fp = cruise[[cast]]$Flux[1:length(depths),]
      cruise[[cast]]$export$fp$Depth = depths

      ## For each depth and bin size, find entries
      for (d in 1:length(depths)) {
        for (bin in 1:(length(cruise[[cast]]$params$bins - 1))) {

          ## Set default value
          cruise[[cast]]$export$fp[d, bin + 1] = 0

          ## Entries we care about (l referenced)
          k = which(fp$ESD.um[l] >= cruise[[cast]]$params$bins[bin] & fp$ESD.um[l] < cruise[[cast]]$params$bins[bin+1] & fp$Depth[l] == depths[d])

          if (length(k) > 0) {
            cruise[[cast]]$export$fp[d, bin + 1] = sum(fp$Mass.pg[l[k]] * fp$Conversion.Factor[l[k]]) / 1e9 ## pg -> mg
          }
        }
      }
      ## Recalcualte total column
      cruise[[cast]]$export$fp$Total = 0
      cruise[[cast]]$export$fp$Total = apply(cruise[[cast]]$export$fp[,-1], 1, sum)
    }
  }

  ## Return
  cruise
}

#### add.spectra.model()
# Calculates the size-spectral slope for each bin and saves it in the UVP cast object. This function
# is designed to run on cruise objects (a list of multiple UVP cast objects).
add.spectra.model = function(cruise) {
  for (cast in 1:length(cruise)){
    delta = cruise[[cast]]$params$delta.bins
    bins = cruise[[cast]]$params$bins[1:length(delta)]

    ## Initialize
    spectrum = data.frame(Depth = cruise[[cast]]$data$Depth, m = NA)

    for (i in 1:nrow(spectrum)) {
      x = bins + delta/2
      y = as.numeric(cruise[[cast]]$data[i,2:ncol(cruise[[cast]]$data)])[1:length(x)]

      y = log(y)
      x = log(x)

      x = x[is.finite(y)]
      y = y[is.finite(y)]

      if (length(y) > 0) {
        model = lm(y ~ x)
        spectrum$m[i] = as.numeric(model$coefficients[2])
      }
    }
    cruise[[cast]]$params$nslope = spectrum
  }

  #Return
  cruise
}


# CPUE_analysis_2012
# SDH starting 2012-06-10
# 1. Extract data using 2012_data_prep.r
# 2. A bit of pre-processing using intro_processing_pl.r
# 2b. Bit more cleaning
# 3. Split up by region
# 4. Cluster a region by trip using kmeans
# 5. Link each set with a cluster
# 6. Plot the sets on a map, coloured by cluster
# 7. Standardize all the clusters for each region

setwd("D:/L/alb/2012/assessment/Data_preparation/CPUE/")
# setwd("X:/L/alb/2012/assessment/Data_preparation/CPUE")
load("2012_allfleets2.RData")
length(unique(pl$boat_id))
ls()
dim(pl)
library(rpart)
library(cluster)
require(pkpkg)
require(R4MFCL)
require(MASS)

ezpac <- read.table("I:/assessments/Pop dy modeling/MFCL/R functions/EZNEW2.TXT")
names(ezpac) <- c("lon","lat")

windows()
hist(pl$set_yr)
boxplot(pl$sets_per_trip~pl$set_yr) # high in 1960-61 because of two vessels with sets in both yrs, need to assign to start(trip_date) and graph    #GMP: also increased across time to 2005...
windows();par(mfrow=c(2,1))
boxplot(pl$sets_per_trip~pl$flag_id)
barplot(table(pl$flag_id))

tp <- aggregate(cbind(trip_yr,sets_per_trip) ~ tripest_id + flag_id,data=pl,max)
windows(16,16);par(mfrow=c(4,4),mar=c(2,2,2,0))
boxplot(tp$sets_per_trip~tp$trip_yr)
for(f in sort(unique(tp$flag_id))) {
  with(tp[tp$flag_id ==f,],boxplot(sets_per_trip ~ trip_yr,main=f,ylim=c(0,250)))
  }
savePlot("sets_per_trip_by_flag.png",type="png")

# Remove redundant fields to clean up the data frame
pl <- pl[,c("trip_id","tripest_id","set_id","flag_id","ez_id","hook","hk_bt_flt","alb_n","yft_n","bet_n","oth_n","latd","lond","lat5","lon5","latlong","centlat","centlong",
          "reg","boat_id","src_id","fleet_id","swo","bum","mls","blm","wah","dol","skj","bsh","sbf","shk","uns",
          "trip_yr","trip_mon","set_yr","set_mon","set_qtr","set_yrqtr","tuna_n","bet_cpue","alb_cpue","yft_cpue","bet_perc","alb_perc","yft_perc","wt")]
table(pl$reg)

# Some plotting to see what's going on.
windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  boxplot(alb_cpue ~ eval(floor(hook/200)*200),data=reg,main=paste("Region",rg),ylim=c(0,400))
  }
savePlot("alb_cpue_by_hooks",type="png")

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  boxplot(alb_n ~ eval(floor(hook/200)*200),data=reg,main=paste("Region",rg))
  }
savePlot("alb_catch_by_hooks",type="png")

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  boxplot(hook ~ set_yr,data=reg,main=paste("Region",rg))
  }

a <- pl[pl$set_yr >= 2000,]
for(rg in 1:4) {
  reg <- a[a$reg==rg,]
  boxplot(alb_cpue ~ eval(floor(hook/200)*200),data=reg,main=paste("Region",rg))
  }

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
a <- pl[pl$set_yr > 1980,]
for(rg in 1:4) {
  reg <- a[a$reg==rg,]
  boxplot(alb_cpue ~ eval(floor(hook/200)*200),data=reg,main=paste("Region",rg),ylim=c(0,400))
  }

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  boxplot(alb_cpue ~ set_yr,data=reg,main=paste("Region",rg),ylim=c(0,400))
  }
windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  hist(reg$hook,main=paste("Region",rg))
  }

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,1,1))
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
#  hist(reg$alb_n,main=paste("Region",rg))
  a <- table(reg$alb_n)
  plot(as.numeric(names(a)),log(a))
  }
for(rg in 1:4) {
  reg <- pl[pl$reg==rg,]
  print(quantile(reg$alb_n,c(.001,.01,.05,.5,.95,.99,.999)))
  }
a <- pl[pl$alb_n > 700,]
windows()
a <- pl[pl$set_yr >2000,]
a <- pl[pl$alb_n >400,]
plot(a$alb_n,a$alb_c)   # alb_n seems to match alb_c. Not sure about alb_w
table(ceiling(a$alb_w/10),ceiling(a$alb_n/50))

# remove sets without many hooks
a <- pl[pl$hook > 1000,]
length(unique(a$boat_id))
table(pl$flag_id)
table(a$flag_id)
barplot(table(a$flag_id)/table(pl$flag_id),xlab="Flag",ylab="Proportion of sets remaining",ylim=c(0,1))
savePlot("Effect of 1000 hook limit on sets",type="png")
barplot(tapply(a$hook,a$flag_id,sum)/tapply(pl$hook,pl$flag_id,sum),xlab="Flag",ylab="Proportion of effort remaining",ylim=c(0,1))
savePlot("Effect of 1000 hook limit on hooks",type="png")

pl2 <- pl[pl$hook > 1000,]    #

#### Set up variables for trip-level clustering
tpall <- aggregate(cbind(hook,hk_bt_flt,alb_n,yft_n,bet_n,oth_n,latd,lond,swo,bum,mls,blm,wah,dol,skj,bsh,sbf,shk,uns) ~ tripest_id + flag_id + boat_id + trip_yr + reg,data=pl2,mean)
tpall$bet_cpue <- 1000*tpall$bet_n/tpall$hook
tpall$yft_cpue <- 1000*tpall$yft_n/tpall$hook
tpall$alb_cpue <- 1000*tpall$alb_n/tpall$hook
tpall$oth_cpue <- 1000*tpall$oth_n/tpall$hook
tpall$swo_cpue <- 1000*tpall$swo/tpall$hook
tpall$bum_cpue <- 1000*tpall$bum/tpall$hook
tpall$mls_cpue <- 1000*tpall$mls/tpall$hook
tpall$blm_cpue <- 1000*tpall$blm/tpall$hook
tpall$wah_cpue <- 1000*tpall$wah/tpall$hook
tpall$dol_cpue <- 1000*tpall$dol/tpall$hook
tpall$skj_cpue <- 1000*tpall$skj/tpall$hook
tpall$bsh_cpue <- 1000*tpall$bsh/tpall$hook
tpall$sbf_cpue <- 1000*tpall$sbf/tpall$hook
tpall$shk_cpue <- 1000*tpall$shk/tpall$hook
tpall$uns_cpue <- 1000*tpall$uns/tpall$hook

tp <- aggregate(cbind(bet_n,yft_n,alb_n,oth_n,swo,bum,mls,blm,wah,dol,skj,bsh,sbf,shk,uns,hk_bt_flt) ~ tripest_id + flag_id + boat_id + trip_yr + reg,data=pl2,mean)
a <- aggregate(bet_n ~ tripest_id + flag_id + boat_id + trip_yr + reg,data=pl2,length)
dima <- dim(tp)[2]
tp <- cbind(tp,a[,6])
names(tp)[dima+1] <- "nset"
tp$tot_n <- tp$alb_n + tp$yft_n + tp$bet_n + tp$oth_n
tp$tuna_n <- tp$alb_n + tp$yft_n + tp$bet_n
tp$bet_perc <- tp$bet_n/tp$tuna_n
tp$alb_perc <- tp$alb_n/tp$tuna_n
tp$yft_perc <- tp$yft_n/tp$tuna_n
tp$bet_totpc <- tp$bet_n/tp$tot_n
tp$alb_totpc <- tp$alb_n/tp$tot_n
tp$yft_totpc <- tp$yft_n/tp$tot_n
tp$oth_totpc <- tp$oth_n/tp$tot_n
tp$swo_totpc <- tp$swo/tp$tot_n
tp$bum_totpc <- tp$bum/tp$tot_n
tp$mls_totpc <- tp$mls/tp$tot_n
tp$blm_totpc <- tp$blm/tp$tot_n
tp$wah_totpc <- tp$wah/tp$tot_n
tp$dol_totpc <- tp$dol/tp$tot_n
tp$skj_totpc <- tp$skj/tp$tot_n
tp$bsh_totpc <- tp$bsh/tp$tot_n
tp$sbf_totpc <- tp$sbf/tp$tot_n
tp$shk_totpc <- tp$shk/tp$tot_n
tp$uns_totpc <- tp$uns/tp$tot_n
gc()

str(tp)
pairs(tp[,21:32])
for(r in 1:4) {
  windows(height=20,width=30); par(mfrow=c(4,4))
  hist(tp[tp$reg==r,25:39])
  title(paste("Region",r),outer=T,line=-1)
  savePlot(paste("hists_by_sp_reg_",rg,sep=""),type="png")
  }

# Regression trees to see which factors affect alb cpue
windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,2,2))
for(rg in 1:4) {
  a <- tpall[tpall$reg==rg,]
  tree1 <- rpart(alb_cpue ~ latd + lond + trip_yr + flag_id + bet_cpue + yft_cpue + swo_cpue + bsh_cpue + hook, data=a)
  plot(tree1,main=paste("Region",rg))
  text(tree1)
  }
savePlot("Rtrees_by_reg_by_trip",type="png")

windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,2,2))
for(rg in 1:4) {
  a <- pl2[pl2$reg==rg,]
  tree1 <- rpart(alb_cpue ~ latd + lond + trip_yr + flag_id + bet_cpue + yft_cpue + hook, data=a)
  plot(tree1,main=paste("Region",rg))
  text(tree1)
  }
savePlot("Rtrees_by_reg_by_set",type="png")

# Regression trees to see which factors affect alb percent
windows(width=22,height=18); par(mfrow=c(2,2),mar=c(2,2,2,2))
for(rg in 1:4) {
  a <- tpall[tpall$reg==rg,]
  a$alb_perc <- with(a,alb_n / (alb_n + yft_n + bet_n + oth_n))
  tree1 <- rpart(alb_perc ~ latd + lond + trip_yr + flag_id + hook, data=a)
  plot(tree1,main=paste("Region",rg))
  text(tree1)
  }
savePlot("Rtrees_albperc_by_reg_by_trip",type="png")

windows(width=22,height=18); par(mfrow=c(2,2),mar=c(2,2,2,2))
for(rg in 1:4) {
  a <- pl2[pl2$reg==rg,]
  a$alb_perc <- with(a,alb_n / (alb_n + yft_n + bet_n + oth_n))
  tree1 <- rpart(alb_cpue ~ latd + lond + trip_yr + flag_id + hook, data=a)
  plot(tree1,main=paste("Region",rg))
  text(tree1)
  }
savePlot("Rtrees_albperc_by_reg_by_set",type="png")

# Look at numbers of clusters
tpx <- tp[,c("bet_perc","yft_perc","alb_perc","oth_totpc","trip_yr","tripest_id", "hk_bt_flt","reg")]
triptots <- tp[,c("bet_n","yft_n","alb_n","oth_n","trip_yr","tripest_id", "hk_bt_flt","reg")]
tpx <- na.omit(tpx)
windows(width=20,height=18); par(mfrow=c(2,2),mar=c(2,2,2,2))
nsp=3
for(rg in 1:4) {
  a <- tpx[tpx$reg==rg,]
  a[,1:nsp] <- scale(a[,1:nsp])
  wss <- (nrow(a)-1)*sum(apply(a[,1:nsp],2,var))
  for (i in 2:15) wss[i] <- sum(kmeans(a[,1:nsp],centers=i,iter.max = 40)$withinss)
  plot(1:15, wss, type="b", xlab="Number of Clusters",ylab="Within groups sum of squares",main=paste("Region",rg))
  }
savePlot(paste("cluster_num_v_SS_by_reg_",nsp,"_spp",sep=""),type="png")

# identify catch rates by trip
for(rg in 1:4) {
  a <- tp[tp$reg==rg,]
  windows(width=20,height=18); par(mfrow=c(2,2))
  boxplot(a$bet_perc~a$trip_yr, xlab="Year", ylab="bet_perc")   #looks like high BET C prop prior to ~1984, and post 2002
  boxplot(a$alb_perc~a$trip_yr, xlab="Year", ylab="bet_perc")
  boxplot(a$yft_perc~a$trip_yr, xlab="Year", ylab="bet_perc")
  boxplot(a$oth_totpc~a$trip_yr, xlab="Year", ylab="bet_perc")
  title(paste("Region",rg),outer=T,line=-1)
  savePlot(paste("boxplot_sp_percent_reg_",rg,sep=""),type="png")
}

## GMP: start here
table(tp$tuna_n==0)
tp <- tp[tp$tuna_n!=0, ]   # removing 82 trips

###################################
## GMP note - choose which of these periods you want to look at - incl post 1999, 1990-1999, or the whole kaboosh (not done here)
## Start with post 1999
## SDH change later to make it pre-1984, 1984-2002, and 2003-2011
## SDH change again to do all at once
###################################
#junk5 <- junk3[junk3$ret_year>=1999,]
#dim(junk5)         #[1] 469   10

for(reg in 1:4) { # This takes a long time to run for R1 and R2
  gc()
  ax2 <- tp[tp$reg==reg,c("bet_perc","yft_perc","alb_perc","trip_yr","tripest_id", "hk_bt_flt")]
  ax <- tp[tp$reg==reg & tp$nset >= 5,c("bet_perc","yft_perc","alb_perc","trip_yr","tripest_id", "hk_bt_flt")]
  triptots2 <- tp[tp$reg==reg,c("bet_n","yft_n","alb_n","trip_yr","tripest_id", "hk_bt_flt")]
  triptots <- tp[tp$reg==reg & tp$nset >= 5,c("bet_n","yft_n","alb_n","trip_yr","tripest_id", "hk_bt_flt")]
  a <- na.omit(ax)
  a2 <- na.omit(ax2)
  a2[,1:3] <- scale(a2[,1:3])
  triptots[,1:3] <- scale(triptots[,1:3])
  triptots2[,1:3] <- scale(triptots2[,1:3])
  summary(triptots[,1:3])

  ##########################
  ## GMP: first dendrogram to id k cluster number
  ## These dendrograms take forever and use a lot of memory
  ##########################
  # other cluster method of all trips in entire series there are x total bet trips
  d <- dist(a[1:3], method = "euclidean") # distance matrix
  fit <- hclust(d, method="ward")
  windows(10,10);par(mfrow=c(2,2))
  plot(fit, labels = FALSE, hang=-1,  main = "dendrogram (whole period)") # display dendogram  #looks like 3 (or 4) main branches
  groups <- cutree(fit, k=3) # cut tree into 3 clusters
  # draw dendogram with red borders around the 3 clusters
  rect.hclust(fit, k=3, border="red")
  table(groups)
  clarax <- clara(a[1:3],3)             #clustering based upon the percent of spp in total catch of tuna     NOTE: using clusters from hclust k above(?? think it's actually independent clustering SDH)
  save(a,d,fit,clarax,file=paste("reg_",reg,"_fitfiles.RData",sep=""))
  plot(clarax)
  savePlot(file=paste("cluster_allyrs_dendrogram_R",reg,".png",sep=""),type="png")
}

for(reg in 1:4) {
  load(file=paste("reg_",reg,"_fitfiles.RData",sep=""))
  print(reg)
  print(aggregate(a[,1:3],by=list(clarax$clustering),FUN=mean))
  print(aggregate(clarax$data,by=list(clarax$clustering),FUN=mean))

#[1] 1
#  Group.1   bet_perc   yft_perc  alb_perc
#1       1 0.02377515 0.05786726 0.9183576
#2       2 0.07744380 0.19064415 0.7319121
#3       3 0.12282213 0.49362036 0.3835575
#  Group.1   bet_perc   yft_perc  alb_perc
#1       1 0.02377515 0.05786726 0.9183576
#2       2 0.07744380 0.19064415 0.7319121
#3       3 0.12282213 0.49362036 0.3835575
#
#   1    2    3
#7807 6329 4215
#[1] 2
#  Group.1   bet_perc  yft_perc  alb_perc
#1       1 0.11961166 0.1497490 0.7306394
#2       2 0.03894412 0.0479472 0.9131087
#3       3 0.23057253 0.4102599 0.3591676
#  Group.1   bet_perc  yft_perc  alb_perc
#1       1 0.11961166 0.1497490 0.7306394
#2       2 0.03894412 0.0479472 0.9131087
#3       3 0.23057253 0.4102599 0.3591676
#
#   1    2    3
#7617 7698 5839
#[1] 3
#  Group.1    bet_perc    yft_perc  alb_perc
#1       1 0.026824129 0.026789908 0.9463860
#2       2 0.008043066 0.005833925 0.9861230
#3       3 0.051543031 0.101308324 0.8471486
#  Group.1    bet_perc    yft_perc  alb_perc
#1       1 0.026824129 0.026789908 0.9463860
#2       2 0.008043066 0.005833925 0.9861230
#3       3 0.051543031 0.101308324 0.8471486
#
#  1   2   3
#396 680 163
#[1] 4
#  Group.1    bet_perc   yft_perc  alb_perc
#1       1 0.032734083 0.04254883 0.9247171
#2       2 0.008987234 0.00744052 0.9835722
#3       3 0.115038781 0.18533184 0.6996294
#  Group.1    bet_perc   yft_perc  alb_perc
#1       1 0.032734083 0.04254883 0.9247171
#2       2 0.008987234 0.00744052 0.9835722
#3       3 0.115038781 0.18533184 0.6996294
#
#   1    2    3
#1107 1487  165
#

  print(table(clarax$clustering))

  junk4b <- table(clarax$clustering)
  junk4c <- cbind(a, clarax$clustering)                                                                    #appends cluster to dataframe, then names (in row below)
  names(junk4c) <- c("bet_perc","yft_perc","alb_perc","ret_year","tripest_id", "hk_bt_flt", "cluster")
  assign(paste("clust_R",reg,sep=""),junk4c)
  }

clust_R1$reg <- 1
clust_R2$reg <- 2
clust_R3$reg <- 3
clust_R4$reg <- 4
hclusts <- rbind(clust_R1,clust_R2,clust_R3,clust_R4)
save(hclusts,file="hclusts.RData")
load(file="hclusts.RData")

aggregate(hclusts[,1:3],by=list(hclusts$cluster,hclusts$reg),FUN=mean)

# Following up with a few alternative cluster methods - I think these were done just for comparison
# Model Based Clustering
library(mclust)
fit <- Mclust(triptots[,1:3])
windows(15,15);par(mfrow=c(2,2))
plot(fit, triptots[,1:3]) # plot results
print(fit) # display the best model
plot.Mclust

# Ward Hierarchical Clustering with Bootstrapped p values
library(pvclust)
iv <- as.matrix((a[,1:3]))
summary(iv)
result <- pvclust((lung), method.dist="cor", method.hclust="average", nboot=200)
plot(result) # dendogram with p values
pvrect(result, alpha=.95)

fit <- pvclust(t(iv), method.dist="cor", method.hclust="average", use.cor="all.obs",nboot=200)
fit <- pvclust(t(iv), method.hclust="ward", method.dist="euclidean",nboot=500)
plot(fit) # dendogram with p values
# add rectangles around groups highly supported by the data
  pvrect(fit, alpha=.95)

##################################
# Apparently the fit clustering takes too long. Might redo later since it's feasible on supercalc.
# Better apply other species in the clustering? SWO? No maybe not. Just use tunas across the whole period.
# This is where the trip clusters are identified, and later applied to the set-by-set data
tpx <- tp[,c("bet_perc","yft_perc","alb_perc","oth_totpc","trip_yr","tripest_id", "hk_bt_flt","reg")]
tpx <- na.omit(tpx)
nsp=3
clx <- claracl <- list()
ncl <- c(3,3,3,3)
tpx$clust <- tpx$claracl <- NA
for(rg in 1:4) {
  a <- tpx[tpx$reg==rg,]
  a[,1:nsp] <- scale(a[,1:nsp])
  clx[[rg]] <- kmeans(a[,1:nsp],centers=ncl[rg],iter.max = 40)
  claracl[[rg]] <- clara(a[,1:nsp],k=ncl[rg])
  tpx[tpx$reg==rg,]$clust <- clx[[rg]]$cluster
  tpx[tpx$reg==rg,]$claracl <- claracl[[rg]]$clustering
  }

# Apply clusters to sets
pl2$clust <- as.factor(tpx[match(paste(pl2$tripest_id,pl2$reg),paste(tpx$tripest_id,tpx$reg)),]$clust)
pl2$claracl <- as.factor(tpx[match(paste(pl2$tripest_id,pl2$reg),paste(tpx$tripest_id,tpx$reg)),]$claracl)
pl2$hclustcl <- as.factor(hclusts[match(paste(pl2$tripest_id,pl2$reg),paste(hclusts$tripest_id,hclusts$reg)),]$cluster)
save(pl2,file="pl2_clustered.RData")
load(file="pl2_clustered.RData")

length(unique(pl2$boat_id[!is.na(pl2$hclustcl)]))
length(unique(pl2$trip_id[!is.na(pl2$hclustcl)]))
length(unique(pl2$set_id[!is.na(pl2$hclustcl)]))

table(pl2$hclustcl,useNA="always")
a <- pl2[is.na(pl2$hclustcl)==F,]
with(a,aggregate(cbind(alb_perc,bet_perc,yft_perc) ~ hclustcl + reg,FUN=mean))
with(a,aggregate(cbind(alb_perc,bet_perc,yft_perc) ~ clust + reg,FUN=mean))
with(a,aggregate(cbind(alb_perc,bet_perc,yft_perc) ~ claracl + reg,FUN=mean))

#windows(width=20,height=18); par(mfrow=c(2,2))
# Plot clusters on a map. Mostly SDH code from here down.
require(maps); require(maptools); require(mapdata)
windows(width=20,height=18); par(mfrow=c(2,2))
for(rg in 1:4) {
  a <- pl2[pl2$reg==rg & pl2$set_yr < 1980,]
  plot(1:10,1:10,type="n",xlab="Longitude",ylab="Latitude",xlim=range(a$lond),ylim=range(a$latd))
  for(cl in 1:ncl[rg]) {
    b <- a[a$clust==cl,]
    points(b$lond,b$latd,cex=0.5,col=cl)
    }
  lines(ezpac$lon, ezpac$lat)
  map(add=T)
  }
savePlot("map_clusters_kmeans_pre1980",type="png")
windows(width=20,height=18); par(mfrow=c(2,2))
for(rg in 1:4) {
  a <- pl2[pl2$reg==rg & pl2$set_yr < 1980,]
  plot(1:10,1:10,type="n",xlab="Longitude",ylab="Latitude",xlim=range(a$lond),ylim=range(a$latd))
  for(cl in 1:ncl[rg]) {
    b <- a[a$claracl==cl,]
    points(b$lond,b$latd,cex=0.5,col=cl)
    }
  lines(ezpac$lon, ezpac$lat)
  map(add=T)
  }
savePlot("map_clusters_clara_pre1980",type="png")
windows(width=20,height=18); par(mfrow=c(2,2))
for(rg in 1:4) {
  a <- pl2[pl2$reg==rg & pl2$set_yr < 1980,]
  plot(1:10,1:10,type="n",xlab="Longitude",ylab="Latitude",xlim=range(a$lond),ylim=range(a$latd))
  for(cl in 1:ncl[rg]) {
    b <- a[a$hclustcl==cl,]
    points(b$lond,b$latd,cex=0.5,col=cl)
    }
  lines(ezpac$lon, ezpac$lat)
  map(add=T)
  }
savePlot("map_clusters_hclust_pre1980",type="png")

# Make 2x2 maps
postyr <- 1980
preyr <- 1980
agglocs_hc <- with(pl2[pl2$set_yr <= preyr,],tapply(hook,list(2*floor(lond/2),2*floor(latd/2),hclustcl,reg),sum,na.rm=T))
agg <- with(pl2[pl2$set_yr <= preyr,],tapply(hook,list(2*floor(lond/2),2*floor(latd/2),reg),sum,na.rm=T))
#agglocs_hc <- tapply(pl2$hook,list(1*floor(pl2$lond/1),1*floor(pl2$latd/1),pl2$hclustcl,pl2$reg),sum,na.rm=T)
#agg <- tapply(pl2$hook,list(1*floor(pl2$lond/1),2*floor(pl2$latd/1),pl2$reg),sum,na.rm=T)
for(cl in 1:3) {
  windows(12,12)
  plot(1:10,1:10,type="n",xlim=c(140,250),ylim=c(-45,0),xlab="Longitude",ylab="Latitude",main=paste("Cluster",cl))
  for(reg in 1:4) {
    a <- agglocs_hc[,,cl,reg]/agg[,,reg]
    image(as.numeric(dimnames(a)[[1]]),as.numeric(dimnames(a)[[2]]),a,add=T)
    contour(as.numeric(dimnames(a)[[1]]),as.numeric(dimnames(a)[[2]]),a,add=T)
   }
  map(add=T)
  lines(c(180,180),c(-65,10),lwd=2)
  lines(c(100,300),c(-25,-25),lwd=2,col=1)
  savePlot(paste("Cluster_map_hcl_2x2_pre",preyr,cl,sep="_"),type="png")
  }

agglocs_hc[1:40,16:30,1,1]
props[1:40,16:30,1,1]
props[1:40,16:30,2,1]
props[1:40,16:30,3,1]

table(tpx$reg,tpx$clust)
table(tpx$reg,tpx$claracl)
aggregate(cbind(alb_perc,bet_perc,yft_perc) ~ clust + reg,data=pl2,mean)
aggregate(cbind(alb_perc,bet_perc,yft_perc) ~ claracl + reg,data=pl2,mean)
aggregate(cbind(claracl==1,claracl==2,claracl==3) ~ reg,data=pl2,mean)
#   claracl reg  alb_perc   bet_perc   yft_perc
#1        1   1 0.9190255 0.01937280 0.06160166   *  40%
#2        2   1 0.7499081 0.05723085 0.19286104      36%
#3        3   1 0.4138501 0.15995933 0.42619061      24%
#4        1   2 0.7125166 0.13201548 0.15546788      37%
#5        2   2 0.9056770 0.04079331 0.05352972   *  35%
#6        3   2 0.3106432 0.32911140 0.36024536      28%
#7        1   3 0.8905033 0.05205180 0.05744493      17%
#8        2   3 0.9727803 0.01270842 0.01451126   *  82%
#9        3   3 0.4460348 0.20826673 0.34569844      0.5%
#10       1   4 0.9010575 0.04170756 0.05723498      26%
#11       2   4 0.9745593 0.01273401 0.01270669   *  73%
#12       3   4 0.5805059 0.17887636 0.24061776       1%

tapply(cbind(tp$bet_perc),list(tpx$reg,tpx$clust),mean)
table(pl2$reg,pl2$clust)
table(pl2$reg,pl2$claracl)

windows(width=15,height=18); par(mfrow=c(2,2))
for(r in 1:4) {
  plot(1:10,1:10,xlim=c(1960,2011),ylim=c(0,1),xlab="Year",ylab="",main="kmeans")
  a <- with(pl2[pl2$reg==r,],tapply(set_yr,list(set_yr,clust),length))
  a[is.na(a)] <- 0
  for(cl in 1:3) {
    points(as.numeric(rownames(a)),a[,cl]/apply(a,1,sum),col=cl,pch=cl)
    }
  }
legend(1990,0.5,legend=paste("cluster",1:3),pch=1:3,col=1:3)
savePlot("clusters_by_yr_kmeans",type="png")

windows(width=15,height=18); par(mfrow=c(2,2))
for(r in 1:4) {
  plot(1:10,1:10,xlim=c(1960,2011),ylim=c(0,1),xlab="Year",ylab="",main="clara")
  a <- with(pl2[pl2$reg==r,],tapply(set_yr,list(set_yr,claracl),length))
  a[is.na(a)] <- 0
  for(cl in 1:3) {
    points(as.numeric(rownames(a)),a[,cl]/apply(a,1,sum),col=cl,pch=cl)
    }
  }
legend(1990,0.5,legend=paste("cluster",1:3),pch=1:3,col=1:3)
savePlot("clusters_by_yr_clara",type="png")

windows(width=15,height=18); par(mfrow=c(2,2))
for(r in 1:4) {
  plot(1:10,1:10,xlim=c(1960,2011),ylim=c(0,1),xlab="Year",ylab="",main="hclust")
  a <- with(pl2[pl2$reg==r,],tapply(set_yr,list(set_yr,hclustcl),length))
  a[is.na(a)] <- 0
  for(cl in 1:3) {
    points(as.numeric(rownames(a)),a[,cl]/apply(a,1,sum),col=cl,pch=cl)
    }
  }
legend(1990,0.5,legend=paste("cluster",1:3),pch=1:3,col=1:3)
savePlot("clusters_by_yr_hclust",type="png")

usecl_h <- c(paste(1,c(1,2)),paste(2,c(1,2)),paste(3,c(1,2)),paste(4,c(1,2)))
usecl_c <- c(paste(1,c(1,2)),paste(2,c(1,2)),paste(3,c(1,2)),paste(4,c(1,2)))
usecl_k <- c(paste(1,c(2)),paste(2,c(2)),paste(3,c(1,2,3)),paste(4,c(1,3)))
pl2$boat_id <- as.factor(pl2$boat_id)
albpl <- pl2[paste(pl2$reg,pl2$claracl) %in% usecl_c,]
save(albpl,file="albacore_doubleclusters_clara.RData")
albpl <- pl2[paste(pl2$reg,pl2$hclustcl) %in% usecl_h,]
save(albpl,file="albacore_doubleclusters_hclust.RData")
albpl <- pl2[paste(pl2$reg,pl2$hclustcl) %in% usecl_k,]
save(albpl,file="albacore_doubleclusters_kmeans.RData")

ls()
rm(a,a1,a2,ax,b,b2,channel,cl,claracl,clx,d,dima,f,fit,groups,i,l_bycat,ncl,nsp,pl,pl5,r,reg,reg1,rg,tp,tp1,tpall,tpx,triptots,usecl,wss)

table(albpl$reg,albpl$flag_id)

####################################################
# CPUE analysis
####################################################

load(file="albacore_doubleclusters_hclust.RData")
albpl_h <- albpl
load(file="albacore_doubleclusters_clara.RData")
albpl_c <- albpl
load(file="albacore_doubleclusters_kmeans.RData")
albpl_k <- albpl
albpl_h$hclustcl <- as.factor(albpl_h$hclustcl)
albpl_h$clust <- as.factor(albpl_h$clust)
albpl_h$claracl <- as.factor(albpl_h$claracl)
albpl_c$hclustcl <- as.factor(albpl_c$hclustcl)
albpl_c$clust <- as.factor(albpl_c$clust)
albpl_c$claracl <- as.factor(albpl_c$claracl)
albpl_k$hclustcl <- as.factor(albpl_k$hclustcl)
albpl_k$clust <- as.factor(albpl_k$clust)
albpl_k$claracl <- as.factor(albpl_k$claracl)

albpl_c$cl <- albpl_c$claracl
albpl_h$cl <- albpl_h$hclustcl
albpl_k$cl <- albpl_k$clust

windows(15,15); par(mfrow=c(2,2))
for(r in 1:4) {
  dd <- albpl_h[albpl_h$reg==r,]
  catch  <- tapply(dd$alb_n, dd$set_yrqtr, sum)
  effort <- tapply(dd$hook, dd$set_yrqtr, sum)
  cpue <- 1000*catch/effort
  ytot <- sort(unique(dd$set_yrqtr))
  timeseries <- seq(1960.125, 2012, by=0.25)
  timeNA <- data.frame(ytot[match(timeseries,ytot)])
  names(timeNA) <- c("time")
  cpue <- data.frame(cpue)
  cpue$time <- row.names(cpue)
  final <- data.frame(cpue[match(timeNA[,1],cpue[,2]),1])
  names(final) <- c("cpue")
  plot(timeNA$time, final$cpue, type="n", col="red", xlim=c(1960,2012),ylim=c(0,max(cpue$cpue)))
  lines(timeNA$time,final$cpue, col="blue")

  dd <- albpl_c[albpl_c$reg==r,]
  catch  <- tapply(dd$alb_n, dd$set_yrqtr, sum)
  effort <- tapply(dd$hook, dd$set_yrqtr, sum)
  cpue <- 1000*catch/effort
  ytot <- sort(unique(dd$set_yrqtr))
  timeseries <- seq(1960.125, 2012, by=0.25)
  timeNA <- data.frame(ytot[match(timeseries,ytot)])
  names(timeNA) <- c("time")
  cpue <- data.frame(cpue)
  cpue$time <- row.names(cpue)
  final <- data.frame(cpue[match(timeNA[,1],cpue[,2]),1])
  names(final) <- c("cpue")
  lines(timeNA$time,final$cpue, col="red")

  dd <- albpl_k[albpl_k$reg==r,]
  catch  <- tapply(dd$alb_n, dd$set_yrqtr, sum)
  effort <- tapply(dd$hook, dd$set_yrqtr, sum)
  cpue <- 1000*catch/effort
  ytot <- sort(unique(dd$set_yrqtr))
  timeseries <- seq(1960.125, 2012, by=0.25)
  timeNA <- data.frame(ytot[match(timeseries,ytot)])
  names(timeNA) <- c("time")
  cpue <- data.frame(cpue)
  cpue$time <- row.names(cpue)
  final <- data.frame(cpue[match(timeNA[,1],cpue[,2]),1])
  names(final) <- c("cpue")
  lines(timeNA$time,final$cpue, col="green")
  }
savePlot("CPUE_raw2_by_reg",type="png")

    # filter for active boats and post-2000

lenun <- function(x) length(unique(x))

for(r in 2:4) {
  print(r)
  dd <- albpl_c[albpl_c$reg==r,]
#  vessyrs <- c(5,5,1,1)[r]
  vessyrs <- c(5,10,1,1)[r]
  a <- tapply(dd$boat_id,list(dd$boat_id,dd$set_yrqtr),length)
  a1 <- apply(is.na(a[,])=="FALSE",1,sum)
  a1 <- a1[a1>vessyrs]
  rb <- tapply(dd$set_yrqtr,dd$boat_id,max)
  rb1 <- rb[!is.na(rb) & rb>2000]
#  activeboats <- c(as.numeric(names(a1)), as.numeric(names(rb1)))
  activeboats <- as.numeric(names(a1)) # plenty of recent activity so no need for recent boats
  activeboats <- unique(activeboats)
  a <- dd[dd$boat_id %in% activeboats,]

  modtxt <- "alb_n ~ as.factor(set_yrqtr) + offset(log(hook))"
  if(length(unique(a$cl)) > 1) modtxt <- "alb_n ~ as.factor(set_yrqtr) + cl + offset(log(hook))"
  glm_nb1 <- glm.nb(modtxt, data=a)
  save(glm_nb1,file=paste("clara_glm_nb1_",r,".RData",sep="")); rm(glm_nb1); gc()
  modtxt <- "alb_n ~ as.factor(set_yrqtr) + latlong + as.factor(boat_id)+offset(log(hook))"
  if(length(unique(a$cl)) > 1) modtxt <- "alb_n ~ as.factor(set_yrqtr) + latlong + cl + as.factor(boat_id)+offset(log(hook))"
  glm_nb2 <- glm.nb(modtxt, data=a)
  save(glm_nb2,file=paste("clara_glm_nb2_",r,".RData",sep=""));

  ymax <- 3
  yr <- sort(unique(a$set_yrqtr))
  y <- length(yr)
  load(file=paste("clara_glm_nb1_",r,".RData",sep=""))
  coefs1 <- exp(c(0,summary(glm_nb1)$coefficients[2:y,1]))
  coefs1 <- coefs1/mean(coefs1)
  coefs2 <- exp(c(0,summary(glm_nb2)$coefficients[2:y,1]))
  coefs2 <- coefs2/mean(coefs2)

  catch  <- tapply(a$alb_n, a$set_yrqtr, sum)
  effort <- tapply(a$hook, a$set_yrqtr, sum)
  cpue <- 1000*catch/effort
  cpue <- cpue / mean(cpue)
  timeseries <- seq(1960.125, 2012, by=0.25)
  timeNA <- data.frame(yr[match(timeseries,yr)])
  names(timeNA) <- c("time")

  coefs3 <- cbind(yr,cpue, coefs1, coefs2)
  final <- data.frame(coefs3[match(timeNA[,1],coefs3[,1]),2])
  final2 <- data.frame(coefs3[match(timeNA[,1],coefs3[,1]),3])
  final3 <- data.frame(coefs3[match(timeNA[,1],coefs3[,1]),4])
  names(final) <- c("cpue")
  names(final2) <- c("coefs1")
  names(final3) <- c("coefs2")
  final4 <- cbind(final, final2, final3)

  plot(timeNA$time, final4$coefs1, type="n", xlab=c("Time"), ylab=c("Relative abundance"), xlim=c(1960,2012),ylim=c(0,ymax))
  lines(timeNA$time,final4$cpue, col="black")
  lines(timeNA$time,final4$coefs1, col="blue")
  lines(timeNA$time,final4$coefs2, col="red")
  fname <- paste("spalb_clara", r,".png",sep="")
  savePlot(fname,type="png")

  coefs3 <- summary(glm_nb2)$coefficients[1:y,2]
  junk <- data.frame(cbind(yr, coefs2, coefs3))
  names(junk) <- c("yrqtr", "coef", "std.error")

  newdat <- with(a,expand.grid(set_yrqtr=sort(unique(a$set_yrqtr)),latlong=latlong[1],cl=cl[1],boat_id=boat_id[1],hook=median(hook)))
  a2 <- predict(glm_nb2,newdata=newdat,type="terms",se.fit=T)
  junk$coef2 <- exp(a2$fit[,1]) / mean(exp(a2$fit[,1]))
  junk$std_error2 <- a2$se.fit[,1]

  fname <- paste("spalb_clara", r,".dat",sep="")
  write.table(junk, fname, sep=c(" "), row.names=F)
  }

# consider activity filter to remove some vessels

lenun <- function(x) length(unique(x))
with(albpl,tapply(boat_id,reg,lenun))

atot <- albpl[albpl$reg==2,]

#for (vessyrs in c(10)) {
for (vessyrs in c(10)) { # for area 2
    # filter for active boats and post-2000
    a <- tapply(atot$boat_id,list(atot$boat_id,atot$set_yrqtr),length)
    a1 <- apply(is.na(a[,])=="FALSE",1,sum)
    a1 <- a1[a1>vessyrs]
    rb <- tapply(atot$set_yrqtr,atot$boat_id,max)
    rb1 <- rb[rb>2000]
    activeboats <- c(as.numeric(names(a1)), as.numeric(names(rb1)))
    activeboats <- unique(activeboats)
    a <- atot[atot$boat_id %in% activeboats,]
    rb <- tapply(a$set_yrqtr,a$boat_id,max)
    rb1 <- rb[rb>2000]
    recentboats <- as.numeric(names(rb1))
    a$era <- 0
    a$era[a$boat_id %in% recentboats] <- 1
}
with(a,tapply(boat_id,reg,lenun))

dim(a)
unique(a$boat_id) # reg 1 548
unique(a$boat_id) # reg 2 1006 filter of 40
unique(a$boat_id) # reg 3 277 activity filter not used
unique(a$boat_id) # reg 4 368
table(a$flag_id)

setwd("D:/L/alb/2012/assessment/Data_preparation/CPUE/myStd")
for(r in 1:4) {
  a <- read.table(paste("cpue_reg",r,".dat",sep=""),header=T)
  a <- a[!is.na(a[,4]),c(1,4,6)]
  names(a) <- c("yrqtr","coef","std.error")
  write.table(a,file=paste("spalb_",r,".dat",sep=""),row.names=F)
}

# older stuff --------------------
pl$date <- as.Date(pl$end_date, format="%Y-%m-%d")
pl$ret_year <- as.numeric(format(pl$date, "%Y"))
pl$ret_month <- as.numeric(format(pl$date, "%m"))
pl$ret_day <- as.numeric(format(pl$date, "%d"))
table(pl$ret_year)
# 1961  1962  1963  1964  1965  1966  1967  1968  1969  1970  1971  1972  1973  1974  1975  1976  1977  1978  1979  1980  1981  1982  1983  1984  1985  1986  1987  1988  1989  1990  1991  1992  1993  1994  1995  1996  1997  1998  1999
#  555    61  5919  5912  9556 19336 28271 22897 21132 24206 22816 21949 27777 26629 19146 14871 18804 15194 12874  8395 14634 16571  7622 11814 13697 14264 15519 13060  8502  5754  5831  5572  7273  6144  4713  5763  5632  4074  4912
# 2000  2001  2002  2003  2004  2005  2006  2007  2008  2009  2010
# 7827  2459  6220  5672  4571  3039  1873  2876   209   978    53

# estimate no_sets per trip for GLM weighting
pl$tmp <- (rep(1, as.numeric(dim(pl)[1])))
junk2 <- aggregate(pl$tmp,list(pl$tripest_id),sum)       #i.e. take the trip id list, lots of 1's from the tmp column, and sum 'em to sum the number of rows (sets) in each trip
pl$sets_per_trip <- junk2[match(pl[,2],junk2[,1]),2]     #then match columns tripest_id and 'Group.1' (tripest_id) from junk and return the sum by trip
pl$wt <- 1/sqrt(pl$sets_per_trip)
boxplot(pl$sets_per_trip~pl$set_yr) # high in 1960-61 because of two vessels with sets in both yrs, need to assign to start(trip_date) and graph    #GMP: also increased across time to 2005...
pl3 <- pl


print(getwd())
suppressMessages(library("FRESA.CAD"))
suppressMessages(library(readxl))

AdjustedTrainFrame <- read.csv("data/dataTadpole$AdjustedTrainFrame.csv")
testingFrame <- read.csv("data/dataTadpole$testingFrame.csv")
Test_Imputed <- read.csv("data/dataTadpole$Test_Imputed.csv")
submissionTemplate <- as.data.frame(read_excel("data/TADPOLE_Simple_Submission_TeamName.xlsx"))
train_df <- read.csv("data/train_df.csv", na.strings=c("NA",-4,"-4.0",""," "))

submissionTemplate$`Forecast Date` <- as.Date(paste(submissionTemplate$`Forecast Date`,"-01",sep=""))
submissionTemplate$`CN relative probability` <- as.numeric(nrow(submissionTemplate))
submissionTemplate$`MCI relative probability` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$`AD relative probability` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$ADAS13 <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$`ADAS13 50% CI lower` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$`ADAS13 50% CI upper` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$Ventricles_ICV <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$`Ventricles_ICV 50% CI lower` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate$`Ventricles_ICV 50% CI upper` <-  as.numeric(nrow(submissionTemplate))
submissionTemplate <- submissionTemplate[order(submissionTemplate$`Forecast Month`),]

TrainingSet <- subset(train_df,D1==1)
rownames(TrainingSet) <- paste(TrainingSet$RID,TrainingSet$VISCODE,sep="_")
rownames(AdjustedTrainFrame) <- paste(AdjustedTrainFrame$RID,AdjustedTrainFrame$VISCODE,sep="_")

TrainingSet <- TrainingSet[order(TrainingSet$EXAMDATE),]
TrainingSet <- TrainingSet[order(as.numeric(TrainingSet$RID)),]

source('R_scripts/TADPOLE_Train.R')
## Train 25 Models for the D2 subjects
CognitiveClassModels <- TrainTadpoleClassModels(AdjustedTrainFrame,
                                                predictors=c("AGE","PTGENDER",colnames(AdjustedTrainFrame)[-c(1:22)]),
                                                numberOfRandomSamples=25,
                                                delta=TRUE,
                                                MLMethod=BSWiMS.model,
                                                NumberofRepeats = 1)
save(CognitiveClassModels,file="data/_CognitiveClassModels_25.RDATA.RDATA")

# Predict the models on D2 subjects
source('R_scripts/predictCognitiveStatus.R')
predictADNI <- forecastCognitiveStatus(CognitiveClassModels,testingFrame)

########################Regresion models
### Training the ADAS13 and Ventricles
dim(AdjustedTrainFrame)
### Get the original Data D3 Train
AdjustedTrainFrame$Ventricles <- TrainingSet[rownames(AdjustedTrainFrame),"Ventricles"]/TrainingSet[rownames(AdjustedTrainFrame),"ICV"]
AdjustedTrainFrame$ADAS13 <- TrainingSet[rownames(AdjustedTrainFrame),"ADAS13"]

  ## Train 50 models based on D1 data

  source('R_scripts/TADPOLE_Train_ADAS_ICV.R')
  CognitiveRegresModels <- TrainTadpoleRegresionModels(AdjustedTrainFrame,
                                                       predictors=c("AGE","PTGENDER",colnames(AdjustedTrainFrame)[-c(1:22)]),
                                                       numberOfRandomSamples=50,
                                                       MLMethod=BSWiMS.model,
                                                       NumberofRepeats = 1)

  save(CognitiveRegresModels,file="data/_CognitiveRegresModels_50_Nolog.RDATA")

source('R_scripts/predictTADPOLERegresions.R')

#################################### xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
### Ventricles and ADAS13 prediction preparation
## Transforming the test data set

testingFrame$Ventricles <- Test_Imputed[rownames(testingFrame),"Ventricles"]/Test_Imputed[rownames(testingFrame),"ICV"]
testingFrame$ADAS13 <- Test_Imputed[rownames(testingFrame),"ADAS13"]

## THe last time point required for forecasting ADAS13 and Ventricles
ltptf <- testingFrame
ltptf <- ltptf[order(ltptf$EXAMDATE),]
ltptf <- ltptf[order(as.numeric(ltptf$RID)),]
rids <- ltptf$RID
ltptf <- ltptf[c(rids[1:(length(rids)-1)] != rids[-1],TRUE),]
rownames(ltptf) <- ltptf$RID

print("forecast_d2")
  ### Forecasting 5 years. The forcast transfomrs back to the actual space
  source('R_scripts/FiveYearForecast.R')
  forecast <- FiveYearForeCast(predictADNI,
                               testDataset=ltptf,
                               ADAS_Ventricle_Models=CognitiveRegresModels,
                               Subject_datestoPredict=submissionTemplate)

  write.csv(forecast,file="data/_ForecastD2_BORREGOS_TEC.csv")


plotFootprint <- function(x,SensorName,rn=NULL,MyMap=NULL,type=c("CE","wCE","uCE"),use.avg=FALSE,use.sym=FALSE,use.var=TRUE,wTDcutoff=NULL,origin=NULL,
	dx=2,dy=dx,breaks=function(x)quantile(c(0,max(x)),c(0.01,0.1,0.5,0.9)),xlim=c(-100,100),ylim=c(-100,100),add=FALSE,alpha=0.3,axs=c("r","i"),
	main=NULL,asp=1,fill=TRUE,sub=NULL,bg.col=NULL,addSource=TRUE,showMax=FALSE,showSensor=TRUE,dispSname=showSensor, N0 = NULL,
	lpos=NULL,showPerc=FALSE,leg.bg.col=grey(0.9),cpal=NULL,decPlaces=0,sigNums=1,addWR=FALSE,WRpos=2,WRfrac=20,WRscale=1,xy_transform=NULL,transformArgs=NULL,
	useSTRtree=TRUE,avoidGEOS = FALSE,addSB=FALSE,SBpos=3,StaticMapArgs=NULL,showLegend=TRUE){

	if(!requireNamespace("maptools")){
		stop("please install package maptools: install.packages('maptools')")
	}
	if(!requireNamespace("rgeos")){
		stop("please install package rgeos: install.packages('rgeos')")
	}
	# Notizen:
	#	- Sources spaeter hinzufuegen
	#	- Methode fuer Catalog hinzufuegen
	#	- arguments besser organisieren
	#	- main auch bei MyMap
	#	- xlim/ylim xy_transform WGS84 etc... besser organisieren!!!
	#	- xy_transform --> coords_2_WGS84 oder so
	#	- TrueProj als Argument, oder besser: if add=TRUE, par()$usr -> MyMap$size???
	sx <- as.character(substitute(x))

	if(inherits(x, "footprint")){
		# breaks=rev(brks)
		xy_transform <- x$xy_transform
		transformArgs <- x$transformArgs
		SensorPosition <- x$SensorPosition
		WDmean <- x$WDmean
		xlimOriginal <- x$xlimOriginal
		ylimOriginal <- x$ylimOriginal
		xm <- x$xm
		ym <- x$ym
		xy <- x$xy
		if(!add){
			stop("only add=TRUE supported when providing a footprint object")
		}
	} else {
	  # convert old versions
		x <- copy(x)
		setDT(x)
		switchNames(x)
	  if(is.null(attr(x, "Version"))){
			warning(paste0("Object '", sx[min(length(sx), 2)], "' has not yet been converted to version 4.2+"))
			convert(x)
	  }

		# checks:
		if(missing(SensorName)){
			stop("SensorName must be provided")
		} else {
			getThisSensor <- as.character(SensorName[1])
			if(!nrow(x[Sensor==getThisSensor]))stop("No results for Sensor: ",getThisSensor," availabe!")
		}
		stopifnot(type[1] %in% c("CE","wCE","uCE"))

		if(is.null(rn)){
			getThisRows <- x[Sensor==getThisSensor,unique(rn)]
		} else {
			getThisRows <- as.integer(rn)
		}
		getThisSource <- x[rn%in%getThisRows&Sensor==getThisSensor,Source[1]]
		index <- x[,which(rn%in%getThisRows&Sensor==getThisSensor&Source==getThisSource)]

		WD <- x[index,WD]
		if(is.null(N0)){
			N0 <- x[index[1],N0]
		} else {
			if(any(x[index,N0]<N0))stop("Choose N0 smaller or equal to original N0!")
		}

		Ustar <- x[index,Ustar]
		Suu <- x[index,sUu]
		Svu <- x[index,sVu]
		bw <- x[index,bw]
		z <- x[index,SensorHeight]
		L <- x[index,L]
		Zo <- x[index,Zo]
		Source <- attr(procSources(attr(x,"ModelInput")$Sources),"SourceList")

		if(length(index)>1){
			WDmean <- (360 + atan2(sum(sin(WD/180*pi)*Ustar)/sum(Ustar),sum(cos(WD/180*pi)*Ustar)/sum(Ustar))/pi*180) %% 360
		} else {
			WDmean <- WD
		}

		Calc.Sensors <- procSensors(attr(x,"ModelInput")$Sensors)$"Calc.Sensors"
		SensorPosition <- Calc.Sensors[Calc.Sensors[, "Sensor Name"] %chin% SensorName,
			c("Sensor Name", "x-Coord (m)", "y-Coord (m)", "Sensor ID", "Node")]
		SPR <- rotate(SensorPosition[,2:3],Angle=-WDmean)

		if(is.null(origin)){
			origin <- colMeans(SensorPosition[,2:3])
		}
		if(!add){
		if(is.null(main))main <- switch(type[1],
			"CE"="C-Footprint",
			"wCE"="w'C'-Footprint",
			"uCE"="u'C'-Footprint")
			if(is.null(MyMap)){
				plot(SensorPosition[,2],SensorPosition[,3],type="n",xlim=xlim + origin[1],ylim=ylim + origin[2],xlab="",ylab="",asp=asp,yaxt="n",xaxt="n",main=main,sub=sub)
				pr <- par()
				if(!is.null(bg.col))polygon(pr$usr[c(1,2,2,1)],pr$usr[c(3,3,4,4)],col=bg.col)
				axis(1,at=atx<-pretty(pr$usr[1:2]))
				axis(2,at=aty<-pretty(pr$usr[3:4]))
			} else {
				do.call(PlotOnStaticMap,c(list(MyMap=MyMap),StaticMapArgs))
				pr <- par()
				add <- TRUE
			}
		} else {
			pr <- par()
		}

		if(!is.null(MyMap)){
			if(!("TrueProj" %in% names(StaticMapArgs))||!StaticMapArgs$TrueProj){
				xy_transformOriginal <- xy_transform
				if(is.null(xy_transform)){
					xy_transform <- function(x,y,mymap=MyMap,...){
						LatLon2XY.centered(mymap,y,x)
					}
				} else {
					xy_transform <- function(x,y,mymap=MyMap,...){
						xy <- xy_transformOriginal(x,y,...)
						LatLon2XY.centered(mymap,xy$y,xy$x)
					}
				}
			}
		}
		if(addSource){
			for(i in Source){
				pg <- i
				if(!is.null(xy_transform)){
					pg[1:2] <- do.call(xy_transform,c(list(x=pg[,1],y=pg[,2]),transformArgs))
				}
				upg <- unique(pg[,3])
				for(j in upg){
					ind <- which(pg[,3]==j)
					polygon(pg[ind,1],pg[ind,2],col="#006837")
				}
			}
		}
		# transform x/y:
		if(!is.null(xy_transform)){
			SensorPosition[, 2:3] <- do.call(xy_transform,c(list(x=SensorPosition[,2],y=SensorPosition[,3]),transformArgs))
		}
		if(showSensor){
			sp_dt <- setnames(as.data.table(attr(x,"ModelInput")$Sensors[,
				c("Sensor Name", "x-Coord (m)", "y-Coord (m)", "Sensor ID", "Node")]),
				c("name", "x", "y", "id", "node"))[name == getThisSensor]

			# cat("hier stimmt's noch nicht falls google maps!\n")

			if(dispSname){
				if(sp_dt[, length(unique(id)) > 1]){
					sp_dt[, {
						ind <- order(node)
						lines(x[ind], y[ind], lty = 2, cex = 1.5)
						points(x[ind], y[ind], pch = 20, cex = 1.5)
						text(mean(x), mean(y), paste0(name[1], " (", .BY$id, ")"), cex = 0.6, pos = 4)
					}, by = id]
				} else {
					sp_dt[, {
						ind <- order(node)
						lines(x[ind], y[ind], lty = 2, cex = 1.5)
						points(x[ind], y[ind], pch = 20, cex = 1.5)
						text(mean(x), mean(y), name[1], cex = 0.6, pos = 4)
					}, by = id]
				}
			} else {
				sp_dt[, {
					ind <- order(node)
					lines(x[ind], y[ind], lty = 2, cex = 1.5)
					points(x[ind], y[ind], pch = 20, cex = 1.5)
				}, by = id]
			}
		}
		xlim <- pr$usr[1:2]
		ylim <- pr$usr[3:4]

		xlimOriginal <- xlim
		ylimOriginal <- ylim

		if(!is.null(xy_transform)){
			parscale1 <- max(c(xlim[1],ylim[1]))
			parscale2 <- max(c(xlim[2],ylim[2]))
			lim1 <-  optim(c(-1,-1),function(x)sum((unlist(do.call(xy_transform,c(list(x=x[1],y=x[2]),transformArgs))) - c(xlim[1],ylim[1]))^2),control=list(reltol=sqrt(.Machine$double.eps)/parscale1))$par
			lim2 <-  optim(c(1,1),function(x)sum((unlist(do.call(xy_transform,c(list(x=x[1],y=x[2]),transformArgs))) - c(xlim[2],ylim[2]))^2),control=list(reltol=sqrt(.Machine$double.eps)/parscale2))$par
			xlim <- c(lim1[1],lim2[1])
			ylim <- c(lim1[2],lim2[2])
		}

		xylim <- cbind(x=c(xlim,rev(xlim)),y=rep(ylim,each=2))
		xylim <- rotate(xylim,Angle=-WDmean)
		xb <- seq(min(xylim[,1])-10*dx,max(xylim[,1])+10*dx,dx)
		yb <- seq(min(xylim[,2])-10*dy,max(xylim[,2])+10*dy,dy)
		xm <- xb[-1] - dx/2
		ym <- yb[-1] - dy/2
		xy <- matrix(0,nrow=length(xm),ncol=length(ym))

		# loop over index
		for(j in seq_along(index)){
			cat(j,"/",length(index),"\n")
			Catalogs <- getCatalogs(x,index[j])
			CatNames <- Catalogs[,Catalog]
			Subset_seed <- Catalogs[, seed]
			dummy <- ""
			Ustardummy <- -9999
			# loop over point sensors
			for(i in seq_along(CatNames)){
				# i <- 1
				xytemp <- matrix(0,nrow=length(xm),ncol=length(ym))
				if(dummy!=CatNames[i]|x[index[j],Ustar!=Ustardummy]){
					dummy <- CatNames[i]
					Catalog <- readCatalog(CatNames[i])
					initializeCatalog(x[index[j],], Catalog=Catalog)
					uvw <- uvw0(Catalog)
					# subset?
					if(attr(Catalog,"N0")>N0){
						env <- globalenv()
					    oseed <- env$.Random.seed
					    set.seed(Subset_seed,kind="L'Ecuyer-CMRG")
						takeSub <- sort(sample.int(attr(Catalog,"N0"),N0))
				        if (is.null(oseed)) {
				            rm(list = ".Random.seed", envir = env)
				        } else {
				            assign(".Random.seed", value = oseed, envir = env)
				        }
						attCat <- attributes(Catalog)
						indexNew <- 1:N0
						names(indexNew) <- takeSub
						Catalog <- Catalog[Traj_ID %in% takeSub,]
						Catalog[,":="(Traj_ID=indexNew[as.character(Traj_ID)])]
						for(ac in (names(attCat) %w/o% c("names","row.names",".internal.selfref","uvw0")))setattr(Catalog,ac,attCat[[ac]])
						uvw <- uvw[takeSub,]
						setattr(Catalog,"uvw0",uvw)
						HeaderSub <- paste(attr(Catalog,"header"),"\n*** Subset of ",N0," Trajectories ***\n\n",sep="")
						class(HeaderSub) <- c("TDhead","character")
						setattr(Catalog,"N0",N0)
						setattr(Catalog,"header",HeaderSub)
					}

					if(!is.null(wTDcutoff)) Catalog[wTD<wTDcutoff,wTD:=wTDcutoff]

					Catalog[,CE:=2/wTD/N0]

					if(use.avg)Catalog[,CE:=mean(CE)]

					if(type[1]!="CE"){
						if(type[1]=="wCE"){
							w0 <- uvw0(Catalog)[,"w0"]
						} else {
							w0 <- uvw0(Catalog)[,"u0"] - calcU(Ustar, Zo, L, z)
						}
						Catalog[,CE:=w0[Traj_ID]*CE]
					}

					if(use.sym){
						Catalog <- Catalog[rep(1:.N,2)]
						Catalog[1:(.N/2),y:=-y]
						Catalog[,CE:=CE/2]
					}

				}
				Ctlg <- copy(Catalog)
				rotateCatalog(Ctlg,WD[j]-WDmean)
				Ctlg <- Ctlg[,":="(x=x+SPR[i,1],y=y+SPR[i,2],CE=CE/length(CatNames)/length(index))][
					x>=xb[1]&x<=xb[length(xb)]&y>=yb[1]&y<=yb[length(yb)]
				]

				Ctlg[,":="(xtag=findInterval(x,xb, rightmost.closed = TRUE),
					ytag=findInterval(y,yb, rightmost.closed = TRUE))]
				Cat <- Ctlg[,sum(CE),by=.(xtag,ytag)]
				xytemp[Cat[,cbind(xtag,ytag)]] <- Cat[,V1]

				if(use.var){
					xb2l <- Ctlg[,c(rev(seq(SPR[i,1]-3*dx/2,min(x,SPR[i,1])-10*dx,-2*dx)),seq(SPR[i,1]+dx/2,max(x,SPR[i,1])+10*dx,2*dx))]
					yb2l <- Ctlg[,c(rev(seq(SPR[i,2]-3*dy/2,min(y,SPR[i,2])-10*dy,-2*dy)),seq(SPR[i,2]+dy/2,max(y,SPR[i,2])+10*dy,2*dy))]

					xb2r <- xb2l + dx
					yb2r <- yb2l + dx
					Ctlg[,":="(
						xtag_ll=findInterval(x,xb2l),ytag_ll=findInterval(y,yb2l)
						,xtag_lr=findInterval(x,xb2l),ytag_lr=findInterval(y,yb2r)
						,xtag_rl=findInterval(x,xb2r),ytag_rl=findInterval(y,yb2l)
						,xtag_rr=findInterval(x,xb2r),ytag_rr=findInterval(y,yb2r)
						)]
					Cat_ll <- Ctlg[,sum(CE),by=.(xtag_ll,ytag_ll)]
					Cat_lr <- Ctlg[,sum(CE),by=.(xtag_lr,ytag_lr)]
					Cat_rl <- Ctlg[,sum(CE),by=.(xtag_rl,ytag_rl)]
					Cat_rr <- Ctlg[,sum(CE),by=.(xtag_rr,ytag_rr)]

					xy_ll <- xy_lr <- xy_rl <- xy_rr <- matrix(0,nrow=length(xb2r)-1,ncol=length(yb2r)-1)
					xy_ll[Cat_ll[,cbind(xtag_ll,ytag_ll)]] <- Cat_ll[,V1]
					xy_lr[Cat_lr[,cbind(xtag_lr,ytag_lr)]] <- Cat_lr[,V1]
					xy_rl[Cat_rl[,cbind(xtag_rl,ytag_rl)]] <- Cat_rl[,V1]
					xy_rr[Cat_rr[,cbind(xtag_rr,ytag_rr)]] <- Cat_rr[,V1]

					xmil <- findInterval(xm,xb2l,all.inside = TRUE)
					ymil <- findInterval(ym,yb2l,all.inside = TRUE)
					xmir <- findInterval(xm,xb2r,all.inside = TRUE)
					ymir <- findInterval(ym,yb2r,all.inside = TRUE)

					xyi_ll <- as.matrix(expand.grid(x=xmil,y=ymil,KEEP.OUT.ATTRS=FALSE))
					xyi_rr <- as.matrix(expand.grid(x=xmir,y=ymir,KEEP.OUT.ATTRS=FALSE))
					xyi_lr <- as.matrix(expand.grid(x=xmil,y=ymir,KEEP.OUT.ATTRS=FALSE))
					xyi_rl <- as.matrix(expand.grid(x=xmir,y=ymil,KEEP.OUT.ATTRS=FALSE))

					Mu <- (xy_ll[xyi_ll] + xy_lr[xyi_lr] + xy_rl[xyi_rl] + xy_rr[xyi_rr])/4
					Var <- (4*xytemp - Mu)^2
					xytemp <- (xytemp*Var + (max(Var)-Var)/4*Mu)/(max(Var))
				}

				xy <- xy + xytemp/(dx*dy)

			}
		}
		rm(Catalog,Ctlg,Cat)
		xy[,c(1,ncol(xy))] <- 0
		xy[c(1,nrow(xy)),] <- 0
	}

	brks <- breaks(xy)

	cl <- contourLines(xm,ym,xy,levels=brks)
	clRot <- lapply(cl,rotate,Angle=WDmean)
	clFac <- as.factor(sapply(clRot,"[[","level"))
	uclFac <- unique(clFac)

	# transform x/y:
	if(!is.null(xy_transform)){
		clRot <- lapply(clRot,function(x){
			a <- do.call(xy_transform,c(list(x=x$x,y=x$y),transformArgs))
			list(level=x$level,x=a[[1]],y=a[[2]])
		})
	}

	clP <- lapply(clRot,function(x)sp::Polygon(cbind(x$x,x$y)))
	clPs <- lapply(uclFac,function(x,y,z,a,b)maptools::checkPolygonsHoles(sp::Polygons(y[z==x],as.character(x)),useSTRtree=a,avoidGEOS=b),y=clP,z=clFac,a=useSTRtree,b=avoidGEOS)
	clSp <- sp::SpatialPolygons(clPs,as.integer(uclFac))

	# if(is.null(xlim)&is.null(ylim)){
	# 	xyr <- rotate(cbind(x=range(xm),y=range(ym)),Angle=WDmean+180)
	# 	xlim <- range(xyr[,1]) + range(SensorPosition[,2])
	# 	ylim <- range(xyr[,2]) + range(SensorPosition[,3])
	# }

	# Loesung:
	mlt <- switch(axs[1],
		"i"=1.08,
		1
		)
	xlim2 <- xlimOriginal - diff(xlimOriginal)*(1-1/mlt)/2;ylim2 <- ylimOriginal - diff(ylimOriginal)*(1-1/mlt)/2
	c1 <- sp::Polygon(cbind(c(xlim2[1],xlim2[2],xlim2[2],xlim2[1], xlim2[1]),c(ylim2[1],ylim2[1],ylim2[2],ylim2[2],ylim2[1])))
	c2 <- sp::Polygons(list(c1), "sclip")
	Pclip <- sp::SpatialPolygons(list(c2))

	SpPclip <- rgeos::gIntersection(clSp, Pclip, byid = TRUE)

	alphachar <- as.hexmode(round(alpha*255))

	if(is.null(cpal)){
		cpal <- if(type[1]=="CE") ConcPalette(length(brks)) else FluxPalette(length(brks))
	} else {
		cpal <- cpal(length(brks))
	}

	if(!add){abline(h=aty,lty="dotted",col="lightgrey");abline(v=atx,lty="dotted",col="lightgrey")}

	if(fill)fillcol <- paste0(cpal,alphachar) else fillcol <- NA

	sp::plot(SpPclip,col=fillcol,border=cpal,add=TRUE)
	box()

	if(showMax){
		mi <- which(xy==max(xy),arr.ind=T)
		maxli <- rotate(cbind(x=xm[mi[1]],y=ym[mi[2]]),Angle=WD+90,Center=origin)+c(SensorPosition[,2],SensorPosition[,3])
		points(maxli,pch=20,cex=0.4,col="red")
		text(maxli[1],maxli[2],"max.",cex=0.6,pos=4,offset=0.2,col="red")
	}

	if(showLegend){
		if(is.null(lpos))lpos <- c("bottomleft","topleft","topright","bottomright")[floor(WDmean/90)+1]
		if(showPerc){
			ltex <- sprintf(paste0("%2.",decPlaces,"f%%"),rev(brks)/max(xy)*100)
			ltex <- paste0(">",ltex)
			temp <- legend(lpos,legend=rep(" ",length(ltex)),title="% of max.",text.width=strwidth(paste0("00",if(decPlaces>0){paste0(".",paste0(rep("0",decPlaces),collapse=""))}else{""}," %")),fill=paste0(rev(cpal),alphachar),border=rev(cpal),bg=leg.bg.col)
			text(temp$rect$left + temp$rect$w, temp$text$y,ltex, pos = 2)
		} else {
			ltex <- signif(rev(brks),sigNums)
			ltex <- paste0(">",ltex)
			legend(lpos,legend=ltex,xjust=0,fill=paste0(rev(cpal),alphachar),border=rev(cpal),bg=leg.bg.col)
		}
	}
	if(addWR)addWindrose(WDmean,pos=WRpos,frac=WRfrac,scF=WRscale)
	scale <- if(is.null(MyMap)) 1 else MyMap
	if(addSB)addScaleBar(SBpos,scale)
	wm <- which(xy==max(xy),arr.ind=TRUE)
	WDrad <- WDmean/180*pi
	out <- structure(list(
		breaks=rev(brks),
		range.z=range(xy),
		max.pos=cbind(x=-xm[wm[1]]*sin(WDrad)+ym[wm[2]]*cos(WDrad)+SensorPosition[,2],y=-xm[wm[1]]*cos(WDrad)-ym[wm[2]]*sin(WDrad)+SensorPosition[,3]),
		xy_transform = xy_transform,
		transformArgs = transformArgs,
		SensorPosition = SensorPosition,
		WDmean = WDmean,
		xlimOriginal = xlimOriginal,
		ylimOriginal = ylimOriginal,
		xm = xm,
		ym = ym,
		xy = xy), class = "footprint"
		)
	return(invisible(out))

}


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' MVP, Memory-efficient, Visualization-enhanced, Parallel-accelerated
#'
#' Object 1: To perform GWAS using General Linear Model (GLM), Mixed Linear Model (MLM), and FarmCPU model
#' Object 2: To calculate kinship among individuals using Varaden method
#' Object 3: Estimate variance components using EMMA, FaST-LMM, and HE regression
#' Object 4: Generate high-quality figures
#'
#' Build date: Aug 30, 2017
#' Last update: Dec 14, 2018
#'
#' @author Lilin Yin, Haohao Zhang, and Xiaolei Liu
#'
#' @param phe phenotype, n * 2 matrix, n is sample size
#' @param geno Genotype in bigmatrix format; m * n, m is marker size, n is sample size
#' @param map SNP map information, SNP name, Chr, Pos
#' @param K Kinship, Covariance matrix(n * n) for random effects, must be positive semi-definite
#' @param nPC.GLM number of PCs added as fixed effects in GLM
#' @param nPC.MLM number of PCs added as fixed effects in MLM
#' @param nPC.FarmCPU number of PCs added as fixed effects in FarmCPU
#' @param CV.GLM covariates added in GLM
#' @param CV.MLM covariates added in MLM
#' @param CV.FarmCPU covariates added in FarmCPU
#' @param REML a list contains ve and vg
#' @param priority speed or memory
#' @param ncpus number of cpus used for parallel
#' @param vc.method methods for estimating variance component("EMMA" or "HE" or "BRENT")
#' @param method the GWAS model, "GLM", "MLM", and "FarmCPU", models can be selected simutaneously, i.e. c("GLM", "MLM", "FarmCPU")
#' @param p.threshold if all p values generated in the first iteration are bigger than p.threshold, FarmCPU stops
#' @param QTN.threshold in second and later iterations, only SNPs with lower p-values than QTN.threshold have chances to be selected as pseudo QTNs
#' @param method.bin 'static' or 'FaST-LMM'
#' @param bin.size window size in genome
#' @param bin.selection a vector, how many windows selected
#' @param maxLoop maximum number of iterations
#' @param permutation.threshold if use a permutation cutoff or not (bonferroni cutoff)
#' @param permutation.rep number of permutation replicates
#' @param col for color of points in each chromosome on manhattan plot
#' @param memo Character. A text marker on output files
#' @param outpath Effective only when file.output = TRUE, determines the path of the output file
#' @param file.output whether to output files or not
#' @param file.type figure formats, "jpg", "tiff"
#' @param dpi resolution for output figures
#' @param threshold a cutoff line on manhattan plot, 0.05/marker size
#' @param verbose whether to print detail.
#'
#' @export
#' @return a m * 2 matrix, the first column is the SNP effect, the second column is the P values
#' Output: MVP.return$map - SNP map information, SNP name, Chr, Pos
#' Output: MVP.return$glm.results - p-values obtained by GLM method
#' Output: MVP.return$mlm.results - p-values obtained by MLM method
#' Output: MVP.return$farmcpu.results - p-values obtained by FarmCPU method
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' print(dim(genotype))
#' mapPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.map", package = "rMVP")
#' map <- read.table(mapPath , head = TRUE)
#'
#' opts <- options(rMVP.OutputLog2File = FALSE)
#'
#' mvp <- MVP(phe=phenotype, geno=genotype, map=map, maxLoop=3,
#'   method=c("GLM", "MLM", "FarmCPU"), file.output=FALSE, ncpus=1)
#' str(mvp)
#'
#' options(opts)
MVP <-
function(phe, geno, map, K=NULL, nPC.GLM=NULL, nPC.MLM=NULL, nPC.FarmCPU=NULL,
         CV.GLM=NULL, CV.MLM=NULL, CV.FarmCPU=NULL, REML=NULL, priority="speed",
         ncpus=detectCores(logical = FALSE), vc.method=c("BRENT", "EMMA", "HE"),
         method=c("GLM", "MLM", "FarmCPU"), p.threshold=NA,
         QTN.threshold=0.01, method.bin="static", bin.size=c(5e5,5e6,5e7),
         bin.selection=seq(10,100,10), maxLoop=10, permutation.threshold=FALSE,
         permutation.rep=100, memo=NULL, outpath=getwd(),
         col=c("#4197d8", "#f8c120", "#413496", "#495226", "#d60b6f", "#e66519",
         "#d581b7", "#83d3ad", "#7c162c", "#26755d"), file.output=TRUE,
         file.type="jpg", dpi=300, threshold=0.05, verbose=TRUE
) {

    # Compatible with old ways
    if (file.output == TRUE) {
      file.output <- c("pmap", "pmap.signal", "plot", "log")
    } else if (file.output == FALSE) {
      file.output <- c()
    }

    for(mt in method){
        if(!mt %in% c("GLM", "MLM", "FarmCPU"))
            stop("Unknow method: ", mt)
    }

    # Set output path of log file
    logging.outpath <- NULL
    if ("log" %in% file.output) {
      logging.outpath <- outpath
    }
    logging.initialize("MVP", logging.outpath)

    MVP.Version(width = 60, verbose = verbose)
    logging.log("Start:", as.character(Sys.time()), "\n", verbose = verbose)
    if ("log" %in% file.output) {
        logging.log("The log has been output to the file:", get("logging.file", envir = package.env), "\n", verbose = verbose)
    }
    vc.method <- match.arg(vc.method)
    if (nrow(phe) != ncol(geno)) stop("The number of individuals in phenotype and genotype doesn't match!")
    if (nrow(geno) != nrow(map)) stop("The number of markers in genotype and map doesn't match!")
    if (!is.big.matrix(geno))    stop("genotype should be in 'big.matrix' format.")
    if(hasNA(geno@address))   stop("NA is not allowed in genotype, use 'MVP.Data.impute' to impute.")

    #list -> matrix
    map <- as.data.frame(map)
    for(i in 1 : ncol(map)){
        if(is.factor(map[, i])) map[, i] <- as.character.factor(map[, i])
    }

    na.index <- NULL
    if (!is.null(CV.GLM)) {
        CV.GLM <- as.matrix(CV.GLM)
    if (nrow(CV.GLM) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
        na.index <- c(na.index, which(is.na(CV.GLM), arr.ind = TRUE)[, 1])
    }
    if (!is.null(CV.MLM)) {
        CV.MLM <- as.matrix(CV.MLM)
        if (nrow(CV.MLM) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
       na.index <- c(na.index, which(is.na(CV.MLM), arr.ind = TRUE)[, 1])
    }
    if (!is.null(CV.FarmCPU)) {
        CV.FarmCPU <- as.matrix(CV.FarmCPU)
        if (nrow(CV.FarmCPU) != ncol(geno)) stop("The number of individuals in covariates and genotype doesn't match!")
        na.index <- c(na.index, which(is.na(CV.FarmCPU), arr.ind = TRUE)[, 1])
    }
    na.index <- unique(na.index)

    #Data information
    m <- nrow(geno)
    n <- ncol(geno)
    logging.log(paste("Input data has", n, "individuals,", m, "markers"), "\n", verbose = verbose)
    logging.log("Analyzed trait:", colnames(phe)[2], "\n", verbose = verbose)
    logging.log("Number of threads used:", ncpus, "\n", verbose = verbose)

    #remove samples with missing phenotype
    seqTaxa = which(!is.na(phe[,2]))
    if (length(na.index) != 0) seqTaxa <- intersect(seqTaxa, c(1:n)[-na.index])
    if (length(seqTaxa) != n) {
        logging.log("Total", n - length(seqTaxa), "individuals removed due to missings", "\n", verbose = verbose)
        geno = deepcopy(
          x = geno,
          cols = seqTaxa
        )
        phe = phe[seqTaxa,]
        if (!is.null(K)) { K = K[seqTaxa, seqTaxa] }
        if (!is.null(CV.GLM)) { CV.GLM = CV.GLM[seqTaxa,] }
        if (!is.null(CV.MLM)) { CV.MLM = CV.MLM[seqTaxa,] }
        if (!is.null(CV.FarmCPU)) { CV.FarmCPU = CV.FarmCPU[seqTaxa,] }
    }

    m <- nrow(geno)
    n <- ncol(geno)

    #initial results
    glm.results <- NULL
    mlm.results <- NULL
    farmcpu.results <- NULL

    #indicators for models
    glm.run <- "GLM" %in% method
    mlm.run <- "MLM" %in% method
    farmcpu.run <- "FarmCPU" %in% method

    nPC <- suppressWarnings(max(nPC.GLM, nPC.MLM, nPC.FarmCPU, na.rm = TRUE))
    if (nPC <= 0) {
        nPC <- NULL
    } else if (nPC < 3) {
        nPC <- 3
    }

    if (!is.null(K)) { K <- as.matrix(K) }
    if (!is.null(nPC) | "MLM" %in% method) {
        if (is.null(K)) {
            K <- MVP.K.VanRaden(
              M = geno,
              priority = priority,
              cpu = ncpus,
              verbose = verbose
            )
        }
        logging.log("Eigen Decomposition on GRM", "\n", verbose = verbose)
        eigenK <- eigen(K, symmetric = TRUE)
        if (!is.null(nPC)) {
            ipca <- eigenK$vectors[, 1:nPC]
            logging.log("Deriving PCs successfully", "\n", verbose = verbose)
        }
        if (("MLM" %in% method) & vc.method == "BRENT") { K <- NULL; gc()}
        if (!"MLM" %in% method) { rm(eigenK); rm(K); gc() }
    }

    if (!is.null(nPC)) {
        #CV for GLM
        if (glm.run) {
            if (!is.null(CV.GLM)) {
                logging.log("Number of provided covariates of GLM:", ncol(CV.GLM), "\n", verbose = verbose)
                if (!is.null(nPC.GLM)) {
                    logging.log("Number of PCs included:", nPC.GLM, "\n", verbose = verbose)
                    CV.GLM <- cbind(ipca[,1:nPC.GLM], CV.GLM)
                }
            } else if (!is.null(nPC.GLM)) {
                logging.log("Number of PCs included in GLM:", nPC.GLM, "\n", verbose = verbose)
                CV.GLM <- ipca[,1:nPC.GLM]
            }
        }

        #CV for MLM
        if (mlm.run) {
            if (!is.null(CV.MLM)) {
                logging.log("Number of provided covariates of MLM:", ncol(CV.MLM), "\n", verbose = verbose)
                if (!is.null(nPC.MLM)) {
                    logging.log("Number of PCs included:", nPC.MLM, "\n", verbose = verbose)
                    CV.MLM <- cbind(ipca[,1:nPC.MLM], CV.MLM)
                }
            } else if (!is.null(nPC.MLM)) {
                logging.log("Number of PCs included in MLM:", nPC.MLM, "\n", verbose = verbose)
                CV.MLM <- ipca[,1:nPC.MLM]
            }
        }

        #CV for FarmCPU
        if (farmcpu.run) {
            if (!is.null(CV.FarmCPU)) {
                logging.log("Number of provided covariates of FarmCPU:", ncol(CV.FarmCPU), "\n", verbose = verbose)
                if (!is.null(nPC.FarmCPU)) {
                    logging.log("Number of PCs included:", nPC.FarmCPU, "\n", verbose = verbose)
                    CV.FarmCPU <- cbind(ipca[,1:nPC.FarmCPU], CV.FarmCPU)
                }
            }else if (!is.null(nPC.FarmCPU)) {
                logging.log("Number of PCs included in FarmCPU:", nPC.FarmCPU, "\n", verbose = verbose)
                CV.FarmCPU <- ipca[,1:nPC.FarmCPU]
            }
        }
    }else{
        if (glm.run) {
            if (!is.null(CV.GLM)) {
                logging.log("Number of provided covariates of GLM:", ncol(CV.GLM), "\n", verbose = verbose)
            }
        }
        if (mlm.run) {
            if (!is.null(CV.MLM)) {
                logging.log("Number of provided covariates of MLM:", ncol(CV.MLM), "\n", verbose = verbose)
            }
        }
        if (farmcpu.run) {
            if (!is.null(CV.FarmCPU)) {
                logging.log("Number of provided covariates of FarmCPU:", ncol(CV.FarmCPU), "\n", verbose = verbose)
            }
        }
    }

    #GWAS
    logging.log("-------------------------GWAS Start-------------------------", "\n", verbose = verbose)
    if (glm.run) {
        logging.log("General Linear Model (GLM) Start...", "\n", verbose = verbose)
        glm.results <- MVP.GLM(phe=phe, geno=geno, CV=CV.GLM, cpu=ncpus, verbose = verbose);gc()
        colnames(glm.results) <- c("Effect", "SE", paste(colnames(phe)[2],"GLM",sep="."))
        z = glm.results[, 1]/glm.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map, glm.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".GLM.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    if (mlm.run) {
        logging.log("Mixed Linear Model (MLM) Start...", "\n", verbose = verbose)
        mlm.results <- MVP.MLM(phe=phe, geno=geno, K=K, eigenK=eigenK, CV=CV.MLM, cpu=ncpus, vc.method=vc.method, verbose = verbose);gc()
        colnames(mlm.results) <- c("Effect", "SE", paste(colnames(phe)[2],"MLM",sep="."))
        z = mlm.results[, 1]/mlm.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map, mlm.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".MLM.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    if (farmcpu.run) {
        logging.log("FarmCPU Start...", "\n", verbose = verbose)
        farmcpu.results <- MVP.FarmCPU(phe=phe, geno=geno, map=map[,1:3], CV=CV.FarmCPU, ncpus=ncpus, memo="MVP.FarmCPU", p.threshold=p.threshold, QTN.threshold=QTN.threshold, method.bin=method.bin, bin.size=bin.size, bin.selection=bin.selection, maxLoop=maxLoop, verbose = verbose)
        colnames(farmcpu.results) <- c("Effect", "SE", paste(colnames(phe)[2],"FarmCPU",sep="."))
        z = farmcpu.results[, 1]/farmcpu.results[, 2]
        lambda = median(z^2, na.rm=TRUE)/qchisq(1/2, df = 1,lower.tail=FALSE)
        logging.log("Genomic inflation factor (lambda):", round(lambda, 4), "\n", verbose = verbose)
        if ("pmap" %in% file.output) {
            logging.log("Writing results to local file", "\n", verbose = verbose)
            write.csv(x = cbind(map,farmcpu.results),
                    file = file.path(outpath, paste(colnames(phe)[2], ".FarmCPU.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                    row.names = FALSE)
        }
    }

    MVP.return <- list(map=map, glm.results=glm.results, mlm.results=mlm.results, farmcpu.results=farmcpu.results)

    if(permutation.threshold){
        # set.seed(12345)
        i=1
        for(i in 1:permutation.rep){
            index = 1:nrow(phe)
            index.shuffle = sample(index,length(index),replace=FALSE)
            myY.shuffle = phe
            myY.shuffle[,2] = myY.shuffle[index.shuffle,2]
            #GWAS using t.test...
            myPermutation = MVP.GLM(phe=myY.shuffle[,c(1,2)], geno=geno, cpu=ncpus)
            pvalue = min(myPermutation[,2],na.rm=TRUE)
            if(i==1){
                    pvalue.final=pvalue
               }else{
                    pvalue.final=c(pvalue.final,pvalue)
            }
        }#end of permutation.rep
        permutation.cutoff = sort(pvalue.final)[ceiling(permutation.rep*0.05)]
        threshold = permutation.cutoff * m
    }
    logging.log(paste0("Significant level: ", formatC(threshold/m, format = "e", digits = 2)), "\n", verbose = verbose)
    if ("pmap.signal" %in% file.output) {
        if (glm.run) {
            index <- which(glm.results[, ncol(glm.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, glm.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".GLM_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
        if (mlm.run) {
            index <- which(mlm.results[, ncol(mlm.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, mlm.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".MLM_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
        if (farmcpu.run) {
            index <- which(farmcpu.results[, ncol(farmcpu.results)] < threshold/m)
            if (length(index) != 0) {
              write.csv(x = cbind.data.frame(map, farmcpu.results)[index, ],
                        file = file.path(outpath, paste(colnames(phe)[2], ".FarmCPU_signals.", memo, ifelse(is.null(memo),"csv",".csv"), sep = "")),
                        row.names = FALSE)
            }
        }
    }
    if ("plot" %in% file.output) {
        logging.log("---------------------Visualization Start--------------------", "\n", verbose = verbose)
        logging.log("Phenotype distribution Plotting", "\n", verbose = verbose)
        MVP.Hist(memo=memo, outpath=outpath, file.output=TRUE, phe=phe, file.type=file.type, col=col, dpi=dpi)
        #plot3D <- !is(try(library("rgl"),silent=TRUE), "try-error")
        plot3D <- FALSE
        if(!is.null(nPC)){
          MVP.PCAplot(
            ipca[,1:3],
            col=col,
            plot3D=plot3D,
            file.output=TRUE,
            file.type=file.type,
            outpath=outpath,
            memo = ifelse(is.null(memo), colnames(phe)[2], paste(colnames(phe)[2], memo, sep=".")),
            dpi=dpi,
          )
        }

        MVP.Report(
            MVP.return,
            col=col,
            plot.type=c("c","m","q","d"),
            file.output=TRUE,
            file.type=file.type,
            outpath=outpath,
            memo = memo,
            chr.den.col=c("darkgreen", "yellow", "red"),
            dpi=dpi,
            threshold=threshold/m,
        )

        if(sum(c(is.null(glm.results), is.null(mlm.results), is.null(farmcpu.results))) < 2) {
            MVP.Report(
                MVP.return,
                col=col,
                plot.type=c("m","q"),
                multracks=TRUE,
                file.output=TRUE,
                file.type=file.type,
                outpath=outpath,
                memo = memo,
                dpi=dpi,
                threshold=threshold/m
            )
        }
    }
    now <- Sys.time()
    if (length(file.output) > 0) {
      logging.log("Results are stored at Working Directory:", outpath, "\n", verbose = verbose)
    }
    logging.log("End:", as.character(now), "\n", verbose = verbose)
    print_accomplished(width = 60, verbose = verbose)

    return(invisible(MVP.return))
}#end of MVP function