# Explained Variance (R2) calculation for left-handedness (binomial trait)
# V.Odintsova, J.van Dongen, C.Dolan
# Based on Lee et al.
# Genetic Epidemiology 36 : 214–224 (2012)
# A Better Coefficient of Determination for Genetic Profile Analysis

########################### ############## ##############
# Load data
########################### ############## ##############
# polygenic risk scores (PGS)
# methylation scores (MS)
# EWAS covariates
# PGS covariates

########################### ############## ##############
# Select variables for the prediction models
########################### ############## ##############
# FISNumber
# FamilyNumber
# sex
# age (age at DNA bloodsampling, scaled)
# hand01 (left-handedness variable: right-handed = 0, left-handed = 1)

# PGS and GWAS covariates
# PGS
# PC1 - PC10 (principal components)
# platform2 - platform6 (platform dummy variables)

# Methylation scores and EWAS covariates from adjusted model
# MS1 (methylation score calculated with weights at p-value thresholds 10^-1)
# MS3 (methylation score calculated with weights at p-value thresholds 10^-3)
# MS5 (methylation score calculated with weights at p-value thresholds 10^-5)
# smoking
# BMI
# Neut_Perc (neutrophils percentage)
# Mono_Perc (monocytes percentage)
# Eos_Perc (eosinophils percentage)
# Array_rownum (array rownumber)
# Sample_Plate (sample plate)
# Sample_Plate1 - Sample_PlateN (dummy variables for sample plate)

########################### ############## ##############
# Logistic regression to calculate R2 for PGS and MS
############################ ############## ##############
# function for logistic regression model with PGS and covariates prints PGS effect size, se, p-value, R2
PGSlogit_function = function(NTRdata) {
                  dat = NTRdata
                  hand01=as.numeric(dat$hand01)
                  sex=as.numeric(dat$sex)
                  PGS=as.numeric(dat$PGS)
                  PC1 = as.numeric(dat$PC1)
                  PC2 = as.numeric(dat$PC2)
                  PC3 = as.numeric(dat$PC3)
                  PC4 = as.numeric(dat$PC4)
                  PC5 = as.numeric(dat$PC5)
                  PC6 = as.numeric(dat$PC6)
                  PC7 = as.numeric(dat$PC7)
                  PC8 = as.numeric(dat$PC8)
                  PC9 = as.numeric(dat$PC9)
                  PC10 = as.numeric(dat$PC10)
                  platform2=as.numeric(dat$platform2)
                  platform3=as.numeric(dat$platform3)
                  platform5=as.numeric(dat$platform5)
                  platform6=as.numeric(dat$platform6)
                  # MODEL 1: handedness ~ PGS + GWAS covariates
                  vare1 = pi^2 / 3     # residual (homoskedastic) variance
                  r1=glm(hand01~PGS+sex+ platform2+platform3+platform5+platform6+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10,
                         family=binomial(link='logit'))  # logistic regression
                  vp1=var( r1$coefficients["PGS"]*PGS+
                          r1$coefficients["sex"]*sex+
                          r1$coefficients["platform2"]*platform2+
                          r1$coefficients["platform3"]*platform3+
                          r1$coefficients["platform5"]*platform5+
                          r1$coefficients["platform6"]*platform6+
                          r1$coefficients["PC1"]*PC1+
                          r1$coefficients["PC2"]*PC2+
                          r1$coefficients["PC3"]*PC3+
                          r1$coefficients["PC4"]*PC4+
                          r1$coefficients["PC5"]*PC5+
                          r1$coefficients["PC6"]*PC6+
                          r1$coefficients["PC7"]*PC7+
                          r1$coefficients["PC8"]*PC8+
                          r1$coefficients["PC9"]*PC9+
                          r1$coefficients["PC10"]*PC10)    # variance explained
                  R2logist1 = vp1 / (vp1+vare1)   # explained var  / total var
                  # MODEL 2: handedness ~ GWAS covariates
                  r2=glm(hand01~sex+platform2+platform3+platform5+platform6+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10,
                         family=binomial(link='logit'))
                  vp2=var(
                            r2$coefficients["sex"]*sex+
                            r2$coefficients["platform2"]*platform2+
                            r2$coefficients["platform3"]*platform3+
                            r2$coefficients["platform5"]*platform5+
                            r2$coefficients["platform6"]*platform6+
                            r1$coefficients["PC1"]*PC1+
                            r1$coefficients["PC2"]*PC2+
                            r1$coefficients["PC3"]*PC3+
                            r1$coefficients["PC4"]*PC4+
                            r1$coefficients["PC5"]*PC5+
                            r1$coefficients["PC6"]*PC6+
                            r1$coefficients["PC7"]*PC7+
                            r1$coefficients["PC8"]*PC8+
                            r1$coefficients["PC9"]*PC9+
                            r1$coefficients["PC10"]*PC10)    # variance explained
                  R2logist2 = vp2 / (vp2+vare1)   # explained var  / total var
                  t = matrix(0, 1, 6)
                  t[1,1] = summary(r1)$coefficients[2,1]
                  t[1,2] = summary(r1)$coefficients[2,2]
                  t[1,3] = summary(r1)$coefficients[2,4]
                  t[1,4] = R2logist1 - R2logist2
                  print(t)
}

# function for logistic regression model with MS, PGS and covariates prints MS effect size, se, p-value, R2
MSlogit_function = function(NTRdata, MScore) {
                  dat = NTRdata
                  MS = as.numeric(MScore)
                    hand01=as.numeric(dat$hand01)
                    age=as.numeric(dat$age)
                    sex=as.numeric(dat$sex)
                    PGS=as.numeric(dat$PGS)
                    PC1 = as.numeric(dat$PC1)
                    PC2 = as.numeric(dat$PC2)
                    PC3 = as.numeric(dat$PC3)
                    PC4 = as.numeric(dat$PC4)
                    PC5 = as.numeric(dat$PC5)
                    PC6 = as.numeric(dat$PC6)
                    PC7 = as.numeric(dat$PC7)
                    PC8 = as.numeric(dat$PC8)
                    PC9 = as.numeric(dat$PC9)
                    PC10 = as.numeric(dat$PC10)
                    platform1=as.numeric(dat$platform1) # not used in models
                    platform2=as.numeric(dat$platform2)
                    platform3=as.numeric(dat$platform3)
                    platform5=as.numeric(dat$platform5)
                    platform6=as.numeric(dat$platform6)
                    smoking = as.numeric(dat$smoking)
                    BMI = as.numeric(dat$BMI)
                    Neut_Perc = as.numeric(dat$Neut_Perc)
                    Mono_Perc = as.numeric(dat$Mono_Perc)
                    Eos_Perc = as.numeric(dat$Eos_Perc)
                    Sample_Plate = as.factor(dat$Sample_Plate)
                    Sample_Plate1 = ifelse(Sample_Plate== 1, 1, 0)
                    Sample_Plate2 = ifelse(Sample_Plate== 2, 1, 0)
                    Sample_Plate3 = ifelse(Sample_Plate== 3, 1, 0)
                    Sample_Plate4 = ifelse(Sample_Plate== 4, 1, 0)
                    Sample_Plate5 = ifelse(Sample_Plate== 5, 1, 0)
                    Sample_Plate6 = ifelse(Sample_Plate== 6, 1, 0)
                    Sample_Plate7 = ifelse(Sample_Plate== 7, 1, 0)
                    Sample_Plate8 = ifelse(Sample_Plate== 8, 1, 0)
                    Sample_Plate9 = ifelse(Sample_Plate== 9, 1, 0)
                    Sample_Plate10 = ifelse(Sample_Plate== 10, 1, 0)
                    Sample_Plate11 = ifelse(Sample_Plate== 11, 1, 0)
                    Sample_Plate12 = ifelse(Sample_Plate== 12, 1, 0)
                    Sample_Plate13 = ifelse(Sample_Plate== 13, 1, 0)
                    Sample_Plate14 = ifelse(Sample_Plate== 14, 1, 0)
                    Sample_Plate15 = ifelse(Sample_Plate== 15, 1, 0)
                    Sample_Plate16 = ifelse(Sample_Plate== 16, 1, 0)
                    Sample_Plate17 = ifelse(Sample_Plate== 17, 1, 0)
                    Sample_Plate18 = ifelse(Sample_Plate== 18, 1, 0)
                    Sample_Plate19 = ifelse(Sample_Plate== 19, 1, 0)
                    Sample_Plate20 = ifelse(Sample_Plate== 20, 1, 0)
                    Sample_Plate21 = ifelse(Sample_Plate== 21, 1, 0)
                    Sample_Plate22 = ifelse(Sample_Plate== 22, 1, 0)
                    Sample_Plate23 = ifelse(Sample_Plate== 23, 1, 0)
                    Sample_Plate24 = ifelse(Sample_Plate== 24, 1, 0)
                    Sample_Plate25 = ifelse(Sample_Plate== 25, 1, 0)
                    Sample_Plate26 = ifelse(Sample_Plate== 26, 1, 0)
                    Sample_Plate27 = ifelse(Sample_Plate== 27, 1, 0)
                    Sample_Plate28 = ifelse(Sample_Plate== 28, 1, 0)
                    Sample_Plate29 = ifelse(Sample_Plate== 29, 1, 0)
                    Sample_Plate30 = ifelse(Sample_Plate== 30, 1, 0)
                    Sample_Plate31 = ifelse(Sample_Plate== 31, 1, 0)
                    Sample_Plate32 = ifelse(Sample_Plate== 32, 1, 0)
                    Sample_Plate33 = ifelse(Sample_Plate== 33, 1, 0)
                    Sample_Plate34 = ifelse(Sample_Plate== 34, 1, 0)
                    # MODEL 1: handedness ~ MS+PGS + covariates
                    vare1 = pi^2 / 3     # residual (homoskedastic) variance
                    r1=glm(hand01~PGS+age+sex+
                             platform2+platform3+platform5+platform6+PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+
                             smoking+BMI+Neut_Perc+Mono_Perc+Eos_Perc+Sample_Plate+MS,
                             family=binomial(link='logit'))  # logistic regression
                    vp1=var( r1$coefficients["PGS"]*PGS+
                            r1$coefficients["age"]*age+
                            r1$coefficients["sex"]*sex+
                            r1$coefficients["platform2"]*platform2+
                            r1$coefficients["platform3"]*platform3+
                            r1$coefficients["platform5"]*platform5+
                            r1$coefficients["platform6"]*platform6+
                            r1$coefficients["PC1"]*PC1+
                            r1$coefficients["PC2"]*PC2+
                            r1$coefficients["PC3"]*PC3+
                            r1$coefficients["PC4"]*PC4+
                            r1$coefficients["PC5"]*PC5+
                            r1$coefficients["PC6"]*PC6+
                            r1$coefficients["PC7"]*PC7+
                            r1$coefficients["PC8"]*PC8+
                            r1$coefficients["PC9"]*PC9+
                            r1$coefficients["PC10"]*PC10+
                            r1$coefficients["smoking"]*smoking+
                            r1$coefficients["BMI"]*BMI+
                            r1$coefficients["Neut_Perc"]*Neut_Perc+
                            r1$coefficients["Mono_Perc"]*Mono_Perc+
                            r1$coefficients["Eos_Perc"]*Eos_Perc+
                            r1$coefficients["Sample_Plate2"]*Sample_Plate2+
                            r1$coefficients["Sample_Plate3"]*Sample_Plate3+
                            r1$coefficients["Sample_Plate4"]*Sample_Plate4+
                            r1$coefficients["Sample_Plate5"]*Sample_Plate5+
                            r1$coefficients["Sample_Plate6"]*Sample_Plate6+
                            r1$coefficients["Sample_Plate7"]*Sample_Plate7+
                            r1$coefficients["Sample_Plate8"]*Sample_Plate8+
                            r1$coefficients["Sample_Plate9"]*Sample_Plate9+
                            r1$coefficients["Sample_Plate10"]*Sample_Plate10+
                            r1$coefficients["Sample_Plate11"]*Sample_Plate11+
                            r1$coefficients["Sample_Plate12"]*Sample_Plate12+
                            r1$coefficients["Sample_Plate13"]*Sample_Plate13+
                            r1$coefficients["Sample_Plate14"]*Sample_Plate14+
                            r1$coefficients["Sample_Plate15"]*Sample_Plate15+
                            r1$coefficients["Sample_Plate16"]*Sample_Plate16+
                            r1$coefficients["Sample_Plate17"]*Sample_Plate17+
                            r1$coefficients["Sample_Plate18"]*Sample_Plate18+
                            r1$coefficients["Sample_Plate19"]*Sample_Plate19+
                            r1$coefficients["Sample_Plate20"]*Sample_Plate20+
                            r1$coefficients["Sample_Plate21"]*Sample_Plate21+
                            r1$coefficients["Sample_Plate22"]*Sample_Plate22+
                            r1$coefficients["Sample_Plate23"]*Sample_Plate23+
                            r1$coefficients["Sample_Plate24"]*Sample_Plate24+
                            r1$coefficients["Sample_Plate25"]*Sample_Plate25+
                            r1$coefficients["Sample_Plate26"]*Sample_Plate26+
                            r1$coefficients["Sample_Plate27"]*Sample_Plate27+
                            r1$coefficients["Sample_Plate28"]*Sample_Plate28+
                            r1$coefficients["Sample_Plate29"]*Sample_Plate29+
                            r1$coefficients["Sample_Plate30"]*Sample_Plate30+
                            r1$coefficients["Sample_Plate31"]*Sample_Plate31+
                            r1$coefficients["Sample_Plate32"]*Sample_Plate32+
                            r1$coefficients["Sample_Plate33"]*Sample_Plate33+
                            r1$coefficients["Sample_Plate34"]*Sample_Plate34+
                            r1$coefficients["MS"]*MS)   # variance explained
                    R2logist1 = vp1 / (vp1+vare1)   # explained var  / total var
                    # MODEL 2: handedness ~ PGS +  covariates
                    r2=glm(hand01~PGS5+age+sex+platform2+platform3+platform5+platform6+
                                PC1+PC2+PC3+PC4+PC5+PC6+PC7+PC8+PC9+PC10+
                                smoking+BMI+Neut_Perc+Mono_Perc+Eos_Perc+Sample_Plate,
                                family=binomial(link='logit'))

                    vp2=var(            r2$coefficients["PGS"]*PGS+
                                        r2$coefficients["age"]*age+
                                        r2$coefficients["sex"]*sex+
                                        r2$coefficients["platform2"]*platform2+
                                        r2$coefficients["platform3"]*platform3+
                                        r2$coefficients["platform5"]*platform5+
                                        r2$coefficients["platform6"]*platform6+
                                        r2$coefficients["PC1"]*PC1+
                                        r2$coefficients["PC2"]*PC2+
                                        r2$coefficients["PC3"]*PC3+
                                        r2$coefficients["PC4"]*PC4+
                                        r2$coefficients["PC5"]*PC5+
                                        r2$coefficients["PC6"]*PC6+
                                        r2$coefficients["PC7"]*PC7+
                                        r2$coefficients["PC8"]*PC8+
                                        r2$coefficients["PC9"]*PC9+
                                        r2$coefficients["PC10"]*PC10+
                                        r2$coefficients["smoking"]*smoking+
                                        r2$coefficients["BMI"]*BMI+
                                        r2$coefficients["Neut_Perc"]*Neut_Perc+
                                        r2$coefficients["Mono_Perc"]*Mono_Perc+
                                        r2$coefficients["Eos_Perc"]*Eos_Perc+
                                        r2$coefficients["Sample_Plate2"]*Sample_Plate2+
                                        r2$coefficients["Sample_Plate3"]*Sample_Plate3+
                                        r2$coefficients["Sample_Plate4"]*Sample_Plate4+
                                        r2$coefficients["Sample_Plate5"]*Sample_Plate5+
                                        r2$coefficients["Sample_Plate6"]*Sample_Plate6+
                                        r2$coefficients["Sample_Plate7"]*Sample_Plate7+
                                        r2$coefficients["Sample_Plate8"]*Sample_Plate8+
                                        r2$coefficients["Sample_Plate9"]*Sample_Plate9+
                                        r2$coefficients["Sample_Plate10"]*Sample_Plate10+
                                        r2$coefficients["Sample_Plate11"]*Sample_Plate11+
                                        r2$coefficients["Sample_Plate12"]*Sample_Plate12+
                                        r2$coefficients["Sample_Plate13"]*Sample_Plate13+
                                        r2$coefficients["Sample_Plate14"]*Sample_Plate14+
                                        r2$coefficients["Sample_Plate15"]*Sample_Plate15+
                                        r2$coefficients["Sample_Plate16"]*Sample_Plate16+
                                        r2$coefficients["Sample_Plate17"]*Sample_Plate17+
                                        r2$coefficients["Sample_Plate18"]*Sample_Plate18+
                                        r2$coefficients["Sample_Plate19"]*Sample_Plate19+
                                        r2$coefficients["Sample_Plate20"]*Sample_Plate20+
                                        r2$coefficients["Sample_Plate21"]*Sample_Plate21+
                                        r2$coefficients["Sample_Plate22"]*Sample_Plate22+
                                        r2$coefficients["Sample_Plate23"]*Sample_Plate23+
                                        r2$coefficients["Sample_Plate24"]*Sample_Plate24+
                                        r2$coefficients["Sample_Plate25"]*Sample_Plate25+
                                        r2$coefficients["Sample_Plate26"]*Sample_Plate26+
                                        r2$coefficients["Sample_Plate27"]*Sample_Plate27+
                                        r2$coefficients["Sample_Plate28"]*Sample_Plate28+
                                        r2$coefficients["Sample_Plate29"]*Sample_Plate29+
                                        r2$coefficients["Sample_Plate30"]*Sample_Plate30+
                                        r2$coefficients["Sample_Plate31"]*Sample_Plate31+
                                        r2$coefficients["Sample_Plate32"]*Sample_Plate32+
                                        r2$coefficients["Sample_Plate33"]*Sample_Plate33+
                                        r2$coefficients["Sample_Plate34"]*Sample_Plate34
                    )    # variance explained
                    R2logist2 = vp2 / (vp2+vare1)   # explained var  / total var
                    t = matrix(0, 1, 6)
                    t[1,1] = summary(r1)$coefficients[57,1]
                    t[1,2] = summary(r1)$coefficients[57,2]
                    t[1,3] = summary(r1)$coefficients[57,4]
                    t[1,6] = R2logist1 - R2logist2
                    print(t)
}


# R code
# Luis P. F. Garcia 2018
# Predict the labels for new data

labels <- function(pred, df, wtype, size) {

  if(wtype == "slide") {
    size = size/3;
  }

  aux = table(df$timestamp)
  sec = size/15

  result = lapply(1:(length(aux)/sec), function(i) {
    tmp = names(aux[((i-1)*sec + 1):(i*sec)])
    vet = subset(df, as.character(df$timestamp) %in% tmp)
    pred[rep(i, nrow(vet)),]
  })

  do.call("rbind", result)
}

build <- function(data, result, output) {
  aux = nrow(data) - nrow(result)
  result = rbind(result, tail(result, aux))
  write.csv(result, output, row.names=FALSE)
}

is.svm <- function(model) {
  any(class(model) == "svm")
}

init_model <- function (modelPath) {
  print("loading model...")
  model <<- readRDS(modelPath)
  print("done.")
}

prediction <- function(input, output="out.csv") {

  df = read(input)

  data = sampling(df)
  test = window(data, model$wtype, model$ftype, model$size)
  pred = predict(model$model, test, type="prob", prob=TRUE)

  if(is.svm(model$model))
    pred = attr(pred, "probabilities")

  result = labels(pred, df, model$wtype, model$size)
  build(df, result, output)
  return(0)
}


#Runs likelihood optimization in the beginning to
#start in a better place.

logLikAllOptimize  <- function(x,cp){
    #Optimizer wrapper for the log likelihood function
    Theta      <- x["Theta"]
    DeltaD      <- x["DeltaD"]
    DeltaS      <- x["DeltaS"]
    Lambda      <- x["Lambda"]
    LambdaRight <- x["LambdaRight"]
    LambdaDisp  <- x["LambdaDisp"]
    Rho         <- x["Rho"]
    if (sum(c(DeltaD,DeltaS,Lambda,LambdaRight)>1)>0 || sum(c(Theta,DeltaD,DeltaS,Lambda,LambdaRight,Rho)<0)>0){
        #This very convenient for lazy people, using a unbounded optimization method Nelder-Mead
        #just returning Inf when we are outside the boundary.
        return(Inf)
    }
    if(cp$fix_ti_tv){
        theta_mat  <- getPmat(Theta,cp$Rho,cu_pa$acgt)
    }else {
        theta_mat  <- getPmat(Theta,Rho,cu_pa$acgt)
    }
    if (cp$fix_disp){
        disp_to_use =  cp$LambdaDisp
    }else {
        disp_to_use = LambdaDisp
    }
    leftLaVec  <- seqProbVecLambda(Lambda, disp_to_use, cu_pa$m, cu_pa$termini)
    rightLaVec  <- seqProbVecLambda(LambdaRight, disp_to_use, cu_pa$m, cu_pa$termini)
    if (cp$same_overhangs){
        rightLaVec <- leftLaVec
    }

    if (cp$termini == "5p") {
        #Only using the forward end
        laVec <- leftLaVec
    } else if (cp$termini == "3p") {
        #Only using the backward end
        laVec <- rightLaVec
    } else {
        #Both ends
        stopifnot(cp$termini == "both")
        laVec <- c(leftLaVec[1:(cu_pa$m/2)],rightLaVec[(cu_pa$m/2+1):cu_pa$m])
    }

    return(-logLikAll(cp$dat,theta_mat,DeltaD,DeltaS,laVec,cp$nuVec,cp$m))
}

gridSearch <- function(cp,iter){
    #Starts the Markov chain in local maxima for "quicker" burn-in period
    #No theoretical reasoning behind this but seems to work well in practice.
    if(!cp$quiet){
        cat("Starting grid search, starting from random values\n")
    }
    minVal <- Inf
    minParams <- list()
    control  <- list(maxit=5000)
    for (i in 1:iter){
        out <- optim(
                     c(Theta=runif(1),
                       DeltaD=runif(1),
                       DeltaS=runif(1),
                       Lambda=runif(1),
                       LambdaRight=runif(1),
                       LambdaDisp=sample(c(0.5,1,2,3,4,50,100,150,400),1),
                       Rho=sample(c(0.5,.75,1,1.25,1.5),1)
                      ),
                     logLikAllOptimize,
                     NULL,
                     cp=cp,
                     method="Nelder-Mead",
                     control=control
                     )
        if (out$value<minVal){
            minParams <- out
            minVal <- out$value
        }
        if (cp$verbose){
            cat("Iteration\t",i,"\t",-minVal,"\n")
        }
    }
    #These parameters are always optimized
    cp$Theta <- minParams$par["Theta"]
    cp$DeltaD <- minParams$par["DeltaD"]
    cp$DeltaS <- minParams$par["DeltaS"]
    cp$Lambda <- minParams$par["Lambda"]

    #Only update the other ones if the user requested for them
    if (!cp$fix_ti_tv){
        cp$Rho  <- minParams$par["Rho"]
    }
    if (!cp$fix_disp){
        cp$LamdaDisp  <- minParams$par["LambdaDisp"]
    }
    if (!cp$same_overhangs){
        cp$LamdaRight  <- minParams$par["LambdaRight"]
    }

    #Now calculating matrix and vectors accompanying the optimal values
    cp$laVec <- seqProbVecLambda(cp$Lambda, cp$LambdaDisp, nrow(cp$dat), cp$termini)
    cp$laVecRight <- seqProbVecLambda(cp$Lambda, cp$LambdaDisp, nrow(cp$dat), cp$termini)
    cp$ThetaMat <- getPmat(cp$Theta,cp$Rho,cp$acgt)
    cp$old_lik <- - minVal

    return(cp)
}


#' Score Linkage Variables
#'
#' @param df site MSD file
#'
#' @importFrom magrittr %>%
#' @export

score_lnk <- function(df){
  #1. Proxy Linkage

  #pull headers to figure out last three quarters to keep
    headers <- names(df)
    pds <- headers[stringr::str_detect(headers, "q(?=[:digit:])")] %>%
      tail(., n =3)

  #narrow down to data needed for indicator creation
    lnk_val <- df %>%
      dplyr::filter(indicator %in% c("HTS_TST_POS", "TX_NEW"),
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, indicator, pds) %>%
      dplyr::filter_at(dplyr::vars(dplyr::contains("q")), dplyr::any_vars(!is.na(.) & .!=0)) #remove if all quarters are missing

  #create linkage value
    lnk_val <- lnk_val %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy")) %>%
      dplyr::select(-pd) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup() %>%
      tidyr::spread(indicator, val) %>%
      dplyr::mutate(linkage = TX_NEW / HTS_TST_POS,
             linkage = ifelse(!is.finite(linkage), 0, linkage))

  #Calculate percentile grouping
    lnk_val <- lnk_val %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(lnk.proxylinkage.score =
                      dplyr::case_when(linkage < quantile(linkage, .25) ~ 2,
                                       linkage < quantile(linkage, .50) ~ 1,
                                       TRUE                             ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::rename(lnk.proxylinkage.value = linkage) %>%
      dplyr::select(-HTS_TST_POS, -TX_NEW)

  #4. & 5. Number of quarters without decrease/increase
  #narrow down to data needed for indicator creation
    lnk_chng <- df %>%
      dplyr::filter(indicator %in% c("HTS_TST_POS", "TX_NEW"),
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, indicator, dplyr::contains("q")) %>%
      dplyr::filter_at(dplyr::vars(dplyr::contains("q")), dplyr::any_vars(!is.na(.) & .!=0)) #remove if all quarters are missing

  #create linkage value
    lnk_chng <- lnk_chng %>%
      #get all indicator values on same rows
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup() %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy")) %>%
      tidyr::spread(indicator, val) %>%
      dplyr::mutate(linkage = TX_NEW / HTS_TST_POS,
                    linkage = ifelse(!is.finite(linkage), 0, linkage))
  #change
    lnk_chng <- lnk_chng %>%
      dplyr::group_by(operatingunit, psnu, sitename, orgunituid) %>%
      dplyr::mutate(link_qtrdiff_pos = ifelse(linkage - lag(linkage) > 0, 1, 0),
                    link_qtrdiff_neg = ifelse(linkage - lag(linkage) < 0, 1, 0))%>%
      dplyr::ungroup()

    lnk_chng <- lnk_chng %>%
      dplyr::group_by(operatingunit, psnu, sitename, orgunituid) %>%
      dplyr::summarise_at(dplyr::vars(dplyr::contains("link")), ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup()

    lnk_chng <- lnk_chng %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(lnk.lnk_pos_chng.score =
                      dplyr::case_when(link_qtrdiff_pos > quantile(link_qtrdiff_pos, .75) ~ 2,
                                       link_qtrdiff_pos > quantile(link_qtrdiff_pos, .50) ~ 1,
                                       TRUE                                               ~ 0),
                    lnk.lnk_neg_chng.score =
                      dplyr::case_when(link_qtrdiff_neg > quantile(link_qtrdiff_neg, .75) ~ 2,
                                       link_qtrdiff_neg > quantile(link_qtrdiff_neg, .50) ~ 1,
                                       TRUE                                               ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::rename(lnk.lnk_pos_chng.value = link_qtrdiff_pos,
             lnk.lnk_neg_chng.value = link_qtrdiff_neg) %>%
      dplyr::select(-linkage)

  #combine all together
    lnk <- dplyr::full_join(lnk_chng, lnk_val, by = c("operatingunit", "psnu", "sitename", "orgunituid"))
    return(lnk)

}


# Linear search implementation in R

linearSearch <- function(x, val){
  i = 1
  while(i <= length(x)){
    if(x[i] == val){
      return(cat(sprintf("%d is found at index: %d", val, i)))
    }
    i = i+1
  }
  return(cat(sprintf("%d is not found", val)))
}

x = c(1,7,2,14,16,200,192,141,3,67,89)
linearSearch(x, 200) # found at index 6
linearSearch(x, 500) # not found


#' xpose
#'
#' Transpose a float vector/matrix.
#'
#' @param x
#' A float vector/matrix.
#'
#' @return
#' A float vector/matrix.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' dim(s)
#' ts = t(s)
#' dim(ts)
#'
#' @useDynLib float R_xpose_spm
#' @name xpose
#' @rdname xpose
NULL

xpose_float32 = function(x)
{
  ret = .Call(R_xpose_spm, DATA(x))
  float32(ret)
}

#' @rdname xpose
#' @export
setMethod("t", signature(x="float32"), xpose_float32)


library('rattle')
ds <- get("weather")
vars <- names(ds)
target <- "rain_tomorrow"
risk <- "risk_mm"
id <- ("date", "location")
ignore <- union(id, if(exists("risk")) risk)
(ids <- which(sapply(ds, function(x) length(unique(x)))==nrow(ds)))
ignore <- union(ignore, ids)
## ignore variables with missing values
mvc <- sapply(ds[vars], function(x) sum(is.na(x)))
mvn <- names(which(mvc == nrow(ds)))
ignore <- union(ignore, mvn)
mvn <- names(which(mvc >= 0.7*nrow(ds)))
ignore <- union(ignore, mvn)
## ignore variables with too many levels
factors <- which(sapply(ds[vars], is.factor))
lvls <- sapply(factors, function(x) length(levels(ds[[x]])))
many <- names(which(lvls > 20))
ignore <- union(ignore, many)
## ignore variables with constant values
(constants <- names(which(sapply(ds[vars], function(x) all(x==x[1L])))))
ignore <- union(ignore, constants)
## remove the variables
length(vars)
vars <- setdiff(vars, ignore)
length(vars)
## remove missing target
dim(ds)
sum(is.na(ds[target]))
ds <- ds[!is.na(ds[target]), ]
sum(is.na(ds[target]))
dim(ds)
## deal with missing values
ods <- ds
dim(ds[vars])
sum(is.na(ds[vars]))
ds[vars] <- na.roughfix(ds[vars])
sum(is.na(ds[vars]))
dim(ds[vars])
ds <-ods
## omitting observations
ods <- ds
omit <- NULL
dim(ds[vars])
sum(is.na(ds[vars]))
mo <- attr(na.omit(ds[vars]), "na.action")
omit <- union(omit, mo)
if(length(omit)) ds <- ds[-omit,]
sum(is.na(ds[vars]))
dim(ds[vars])
ds <- ods
## normalise factors
factors <- which(sapply(ds[vars], is.factor))
for (f in factors) levels(ds[[f]]) <- normVarNames(levels(ds[[f]]))
## ensure target is categoric
ds[target] <- as.factor(ds[[target]])
table(ds[target])
p <- ggplot(ds, aes_string(x=target))
p <- p+geom_bar(width=0.2)
print(p)


extract.detection.pvalues <- function(rg, probes, verbose=F) {
    msg(verbose=verbose)

    dyes <- c(R="R", G="G")
    negative.intensities <- lapply(dyes, function(color) {
        addresses <- with(probes, address[which(dye == color & target == "NEGATIVE")])
        rg[[color]][which(rownames(rg[[color]]) %in% addresses),"Mean"]
    })
    negative.med <- lapply(negative.intensities, median, na.rm=T)
    negative.sd  <- lapply(negative.intensities, mad, na.rm=T)

    features <- unique(na.omit(probes$name))

    detection.stats <- lapply(c(M="M", U="U"), function(target) {
        probes <- probes[which(probes$target == target),]
        probes <- probes[match(features, probes$name),]
        r.idx <- which(probes$dye == "R")
        g.idx <- which(probes$dye == "G")

        intensity <- rep(NA, nrow(probes))

        addresses <- probes$address[r.idx]
        if(!all(addresses %in% rownames(rg$R)))
            stop("It seems that the IDAT files do not match the supplied chip annotation")
        intensity[r.idx] <- rg$R[match(probes$address[r.idx], rownames(rg$R)),"Mean"]

        addresses <- probes$address[g.idx]
        if(!all(addresses %in% rownames(rg$G)))
            stop("It seems that the IDAT files do not match the supplied chip annotation")
        intensity[g.idx] <- rg$G[match(probes$address[g.idx], rownames(rg$G)),"Mean"]

        med <- rep(NA, nrow(probes))
        med[r.idx] <- negative.med$R
        med[g.idx] <- negative.med$G

        sd <- rep(NA, nrow(probes))
        sd[r.idx] <- negative.sd$R
        sd[g.idx] <- negative.sd$G

        data.frame(intensity=intensity, med=med, sd=sd)
    })

    p.value <- with(detection.stats, 1-pnorm(M$intensity + U$intensity,
                                             mean=M$med + U$med,
                                             sd=M$sd + U$sd))
    names(p.value) <- features
    p.value
}


function (d, bcol = 1, y.lim = NA, y.lab = "")
{
    nitems <- dim(d)[1]
    nvars <- dim(d)[2]
    mns <- colMeans(d, na.rm = T)
    serr <- rep(0, times = nvars)
    for (i in c(1:nvars)) {
        serr[i] <- sqrt(var(d[, i], na.rm = T))/sqrt(nitems -
            sum(is.na(d[, i])))
    }
    if (is.na(y.lim[1])) {
        y.lim <- c(min(mns - serr), max(mns + serr)) * 1.1
    }
    msgn <- rep(1, times = nvars)
    msgn[mns < 0] <- -1
    p <- barplot(mns, beside = T, ylim = y.lim, col = bcol, ylab = y.lab)
    arrows(p, mns, p, mns + (serr * msgn), angle = 90)
    box()
}


#' @title spdf_from_extent
#' @description Create a spatialPolygonsDataFrame from extent of a spatial object.
#'
#' @param x A spatial object.
#'
#' @details If x is projected, the spatialpolygonsdataframe will also be projected
#'
#' @examples
#' require(raster) #load required package.
#' r1<-raster::raster(ext=extent(c(0,10,0,10)), res=1, vals=1:100) #create example raster.
#' spdf<-spdf_from_extent(r1) #convert the raster extent to SpatialPolygonsdataFrame.
#' plot(spdf) #Plot results.
#'
#' @return SpatialPolygonsDataFrame.
#'
#' @import 'raster'
#' @import 'sp'
#'
#' @export
spdf_from_extent<-function(x){
  x1<-as.vector(extent(x))[1]
  x2<-as.vector(extent(x))[2]
  y1<-as.vector(extent(x))[3]
  y2<-as.vector(extent(x))[4]
  coords<-rbind(c(x1,y1), c(x1, y2), c(x2,y2), c(x2, y1), c(x1,y1))
  p = Polygon(coords)
  ps = Polygons(list(p),1)
  sps = SpatialPolygons(list(ps))
  if(!is.na(crs(x)))crs(sps)<-crs(x)
  sps$id<-1
  return(sps)
}


# <-- encoding UTF-8 -->
# panel data model tools
# -----------------------------------------
# DOC STRING
#
#
# Tianhao Zhao
# Dec 2018
# -----------------------------------------
library(plm)  # popular panel data model library
require(purrr)  # function operation tools, std lib

# -----------------------------------------
# function: check p-values, returns significant marks (e.g. ***)
format_chkp <- function(pvalvec){
    tmpstrvec <- vector(mode="character",length=length(pvalvec))
    for(idx in 1:length(pvalvec)){
        if( pvalvec[idx] < 0.01 ){
            tmpstrvec[idx] <- "***"
        }else if( pvalvec[idx] < 0.05 ){
            tmpstrvec[idx] <- "**"
        }else if( pvalvec[idx] < 0.1 ){
            tmpstrvec[idx] <- "*"
        }else{
            tmpstrvec[idx] <- ""
        }
    }
    return(tmpstrvec)
}

# -----------------------------------------
# function: formatted a plm model to a data.frame of strings
# NOTE: because we use MS WORD to write papers,
#       it is essential to have this method to avoid manually transcripting regressions results to
#       formatted texts used in MS WORD;
#       if several models there, you may easily combine them in MS EXCEL
format_pggls <- function( summod, digits = 4, Yname = summod$formula[[2]] ){
    # input:
    # 1. summod: a summarized plm model, estimated by plm::pggls (FGLS estimator)
    # output:
    # 1. dfstr: a formatted data.frame, values are transformatted to string (with significance marks, SE in parentheses etc)
    # ---------
    # 1. get sumamrized coefficient table
    coeftab <- summod$CoefTable
    kvar <- nrow(coeftab)  # number of variables
    # 2. construct col 1 (variable names)
    # NOTE: like: [var1; var1 ;var2; var2 ;var3; var3], because we put SEs under coefs+signifmarks, every variable requires two rows
    dfstr <- list(
        Variable = rep(rownames(coeftab), each=2)  # 1st col: variable names
    )
    # NOTE: decorate the rows of SE to distinguish from coef rows, to avoid duplicated rows in merging
    dfstr$Variable[ (1:kvar)*2 ] <- paste(sep="", dfstr$Variable[ (1:kvar)*2 ], "_SE" )
    # 3. use Y name as the title of the 2nd column
    # yname <- summod$formula[[2]]
    yname <- Yname
    dfstr[[ yname ]] <- 0
    # 4. insert coefficients + significant marks
    # NOTE: convert p-values to string marks (***,**,*)
    dfstr[[yname]][ (1:kvar)*2-1 ] <- paste(sep="", format(round(coeftab[,"Estimate"],digits = digits)), format_chkp( coeftab[,"Pr(>|z|)"] )  )
    # 5. insert SE in parentheses
    # NOTE: round to operate data, format to make the operated data print in uniform digits (the same as the digits in round())
    dfstr[[yname]][ (1:kvar)*2 ] <- paste(sep="","(",format(round(coeftab[,"Std. Error"],digits = digits)),")" )

    # 6. convert the list to a dataframe
    dfstr <- data.frame(dfstr)
    # 7. add Multiple R-squared to the last row
    lastrow <- list( Variable = "Multiple R-squared" )
    lastrow[[yname]] <- format(round(summod$rsqr,digits=digits))
    lastrow <- data.frame(lastrow)
    dfstr <- rbind( dfstr, lastrow )

    return(dfstr)
}
# ---------------------------------------------
# NOTE: used on the summarized models estimated by plm(), and
# NOTE: two-ways effect models can only by estimated by plm()
format_plm <- function( summod, digits = 4, Yname = formula(summod)[[2]] ){
    # input:
    # 1. summod: a summarized plm model, estimated by plm::pggls (FGLS estimator)
    # output:
    # 1. dfstr: a formatted data.frame, values are transformatted to string (with significance marks, SE in parentheses etc)
    # ---------
    # 1. get sumamrized coefficient table
    coeftab <- summod$coefficients
    kvar <- nrow(coeftab)  # number of variables
    # 2. construct col 1 (variable names)
    # NOTE: like: [var1; var1 ;var2; var2 ;var3; var3], because we put SEs under coefs+signifmarks, every variable requires two rows
    dfstr <- list(
        Variable = rep(rownames(coeftab), each=2)  # 1st col: variable names
    )
    # NOTE: decorate the rows of SE to distinguish from coef rows, to avoid duplicated rows in merging
    dfstr$Variable[ (1:kvar)*2 ] <- paste(sep="", dfstr$Variable[ (1:kvar)*2 ], "_SE" )
    # 3. use Y name as the title of the 2nd column
    # yname <- summod$formula[[2]]
    yname <- Yname
    dfstr[[ yname ]] <- 0
    # 4. insert coefficients + significant marks
    # NOTE: convert p-values to string marks (***,**,*)
    dfstr[[yname]][ (1:kvar)*2-1 ] <- paste(sep="", format(round(coeftab[,"Estimate"],digits = digits)), format_chkp( coeftab[,"Pr(>|t|)"] )  )
    # 5. insert SE in parentheses
    # NOTE: round to operate data, format to make the operated data print in uniform digits (the same as the digits in round())
    dfstr[[yname]][ (1:kvar)*2 ] <- paste(sep="","(",format(round(coeftab[,"Std. Error"],digits = digits)),")" )

    # 6. convert the list to a dataframe
    dfstr <- data.frame(dfstr)
    # 7. add Multiple R-squared to the last 2 rows
    lastrow <- list( Variable = c("R-squared", "Adjusted R-squared" )  )
    lastrow[[yname]] <- c(  format(round(summod$r.squared["rsq"],digits=digits)),
                            format(round(summod$r.squared["adjrsq"],digits=digits))
                        )
    lastrow <- data.frame(lastrow)
    dfstr <- rbind( dfstr, lastrow )

    return(dfstr)
}
# ---------------------------------------------
# NOTE: used on the summarized models estimated by nlme::gls()
format_gls <- function( summod, digits = 4, Yname = formula(summod)[[2]] ){
    # input:
    # 1. summod: a summarized plm model, estimated by plm::pggls (FGLS estimator)
    # output:
    # 1. dfstr: a formatted data.frame, values are transformatted to string (with significance marks, SE in parentheses etc)
    # ---------
    # 1. get sumamrized coefficient table
    coeftab <- summod$tTable
    kvar <- nrow(coeftab)  # number of variables
    # 2. construct col 1 (variable names)
    # NOTE: like: [var1; var1 ;var2; var2 ;var3; var3], because we put SEs under coefs+signifmarks, every variable requires two rows
    dfstr <- list(
        Variable = rep(rownames(coeftab), each=2)  # 1st col: variable names
    )
    # NOTE: decorate the rows of SE to distinguish from coef rows, to avoid duplicated rows in merging
    dfstr$Variable[ (1:kvar)*2 ] <- paste(sep="", dfstr$Variable[ (1:kvar)*2 ], "_SE" )
    # 3. use Y name as the title of the 2nd column
    # yname <- summod$formula[[2]]
    yname <- Yname
    dfstr[[ yname ]] <- 0
    # 4. insert coefficients + significant marks
    # NOTE: convert p-values to string marks (***,**,*)
    dfstr[[yname]][ (1:kvar)*2-1 ] <- paste(sep="", format(round(coeftab[,"Value"],digits = digits)), format_chkp( coeftab[,"p-value"] )  )
    # 5. insert SE in parentheses
    # NOTE: round to operate data, format to make the operated data print in uniform digits (the same as the digits in round())
    dfstr[[yname]][ (1:kvar)*2 ] <- paste(sep="","(",format(round(coeftab[,"Std.Error"],digits = digits)),")" )

    # 6. convert the list to a dataframe
    dfstr <- data.frame(dfstr)
    # 7. add Multiple R-squared to the last 2 rows
    lastrow <- list( Variable = c("AIC", "BIC" )  )
    lastrow[[yname]] <- c(  format(round(summod$AIC,digits=digits)),
                            format(round(summod$BIC,digits=digits))
    )
    lastrow <- data.frame(lastrow)
    dfstr <- rbind( dfstr, lastrow )

    return(dfstr)
}
# ---------------------------------------------
# NOTE: used on the summarized models estimated by lm(), OLS estimator
format_lm <- function( summod, digits = 4, Yname = formula(summod)[[2]] ){
    # input:
    # 1. summod: a summarized plm model, estimated by plm::pggls (FGLS estimator)
    # output:
    # 1. dfstr: a formatted data.frame, values are transformatted to string (with significance marks, SE in parentheses etc)
    # ---------
    # 1. get sumamrized coefficient table
    coeftab <- summod$coefficients
    kvar <- nrow(coeftab)  # number of variables
    # 2. construct col 1 (variable names)
    # NOTE: like: [var1; var1 ;var2; var2 ;var3; var3], because we put SEs under coefs+signifmarks, every variable requires two rows
    dfstr <- list(
        Variable = rep(rownames(coeftab), each=2)  # 1st col: variable names
    )
    # NOTE: decorate the rows of SE to distinguish from coef rows, to avoid duplicated rows in merging
    dfstr$Variable[ (1:kvar)*2 ] <- paste(sep="", dfstr$Variable[ (1:kvar)*2 ], "_SE" )
    # 3. use Y name as the title of the 2nd column
    # yname <- summod$formula[[2]]
    yname <- Yname
    dfstr[[ yname ]] <- 0
    # 4. insert coefficients + significant marks
    # NOTE: convert p-values to string marks (***,**,*)
    dfstr[[yname]][ (1:kvar)*2-1 ] <- paste(sep="", format(round(coeftab[,"Estimate"],digits = digits)), format_chkp( coeftab[,"Pr(>|t|)"] )  )
    # 5. insert SE in parentheses
    # NOTE: round to operate data, format to make the operated data print in uniform digits (the same as the digits in round())
    dfstr[[yname]][ (1:kvar)*2 ] <- paste(sep="","(",format(round(coeftab[,"Std. Error"],digits = digits)),")" )

    # 6. convert the list to a dataframe
    dfstr <- data.frame(dfstr)
    # 7. add Multiple R-squared to the last 2 rows
    lastrow <- list( Variable = c("R-squared", "Adjusted R-squared" )  )
    lastrow[[yname]] <- c(  format(round(summod$r.squared,digits=digits)),
                            format(round(summod$adj.r.squared,digits=digits))
    )
    lastrow <- data.frame(lastrow)
    dfstr <- rbind( dfstr, lastrow )

    return(dfstr)
}

#
# tmp1 <- summary(li_ModFix_NHSS$illnessratio)
# tmp2 <- summary(li_ModRan_NHSS$illnessratio)
# tmp3 <- summary(li_ModTwo_NHSS$illnessratio)
# tmp4 <- summary(li_ModPoolOLS_NHSS$illnessratio)
# tmp5 <- summary(li_ModPoolGLS_NHSS$illnessratio)
#
# tmp1$CoefTable
# tmp2$CoefTable
# tmp3$coefficients
# tmp4$coefficients
# tmp5$tTable
#
#
# summod <- tmp4


source("~/Documentos/2019A/paper_gen_decrement/analysis/r/wrapper.r")

path_read.general = "~/Documentos/2019A/paper_gen_decrement/Data/"
path_read.mif = path_read.general + "processed/mult_IF_acq"

subjects_vec = 326:333
colores = c('#8c8c8c', "#8F2727")

mif <- bp_fi_wrp(subjects_vec, 60,
                 rp_index=c(1,11),
                 path_read = path_read.mif)

mif$ctrial = 1

mif <- mif %>%
  group_by(sujeto,cde) %>%
  arrange(sesion) %>%
  mutate(cum_trial = cumsum(ctrial))

png('bp_mif_acq.png',
    res = 120, width = 600, height = 480)

par(mfrow = c(1, 2),
    mar = c(4,4,3,0.2))

scatter.smooth(mif$cum_trial[mif$cde == 1],
               mif$bp[mif$cde == 1],
               pch = '.', ylim = c(0, 65), cex = 2,
               col = colores[1], axes = F,
               panel.first = grid(),
               lpars = list(col = colores[2], lwd = 3, lty = 1),
               xlab = 'Trials', ylab = 'Breakpoint (s)')

title(main = 'Delayed')
axis(1, tck = -0.02)
axis(2, tck = -0.02)
scatter.smooth(mif$cum_trial[mif$cde == 2],
               mif$bp[mif$cde == 2],
               pch = '.', ylim = c(0, 65), cex = 2,
               panel.first = grid(),axes = F,
               lpars = list(col = 'black', lwd = 3, lty = 1),
               col = colores[2], ylab = '', xlab = '')
axis(1, tck = -0.02)
axis(2, tck = -0.02)
title(main = 'Immediate', xlab = 'Trials')
dev.off()

ses = unique(mif$sesion)
cdes = unique(mif$cde)

dF = data.frame()

for (ii in ses){

  dii = mif[mif$sesion == ii, ]

  for (iii in cdes) {
    diii = dii[dii$cde == iii, ]
    sumr = sum(length(diii$r2) > 0 & length(diii$r2 > 0))
    if( sumr > 0) {
      ratio = mean(diii$r2 / diii$r1)
      ratio = log10(ratio)
      dFtmp = data.frame(ses = ii, cde = iii, ratio = ratio)
    } else {
      dFtmp = data.frame()
    }

    dF = bind_rows(dF, dFtmp)
  }
}

dF = dF %>%
  arrange(ses) %>%
  as.data.frame()

cdes = c(1, 2)
colores = c('#8c8c8c', "#8F2727")

xmax = max(dF$ses)
ymax = max(dF$ratio)
ymin = min(dF$ratio)

png('ratio_r1r2_mifacq.png',
    res = 120)

plot(NA,NA, xlim = c(1, xmax), ylim = c(ymin, ymax), axes = F,
     xlab = 'Sessions', ylab = TeX('$\\log_{10}$ mean ratio'),
     panel.first = grid())

for (cdi in cdes) {
  if (cdi == 1){
    col = colores[1]
  } else {
    col = colores[2]
  }
  x = dF$ses[dF$cde == cdi]
  y = dF$ratio[dF$cde == cdi]
  points(x, y, pch = 21, bg = col)
  lines(x, y, col = col)
}

legend('topleft', legend = c('Delayed','Immediate'),
       col = colores, pch = c(16, 16), bty = 'n')
axis(1, tck = -0.02, seq(0, xmax, 5))
axis(2, tck = -0.02)
dev.off()
## qlife

qlife_mif <- qlife_wrp(subjects_vec, 60,
                       rp_index=c(1,11),
                       path_read = path_read.mif)

qlife_mif$ctrial = 1

qlife_mif <- qlife_mif %>%
  group_by(sujeto,cde) %>%
  arrange(sesion) %>%
  mutate(cum_trial = cumsum(ctrial))

png('qlife_mif_acq.png', res = 120,
    width = 666, height = 480)

par(mfrow = c(1, 2),
    mar = c(4,4,3,0.2))

scatter.smooth(qlife_mif$cum_trial[qlife_mif$cde == 1],
               qlife_mif$q25[qlife_mif$cde == 1],
               pch = '.', ylim = c(0, 65), cex = 2,
               col = colores[1], axes = F,
               panel.first = grid(),
               lpars = list(col = colores[2], lwd = 3, lty = 1),
               xlab = 'Trials', ylab = 'Quarter life (s)')

title(main = 'Delayed')
axis(1, tck = -0.02)
axis(2, tck = -0.02)
scatter.smooth(qlife_mif$cum_trial[qlife_mif$cde == 2],
               qlife_mif$q25[qlife_mif$cde == 2],
               pch = '.', ylim = c(0, 65), cex = 2,
               panel.first = grid(),axes = F,
               lpars = list(col = 'black', lwd = 3, lty = 1),
               col = colores[2], ylab = '', xlab = '')
axis(1, tck = -0.02)
axis(2, tck = -0.02)
title(main = 'Immediate', xlab = 'Trials')
dev.off()

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

quants = qlife_mif %>%
  group_by(cde, sesion) %>%
  summarise(q25 = mean(q25),
            q75 = mean(q75))

png('mean_qlife_ses.png', res = 120)

plot(quants$sesion[quants$cde == 1],
     quants$q25[quants$cde == 1],
     type = 'o', bg = colores[1],
     axes = F, xlab = 'Sessions',
     ylab = 'Quarter life (s)', cex = 0.8,
     panel.first = grid(), pch = 21)
points(quants$sesion[quants$cde == 2],
       quants$q25[quants$cde == 2], pch = 21,
       bg = colores[2], type = 'o')
axis(1, tck = -0.02)
axis(2, tck = -0.02)
legend('bottomright', legend = c('Delayed','Immediate'),
       col = colores, pch = c(16, 16), bty = 'n')
dev.off()

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

sigmoid = function(x, m, c, s){
  m / (1 + exp(-(x - c) / s))
}

resf = function(y, m, c, s, x) {
  y - m / (1 + exp(-(x - c) / s))
}

m = 2
c = 10
s = 2
x = seq(0, 100, 0.1)
eps = rnorm(length(x), 0, 0.4)

y = m / (1 + exp( -(x - c) / s )) + eps

nlss = nls(formula = y ~ m / (1 + exp( -(x - c) / s ) ),
           data = data.frame(x = x, y = y),
           start = list(m = 9.1, c = 5, s = 2),
           control = nls.control(maxiter = 500))

rsquared = function(y, res) {
  tss = (y - mean(y)) %*% (y - mean(y))
  rss = res %*% res
  1 - rss / tss
}

m = c(1, 1, 2, 2, 5, 5)
c = c(10, 10, 5, 5, 10, 10)
s = c(1, 4, 4, 2, 2, 1)
x = seq(0, 100, 0.1)
y0 = sigmoid(x, m[1], c[1], s[1])

png('r2_nls_sig_demo.png',
    res = 120,
    width = 780, height = 620)

par(mfrow = c(2, 3),
    mgp = c(1.5, 0.5, 0),
    mar = c(4,4,3.5,0.2))

for (i in 1:length(m)) {
  y = sigmoid(x, m[i], x[i], s[i]) + eps

  nlss = nls(formula = y ~ m / (1 + exp( -(x - c) / s ) ),
             data = data.frame(x = x, y = y),
             start = list(m = 9.1, c = 5, s = 2),
             control = nls.control(maxiter = 500))
  r2 = rsquared(y, residuals(nlss))

  plot(x, y, type = 'l', ylim = c(0, 6), axes = F,
       xlab = 'x', ylab = 'f(x)', col = 'grey60')
  lines(x, fitted(nlss), col = colores[2], lwd = 2)
  title(main = sprintf('R^2 = %0.2f, m = %d, \n c = %d, s = %s
                       ', r2, m[i], c[i], s[i]))
  axis(1, tck = -0.02)
  axis(2, tck = -0.02)
}
dev.off()

# exponencial

exp_learn = function(x, k, R){
  k * (1 - exp(- x / R))
}

x = seq(0, 100, 0.1)
k = 5
R = 10
y = exp_learn(x, k, R) + eps

plot(x,y)

# A test

k = c(2, 2, 5, 5, 10, 10)
R = c(5, 10, 5, 10, 5, 10)

png('r2_nls_exp_demo.png',
    res = 120,
    width = 780, height = 620)

par(mfrow = c(2, 3),
    mgp = c(1.5, 0.5, 0),
    mar = c(4,4,3.5,0.2))

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

  y = exp_learn(x, k[i], R[i]) + eps

  nlss = nlsLM(formula = y ~ k * (1 - exp(- x / R)),
               data = data.frame(x = x, y = y),
               start = list(k = k[i] * 0.6, R = R[i] * 0.7),
               control = nls.lm.control(maxiter = 500))

  r2 = rsquared(y, residuals(nlss))
  plot(x, y, type = 'l', ylim = c(0, 11), axes = F,
       xlab = 'x', ylab = 'f(x)', col = 'grey60')
  lines(x, fitted(nlss), col = colores[2], lwd = 2)
  title(main = sprintf('R^2 = %0.2f, k = %d, \n R = %d', r2, k[i], R[i]))
  axis(1, tck = -0.02)
  axis(2, tck = -0.02)
}

dev.off()

hyp_learn = function(x, k, R) {
  k * ( x / ( x + R ) )
}

x = seq(0, 100, 0.1)
k = 5
R = 10
y = hyp_learn(x, k, R) + eps

plot(x,y)

# A test

k = c(2, 2, 5, 5, 10, 10)
R = c(5, 10, 5, 10, 5, 10)

png('r2_nls_hyp_demo.png',
    res = 120,
    width = 780, height = 620)

par(mfrow = c(2, 3),
    mgp = c(1.5, 0.5, 0),
    mar = c(4,4,3.5,0.2))

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

  y = hyp_learn(x, k[i], R[i]) + eps

  nlss = nlsLM(formula = y ~ k * ( x / ( x + R ) ),
               data = data.frame(x = x, y = y),
               start = list(k = k[i] * 0.6, R = R[i] * 0.7),
               control = nls.lm.control(maxiter = 500))

  r2 = rsquared(y, residuals(nlss))
  plot(x, y, type = 'l', ylim = c(0, 11), axes = F,
       xlab = 'x', ylab = 'f(x)', col = 'grey60')
  lines(x, fitted(nlss), col = colores[2], lwd = 2)
  title(main = sprintf('R^2 = %0.2f, k = %d, \n R = %d', r2, k[i], R[i]))
  axis(1, tck = -0.02)
  axis(2, tck = -0.02)
}

dev.off()

# Using mean ratio

e1 = nlsLM(y ~ k * (1 - exp( - x / R)),
           data = data.frame(x = dF$ses[dF$cde == 1],
                             y = dF$ratio[dF$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.lm.control(maxiter = 500))

s1 = nlsLM(formula = y ~ m / (1 + exp( -(x - c) / s ) ),
           data = data.frame(x = dF$ses[dF$cde == 1],
                             y = dF$ratio[dF$cde == 1]),
           start = list(m = 9.1, c = 5, s = 2),
           control = nls.control(maxiter = 500))

h1 = nlsLM(formula = y ~ k * ( x / ( x + R ) ),
           data = data.frame(x = dF$ses[dF$cde == 1],
                             y = dF$ratio[dF$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.control(maxiter = 500))

library(MuMIn)

model.sel(e1, s1, h1)

# Using BP

e1 = nlsLM(y ~ k * (1 - exp( - x / R)),
           data = data.frame(x = mif$sesion[mif$cde == 1],
                             y = mif$bp[mif$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.lm.control(maxiter = 500))

s1 = nlsLM(formula = y ~ m / (1 + exp( -(x - c) / s ) ),
           data = data.frame(x = mif$sesion[mif$cde == 1],
                             y = mif$bp[mif$cde == 1]),
           start = list(m = 9.1, c = 5, s = 2),
           control = nls.control(maxiter = 500))

h1 = nlsLM(formula = y ~ k * ( x / ( x + R ) ),
           data = data.frame(x = mif$sesion[mif$cde == 1],
                             y = mif$bp[mif$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.control(maxiter = 500))

model.sel(e1, s1, h1)

# Using quarter life

e1 = nlsLM(y ~ k * (1 - exp( - x / R)),
           data = data.frame(x = quants$sesion[quants$cde == 1],
                             y = quants$q25[quants$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.lm.control(maxiter = 500))

s1 = nlsLM(formula = y ~ m / (1 + exp( -(x - c) / s ) ),
           data = data.frame(x = quants$sesion[quants$cde == 1],
                             y = quants$q25[quants$cde == 1]),
           start = list(m = 9.1, c = 5, s = 2),
           control = nls.control(maxiter = 500))

h1 = nlsLM(formula = y ~ k * ( x / ( x + R ) ),
           data = data.frame(x = quants$sesion[quants$cde == 1],
                             y = quants$q25[quants$cde == 1]),
           start = list(k = 5, R = 4),
           control = nls.control(maxiter = 500))

model.sel(e1, s1, h1)
AICc(e1, s1, h1)


# Run a test of aggregated vs individual. Aggregate the data, run the model, load the individual results and take the ratio
# Initial setup
#attach("C:/Users/simonh/Documents/I/Pop dy modeling/MFCL/R functions/R4MFCL.RData",pos=2)
#load("C:/Users/simonh/Documents/L/yft/2009/Data Preparation/CPUE/compare_methods/operat.RData")
require(R4MFCL)
#subset
a <- sample(1:nrow(llop),size=floor(0.4*nrow(llop)))
op <- llop[a,]
# rename fields
a <- match(c("bet_n","yft_n","latlong5","hook","boat_id"),names(op))
colnames(op)[a] <-  c("bet","yft","latlong","hooks","vessid")
# Test with SPC-held data
#- load SPC data
# map the data
library(maps)
library(mapproj)
library(mapdata)
plot.pacific.species(eez_file="C:/Users/simonh/Documents/I/Pop dy modeling/MFCL/R functions/EZNEW2.TXT")
points(op$lond,op$latd,cex=0.5)

#- aggregate SPC data

# Now with JPLL data
setwd("D:/SimonHOYLE2011/weight_methods/")

a <- tapply(op$bet!=0,list(op$yrqtr,op$reg,op$newfishingcat),mean)
write.csv(a,file="BET_pos_catches.csv")
a <- tapply(op$yft!=0,list(op$yrqtr,op$reg,op$newfishingcat),mean)
write.csv(a,file="YFT_pos_catches.csv")
a <- tapply(op$bet!=0,list(op$yrqtr,op$reg,op$newfishingcat),length)
write.csv(a,file="BET_ncatches.csv")
a <- tapply(op$yft!=0,list(op$yrqtr,op$reg,op$newfishingcat),length)
write.csv(a,file="YFT_ncatches.csv")

# test sampling and its effect on results
table(op$yrqtr,useNA="always")
mt <- "logn"
glmdat <- select_data(op,runreg=3,runsp="bet",mt,minqtrs,maxqtrs,addmain,addother=addother,fc="OS")
n <- make_strat(glmdat)
d10 <- samp_data(glmdat,n,10)
d20 <- samp_data(glmdat,n,20)
d30 <- samp_data(glmdat,n,30)
d50 <- samp_data(glmdat,n,50)
d10.wts <- mk_wts(d10,wttype="area")
d20.wts <- mk_wts(d20,wttype="area")
d30.wts <- mk_wts(d30,wttype="area")
d50.wts <- mk_wts(d50,wttype="area")
fmla.boat <- make_formula(runsp="bet",mt,addboat=T,splitboat=F,addmain=addmain,addbranch=addbranch)
model.opboat.d10  <- glm(fmla.boat,data=d10,weights=d10.wts);gc()
model.opboat.d20  <- glm(fmla.boat,data=d20,weights=d20.wts);gc()
model.opboat.d30  <- glm(fmla.boat,data=d30,weights=d30.wts);gc()
model.opboat.d50  <- glm(fmla.boat,data=d50,weights=d50.wts);gc()
dyr <- sort(unique(d50$yrqtr))
a <- length(unique(d10$yrqtr))
coefs.d10 <- get.coefs(model.opboat.d10,a)
a <- length(unique(d20$yrqtr))
coefs.d20 <- get.coefs(model.opboat.d20,a)
a <- length(unique(d30$yrqtr))
coefs.d30 <- get.coefs(model.opboat.d30,a)
a <- length(unique(d50$yrqtr))
coefs.d50 <- get.coefs(model.opboat.d50,a)
plot.agg.slope.ratio(coefs.d10,coefs.d50,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d10 vs d50"),lab1="d10",lab2="d50",fname="Compare subsampling")  # plot results
plot.agg.slope.ratio(coefs.d20,coefs.d50,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d20 vs d50"),lab1="d20",lab2="d50",fname="Compare subsampling")  # plot results
plot.agg.slope.ratio(coefs.d30,coefs.d50,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d30 vs d50"),lab1="d30",lab2="d50",fname="Compare subsampling")  # plot results
rm(model.opboat.d20,model.opboat.d30,model.opboat.d10,model.opboat.d50); gc()

mt <- "qp"
glmdat <- select_data(op,runreg=3,runsp="bet",mt,minqtrs,maxqtrs,addmain,addother=addother,fc="OS")
n <- make_strat(glmdat)
d10 <- samp_data(glmdat,n,10)
d20 <- samp_data(glmdat,n,20)
d30 <- samp_data(glmdat,n,30)
d50 <- samp_data(glmdat,n,50)
d10.wts <- mk_wts(d10,wttype="area")
d20.wts <- mk_wts(d20,wttype="area")
d30.wts <- mk_wts(d30,wttype="area")
d50.wts <- mk_wts(d50,wttype="area")
fmla.boat <- make_formula(runsp="bet",modtype="qp",addboat=T,splitboat=F,addmain=addmain,addbranch=addbranch)
model.opboat.d10.qp  <- glm(fmla.boat,data=d10,weights=d10.wts,family=quasipoisson);gc()
model.opboat.d20.qp  <- glm(fmla.boat,data=d20,weights=d20.wts,family=quasipoisson);gc()
model.opboat.d30.qp  <- glm(fmla.boat,data=d30,weights=d30.wts,family=quasipoisson);gc()
model.opboat.d50.qp  <- glm(fmla.boat,data=d50,weights=d50.wts,family=quasipoisson);gc()
a <- length(unique(d10$yrqtr))
coefs.d10.qp <- get.coefs(model.opboat.d10.qp,a)
a <- length(unique(d20$yrqtr))
coefs.d20.qp <- get.coefs(model.opboat.d20.qp,a)
a <- length(unique(d30$yrqtr))
coefs.d30.qp <- get.coefs(model.opboat.d30.qp,a)
a <- length(unique(d50$yrqtr))
coefs.d50.qp <- get.coefs(model.opboat.d50.qp,a)
plot.agg.slope.ratio(coefs.d10.qp,coefs.d50.qp,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d10 vs d50 qp"),lab1="d10",lab2="d50",fname="Compare subsampling qp")  # plot results
plot.agg.slope.ratio(coefs.d20.qp,coefs.d50.qp,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d20 vs d50 qp"),lab1="d20",lab2="d50",fname="Compare subsampling qp")  # plot results
plot.agg.slope.ratio(coefs.d30.qp,coefs.d50.qp,dyr,dyr, titl=paste("Region",runreg,fishlab,methlab,"d30 vs d50 qp"),lab1="d30",lab2="d50",fname="Compare subsampling qp")  # plot results
save(file="Compare weighting qp.RData","model.opboat.d10.qp","model.opboat.d20.qp","model.opboat.d30.qp","model.opboat.d50.qp")
rm("model.opboat.d10.qp","model.opboat.d20.qp","model.opboat.d30.qp","model.opboat.d50.qp"); gc()

# rerun_with_delta_lognormal_no_swo
attach("D:/SimonHOYLE2010/Rfiles/R4mfcl 2010_04_15/R4MFCL.RData",pos=2)
setwd("D:/SimonHOYLE2011/")
source("./Rfiles/support_functions.r")
require(splines)
require(boot)
load("op.RData")
setwd("D:/SimonHOYLE2011/weight_methods_delta")
minqtrs=2; maxqtrs=200; runreg <- 2;addmain<-F; addbranch<-F;addother=F;addalb=F;fc="both";runsp="bet";fc="OS"
#maxqtrs=200; minqtrs_byreg = c(2,2,8,8,2,2,2,8,2)
maxqtrs=200; minqtrs_byreg = c(2,2,2,2,2,2,2,2,2)
for(runreg in c(2:5,9,1,6)) {
#for(runreg in c(9,1,6)) {
#for(runreg in c(6)) {
  for(fc in c("OS","DW"))
#  for(fc in c("DW"))
    {
    for(runsp in c("bet","yft"))
      {
      minqtrs <- minqtrs_byreg[runreg]
      glmdat.bin <- select_data(op,runreg,runsp,mt="deltabin",minqtrs,maxqtrs,fc=fc)
      if(nrow(glmdat.bin)>250000) {
        n <- make_strat(glmdat.bin)
        glmdat.bin <- samp_data(glmdat.bin,n,50)
        }
      glmdat.pos <- glmdat.bin[glmdat.bin[,3]>0,]
      aggdat <- aggregate_data(glmdat.bin,sp=runsp)
      wtt.agg.equal <- mk_wts(aggdat,wttype="equal")
      wtt.agg.area  <- mk_wts(aggdat,wttype="area")
      wtt.opbin.equal  <- mk_wts(glmdat.bin,wttype="equal")
      wtt.opbin.area   <- mk_wts(glmdat.bin,wttype="area")
      wtt.oppos.equal  <- mk_wts(glmdat.pos,wttype="equal")
      wtt.oppos.area   <- mk_wts(glmdat.pos,wttype="area")
      fname <- paste("Compare weightings ",runsp,"_R",runreg,"eq ",minqtrs,"-",maxqtrs,"_qtrs ",fc,sep="")
      fmla.agg <- make_formula(runsp,modtype="logn",addboat=F)
      fmla.opbin <- make_formula(runsp,modtype="deltabin",addboat=F)
      fmla.oppos <- make_formula(runsp,modtype="deltapos",addboat=F)
      fmla.oplogn <- make_formula(runsp,modtype="logn",addboat=F)
      fmla.boatbin <- make_formula(runsp,modtype="deltabin",addboat=T)
      fmla.boatpos <- make_formula(runsp,modtype="deltapos",addboat=T)
      fmla.boatlogn <- make_formula(runsp,modtype="logn",addboat=T)
      model.agg.equal <- glm(fmla.agg,data=aggdat,weights=wtt.agg.equal);gc()
      a <- length(unique(aggdat$yrqtr))
      coefs.agg.equal <- get.coefs(model.agg.equal,a)
      save(file=paste(fname," model.agg.equal.RData",sep=""),model.agg.equal);rm(model.agg.equal);gc()
      model.agg.area  <- glm(fmla.agg,data=aggdat,weights=wtt.agg.area);gc()
      coefs.agg.area <- get.coefs(model.agg.area,a)
      save(file=paste(fname," model.agg.area.RData",sep=""),model.agg.area);rm(model.agg.area);gc()
      model.opbin.equal  <- glm(fmla.opbin,data=glmdat.bin,family="binomial");gc()
      abin <- length(unique(glmdat.bin$yrqtr))
      coefs.opbin.equal <- get.bin.coefs(model.opbin.equal,abin,glmdat.bin)
      save(file=paste(fname," model.opbin.equal.RData",sep=""),model.opbin.equal);rm(model.opbin.equal);gc()
      model.oppos.equal  <- glm(fmla.oppos,data=glmdat.pos,weights=wtt.oppos.equal,family="gaussian");gc()
      apos <- length(unique(glmdat.pos$yrqtr))
      coefs.oppos.equal <- get.coefs(model.oppos.equal,apos)
      save(file=paste(fname," model.oppos.equal.RData",sep=""),model.oppos.equal);rm(model.oppos.equal);gc()
#      model.opbin.area   <- glm(fmla.opbin,data=glmdat.bin,weights=wtt.opbin.area,family="binomial");gc()
#      coefs.opbin.area <- get.coefs(model.opbin.area,abin)
#      save(file=paste(fname," model.opbin.area.RData",sep=""),model.opbin.area);rm(model.opbin.area);gc()
      model.oppos.area   <- glm(fmla.oppos,data=glmdat.pos,weights=wtt.oppos.area,family="gaussian");gc()
      coefs.oppos.area <- get.coefs(model.oppos.area,apos)
      save(file=paste(fname," model.oppos.area.RData",sep=""),model.oppos.area);rm(model.oppos.area);gc()
      model.oplogn.area   <- glm(fmla.oplogn,data=glmdat.bin,weights=wtt.opbin.area,family="gaussian");gc()
      coefs.oplogn.area <- get.coefs(model.oplogn.area,abin)
      save(file=paste(fname," model.oplogn.area.RData",sep=""),model.oplogn.area);rm(model.oplogn.area);gc()
      model.opboatbin.equal  <- glm(fmla.boatbin,data=glmdat.bin,weights=wtt.opbin.equal,family="binomial");gc()
      coefs.opboatbin.equal <- get.bin.coefs(model.opboatbin.equal,abin,glmdat.bin)
      plot_effects(model.opboatbin.equal,indat=glmdat.bin); savePlot(paste(fname,"bin_effects.png",sep=""),type="png")
      save(file=paste(fname," model.opboatbin.equal.RData",sep=""),model.opboatbin.equal);rm(model.opboatbin.equal);gc()
      model.opboatpos.equal  <- glm(fmla.boatpos,data=glmdat.pos,weights=wtt.oppos.equal,family="gaussian");gc()
      coefs.opboatpos.equal <- get.coefs(model.opboatpos.equal,apos)
      save(file=paste(fname," model.opboatpos.equal.RData",sep=""),model.opboatpos.equal);rm(model.opboatpos.equal);gc()
#      model.opboatbin.area   <- glm(fmla.boatbin,data=glmdat.bin,weights=wtt.opbin.area,family="binomial");gc()
#      coefs.opboatbin.area <- get.coefs(model.opboatbin.area,abin)
#      plot_effects(model.opboatbin.area,indat=glmdat.bin); savePlot(paste(fname,"bin_effects.png",sep=""),type="png")
#      save(file=paste(fname," model.opboatbin.area.RData",sep=""),model.opboatbin.area);rm(model.opboatbin.area);gc()
      model.opboatpos.area   <- glm(fmla.boatpos,data=glmdat.pos,weights=wtt.oppos.area,family="gaussian");gc()
      coefs.opboatpos.area <- get.coefs(model.opboatpos.area,apos)
      windows(); par(mfrow=c(2,1),mar=c(4,4,3,1))                           # plot diagnostics
      plotdiags(model.opboatpos.area$residuals,ti="Model including vessel")
      savePlot(paste(fname,"_diags.png",sep=""),type="png")
      plot_effects(model.opboatpos.area,indat=glmdat.pos); savePlot(paste(fname,"pos_effects.png",sep=""),type="png")
      save(file=paste(fname," model.opboatpos.area.RData",sep=""),model.opboatpos.area);rm(model.opboatpos.area);gc()
      model.opboatlogn.area   <- glm(fmla.boatlogn,data=glmdat.bin,weights=wtt.opbin.area,family="gaussian");gc()
      coefs.opboatlogn.area <- get.coefs(model.opboatlogn.area,abin)
      windows(); par(mfrow=c(2,1),mar=c(4,4,3,1))                           # plot diagnostics
      plotdiags(model.opboatlogn.area$residuals,ti="Model including vessel")
      savePlot(paste(fname,"_diags_logn.png",sep=""),type="png")
      plot_effects(model.opboatlogn.area,indat=glmdat.bin); savePlot(paste(fname,"logn_effects_.png",sep=""),type="png")
      save(file=paste(fname," model.opboatlogn.area.RData",sep=""),model.opboatlogn.area);rm(model.opboatlogn.area);gc()

      aggyr <- sort(unique(aggdat$yrqtr))
      opyr <- sort(unique(glmdat.pos$yrqtr))
      myr <- aggyr[match(opyr,aggyr)]
      coefs2.agg.equal <- coefs.agg.equal[match(opyr,aggyr)]
      coefs2.agg.area <- coefs.agg.area[match(opyr,aggyr)]
      fishlab <- switch(runsp,yft="Yellowfin",bet="Bigeye"); methlab <- switch(mt,deltabin="Delta-binomial",deltapos="Delta-positive",logl="Lognormal(+0.5)")
      a <- match(names(coefs.oppos.equal),names(coefs.opbin.equal))             # make op.equal indices
      coefs.op.equal <- coefs.opbin.equal[a] * coefs.oppos.equal
#      a <- match(names(coefs.oppos.area),names(coefs.opbin.area))             # make op.area indices
#      coefs.op.area <- coefs.opbin.area[a] * coefs.oppos.area
      a <- match(names(coefs.oppos.area),names(coefs.opbin.equal))             # make op.area indices
      coefs.op.area2 <- coefs.opbin.equal[a] * coefs.oppos.area
      a <- match(names(coefs.opboatpos.equal),names(coefs.opboatbin.equal))             # make opboat.equal indices
      coefs.opboat.equal <- coefs.opboatbin.equal[a] * coefs.opboatpos.equal
#      a <- match(names(coefs.opboatpos.area),names(coefs.opboatbin.area))             # make opboat.area indices
#      coefs.opboat.area <- coefs.opboatbin.area[a] * coefs.opboatpos.area
      a <- match(names(coefs.opboatpos.area),names(coefs.opboatbin.equal))             # make opboat.area indices
      coefs.opboat.area2 <- coefs.opboatbin.equal[a] * coefs.opboatpos.area
      save(file=paste(fname,"indices.RData",sep=""),list=ls(pattern="coefs."))

      plot.agg.slope.ratio(coefs.agg.equal,coefs.agg.area,aggyr,aggyr, titl=paste("Region",runreg,fishlab,fc,"agg equal vs agg area"),lab1="agg equal",lab2="agg area",fname)  # plot results
      plot.agg.slope.ratio(coefs.op.equal,  coefs.op.area2,  opyr, opyr,  titl=paste("Region",runreg,fishlab,fc,"op equal vs op area2 d_logn"),lab1="op equal",lab2="op area2",fname)  # plot results
      plot.agg.slope.ratio(coefs.agg.equal,coefs.op.equal,opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs op equal d_logn"),lab1="agg equal",lab2="op equal",fname)  # plot results
      plot.agg.slope.ratio(coefs.agg.area, coefs.op.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs op area2 d_logn"),  lab1="agg area", lab2="op area2",fname)  # plot results
      plot.agg.slope.ratio(coefs.agg.equal,coefs.opboat.equal,aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat equal d_logn"),lab1="agg equal",lab2="opboat equal",fname)  # plot results
      plot.agg.slope.ratio(coefs.agg.area, coefs.opboat.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs opboat area2 d_logn"),  lab1="agg area", lab2="opboat area2",fname)  # plot results
      plot.agg.slope.ratio(coefs.op.equal,coefs.opboat.equal,opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op equal vs opboat equal d_logn"),lab1="op equal",lab2="opboat equal",fname)  # plot results
      plot.agg.slope.ratio(coefs.op.area2, coefs.opboat.area2, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op area vs opboat area2 d_logn"),  lab1="op area", lab2="opboat area2",fname)  # plot results
      plot.agg.slope.ratio(coefs.opboat.equal, coefs.opboat.area2, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"opboat equal vs opboat area2 d_logn"),  lab1="opboat equal", lab2="opboat area2",fname)  # plot results
      plot.agg.slope.ratio(coefs.agg.equal, coefs.opboat.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat area2 d_logn"),  lab1="agg equal", lab2="opboat area2",fname)  # plot results
#      plot.agg.slope.ratio(coefs.op.area2, coefs.opboatlogn.area, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op area2 vs opboatlogn area d_logn"),  lab1="op area2", lab2="opboatlogn area",fname)  # plot results
#      plot.agg.slope.ratio(coefs.opboat.area2, coefs.opboatlogn.area, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"opboat area2 vs opboatlogn area d_logn"),  lab1="opboat area2", lab2="opboatlogn area",fname)  # plot results
      rm(list=ls(pattern="coefs."))
      graphics.off()
     }
    }
  }

attach("D:/SimonHOYLE2010/Rfiles/R4mfcl 2010_04_15/R4MFCL.RData",pos=2)
setwd("D:/SimonHOYLE2011/")
source("./Rfiles/support_functions.r")
require(splines)
require(boot)
load("op.RData")
setwd("D:/SimonHOYLE2011/weight_methods_delta_allbait")
minqtrs=2; maxqtrs=200; runreg <- 2;addmain<-F; addbranch<-F;addother=F;addalb=F;fc="both";runsp="bet";fc="OS"
maxqtrs=200; minqtrs_byreg = c(2,2,2,2,2,2,2,2,2)
for(runreg in c(2:5,9,1,6)) {
  for(fc in c("OS","DW"))
    {
    if(runreg!=6 | fc == "DW") {
      for(runsp in c("bet","yft"))
        {
        minqtrs <- minqtrs_byreg[runreg]
        glmdat.bin <- select_data(op,runreg,runsp,mt="deltabin",minqtrs,maxqtrs,fc=fc,bait="allbait")
        if(nrow(glmdat.bin)>2000) {
          n <- make_strat(glmdat.bin)
          glmdat.bin <- samp_data(glmdat.bin,n,2)
          }
        glmdat.pos <- glmdat.bin[glmdat.bin[,3]>0,]
        aggdat <- aggregate_data(glmdat.bin,sp=runsp)
        wtt.agg.equal <- mk_wts(aggdat,wttype="equal")
        wtt.agg.area  <- mk_wts(aggdat,wttype="area")
        wtt.opbin.equal  <- mk_wts(glmdat.bin,wttype="equal")
        wtt.opbin.area   <- mk_wts(glmdat.bin,wttype="area")
        wtt.oppos.equal  <- mk_wts(glmdat.pos,wttype="equal")
        wtt.oppos.area   <- mk_wts(glmdat.pos,wttype="area")
        fname <- paste("Compare weightings ",runsp,"_R",runreg,"eq ",minqtrs,"-",maxqtrs,"_qtrs ",fc,"_allbait",sep="")
        fmla.agg <- make_formula(runsp,modtype="logn",addboat=F)
        fmla.opbin <- make_formula(runsp,modtype="deltabin",addboat=F)
        fmla.oppos <- make_formula(runsp,modtype="deltapos",addboat=F)
        fmla.oplogn <- make_formula(runsp,modtype="logn",addboat=F)
        fmla.boatbin <- make_formula(runsp,modtype="deltabin",addboat=T)
        fmla.boatpos <- make_formula(runsp,modtype="deltapos",addboat=T)
        fmla.boatlogn <- make_formula(runsp,modtype="logn",addboat=T)
        model.agg.equal <- glm(fmla.agg,data=aggdat,weights=wtt.agg.equal);gc()
        a <- length(unique(aggdat$yrqtr))
        coefs.agg.equal <- get.coefs(model.agg.equal,a)
        save(file=paste(fname," model.agg.equal.RData",sep=""),model.agg.equal);rm(model.agg.equal);gc()
        model.agg.area  <- glm(fmla.agg,data=aggdat,weights=wtt.agg.area);gc()
        coefs.agg.area <- get.coefs(model.agg.area,a)
        save(file=paste(fname," model.agg.area.RData",sep=""),model.agg.area);rm(model.agg.area);gc()
        model.opbin.equal  <- glm(fmla.opbin,data=glmdat.bin,family="binomial");gc()
        abin <- length(unique(glmdat.bin$yrqtr))
        coefs.opbin.equal <- get.bin.coefs(model.opbin.equal,abin,glmdat.bin)
        save(file=paste(fname," model.opbin.equal.RData",sep=""),model.opbin.equal);rm(model.opbin.equal);gc()
        model.oppos.equal  <- glm(fmla.oppos,data=glmdat.pos,weights=wtt.oppos.equal,family="gaussian");gc()
        apos <- length(unique(glmdat.pos$yrqtr))
        coefs.oppos.equal <- get.coefs(model.oppos.equal,apos)
        save(file=paste(fname," model.oppos.equal.RData",sep=""),model.oppos.equal);rm(model.oppos.equal);gc()
        model.oppos.area   <- glm(fmla.oppos,data=glmdat.pos,weights=wtt.oppos.area,family="gaussian");gc()
        coefs.oppos.area <- get.coefs(model.oppos.area,apos)
        save(file=paste(fname," model.oppos.area.RData",sep=""),model.oppos.area);rm(model.oppos.area);gc()
        model.oplogn.area   <- glm(fmla.oplogn,data=glmdat.bin,weights=wtt.opbin.area,family="gaussian");gc()
        coefs.oplogn.area <- get.coefs(model.oplogn.area,abin)
        save(file=paste(fname," model.oplogn.area.RData",sep=""),model.oplogn.area);rm(model.oplogn.area);gc()
        model.opboatbin.equal  <- glm(fmla.boatbin,data=glmdat.bin,weights=wtt.opbin.equal,family="binomial");gc()
        coefs.opboatbin.equal <- get.bin.coefs(model.opboatbin.equal,abin,glmdat.bin)
        plot_effects(model.opboatbin.equal,indat=glmdat.bin); savePlot(paste(fname,"bin_effects.png",sep=""),type="png")
        save(file=paste(fname," model.opboatbin.equal.RData",sep=""),model.opboatbin.equal);rm(model.opboatbin.equal);gc()
        model.opboatpos.equal  <- glm(fmla.boatpos,data=glmdat.pos,weights=wtt.oppos.equal,family="gaussian");gc()
        coefs.opboatpos.equal <- get.coefs(model.opboatpos.equal,apos)
        save(file=paste(fname," model.opboatpos.equal.RData",sep=""),model.opboatpos.equal);rm(model.opboatpos.equal);gc()
        model.opboatpos.area   <- glm(fmla.boatpos,data=glmdat.pos,weights=wtt.oppos.area,family="gaussian");gc()
        coefs.opboatpos.area <- get.coefs(model.opboatpos.area,apos)
        windows(); par(mfrow=c(2,1),mar=c(4,4,3,1))                           # plot diagnostics
        plotdiags(model.opboatpos.area$residuals,ti="Model including vessel")
        savePlot(paste(fname,"_diags.png",sep=""),type="png")
        plot_effects(model.opboatpos.area,indat=glmdat.pos); savePlot(paste(fname,"pos_effects.png",sep=""),type="png")
        save(file=paste(fname," model.opboatpos.area.RData",sep=""),model.opboatpos.area);rm(model.opboatpos.area);gc()
        model.opboatlogn.area   <- glm(fmla.boatlogn,data=glmdat.bin,weights=wtt.opbin.area,family="gaussian");gc()
        coefs.opboatlogn.area <- get.coefs(model.opboatlogn.area,abin)
        windows(); par(mfrow=c(2,1),mar=c(4,4,3,1))                           # plot diagnostics
        plotdiags(model.opboatlogn.area$residuals,ti="Model including vessel")
        savePlot(paste(fname,"_diags_logn.png",sep=""),type="png")
        plot_effects(model.opboatlogn.area,indat=glmdat.bin); savePlot(paste(fname,"logn_effects_.png",sep=""),type="png")
        save(file=paste(fname," model.opboatlogn.area.RData",sep=""),model.opboatlogn.area);rm(model.opboatlogn.area);gc()

        aggyr <- sort(unique(aggdat$yrqtr))
        opyr <- sort(unique(glmdat.pos$yrqtr))
        myr <- aggyr[match(opyr,aggyr)]
        coefs2.agg.equal <- coefs.agg.equal[match(opyr,aggyr)]
        coefs2.agg.area <- coefs.agg.area[match(opyr,aggyr)]
        fishlab <- switch(runsp,yft="Yellowfin",bet="Bigeye"); methlab <- switch(mt,deltabin="Delta-binomial",deltapos="Delta-positive",logl="Lognormal(+0.5)")
        a <- match(names(coefs.oppos.equal),names(coefs.opbin.equal))             # make op.equal indices
        coefs.op.equal <- coefs.opbin.equal[a] * coefs.oppos.equal
        a <- match(names(coefs.oppos.area),names(coefs.opbin.equal))             # make op.area indices
        coefs.op.area2 <- coefs.opbin.equal[a] * coefs.oppos.area
        a <- match(names(coefs.opboatpos.equal),names(coefs.opboatbin.equal))             # make opboat.equal indices
        coefs.opboat.equal <- coefs.opboatbin.equal[a] * coefs.opboatpos.equal
        a <- match(names(coefs.opboatpos.area),names(coefs.opboatbin.equal))             # make opboat.area indices
        coefs.opboat.area2 <- coefs.opboatbin.equal[a] * coefs.opboatpos.area
        save(file=paste(fname,"indices.RData",sep=""),list=ls(pattern="coefs."))

        plot.agg.slope.ratio(coefs.agg.equal,coefs.agg.area,aggyr,aggyr, titl=paste("Region",runreg,fishlab,fc,"agg equal vs agg area"),lab1="agg equal",lab2="agg area",fname)  # plot results
        plot.agg.slope.ratio(coefs.op.equal,  coefs.op.area2,  opyr, opyr,  titl=paste("Region",runreg,fishlab,fc,"op equal vs op area2 d_logn"),lab1="op equal",lab2="op area2",fname)  # plot results
        plot.agg.slope.ratio(coefs.agg.equal,coefs.op.equal,opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs op equal d_logn"),lab1="agg equal",lab2="op equal",fname)  # plot results
        plot.agg.slope.ratio(coefs.agg.area, coefs.op.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs op area2 d_logn"),  lab1="agg area", lab2="op area2",fname)  # plot results
        plot.agg.slope.ratio(coefs.agg.equal,coefs.opboat.equal,aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat equal d_logn"),lab1="agg equal",lab2="opboat equal",fname)  # plot results
        plot.agg.slope.ratio(coefs.agg.area, coefs.opboat.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs opboat area2 d_logn"),  lab1="agg area", lab2="opboat area2",fname)  # plot results
        plot.agg.slope.ratio(coefs.op.equal,coefs.opboat.equal,opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op equal vs opboat equal d_logn"),lab1="op equal",lab2="opboat equal",fname)  # plot results
        plot.agg.slope.ratio(coefs.op.area2, coefs.opboat.area2, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op area vs opboat area2 d_logn"),  lab1="op area", lab2="opboat area2",fname)  # plot results
        plot.agg.slope.ratio(coefs.opboat.equal, coefs.opboat.area2, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"opboat equal vs opboat area2 d_logn"),  lab1="opboat equal", lab2="opboat area2",fname)  # plot results
        plot.agg.slope.ratio(coefs.agg.equal, coefs.opboat.area2, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat area2 d_logn"),  lab1="agg equal", lab2="opboat area2",fname)  # plot results
        rm(list=ls(pattern="coefs."))
        graphics.off()
        }
      }
    }
  }

# Rerun quasipoisson with SWO targeting removed (two methods)
attach("D:/SimonHOYLE2010/Rfiles/R4mfcl 2010_04_15/R4MFCL.RData",pos=2)
setwd("D:/SimonHOYLE2011/")
source("./Rfiles/support_functions.r")
require(splines)
require(boot)
load("op.RData")
setwd("D:/SimonHOYLE2011/weight_methods_qp_noswo/")
minqtrs=2; maxqtrs=200; runreg <- 2;addmain<-F; addbranch<-F;addother=F;addalb=F;fc="both"
maxqtrs=200; minqtrs_byreg = c(2,2,2,2,2,2,2,2,2)
runreg=1;runsp="bet";fc="OS";mt="logn"
for(runreg in c(1:5,9,6)) {
  for(fc in c("OS","DW"))
    {
    if(runreg!=6 | fc == "DW") {
      for(bait in c("no23","allbait")) {
        for(runsp in c("bet","yft"))
          {
          minqtrs <- minqtrs_byreg[runreg]
          glmdat <- select_data(op,runreg,runsp,mt,minqtrs,maxqtrs,fc=fc)
          if(nrow(glmdat)>250000) {
            n <- make_strat(glmdat)
            glmdat <- samp_data(glmdat,n,50)
            }
          aggdat <- aggregate_data(glmdat,sp=runsp)
          wtt.agg.equal <- mk_wts(aggdat,wttype="equal")
          wtt.agg.area  <- mk_wts(aggdat,wttype="area")
          wtt.op.equal  <- mk_wts(glmdat,wttype="equal")
          wtt.op.area   <- mk_wts(glmdat,wttype="area")
          fname <- paste("Compare weightings ",runsp,"_R",runreg,"eq ",minqtrs,"-",maxqtrs,"_qtrs ",fc,"_",bait,sep="")
          fmla.agg <- make_formula(runsp,modtype="logn",addboat=F)
          fmla.op <- make_formula(runsp,modtype="qp",addboat=F)
          fmla.boat <- make_formula(runsp,modtype="qp",addboat=T)
          model.agg.equal <- glm(fmla.agg,data=aggdat,weights=wtt.agg.equal);gc()
          a <- length(unique(aggdat$yrqtr))
          coefs.agg.equal <- get.coefs(model.agg.equal,a)
          save(file=paste(fname," model.agg.equal.RData",sep=""),model.agg.equal);rm(model.agg.equal);gc()
          model.agg.area  <- glm(fmla.agg,data=aggdat,weights=wtt.agg.area);gc()
          coefs.agg.area <- get.coefs(model.agg.area,a)
          save(file=paste(fname," model.agg.area.RData",sep=""),model.agg.area);rm(model.agg.area);gc()
          model.op.equal  <- glm(fmla.op,data=glmdat,weights=wtt.op.equal,family="quasipoisson");gc()
          a <- length(unique(glmdat$yrqtr))
          coefs.op.equal <- get.coefs(model.op.equal,a)
          save(file=paste(fname," model.op.equal.RData",sep=""),model.op.equal);rm(model.op.equal);gc()
          model.op.area   <- glm(fmla.op,data=glmdat,weights=wtt.op.area,family="quasipoisson");gc()
          coefs.op.area <- get.coefs(model.op.area,a)
          save(file=paste(fname," model.op.area.RData",sep=""),model.op.area);rm(model.op.area);gc()
          model.opboat.equal  <- glm(fmla.boat,data=glmdat,weights=wtt.op.equal,family="quasipoisson");gc()
          coefs.opboat.equal <- get.coefs(model.opboat.equal,a)
          save(file=paste(fname," model.opboat.equal.RData",sep=""),model.opboat.equal);rm(model.opboat.equal);gc()
          model.opboat.area   <- glm(fmla.boat,data=glmdat,weights=wtt.op.area,family="quasipoisson");gc()
          coefs.opboat.area <- get.coefs(model.opboat.area,a)
          save(file=paste(fname," model.opboat.area.RData",sep=""),model.opboat.area);rm(model.opboat.area);gc()

          aggyr <- sort(unique(aggdat$yrqtr))
          opyr <- sort(unique(glmdat$yrqtr))
          myr <- aggyr[match(opyr,aggyr)]
          coefs2.agg.equal <- coefs.agg.equal[match(opyr,aggyr)]
          coefs2.agg.area <- coefs.agg.area[match(opyr,aggyr)]
          fishlab <- switch(runsp,yft="Yellowfin",bet="Bigeye"); methlab <- switch(mt,deltabin="Delta-binomial",deltapos="Delta-positive",logl="Lognormal(+0.5)")
          save(file=paste(fname,"indices.RData",sep=""),list=ls(pattern="coefs."))

          plot.agg.slope.ratio(coefs2.agg.equal,coefs2.agg.area,aggyr,aggyr, titl=paste("Region",runreg,fishlab,fc,"agg equal vs agg area"),lab1="agg equal",lab2="agg area",fname)  # plot results
          plot.agg.slope.ratio(coefs.op.equal,  coefs.op.area,  opyr, opyr,  titl=paste("Region",runreg,fishlab,fc,"op equal vs op area qp"),lab1="op equal",lab2="op area",fname)  # plot results
          plot.agg.slope.ratio(coefs2.agg.equal,coefs.op.equal,aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs op equal qp"),lab1="agg equal",lab2="op equal",fname)  # plot results
          plot.agg.slope.ratio(coefs2.agg.area, coefs.op.area, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs op area qp"),  lab1="agg area", lab2="op area",fname)  # plot results
          plot.agg.slope.ratio(coefs2.agg.equal,coefs.opboat.equal,aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat equal qp"),lab1="agg equal",lab2="opboat equal",fname)  # plot results
          plot.agg.slope.ratio(coefs2.agg.area, coefs.opboat.area, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg area vs opboat area qp"),  lab1="agg area", lab2="opboat area",fname)  # plot results
          plot.agg.slope.ratio(coefs.op.equal,coefs.opboat.equal,opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op equal qp vs opboat equal qp"),lab1="op equal",lab2="opboat equal",fname)  # plot results
          plot.agg.slope.ratio(coefs.op.area, coefs.opboat.area, opyr,opyr,titl=paste("Region",runreg,fishlab,fc,"op area qp vs opboat area qp"),  lab1="op area", lab2="opboat area",fname)  # plot results
          plot.agg.slope.ratio(coefs.agg.equal, coefs.opboat.area, aggyr,opyr,titl=paste("Region",runreg,fishlab,fc,"agg equal vs opboat area qp"),  lab1="agg equal", lab2="opboat area",fname)  # plot results
          save(file=paste(fname,"indices.RData",sep=""),list=ls(pattern="coefs."))
          rm(list=ls(pattern="coefs."))
          graphics.off()
          }
        }
      }
    }
  }

mt <- "qp"
fmla <- make_formula(runsp,mt,addboat=F,splitboat=F,addmain=addmain,addbranch=addbranch)
fmla.boat <- make_formula(runsp,mt,addboat=T,splitboat=F,addmain=addmain,addbranch=addbranch)
model.op.area.qp <- glm(fmla,data=glmdat,weights=wtt.op.area,family=quasipoisson);gc()
model.opboat.area.qp <- glm(fmla.boat,data=glmdat,weights=wtt.op.area,family=quasipoisson);gc()
a <- length(unique(glmdat$yrqtr))
coefs.op.area.qp <- get.coefs(model.op.area.qp,a)
coefs.opboat.area.qp <- get.coefs(model.opboat.area.qp,a)

plot.agg.slope.ratio(coefs.op.area,  coefs.op.area.qp,  opyr, opyr,  titl=paste("Region",runreg,fishlab,methlab,"op area vs op area qp"),lab1="op area",lab2="op area qp")  # plot results
plot.agg.slope.ratio_2000(coefs.op.area.qp,  coefs.opboat.area.qp,  opyr, opyr,  titl=paste("Region",runreg,fishlab,methlab,"op area qp vs opboat area qp"),lab1="op area qp",lab2="opboat area qp")  # plot results

savePlot(paste(opname,"_agg results.png",sep=""),type="png")
write.csv(cbind(myr,coefs2.agg,cv2.agg,coefs.base,cv.base,coefs.boat,cv.boat),file=paste(fname,"agg.csv",sep=""))  # save summaries
rm(model.agg);gc()

#- test analysis with equal weighting per data pt
#- tst with equal weighting per area
#- test with weigting proportional to total catch in last 20 years

savewd <- getwd()
setwd("D:/SimonHOYLE2011/testwt")
load("D:/SimonHOYLE/op.RData")

newpd <- op[op$vessid!=2,]
compdir <- "D:/SimonHOYLE2011/testwt/"

aggregate_data <- function(dat) {
  tab1 <- aggregate(dat$bet, list(dat$yrqtr, dat$latlong, dat$hbf), sum)
  tab2 <- aggregate(dat$hooks, list(dat$yrqtr, dat$latlong, dat$hbf), sum)
  taball <- cbind(tab1[,1:4],tab2[,4])
  names(taball) <-  c("yrqtr", "latlong","hbf","bet","hooks")
  taball$yrqtr <- as.numeric(as.character(taball$yrqtr))
  taball$latlong <- as.character(taball$latlong)
  taball$hbf <- as.numeric(as.character(taball$hbf))
  taball$bet <- as.numeric(as.character(taball$bet))
  taball$hooks <- as.numeric(as.character(taball$hooks))
  return(taball)
  }

mt="deltapos";runsp="bet"; minqtrs=2; maxqtrs=200; runreg <- 3;addmain<-F; addbranch<-F;addother=F;addalb=F
maxqtrs=200; minqtrs_byreg = c(2,2,8,8,2,2,2,8)
for(runreg in c(2)) {
  mt <- "logn"
  minqtrs <- minqtrs_byreg[runreg]
  for(runsp in c("bet")) {
    fname <- paste(runsp,"_R",runreg,"eq ",minqtrs,"-",maxqtrs,"_qtrs ",mt,ifelse(addother,"_othersp",""),ifelse(addalb,"_albcat",""),sep="")
    glmdat <- select_data(newpd,runreg,runsp,mt,minqtrs,maxqtrs,addmain,addother=addother)
    aggdat <- aggregate_data(glmdat)
    fmla.agg <- make_formula(runsp,mt,addboat=F,splitboat=F,addmain=addmain,addbranch=addbranch,addother=addother,addalb=addalb)
    model.agg <- glm(fmla.agg,data=aggdat);gc()
    a <- length(unique(glmdat$yrqtr))
    coefs.agg <- get.coefs(model.agg,a)
    cv.agg <- summary(model.agg)$coefficients[1:a,2]
    aggyr <- sort(unique(aggdat$yrqtr))
    fmla <- make_formula(runsp,mt,addboat=F,splitboat=F,addmain=addmain,addbranch=addbranch,addother=addother,addalb=addalb)
    model <- glm(fmla.agg,data=glmdat);gc()
    a <- length(unique(glmdat$yrqtr))
    coefs.op <- get.coefs(model,a)
    cv.op <- summary(model)$coefficients[1:a,2]
    opyr <- sort(unique(glmdat$yrqtr))
    myr <- aggyr[match(opyr,aggyr)]
    coefs2.agg <- coefs.agg[match(opyr,aggyr)]
    cv2.agg <- cv.agg[match(opyr,aggyr)]
    fishlab <- switch(runsp,yft="Yellowfin",bet="Bigeye"); methlab <- switch(mt,deltabin="Delta-binomial",deltapos="Delta-positive",logl="Lognormal(+0.5)")
    plot.agg.slope.ratio(coefs2.agg,coefs.op,aggyr,opyr,titl=paste("Region",runreg,fishlab,methlab,"op vs agg"))  # plot results
    savePlot(paste(opname,"_agg results.png",sep=""),type="png")
    write.csv(cbind(myr,coefs2.agg,cv2.agg,coefs.base,cv.base,coefs.boat,cv.boat),file=paste(fname,"agg.csv",sep=""))  # save summaries
    storesumm(model.agg,paste(fname,"_summ_base",sep=""))
    rm(model.agg);gc()

    fmla <- make_formula(runsp,mt,addboat=F,splitboat=F,addmain=addmain,addbranch=addbranch,addother=addother,addalb=addalb)
    model <- glm(fmla.agg,data=glmdat);gc()
    a <- length(unique(glmdat$yrqtr))
    coefs.op <- get.coefs(model,a)
    cv.op <- summary(model)$coefficients[1:a,2]
    opyr <- sort(unique(glmdat$yrqtr))
    myr <- aggyr[match(opyr,aggyr)]
    coefs2.agg <- coefs.agg[match(opyr,aggyr)]
    cv2.agg <- cv.agg[match(opyr,aggyr)]
    fishlab <- switch(runsp,yft="Yellowfin",bet="Bigeye"); methlab <- switch(mt,deltabin="Delta-binomial",deltapos="Delta-positive",logl="Lognormal(+0.5)")
    plot.agg.slope.ratio(coefs2.agg,coefs.op,aggyr,opyr,titl=paste("Region",runreg,fishlab,methlab,"op vs agg"))  # plot results

    graphics.off()
    }
  }

setwd(savewd)


## require(NADA)

setwd("X:\\Hobbs_Will\\Final 2007-2012 Stormwater Data\\R\\")					##tells R what folders to look in

Storm <- read.csv("FinalMasterFile_4-15-2014.csv")

### Make a few adjustments to the Storm dataframe:
Storm <- Storm[-which(Storm$nonDetect_Flag=="WARNING"),]                ### Remove REJ and B data flagged as 'WARNING'
Storm <- Storm[-which(Storm$paramStatus=="Omit"),]                      ### Remove the parameters that are designated 'Omit' for analysis and plotting
Storm <- Storm[-which(substr(Storm$Parameter,1,8) == "Particle"),]

### Create a list of parameter names to group data for plotting/analysis:
Parameter.string <- paste(Storm$Parameter, " ", tolower(Storm$Sample_Matrix), " ",
          tolower(Storm$new_Fraction_Analyzed), " (", Storm$new_Result_Units, ")", sep="")
Storm <- cbind(Storm, Parameter.string)

## Only test those chemicals with 10 or more detections
Parameter.List <- table(Storm[,c("Parameter.string", "nonDetect_Flag")])
Parameter.List <- Parameter.List[which(Parameter.List[,1] >= 10),]
#total.samples<-Parameter.List[,1]+Parameter.List[,2]                             ##pulling out those samples with >90% detection
#Parameter.List <- Parameter.List[which(Parameter.List[,1]/total.samples >= 0.9),]
Parameter.List <- rownames(Parameter.List)

Storm_Detects <- Storm[which(Storm$Parameter.string %in% Parameter.List), ]
Storm_Detects <- droplevels(Storm_Detects[which(Storm_Detects$nonDetect_Flag == FALSE), ])
Storm_qualifiers<-table(Storm_Detects[,c("Parameter.string", "Result_Data_Qualifier")])
write.csv(Storm_qualifiers,"Parameter Data Qualifier summary.csv")

shapiro_normal_test <- unlist(tapply(X=Storm_Detects$new_Result_Value, INDEX=Storm_Detects$Parameter.string, FUN=shapiro.test))
write.csv(shapiro_normal_test, "Shapiro_Normal_Test.csv")

shapiro_Log_normal_test <- unlist(tapply(X=log(Storm_Detects$new_Result_Value), INDEX=Storm_Detects$Parameter.string, FUN=shapiro.test))
write.csv(shapiro_Log_normal_test, "Shapiro_LOG_Normal_Test.csv")

##pdf("QQplots.pdf", height=5, width=10)					##I blocked the QQplot development (don't want it to re-write any plots at this point_)
##for (iParam in Parameter.List) {
  ##layout(matrix(1:2, nrow=1, ncol=2))
  ##testdata <- Storm_Detects[which(Storm_Detects$Parameter.string == iParam),]
  ##qqnorm(testdata$new_Result_Reported_Value, main=iParam)
  ##qqline(testdata$new_Result_Reported_Value)
  ##qqnorm(log(testdata$new_Result_Reported_Value), main=paste("Log(", iParam, ")", sep=""))
  ##qqline(log(testdata$new_Result_Reported_Value))

##}
##dev.off()


#!/usr/bin/env Rscript

library(mongolite)
library(tsoutliers)
library(boot)
library(methods)
library(stats)
library(stsm)
library(tseries)
library(utils)

options(nwarnings = 500)

#connect to mongo
#weights<-mongo(collection = "weights", db = "digitalhomestead", url = "mongodb://localhost:27017")
weights<-mongo(collection = "weights", db = "digitalhomestead", url = "mongodb://mongo:27017")

#get the distinct tags for the animals
distinctIds<-weights$distinct("weights.id")

#iterate over all the animals
countValid<-1
countInvalid<-1
for(id in distinctIds){

  print(id)
  if(id=="-1") next;
  #get the tagWeights: working with 125004185879 125004149782 right now
  tagWeights<-weights$aggregate(
    paste0('[ {"$unwind" : "$weights"}, {"$match":  {"weights.id" : ','"',id,'"','} }, {"$project":  { "weight" : "$weights.weight", "id" : "$weights._id",  "flag" : "$weights.qa_flag"  } } ]'))

  countValid<-1;
  countInvalid<-1;
  indexValid<-vector();
  indexInvalid<-vector();
  weightsValid<-vector();
  weightsInvalid<-vector();

  #iterate over the weights
  for(i in 1:length(tagWeights[[1]]) ){
    if(tagWeights[i,'weight']>650 || tagWeights[i,'weight']<200){
      indexInvalid[countInvalid]<-i;
      weightsInvalid[countInvalid]<-tagWeights[i,'weight'];
      if(is.na( tagWeights[i,'flag']) || tagWeights[i,'flag']!="INVALID")
        weights$update( query=paste0 ('{"_id":"', tagWeights[i,'_id'] ,'", "weights._id": {"$oid":"',tagWeights[i,'id'],'"}}'),
                        update='{"$set":{"weights.$.qa_flag": "INVALID"}}')
      countInvalid<-countInvalid+1;
    }
    else{
      indexValid[countValid]<-i;
      weightsValid[countValid]<-tagWeights[i,'weight'] ;
      countValid<-countValid+1;
      if( is.na(tagWeights[i,'flag']) || tagWeights[i,'flag']!="VALID")
        weights$update( query=paste0 ('{"_id":"', tagWeights[i,'_id'] ,'", "weights._id": {"$oid": "',tagWeights[i,'id'],'"}}'),
                        update='{"$set":{"weights.$.qa_flag": "VALID"}}')

    }
  }

  weightSeries<- logical(0);
  weightOutliers<- logical(0);

  out<-tryCatch({
    if(length(weightsValid)>0)
      weightSeries<-ts(weightsValid);
  },
  error=function(cond){ print(cond); })

  out<-tryCatch({
    if(length(weightSeries)>5)
      weightOutliers<-tso(weightSeries,types= c("TC", "AO"))
  },
  error=function(cond){ print(cond);  })

  #update info about Outliers detected weightOutliers$outliers$type weightOutliers$outliers$ind weightOutliers$outliers$coefhat
  out<-tryCatch({
    if(length(weightOutliers)>0)
      for(j in 1:length(weightOutliers$outliers[[1]]) ){

        weights$update( query=paste0 ('{"_id":"', tagWeights[indexValid[weightOutliers$outliers[j,2]], '_id'] ,'", "weights._id": {"$oid": "',tagWeights[indexValid[weightOutliers$outliers[j,2]], 'id'],'"}}'),
                        update=paste0('{"$set":{"weights.$.qa_flag": "OUTLIER",   "weights.$.qa_value": "',weightOutliers$outliers[j,4],'"}}'))
      }
  },
  error=function(cond){ print(cond); })

}


context("Regression basics")

get.data.regr <- function(n=800) {
  p = 4
  x = matrix(runif(n*p), n, p)
  f = function(x) (x[,1]>0.5) + (x[,2]>0.6) + (x[,3]>0.4)
  return(list(x=x, y=f(x)))
}

train <- get.data.regr(100)
test  <- get.data.regr(101)

test_that("basic regression and prediction", {
  et    <- extraTrees(train$x, train$y, nodesize=1, mtry=2, numRandomCuts=2, ntree=50)
  expect_is   ( et, "extraTrees")
  expect_false( et$factor )
  expect_false( et$multitask )
  expect_equal( 50,    et$ntree )

  yhat  <- predict(et, test$x)
  expect_equal( length(yhat), length(test$y) )
  expect_true(  is.numeric(yhat) )
  expect_true(  is.double(yhat) )

  yall <- predict(et, test$x, allValues=T)
  expect_equal( nrow(yall), nrow(test$x) )
  expect_equal( ncol(yall), 50 )
  expect_true(  is.double(yall) )
  expect_equal( yhat, rowMeans(yall), tolerance=1e-5)
})

test_that("selectTree works with regression", {
  et    <- extraTrees(train$x, train$y, nodesize=1, mtry=2, numRandomCuts=2, ntree=20)
  trees <- rep(c(T, F), 10)
  et10 <- selectTrees(et, trees )
  expect_equal( et10$ntree, 10 )
  yall   <- predict(et,   test$x, allValues=T)
  yall10 <- predict(et10, test$x, allValues=T)
  expect_equal( yall[,trees], yall10, tolerance=1e-5)
})

test_that("integer y is used as double for regression", {
  et   <- extraTrees(train$x, as.integer(train$y), ntree=50)
  yhat <- predict(et, train$x)

  expect_equal( length(yhat), length(train$y) )
  expect_true(  is.double(yhat) )
})

test_that("multi-threaded regression works", {
  et   <- extraTrees(train$x, train$y, numRandomCuts=2, ntree=50, numThreads=2)
  yhat <- predict(et, test$x)
  expect_equal( length(yhat), length(test$y) )
  expect_equal( 50, et$ntree )
  expect_equal( 2,  et$numThreads )
  expect_true(  is.numeric(yhat) )
  expect_true(  is.double(yhat) )
  expect_false( et$factor )

  yall = predict(et, test$x, allValues=T)
  expect_equal( nrow(yall), nrow(test$x) )
  expect_equal( ncol(yall), 50 )
  expect_true(  is.double(yall) )
  expect_equal( yhat, rowMeans(yall), tolerance=1e-5)

  expect_error( extraTrees(train$x, train$y, numThreads=0 ) )
})

test_that("training creates a usable call object", {
  et   <- extraTrees(train$x, train$y, ntree=50)
  expect_true( is.call(et$call) )
  et2  <- eval(et$call)
  expect_is(et2, "extraTrees")
})

test_that("using same set.seed gives same results", {
  set.seed(1000)
  et1   <- extraTrees(train$x, train$y, ntree=10)
  yhat1 <- predict(et1, test$x)

  set.seed(1000)
  et2   <- extraTrees(train$x, train$y, ntree=10)
  yhat2 <- predict(et2, test$x)

  expect_equal( yhat1, yhat2, tolerance=1e-6)
})

test_that("using same set.seed gives same results with multi-threading", {
  set.seed(1000)
  et1   <- extraTrees(train$x, train$y, ntree=10)
  yhat1 <- predict(et1, test$x)

  set.seed(1000)
  et2   <- extraTrees(train$x, train$y, ntree=10, numThreads = 2)
  yhat2 <- predict(et2, test$x)

  expect_equal( yhat1, yhat2, tolerance=1e-6)
})