#' hierarch_plot.means_JAGS
#' Get site level means and sd from NEON data observed at the plot scale.
#' Also return global mean and sd for a given predictor.
#' depends on the runjags package.
#'
#' @param x_mu         #vector of observations to modeled.
#' @param x_sd         #vector of observation uncertainty. Default NA.
#' @param plot_site    #NEON plot IDs associated with x_mu observations.
#' @param n.adapt      #number of adaptive iterations. default 200.
#' @param n.burnin     #number of burnin iterations. default 1000.
#' @param n.sample     #number of sample iterations. default 1000.
#' @param n.chains     #number of MCMC chains. default 3.
#' @param parallel     #run chains in parallel or not? default F, notsetup to work yet.
#'
#' @return
#' @export
#'
#' @examples
#' rm(list=ls())
#' source('paths.r'); source('NEFI_functions/crib_fun.r')
#' dp.10098.plot <- readRDS(dp1.10098.00_plot.level.path)
#' to.ag <- dp.10098.plot[,c('plotID','siteID','relEM','basal_live')]
#' x_mu = to.ag$basal_live; plot_site=to.ag$siteID;n.adapt=200;n.burnin=1000;n.sample=1000;n.chains=3; parallel = F
hierarch_plot.means_JAGS <- function(x_mu, x_sd = NA, plot_site,
                                     n.adapt = 200, n.burnin = 1000, n.sample = 1000, n.chains = 3,
                                     parallel = F, gamma_variance = F){
  #Other functions.
  source('NEFI_functions/precision_matrix_match.r')
  source('NEFI_functions/sd_to_precision.r')

  #Generate precision matrix.----
  #make sd object if not supplied.
  suppressWarnings(
    if(is.na(x_sd)){x_sd = rep(0.0001,length(x_mu))}
  )

  #covert sd to precision. output is matrix.
  x_precision <- sd_to_precision(as.matrix(x_sd))

  #### specify JAGS model ####
  jags.model = "
  model{
    #get site level means.
    for(i in 1:N.plot) {
      plot_la[i] ~ dnorm(site_mu[plot_site[i]], tau.site[plot_site[i]])
      plot_mu[i] ~ dnorm(plot_la[i], plot_precision[i]) #plot precision is observation uncertainty.
    }

    #get global mean and uncertainty.
    for(i in 1:N.site){
    site_mu[i] ~ dnorm(global_mu, tau.glob)
    }

    #Site level priors
    for(i in 1:N.site) {
      sigma.site[i] ~ dunif(0, 100)
        tau.site[i] <- pow(sigma.site[i], -2)
    }

    #Global level priors
    global_mu ~ dnorm(0,1E-3)  #I(0, ) #interval censored to be greater than zero.
    sigma.glob ~ dunif(0,100)
    tau.glob <- pow(sigma.glob, -2)

  }"

  #### JAGS model with gamma on variance prior. ####
  jags.gamma_variance.model = "
  model {
    #get site level means.
    for(i in 1:N.plot) {
      plot_mu[i] ~ dnorm(site_mu[plot_site[i]], tau.site[plot_site[i]])
    }

    #get global mean and uncertainty.
    for(i in 1:N.site){
      site_mu[i] ~ dnorm(global_mu, tau.glob)
    }

    #Site level priors
    for(i in 1:N.site) {
       tau.site[i]  ~ dgamma(1,1)
    }

    #Global level priors
    global_mu ~ dnorm(0,1E-3)  #I(0, ) #interval censored to be greater than zero.
    sigma.glob ~ dunif(0,100)
      tau.glob <- pow(sigma.glob, -2)

  }"

  #### setup JAGS data object. ####
  dat <- data.frame(x_mu, x_precision,plot_site)
  dat <- dat[complete.cases(dat),]
  site.names <- unique((plot_site))
  #reorder site.names so it matches what they are going to be used as.
  site.order <- order(site.names)
  site.names <- as.character(site.names[site.order])

  jags.data <- list(N.plot = length(dat$plot_site), N.site = length(unique(dat$plot_site)),
                    plot_mu = dat$x_mu,
                    plot_precision = dat$x_precision,
                    plot_site = droplevels(as.factor(dat$plot_site))
                    )

  #### fit JAGS model ####
  #runmode <- ifelse(parallel == T,T,F)
  j.model <- jags.model
  if(gamma_variance == T){j.model = jags.gamma_variance.model}
  mod  <- runjags::run.jags(model = j.model,
                            data = jags.data,
                            monitor = c('site_mu','global_mu'),
                            adapt = n.adapt,
                            burnin = n.burnin,
                            sample = n.sample,
                            n.chains = n.chains)
  out <- summary(mod)
  site.table <- data.frame(out[grep('site_mu', rownames(out)),])
  site.table$siteID <- site.names
  glob.table <- data.frame(t(out[grep('global_mu', rownames(out)),]))

  #### return output ####
  output.list <- list(out,site.table,glob.table)
  names(output.list) <- c('jags.summary','site.table','glob.table')
  return(output.list)

}


source("/Users/chr/Prog/R/lmerERP/lmerSPR/plot_lmerSPR.R", encoding = "UTF-8")

produce_spr_plots <- function(
    path
) {
    lmerSPR <- fread(path)

    # Observed Data
    plot_lmerSPR(lmerSPR, "logRT", yunit="logRT", title="Observed RTs") #, ylims=c(5.7, 5.9)

    # Estimated RTs
    estimates <- colnames(lmerSPR)[which(grepl("est_", colnames(lmerSPR)))]
    for (x in estimates) {
         plot_lmerSPR(lmerSPR, x, yunit="logRT", title="Estimated RTs")  #, ylims=c(5.7, 5.9)
    }

    # Residuals
    residuals <- colnames(lmerSPR)[which(grepl("res_", colnames(lmerSPR)))]
    for (x in residuals) {
        plot_lmerSPR(lmerSPR, x, yunit="logRT", title="Residuals: Noun Association + log(Cloze)")  # , ylims=c(0.06, -0.06)
    }

    # Coefficients
    coefs_cols <- colnames(lmerSPR)[grep("coef", colnames(lmerSPR))]
    SE_cols <- colnames(lmerSPR)[grep("SE_", colnames(lmerSPR))]
    cols <- c("Condition", "Item", "Subject", "Region", coefs_cols, SE_cols)
    data <- lmerSPR[,..cols]
    data1 <- melt(data, id.vars=c("Condition", "Region"), measure.vars=coefs_cols, variable.name="Coefficient", value.name="coefficients")
    data1$SE <- melt(data, id.vars=c("Condition", "Region"), measure.vars=SE_cols, variable.name="Coefficient", value.name="SE")$SE
    data1 <- data1[, lapply(.SD, mean), by=list(Region, Coefficient), .SDcols=c("coefficients", "SE")]
    plot_lmerSPR(data1, "coefficients", yunit="SPR Coefficients", title="Coefficients", grouping="Coefficient", ylims=c(5.7,5.85))

    # Z-values
    zval_cols <- setdiff(colnames(lmerSPR)[grep("zval_", colnames(lmerSPR))], "zval_1")
    pval_cols <- setdiff(colnames(lmerSPR)[grep("pval_", colnames(lmerSPR))], "pval_1")
    cols <- c("Condition", "Item", "Subject", "Region", zval_cols, pval_cols)
    data <- lmerSPR[,..cols]
    data1 <- melt(data, id.vars=c("Condition", "Region"), measure.vars=zval_cols, variable.name="Zvalue", value.name="zvalue")
    data1$pvalue <- melt(data, id.vars=c("Condition", "Region"), measure.vars=pval_cols, variable.name="Pvalue", value.name="pvalue")$pvalue
    data1 <- data1[, lapply(.SD, mean), by=list(Region, Zvalue), .SDcols=c("zvalue", "pvalue")]
    plot_lmerSPR(data1, "zvalue", yunit="Z-values", title="SPR Effect Size", ylims=c(-0.5, 4), grouping="Zvalue")

    # Condition A predictions
    dt <- fread("data/lmerSPR_Asrp.csv")
    srp_range <- range(dt$z_srp)
    dt <- dt[, lapply(.SD, mean), by=list(Region, Subject), .SDcols=c("1", "srp", "i_1", "i_srp", "s_1", "s_srp")]

    # To Do : column mult to get subject variation in there (random effects)
    dt$est_max <- (dt$"1" + dt$i_1 + dt$s_1) + (dt$srp + dt$s_srp + dt$i_srp) * srp_range[[1]]
    dt$est_avg <- (dt$"1" + dt$i_1 + dt$s_1) + (dt$srp + dt$s_srp + dt$i_srp) * 0
    dt$est_1SD <- (dt$"1" + dt$i_1 + dt$s_1) + (dt$srp + dt$s_srp + dt$i_srp)  * 1
    dt$est_min <- (dt$"1" + dt$i_1 + dt$s_1) + (dt$srp + dt$s_srp + dt$i_srp)  * srp_range[[2]]

    est_cols <- colnames(dt)[grep("est_", colnames(dt))]
    dt_m <- melt(dt, id.vars=c("Region", "Subject"), measure.vars=est_cols, variable.name="estimate", value.name="logRT")
    #dt_c <- dcast(dt_m, formula = Region + logCloze ~ Electrode, value.var="estimates")
    plot_lmerSPR(dt_m, "logRT", yunit="logRT", title="Estimated RTs", grouping="estimate", ylims=c(5.7,5.85)) #, ylims=c(-0.5, 4))
}


#----------------------------------------------------------------------------#
#' @title summary lm mod
#' @description summary mod lm
#' @param mod a lm mod
#' @import stats
#' @export
summary2_lm = function(mod) {
  out1 =
  cbind(Estimate = coef(mod),
        confint.default(mod),
        P.value = round(coef(summary(mod))[,4],5))
  return(out1)
}


test_that("Interpolacao Bilinear", {
    tri <- interpolador(colinadummy, "triangulacao")
    gradecolina <- predict(tri, coordgrade(colinadummy, 100, 100), as.gradecolina = TRUE)

    # METODO DE DATA.FRAME

    pontos1 <- expand.grid(hl = 55:60, pot = 300:305)

    rr1 <- predict(gradecolina, pontos1)
    expect_equal(class(rr1), "numeric")
    expect_equal(length(rr1), nrow(pontos1))

    rr2 <- predict(gradecolina, pontos1, full.output = TRUE)
    expect_equal(class(rr2), c("data.table", "data.frame"))
    expect_equal(dim(rr2), dim(pontos1) + c(0, 2))
    expect_equal(sort(rr2$hl), sort(pontos1$hl))
    expect_equal(sort(rr2$pot), sort(pontos1$pot))
    expect_equal(rr2$rend, rr1)

    # METODO FITTED

    rr3 <- fitted(gradecolina)
    expect_equal(class(rr3), "numeric")
    expect_equal(length(rr3), nrow(colinadummy$CC))

    rr4 <- fitted(gradecolina, full.output = TRUE)
    expect_equal(class(rr4), c("data.table", "data.frame"))
    expect_equal(dim(rr4), c(nrow(colinadummy$CC), 4))
    expect_equal(sort(rr4$hl), sort(colinadummy$CC$hl))
    expect_equal(sort(rr4$pot), sort(colinadummy$CC$pot))
    expect_equal(rr4$rend, rr3)

    # METODO RESIDUALS

    rr5 <- residuals(gradecolina)
    expect_equal(class(rr5), "numeric")
    expect_equal(length(rr5), nrow(colinadummy$CC))
})


dat<-read.csv("C:\\VisTrails\\DICK_MDS_binary.csv")

rf.full <- randomForest(x=dat[,-1],y=factor(dat[,1]),importance=TRUE,
        ntree=1000, replace=FALSE)

pred<-predict(rf.full, newdata=dat[,-1],type="prob")[,2]

null.dev<-calc.deviance(dat[,1], rep(p.bar,times=length(dat[,1])),family="binomial")*nrow(dat)
    dev.fit<-calc.deviance(dat[,1], pred, family="binomial")*nrow(dat)
    dev.exp <- null.dev - dev.fit
    pct.dev.exp <- dev.exp/null.dev*100

r<-randomForest(x=dat[,-1],y=factor(out$dat$ma$ma[,1]),xtest=xtest,ytest=ytest,importance=TRUE, ntree=n.trees,
        mtry=mtry,replace=samp.replace,sampsize=ifelse(is.null(sampsize),(ifelse(samp.replace,nrow(x),ceiling(.632*nrow(x)))),sampsize),
        nodesize=ifelse(is.null(nodesize),(if (!is.null(y) && !is.factor(y)) 5 else 1),nodesize),maxnodes=maxnodes,
        localImp=localImp, nPerm=nPerm, keep.forest=ifelse(is.null(keep.forest),!is.null(y) && is.null(xtest),keep.forest),
        corr.bias=corr.bias, keep.inbag=keep.inbag)


#' @details
#' This package contains functions to fit joint probability distributions to bivariate wave data (wave height and
#' wave period), estimate environmental contours based on the fitted distribution or directly on a given sample
#' data, output the coordinates of the vertices of the contours, and generate a plot of the contours.
#'
#' The choices for the joint probability distributions include the Heffernan-Tawn model \code{\link{fit_ht}} and
#' the Weibull-log-normal distribution \code{\link{fit_wln}}. The choices for the environmental contours are the
#' direct sampling contours \code{\link{estimate_dsc}}, IFORM
#' contours \code{\link{estimate_iform}}, generalised joint exceedance contours \code{\link{estimate_gje}}, and the
#' isodensity contours \code{\link{estimate_iso}}.
#'
#' This package has been developed as part of the
#' \href{https://www.dnvgl.com/technology-innovation/sri/maritime-transport/ecsades-project.html}{ECSADES} project
#' and is free to use. The
#' statistical models and contour estimation methods included in this package are discussed in detail in the project
#' paper Ross et al. (2018).
#'
#' @examples
#' # Load sample data from NOAA's WaveWatch III project
#' data(ww3_pk)
#'
#' # Fit the Heffernan-Tawn model to the data
#' ht = fit_ht(
#'   data = ww3_pk,
#'   npy = nrow(ww3_pk)/10,
#'   margin_thresh_count = 100,
#'   dep_thresh_count = 500)
#'
#' # Estimate the DSC contours using the Hs return levels as
#' dsc = estimate_dsc(object = ht,  output_rp = c(1,10,100))
#'
#' # Plot output and save to a file
#' plot_ec(
#'   ec = dsc, raw_data = ww3_pk, hs_x = FALSE, save_to_file = "dsc_ht.png",
#'   width = 8, height = 6, units = "in")
#'
#' @references
#' Ross, E., Astrup, O.C., Bitner-Gregersen, E.M., Bunn, N., Feld, G., Gouldby, B., Huseby, A.B., Liu, Y.,
#' Randell, D., Vanem, E., & Jonathan, P. (2019). On environmental contours for marine and coastal design.

"_PACKAGE"
.limit_inf = 1e7
.limit_zero = 1e-7
.seed_sampling = 121110
.knn = 200
.hs_res = .5
.target_rp_lb = .1 # Ratio to the target RP as a threhsold for importance sampling Huseby et al (2014)
.target_rp_ub = 1000 # Ratio to the target RP as an equivalent number of years to simulate from


void plotAllWStrue(TString filename, int sector, int sl){

  if (! TString(gSystem->GetLibraries()).Contains("Histograms_h")) {
    gROOT->LoadMacro("$CMSSW_BASE/src/Validation/DTRecHits/interface/Histograms.h+");
     gROOT->LoadMacro("macros.C");
     gROOT->LoadMacro("ranges.C+");
     gROOT->LoadMacro("summaryPlot.C+");
  }

  bool doRes = true;
  bool doResVsDist = true;
  bool doResVsAngle = true;
  bool doResVsX = true;
  bool doResVsY = true;
  bool doAngleDist = true;

  TStyle * style = getStyle("tdr");
  style->cd();
  gStyle->SetCanvasDefW(1375); // Set larger canvas
  gStyle->SetCanvasDefH(800);
  gStyle->SetTitleSize(0.05,"XYZ"); // Set larger axis titles
  gStyle->SetTitleOffset(1.5,"Y");
  gStyle->SetOptTitle(0); // remove histogram titles

  setPalette();
  opt2Dplot = "col";

 float nsigma = 2;

 TFile *file = new TFile(filename);

  TString canvbasename = filename;
  canvbasename = canvbasename.Replace(canvbasename.Length()-5,5,"") + TString("_Se") + (long) sector + "_SL" + (long) sl;

  HRes1DHit* hRes1D[5][3]; // W, S;
  HRes4DHit* hRes4D[5][3];

  for (int wheel = -2; wheel<=2; ++wheel) {
    for (int station = 1; station<=3; ++station) {

      int iW = wheel+2;
      int iSt= station-1;
      hRes1D[iW][iSt] = new HRes1DHit(file,wheel,station,sl,"S3");
      hRes4D[iW][iSt] = new HRes4DHit(file,wheel,station,0);

    }

  }

  if(doRes){
    TCanvas* c0= new TCanvas(canvbasename+"_AllWSRes", canvbasename+"_AllWSRes");

    c0->Divide(5,3,0.0005,0.0005);

    for (int wheel = -2; wheel<=2; ++wheel) {
      for (int station = 1; station<=3; ++station) {
	int iW = wheel+2;
	int iSt= station-1;

	int ipad=iW+1 +(2-iSt)*5;
	c0->cd(ipad); ++ipad;

	if(wheel<0) continue;

	TH1F* h = hRes1D[iW][iSt]->hRes;

	TF1* fres=drawGFit(h, nsigma, -0.4, 0.4);

      }
    }
  }

  if(doResVsDist){
    TCanvas* c0= new TCanvas(canvbasename+"_AllWSResVsDist", canvbasename+"_AllWSResVsDist");
    c0->Divide(5,3,0.0005,0.0005);

    for (int wheel = -2; wheel<=2; ++wheel) {
      for (int station = 1; station<=3; ++station) {
	int iW = wheel+2;
	int iSt= station-1;
	int ipad=iW+1 + (2-iSt)*5;

	c0->cd(ipad); ++ipad;
	if(wheel<0) continue;

	plotAndProfileX(hRes1D[iW][iSt]->hResVsPos,2,1,1,-.1, .1, 0., 2.1);

      }
    }
  }

  if(doResVsAngle){
    SummaryPlot hs_p0("p0");
    SummaryPlot hs_p1("p1");

    TCanvas* c0= new TCanvas(canvbasename+"_AllWSResVsAngle", canvbasename+"_AllWSResVsAngle");
    c0->Divide(5,3,0.0005,0.0005);

    for (int wheel = -2; wheel<=2; ++wheel) {
      for (int station = 1; station<=3; ++station) {

	  int iW = wheel+2;
	  int iSt= station-1;
	  int ipad=iW+1 + (2-iSt)*5;

	  c0->cd(ipad); ++ipad;
	  if(wheel<0) continue;

	  float min;
	  float max;

	  rangeAngle(wheel, station, sl, min, max);

	  TH1F* hprof = plotAndProfileX(hRes1D[iW][iSt]->hResVsAngle,1,1,1,-0.04, 0.04, min-0.03, max+0.03);
	  TF1 *angleDep= new TF1("angleDep","[0]*cos(x+[2])+[1]", min, max);
	  //TF1 *angleDep= new TF1("angleDep","[0]*x*x+[2]*x+[1]", min, max);
	  angleDep->SetParameters(0.01,0.001, 0.1);

	  if(sl == 2 || (sl == 1 && (iSt!=0 ||(iSt==0 && iW==2)))) angleDep->FixParameter(2,0.);

	  if(sl == 1 && (iW == 3 ||iW == 0) && iSt == 0)  angleDep->SetParameter(2,-0.12);

	  hprof->Fit(angleDep,"RQN");

	  if(sl == 2 && (iW == 0 || iW == 4) && (iSt == 0 || iSt == 1)) continue;

	  angleDep->Draw("same");
	  float p0 = angleDep->GetParameter(0);
	  float p1 = angleDep->GetParameter(1);
	  float p2 = angleDep->GetParameter(2);

       	cout << "Wh:" <<wheel<< " St:"<<station << " SL:" <<sl << " "<< p0 << " " << p1 << " " << p2 << endl;

	  hs_p0.Fill(wheel, station, sector, p0);
	  hs_p1.Fill(wheel, station, sector, p1);

      }
    }
  // Summary plot (still being developed)
    TCanvas* c6= new TCanvas(canvbasename+"_AllWSAngleCorr_p0", canvbasename+"_AllWSAngleCorr_p0");
    hs_p0.hsumm->GetYaxis()->SetRangeUser(0.5,0.5);
    hs_p0.hsumm->Draw("p");

    float p0_m[3][3];
    float p1_m[3][3];

    for (int wheel = 0; wheel<=2; ++wheel) {
      for (int station = 1; station<=3; ++station) {

	float p0_n = hs_p0.hsumm->GetBinContent(hs_p0.bin(-wheel,station,0));
	float p0_p = hs_p0.hsumm->GetBinContent(hs_p0.bin(wheel,station,0));
	float p1_n = hs_p1.hsumm->GetBinContent(hs_p1.bin(-wheel,station,0));
	float p1_p = hs_p1.hsumm->GetBinContent(hs_p1.bin(wheel,station,0));
	p0_m[wheel][station] = (p0_n + p0_p)/2;
	p1_m[wheel][station] = (p1_n + p1_p)/2;
	//	cout << wheel << "   "   << station << "   " <<  p0_m[wheel][station] <<  "   "<<p1_m[wheel][station] <<endl;
      }

    }

 }

  //  if (doResVsX) {
//     TCanvas* c0=new TCanvas(canvbasename+"_AllWSResVsX", canvbasename+"_AllWSResVsX");

//     c0->Divide(5,3);

//     for (int wheel = 0; wheel<=2; ++wheel) {
//       for (int station = 0; station<=2; ++station) {

// 	int ipad=wheel+3 + (2-station)*5;
// 	c0->cd(ipad); ++ipad;
// 	plotAndProfileX(hRes1D[wheel][station]->hResDistVsX,2,1,1,-0.05, 0.05, -150, 150); // FIXME
//       }
//     }
//   }

//  if (doResVsY) {

//    TCanvas* c0=new TCanvas(canvbasename+"_AllWSResVsY", canvbasename+"_AllWSResVsY");

//     c0->Divide(5,3);

//     for (int wheel = 0; wheel<=2; ++wheel) {
//       for (int station = 0; station<=2; ++station) {

// 	int ipad=wheel+3 + (2-station)*5;
// 	c0->cd(ipad); ++ipad;
// 	plotAndProfileX(hRes1D[wheel][station]->hResDistVsY,2,1,1,-0.05, 0.05, -150, 150); // FIXME
//       }
//     }
//   }

 if(doAngleDist){
   TCanvas* c0= new TCanvas(canvbasename+"_AllWSAngleDist", canvbasename+"_AllWSAngleDist");
   c0->Divide(5,3,0.0005,0.0005);

   for (int wheel = -2; wheel<=2; ++wheel) {
     for (int station = 1; station<=3; ++station) {
       int iW = wheel+2;
       int iSt= station-1;
       // DTDetId detId(wheel, station, sector, sl, 0, 0);
       int ipad=iW+1 + (2-iSt)*5;

       c0->cd(ipad); ++ipad;
       if(wheel<0) continue;

       float min;
       float max;

       rangeAngle(wheel, station, sl, min, max);
      //  cout << "min" << min << endl;
//        cout << "max" << max << endl;

       TH1F* hAngle = hRes4D[iW][iSt]->hSimAlpha;
       hAngle->Sumw2();

       if(sl==2){
	 TH1F* hAngle = hRes4D[iW][iSt]->hSimBeta;
	 hAngle->Sumw2();
       }

       hAngle->GetXaxis()->SetRangeUser(-1.2,1.2);
       hAngle->Draw();

     }
   }
}

}


library(tidyverse)
load("all_games_n_chars.rda")
load("all_tier_matrices.rda")

second_matrix_games <- list()

for (j in seq(all_character_matrix)) {
  game_mat <- all_character_matrix[[j]]
  game_name <- names(all_character_matrix[j])

  for (k in seq(nrow(game_mat) )) {
    ## Get char data and car columns
    char = colnames(game_mat)[k]
    loop_table <- game_mat[,-k]
    compare_col <-  game_mat[,k,drop = FALSE]
    ## This apply isn't what we want it basically sorts on a pseudo tier list
    ## I need to find a way to properly do this with weighting peoples scores
    #secondary_out <- apply(loop_table, 2, function(x){sum(abs(compare_col - x),na.rm = T)})
    ## Idea, if birdie has a matchup that is 5.5 and Vega is 5.2 it should result in -0.3 to the score
    ## and if birdie has a matchup that is 4.8 and vega is 5 it should add .2

    ## This apply compares the loops character to all other characters, finding the
    ## difference between their matchup spread, if their matchups are more favorable
    ## they get a postive score, if less favorable they get a negative score
    ## This score is then added together to determine how well the other characters
    ## compliments the main character of the loop.
    secondary_out <- apply(loop_table, 2, function(x){sum(-(compare_col - x),na.rm = T)})
    ## Fixing names
    secondary_out <- c(NA, secondary_out)
    names(secondary_out)[1] <- char
    if (k == 1) {
      #Make table
      secondary_table <- as.data.frame(secondary_out)
      colnames(secondary_table)[k] <- char
    }else{
      #Sort table so it fits the laready made table
      ind <- match(rownames(secondary_table), names(secondary_out))
      sorted_sec <- secondary_out[ind]
      secondary_table <- cbind(secondary_table, sorted_sec)
      colnames(secondary_table)[k] <- char
    }
  }
  second_matrix_games[[game_name]] <- secondary_table
}

second_matrix_games_jon <- list()

for (j in seq(all_character_matrix)) {
  game_mat <- all_character_matrix[[j]]
  game_name <- names(all_character_matrix[j])

  for (k in seq(nrow(game_mat) )) {
    ## Get char data and car columns
    char = colnames(game_mat)[k]
    loop_table <- game_mat[,-k]
    compare_col <-  game_mat[,k,drop = FALSE]
    ## This apply isn't what we want it basically sorts on a pseudo tier list
    ## I need to find a way to properly do this with weighting peoples scores
    #secondary_out <- apply(loop_table, 2, function(x){sum(abs(compare_col - x),na.rm = T)})
    ## Idea, if birdie has a matchup that is 5.5 and Vega is 5.2 it should result in -0.3 to the score
    ## and if birdie has a matchup that is 4.8 and vega is 5 it should add .2

    ## This apply compares the loops character to all other characters, finding the
    ## difference between their matchup spread, if their matchups are more favorable
    ## they get a positive score, if less favorable they get a negative score
    ## This score is then added together to determine how well the other characters
    ## compliments the main character of the loop.
    secondary_out <- apply(loop_table, 2, function(x){
      init_compare <- -(compare_col - x)
      jon_compare <- init_compare[init_compare > 0]
      sum(jon_compare, na.rm = TRUE)
    })

    ## Fixing names
    secondary_out <- c(NA, secondary_out)
    names(secondary_out)[1] <- char
    if (k == 1) {
      #Make table
      secondary_table <- as.data.frame(secondary_out)
      colnames(secondary_table)[k] <- char
    }else{
      #Sort table so it fits the laready made table
      ind <- match(rownames(secondary_table), names(secondary_out))
      sorted_sec <- secondary_out[ind]
      secondary_table <- cbind(secondary_table, sorted_sec)
      colnames(secondary_table)[k] <- char
    }
  }
  second_matrix_games_jon[[game_name]] <- secondary_table
}

save(second_matrix_games, second_matrix_games_jon, file = "secondary_matrix_all_games.rda")
save(second_matrix_games, second_matrix_games_jon, file = "secondary_selector/secondary_matrix_all_games.rda")


#Code to that compares each the observed-to-expected neoantigen ratios between samples marked as "selected" and "neutral" evolution using the subclonalSelection method
#Query at the top joins analysis.neoantigen_depletion table to analysis.subclonalselection table (and others)
#Comparisons are made for initial tumors and for recurrent tumors
#No significant associations
#This analysis is reported in the manuscript
#------------------------------------------------------------------------------

library(odbc)
library(DBI)
library(ggplot2)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "SELECT gs.* , nd1.rneo AS nd_a, nd2.rneo AS nd_b, clin.idh_codel_subtype AS subtype,sc1.most_probable_classification AS neut1, sc2.most_probable_classification AS neut2, sc1.probability_neutral AS prob1, sc2.probability_neutral AS prob2
FROM analysis.gold_set gs
LEFT JOIN analysis.neoantigen_depletion nd1 ON nd1.aliquot_barcode = gs.tumor_barcode_a
LEFT JOIN analysis.neoantigen_depletion nd2 ON nd2.aliquot_barcode = gs.tumor_barcode_b
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = gs.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = gs.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = gs.case_barcode
LEFT JOIN analysis.subclonalselection sc1 ON sc1.aliquot_barcode = gs.tumor_barcode_a
LEFT JOIN analysis.subclonalselection sc2 ON sc2.aliquot_barcode = gs.tumor_barcode_b
WHERE nd1.rneo IS NOT NULL AND nd2.rneo IS NOT NULL AND (nd1.nobs >= 3 AND nd2.nobs >= 3) --AND
--sc1.most_probable_classification IS NOT NULL AND sc2.most_probable_classification IS NOT NULL
ORDER BY nd1.rneo"

res <- dbGetQuery(con, q)

subtypes <- unique(res[,"subtype"])
for(i in 1:length(subtypes))
{
	sub_res <- res[which(res[,"subtype"]==subtypes[i]),]
	pri_s <- sub_res[which(sub_res[,"neut1"]=="S"),"nd_a"]
	pri_n <- sub_res[which(sub_res[,"neut1"]=="N"),"nd_a"]

	rec_s <- sub_res[which(sub_res[,"neut2"]=="S"),"nd_b"]
	rec_n <- sub_res[which(sub_res[,"neut2"]=="N"),"nd_b"]

	t.test(pri_s,pri_n)
	t.test(rec_s,rec_n)

	s1 <- c(pri_s,rec_s)
	n1 <- c(pri_n,rec_n)
	t.test(s1,n1)
}


#' @name
#'
#' @title
#'
#' @description
#'
#' @param
#'
#' @return
#'
#' @author
#' David Beauchesne
#'
#' @references
#'
#' @importFrom
#'
#' @example
#'
#' @rdname
#'
#' @export

crossValidation <- function(data, nCV, validPct, as.strata = TRUE, family = "probit", niter = 10000, nburn = 1000, thin = 10) {

    # ======================================
    # Monte Carlo cross-validation procedure
    # ======================================

        # Matrix to store cross-validation results
        modelAUC <- matrix(ncol = ncol(data$Y), nrow = nCV, data = 0, dimnames = list(paste('iter_', seq(1,nCV), sep = ''), colnames(data$Y)))

        for(cv in 1:nCV){
            # ---------------------------------------
            # Random sampling of dataset observations
            # ---------------------------------------
                # Index of validation observations randomly selected
                if(as.strata == TRUE) {
                    strata <- unique(data$Random[, 'random2'])
                    nStrata <- length(strata)
                    perStrata <- aggregate(data$Random, by = list(c(data$Random[, 'random2'])), FUN = length)[,2]
                    nValid <- round(validPct * perStrata)

                    randomSample <- character()
                    for(i in 1:nStrata) {
                        randomSample <- c(randomSample, as.character(sample(data$Random[data$Random[, 'random2'] == strata[i],'random1'], size = nValid[i], replace = FALSE)))
                    }
                } else {
                    randomSample <- as.character(sample(data$Random[, 'random1'], size = round(validPct * nrow(data$Random)), replace = FALSE))
                }

            # ----------------------------------------------------
            # Divide dataset into training and validation datasets
            # ----------------------------------------------------
                # Identify which rows should be set aside for cross validation
                    removeSample <- which(rownames(X) %in% randomSample)

                # Validation dataset
                    dataValid <- data
                    for (i in 1:3) dataValid[[i]] <- dataValid[[i]][removeSample, ]
                    dataValid[[3]][, 1] <- as.factor(as.character(dataValid[[3]][, 1])) # Need the proper number of levels, build new index

                # Training dataset
                    # HMSC dataset minus sampling units set aside for cross validation
                    dataTrain <- data
                    for (i in 1:3) dataTrain[[i]] <- dataTrain[[i]][-removeSample, ]
                    dataTrain[[3]][, 1] <- as.factor(as.character(dataTrain[[3]][, 1])) # Need the proper number of levels, build new index

            # ------------------------------------
            # Evaluate model with training dataset
            # ------------------------------------
                model <- HMSC::hmsc(dataTrain, family = family, niter = niter, nburn = nburn, thin = thin)

            # -----------------------------------
            # Predictions for validation datasets
            # -----------------------------------
                predVal <- predict(model, newdata = dataValid)

            #------------------------------------
            # Cross-validation: AUC of ROC curves
            #------------------------------------
                for(i in 1:ncol(predVal)) {
                    modelAUC[cv, i] <- ModelMetrics::auc(dataValid$Y[, i], predVal[, i])
                }
        }

        return(modelAUC)
}


alts <- 2 # number of alts you have available
tokens <- 0 # total number of tokens you have (spread across all accounts)
days <- 30 # the amount of days you wish to see growth in

new <- (alts*days*500) + tokens # amount of tokens after n days (n is days var)
growth <- new - tokens # the growth in tokens over a period of time

paste("Starting tokens:", tokens)
paste("Alt Accounts:", alts)
paste("Days:", days)
paste("New Total:", new)
paste("Token Growth:", growth)


# Merge the AERONET and the MetOffice data

aeronet <- import_aeronet_data("data/AERONET/lev20/920801_111119_Chilbolton.lev20")
meto <- import_meto_data("data/MetOffice/MetOData_All.csv")

index(meto) <- as.POSIXct(index(meto))
index(aeronet) <- as.POSIXct(index(aeronet))

ind <- index(aeronet)
rounded <- round_date(ind, 'hour')
time_diffs <- abs(ind - rounded) / 60
aeronet_sub <- aeronet[time_diffs < 15]
index(aeronet_sub) <- round_date(index(aeronet_sub), "hour")

# Options::
# Remove duplicates
#aeronet_sub <- aeronet_sub[!duplicated(aeronet_sub)]
# Use mean of observations at the same time
aeronet_sub <- aggregate(aeronet_sub, index(aeronet_sub), mean)
merged <- merge(aeronet_sub, meto, all=FALSE)

names(merged) <- c('aeronet', 'meto')


x <- 1:100
	xx <- as.character(x)
	xx[x%%3==0] <- "Fizz"
	xx[x%%5==0] <- "Buzz"
	xx[x%%15==0] <- "FizzBuzz"
	xx


penGAM <- function(x, y, lambda.pen, lambda.curv, knots,
                   model = LinReg(), save.x = TRUE,
                   control = grpl.control()){
  ## Purpose:
  ## ----------------------------------------------------------------------
  ## Arguments:
  ## ----------------------------------------------------------------------
  ## Author: Lukas Meier, Date: 13 Mar 2008, 11:30

  if(any(lambda.pen > 1))
    stop("lambda.pen is on a *relative* scale with respect to lambda.max")

  n <- NROW(x)
  p <- NCOL(x)

  ## Construct the design matrix and the penalty matrices
  d <- getDesign(x, knots = knots)

  ## Extract the necessary information
  m.orig <- d$m     ## list of p design matrices
  pen    <- d$pen   ## list of p penalty matrices
  index  <- d$index ## index vector (without intercept)

  ## Coefficients for all combinations of lambda.pen * lambda.curv * coef
  coefficients <- array(0,
                        dim = c(length(lambda.pen),
                                length(lambda.curv),
                                length(index) + 1))

  lambda.max.all <- numeric(length(lambda.curv))

  for(u in 1:length(lambda.curv)){
    if(control@trace >= 1)
      cat("\n*** lambda.curv", lambda.curv[u], "***\n")

    lcurv <- lambda.curv[u]

    ## m contains the whole design matrix but *without* intercept column
    m           <- matrix(0, nrow = n, ncol = length(index))
    colnames(m) <- unlist(lapply(m.orig, colnames))

    ## We have to calculate the penalty matrix for each value of lambda.curv
    ## Transform each predictor group such that we can work with an
    ## "ordinary" Group Lasso model

    chol.decomp <- list(); length(chol.decomp) <- p

    for(j in 1:p){
      ## This will be the penalty matrix for each block
      penmat  <- lcurv * pen[[j]] + crossprod(m.orig[[j]])

      ## Now calculate the cholesky decomposition
      chol.decomp[[j]] <- chol(penmat)
      m[,index == j] <-
        t(forwardsolve(t(chol.decomp[[j]]), t(m.orig[[j]])))
    }

    ## Now we are ready to get the estimates using the grplasso function
    ## for *all* values of lambda.pen

    ## We do *not* have to rescale the penalty
    mypenscale <- function(x) rep(1, length(x))

    ## Calculate lambda.max
    lambda.max <- lambdamax(x = cbind(1, m), y = y, index = c(NA, index),
                            penscale = mypenscale, model = model,
                            standardize = FALSE)

    lambda.max.all[u] <- lambda.max

    ## Actual lambda values
    lambda.use <- lambda.max * lambda.pen

    coef.init    <- rep(0, NCOL(m) + 1)
    coef.init[1] <- model@link(mean(y))

    ## Call now group lasso algorithm on the *transformed* data
    fit.grp <- grplasso(x = cbind(1, m), y = y, index = c(NA, index),
                        lambda = lambda.use, model = model,
                        coef.init = coef.init,
                        standardize = FALSE, penscale = mypenscale,
                        control = control)

    ## Transform the estimates back to the original scale using backsolve
    coef.pre <- coef(fit.grp)[-1,,drop = FALSE] ## without intercept
    coef.out <- matrix(0, nrow = NROW(coef.pre), ncol = NCOL(coef.pre))
    for(j in 1:p){
      sel            <- index == j
      coef.out[sel,] <- backsolve(chol.decomp[[j]], coef.pre[sel,])
    }
    ## Now transform the values back to the original spline-basis and
    ## add intercept.
    ## Put everything into the "coefficients" array.
    coefficients[,u,] <- t(rbind(coef(fit.grp)[1,], coef.out))
  } ## end for(u in 1:length(lambda.curv))

  dimnames(coefficients) <- list(lambda.pen,
                                 lambda.curv,
                                 c("(Intercept)", colnames(m)))

  if(is.null(colnames(x))){
    colnam <- 1:NCOL(x)
  }else{
    colnam <- colnames(x)
  }

  rownam <- rownames(x)

  if(!save.x)
    x <- NULL

  out <- list(coefficients = coefficients,
              x            = x,
              colnames     = colnam,
              rownames     = rownam,
              splineobj    = list(basis = d$basis, index = d$index),
              lambda.max   = lambda.max.all,
              lambda.pen   = lambda.pen,
              lambda.curv  = lambda.curv,
              model        = model)
  structure(out, class = "penGAM")
}

predict.penGAM <- function(object, newdata, type = c("link", "response"), ...)
{
  ## Purpose: Predict fitted object on a new data set
  ## ----------------------------------------------------------------------
  ## Arguments: fit object
  ## ----------------------------------------------------------------------
  ## Author: Lukas Meier, Date: 13 Mar 2008, 12:09

  type <- match.arg(type)

  nr.lambda.pen  <- length(object$lambda.pen)
  nr.lambda.curv <- length(object$lambda.curv)

  if(missing(newdata) || is.null(newdata)){ ## if we don't have new data object
    if(is.null(object$x))
      stop("No x matrix found in 'object'. Set save.x = TRUE or provide newdata!")

    ## Create the whole design matrix (*all* components)
    ## Re-create the design matrix using the given spline basis
    m.list <- list()
    for(j in 1:NCOL(object$x))
      m.list[[j]] <- eval.basis(x[,j], basisobj = object$splineobj$basis[[j]])

    n    <- NROW(m.list[[1]])
    pred <- array(0, dim = c(nr.lambda.pen, nr.lambda.curv, n))

    ## Create predictions
    m <- matrix(unlist(m.list), nrow = n)
    for(l in 1:nr.lambda.pen){
      for(u in 1:nr.lambda.curv){
        pred[l,u,] <- cbind(1, m) %*% coef(object)[l,u,]
      }
    }
    dimnames(pred) <- list(object$lambda.pen, object$lambda.curv,
                           object$rownames)
  }else{ ## if we have *new* data object (!!!add some test-functions later!!!)
    x <- newdata
    n <- NROW(x); p <- NCOL(x)

    pred <- array(0, dim = c(nr.lambda.pen, nr.lambda.curv, n))
    dimnames(pred) <- list(object$lambda.pen, object$lambda.curv, rownames(x))
    lowdiff <- highdiff <- outrange <-
      matrix(FALSE, nrow = NROW(newdata), ncol = p)

    ## Perform *linear* extrapolation

    ## Create the 'cut' design matrix: Sets values of x which exceed the
    ## training range to their corresponding boundaries (given by the range
    ## of the training data)
    x.cut  <- matrix(0, nrow = n, ncol = p)
    m.list <- m.deriv.list <- list()
    length(m.list) <- length(m.deriv.list) <- p

    lower.slopes <- upper.slopes <- list()

    for(j in 1:p){
      ## Extract current predictor
      x.current     <- x[,j]
      x.cut[,j]     <- x.current

      ## Current basis matrix (B-spline basis)
      bas           <- object$splineobj$basis[[j]]

      ## Get the smallest and largest knots (=boundaries)
      lower.end     <- bas$rangeval[1]
      upper.end     <- bas$rangeval[2]

      ## Which observations are exceeding the boundary-values?
      ind.lower     <- x.current < lower.end
      ind.upper     <- x.current > upper.end

      lowdiff[ind.lower,j]  <- (x.current - lower.end)[ind.lower]
      highdiff[ind.upper,j] <- (x.current - upper.end)[ind.upper]

      x.cut[ind.lower,j] <- lower.end
      x.cut[ind.upper,j] <- upper.end

      ## Get the slopes at the boundaries
      m.list[[j]] <- eval.basis(x.cut[,j], bas)
      deriv.info  <- eval.basis(c(lower.end, upper.end), bas, Lfdobj = 1)

      lower.slopes[[j]] <- deriv.info[1,]
      upper.slopes[[j]] <- deriv.info[2,]
    }
    m     <- matrix(unlist(m.list), nrow = n) ## Gets filled *columnwise*
    index <- object$splineobj$index ## without intercept

    for(l in 1:nr.lambda.pen){
      ##cat(l, "\n")
      for(u in 1:nr.lambda.curv){
        beta <- coef(object)[l,u,]

        pred.pre <- cbind(1, m) %*% coef(object)[l,u,]

        ## Put the design matrix of the first derivates (lower.slopes,
        ## upper.slopes) into one long vector each (same length as index) and
        ## multiply with beta vector and take the sum. I.e. perform the matrix
        ## operation in a bit a special form.
        ## The result are the derivatives at the left- and the right-hand side
        ## boundaries of the training range (of the fitted object with the
        ## current coefficients)
        slopes.left  <- rowsum(unlist(lower.slopes) * beta[-1],
                               group = index)
        slopes.right <- rowsum(unlist(upper.slopes) * beta[-1],
                               group = index)

        ## Now we have to multiply the derivatives with the difference
        ## in the x-values (contained in lowdiff and highdiff)
        ## lowdiff and highdiff are matrices with dimensions n x p, i.e. the
        ## dimension of the newdata object.
        ## Each column of lowdiff and highdiff is multiplied with the slope
        ## value. The result will be what we have to add beyond the boundaries.
        ## add.left and add.right will also have dimension n x p.

        ## 'as.array' is here to force a warning message if recycling would
        ## take place (see help file of sweep)
        add.left  <- sweep(lowdiff, MARGIN = 2, STATS = as.array(slopes.left),
                           FUN = "*")
        add.right <- sweep(highdiff, MARGIN = 2, STATS = as.array(slopes.right),
                           FUN = "*")

        ## Calculate the final prediction:
        ## Take the prediction of the 'cut-down' matrix and add the linear
        ## extrapolation part (add.left + add.right). We have to take the sum
        ## in each row of the linear extrapolation part (add.left + add.right)
        pred[l,u,] <- pred.pre + rowSums(add.left + add.right)
      }
    }
  }

  ## Transform to original scale if necessary
  pred <- switch(type,
                 link     = pred,
                 response = object$model@invlink(pred))

  dims <- dim(pred)

  ## If we have only one combination of lpen/lcurv we allow drop = TRUE.
  ## In all other cases
  if(dims[1] == 1 & dims[2] == 1)
    pred <- pred[1,1,,drop = TRUE]

  attr(pred, "lambda.pen")  <- object$lambda.pen
  attr(pred, "lambda.curv") <- object$lambda.curv

  pred
  ##out <- list(pred = pred,
  ##            lambda.pen  = object$lambda.pen,
  ##            lambda.curv = object$lambda.curv)
  ##out
}

plot.penGAM <- function(x, which = NULL, ask = TRUE && dev.interactive(),
                        nrgrid = 100, ...)
{
  ## Purpose:
  ## ----------------------------------------------------------------------
  ## Arguments:
  ## ----------------------------------------------------------------------
  ## Author: Lukas Meier, Date:  6 May 2008, 12:08

  n      <- NROW(x$splineobj$m[[1]])
  index  <- x$splineobj$index

  p      <- index[length(index)]

  dims   <- dim(coef(x))
  if(dims[1] > 1 | dims[2] > 1)
    stop("Use plot(fit[i,j]) to select the desired penalty parameters")

  coefs <- coef(x)[1, 1,][-1] ## without intercept!

  if(is.null(which))
    which <- 1:p
  if(ask){
    op <- par(ask = TRUE)
    on.exit(par(op)) ## use original settings when we leave the function
  }

  for(j in 1:length(which)){
    bas       <- x$splineobj$basis[[j]]
    rng       <- bas$range
    x.current <- seq(rng[1], rng[2], length = nrgrid)
    m.current <- eval.basis(x.current, basisobj = bas)
    ind       <- index == which[j]
    fn        <- scale(m.current %*% coefs[ind], scale = FALSE)
    plot(sort(x.current), fn[order(x.current)], type = "l",
         xlab = x$colnames[which[j]], ylab = bquote(f[.(which[j])]), ...)
  }
}

"[.penGAM" <- function(x, i, j){
  ## Purpose:
  ## ----------------------------------------------------------------------
  ## Arguments:
  ## ----------------------------------------------------------------------
  ## Author: Lukas Meier, Date:  6 May 2008, 12:08

  ## First get dimensions of the original object x
  dim <- dim(coef(x))
  nrlambda.pen  <- dim[1]
  nrlambda.curv <- dim[2]

  if(missing(i))
    i <- 1:nrlambda.pen
  if(missing(j))
    j <- 1:nrlambda.curv

  ## Subset the object
  fit.red <- x

  fit.red$coefficients <- coef(x)[i,j,,drop = FALSE]

  ## We do not allow the situation where everything is removed
  if(length(fit.red$coefficients) == 0)
    stop("Not allowed to remove everything!")

  fit.red$lambda.max   <- x$lambda.max[j]
  fit.red$lambda.pen   <- x$lambda.pen[i]
  fit.red$lambda.curv  <- x$lambda.curv[j]

  fit.red
}

getDesign <- function(x, knots = 10, norder = 4)
{
  ## Purpose: Get design matrix and penalty matrix in the basis of
  ##          B-splines
  ## ----------------------------------------------------------------------
  ## Arguments: x:       Design matrix, *without* intercept column
  ##            nrknots: Number of quantiles at which to put knots
  ##                     (these will be evenly spaced on the quantile scale
  ##                      between 0 and 1)
  ##            norder:  Set norder = 4 for piecewise cubic polynomials
  ## ----------------------------------------------------------------------
  ## Author: Lukas Meier, Date:  4 Mar 2008, 14:49

  p <- NCOL(x)

  if(is.null(colnames(x)))
    colnames(x) <- paste("x", 1:p, sep = "")

  ## If knots is only a number, we have to create the knots first for each
  ## predictor
  if(is.numeric(knots)){
    knots.use <- list()
    for(j in 1:p){
      x.current <- x[,j]
      ## Make sure that we do not place multiple knots at the same
      ## x value (if we have replicates etc.)
      ux.current <- unique(x.current)

      if(knots > length(ux.current)){
        nrknots.use <- length(ux.current)
        cat("Too many knots in predictor", j, "...\n")
        cat("Using as many knots as there are unique predictor values.\n")
      }else{
        nrknots.use <- knots
      }
      knots.use[[j]] <- quantile(ux.current, seq(0, 1, length = nrknots.use))
    }
  }else if(is.list(knots)){
    if(length(list) != p)
      stop("knots has wrong length")

    knots.use <- knots
  }

  ## Create the design and the penalty matrix
  m     <- list()
  pen   <- list()
  basis <- list()
  length(m) <- length(pen) <- length(basis) <- p

  df    <- numeric(p)

  for(j in 1:p){
    x.current <- x[,j]

    ## Create knot sequence
    breaks  <- knots.use[[j]]
    stopifnot(all.equal(range(breaks), range(x.current)))

    ## Get basis-object for the j-th spline
    basis[[j]] <- create.bspline.basis(rangeval = range(breaks),
                                       breaks = breaks, norder = norder)
    ## removed range(x.current)

    ## Get the design matrix for the j-th spline (with the basis of above)
    m[[j]] <- eval.basis(x.current, basis[[j]])

    ## Get the degrees of freedom for the current predictor
    df[j] <- NCOL(m[[j]])

    colnames(m[[j]]) <- paste(colnames(x)[j], ".", 1:df[j], sep = "")

    ## Get penalty matrix ## !!! DOUBLE-CHECK THIS !!!
    pen[[j]] <- getbasispenalty(basis[[j]], Lfdobj = 2)
  }
  list(m = m, pen = pen, basis = basis, index = rep(1:p, times = df))
}

.onAttach <- function(libname, pkgname){
  cat("----------------------------------------------------------------------",
      "Please note that this is an early test release of package 'penGAM'.",
      "It should only be used for experimental reasons. Use at your own risk!",
      "----------------------------------------------------------------------",
      sep = "\n")
}


#install.packages("ggplot2")

require("ggplot2")
par(mfrow=c(1,1))

custom.col <- c("#FFDB6D", "#C4961A", "#F4EDCA",
                "#D16103", "#C3D7A4", "#52854C", "#4E84C4", "#293352")

setwd("C:/Code/climData/glaser2019")

pt1 <- read.csv("csv/p_1000_2018.csv", sep=",", na = "NA")
pt1$m <- NULL
pt1 <- subset(pt1, pt$year>1499)

pt2 <- subset(pt1, !is.na(pt1$precipitation))

mp <- ggplot(pt2, aes(year, month))
mp + geom_raster(aes(fill=precipitation))+
  #theme_classic(base_size=80) +
  theme_classic() +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_x_continuous(limits=c(1500,2020)) +
  scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30") +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="PI", reverse = TRUE))

frq <- fft(pt1$precipitation, inverse = FALSE)
frq2 <- frq

mA <- mean(Mod(frq))
sA   <- sd(Mod(frq))

#frq <- replace(frq, Mod(frq)<mA+2*sA, 0.0)
frq[2000:4000] <- 0.0
frq[490:5510] <- 0.0

frq3 <- frq

mA <- mean(Mod(frq[0:100]))
sA   <- sd(Mod(frq[0:100]))

frq <- replace(frq, Mod(frq)<(mA+sA), 0.0)

for(i in 1:length(frq)) {
  frq[i] <- frq[i]*max(Mod(frq[i])-mA-sA, 0.0)/Mod(frq[i])
}

frq[100:5900] <- 0.0

frq[492:504] <- frq2[492:504]
frq[5490:5525] <- frq2[5490:5525]
frq[992:1004] <- frq2[992:1004]
frq[4990:5025] <- frq2[4990:5025]

amp <- cbind(0:(length(frq)-1), Mod(frq))
plot(amp, t="h", lwd=2, main="",
     xlab="Frequency", ylab="Ampl",
     xlim=c(0,length(amp)/2), ylim=c(0,max(Mod(frq))))

plot(amp, t="h", lwd=2, main="",
     xlab="Frequency", ylab="Ampl",
     xlim=c(0,100), ylim=c(0,max(Mod(frq))))

pt8 <- pt1
pt8$precipitation <- Re(fft(frq3, inverse = TRUE)/length(frq3))

pt9 <- pt1
pt9$precipitation <- Re(fft(frq, inverse = TRUE)/length(frq))

mp <- ggplot(pt8, aes(year, month))
mp + geom_raster(aes(fill=precipitation))+
  #theme_classic(base_size=80) +
  theme_classic() +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_x_continuous(limits=c(1500,2020)) +
  scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30") +
  theme( legend.key.width = unit(2,"cm")) +
  geom_line(aes(y=6+3*pt9$precipitation, x=pt9$time)) +
  guides(fill=guide_legend(title="PI", reverse = TRUE))

mp <- ggplot()
mp + geom_line(aes(y=pt9$precipitation, x=pt9$time))

mp <- ggplot()
mp + geom_line(aes(y=pt2$precipitation, x=pt2$time))


# to install hastaLaVista package use the following:
# devtools::install_github("jwist/hastaLaVista")
# the simply load the library
library(hastaLaVista)

# load demo dataset
data("bariatricRat")
metadata <- bariatricRat$metadata

data("bariatricRat.binned.4")

Xn.binned <- bariatricRat.binned.4$binned.data
ppm.binned <- bariatricRat.binned.4$binned.ppm
matspec(ppm.binned, Xn.binned, shift=c(7,8))

ID <- metadata$Sample.Label
group <- metadata$Class
metadata <- data.frame(metadata)
x <- matrix(Xn.binned, dim(Xn.binned)[1], dim(Xn.binned)[2])
x_axis <- as.numeric( ppm.binned )
color = sapply(group, function(x) getColor2(as.character(x)))

d = list()
c <- data.frame(ID = ID,
                group = group,
                color = color,
                "_highlight" = seq_along(group) - 1,
                dataMatrix = I(matrix( c(rbind(repRow(x_axis, nrow(x)), x)), nrow(x), ncol(x)*2)),
                metadata = I(metadata),
                check.names = FALSE
)
d <- appendData(data = d, variableName = "data", variable = c, type = "table")
d <- appendData(data = d, variableName = "xAxis", variable = x_axis, type = "table")

imag = NULL
for (i in seq(from=2, to=5728*2, by=2)) {
  png(tf1 <- tempfile(fileext = ".png"));  boxplot( dataMatrix[,i] ~ group, data = c); dev.off()
  imag[[i/2]] <- paste0("data:image/png;base64,", base64enc::base64encode(tf1))
}
l <- data.frame("_highlight" = seq_along(x_axis),
                value = unlist(imag),
                check.names = FALSE)
d <- appendData(data = d, variableName = "img", variable = l, type = "table")

v5 <- new("visualization")
v5@view <- "univariate_1_1.view.json"
v5@data <- "univariateExplorer.data.json"
push(v5, type="data", d)
visualize(v5)


#研究t_for时间，即弯月面形成时间
#x轴是电压频率，y轴是t_for，legend是流量

#设定工作目录
setwd("D:/data")
library(xlsx)
 library(RColorBrewer)

#读取数据
q1<-read.xlsx("t_for_z.xls", sheetName = "15", header = TRUE)
q2<-read.xlsx("t_for_z.xls", sheetName = "27", header = TRUE)
q3<-read.xlsx("t_for_z.xls", sheetName = "54", header = TRUE)
q4<-read.xlsx("t_for_z.xls", sheetName = "180", header = TRUE)
#names(q1)<-c("q", 5, 10, 20, 30, 50, 75, 100, 125, 150, 175, 200, 250)
#seq(from=0， to=1, seq.out=12)
mycolors <-brewer.pal(12,"Paired")
par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(2,2,2,2))

plot(q1$k, q1[,1], xaxs = "r", col = 0, xlab = "Duty cycle k ", ylab = "t_for (ms)", main = "Q = 1.5nl/min", cex.lab = 1, cex.main = 1.3, xlim = c(0.2, 0.5), ylim = c(0.2, 40))
for (i in 1:12) {
lines(q1$k, q1[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

plot(q2$k, q2[,1], xaxs = "r", col = 0, xlab = "Duty cycle k", ylab = "t_for (ms)", main = "Q = 27nl/min", cex.lab = 1, cex.main = 1.3, xlim = c(0.2, 0.5), ylim = c(0.2, 40))
for (i in 1:12) {
lines(q2$k, q2[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

plot(q3$k, q3[,1], xaxs = "r", col = 0, xlab = "Duty cycle k", ylab = "t_for (ms)", main = "Q = 54nl/min", cex.lab = 1, cex.main = 1.3, xlim = c(0.2, 0.5), ylim = c(0.2, 25))
for (i in 1:12) {
lines(q3$k, q3[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

plot(q4$k, q4[,1], xaxs = "r", col = 0, xlab = "Duty cycle k", ylab = "t_for (ms)", main = "Q = 180nl/min", cex.lab = 1, cex.main = 1.3, xlim = c(0.2, 0.5), ylim = c(0.2, 50))
for (i in 1:12) {
lines(q4$k, q4[, i+1], col=mycolors[i], lwd=2, type="l", lty=1)
}

legend("topleft", c("5Hz", "10Hz", "20Hz", "30Hz", "50Hz", "75Hz", "100Hz", "125Hz", "150Hz", "175Hz", "200Hz", "250Hz"), col = mycolors, lwd = 2, lty = 1, cex = 0.9, bty = "n", inset = .03)


# Conditional statements
# Reviewing the conditional operators (if statements)

# 1. Simple if statement
# Variables related to your last day of recordings
medium <- "LinkedIn"
num_views <- 20

# Examine the if statement for medium
if (medium == "LinkedIn") {
  print("Showing LinkedIn information")
}

# Write the if statement for num_views
if (num_views > 15) {
  print("You are popular!")
}

# 2. Adding the else statement component
# Control structure for medium
if (medium == "LinkedIn") {
  print("Showing LinkedIn information")
} else {
  print("Unknown medium")
}

# Control structure for num_views
if (num_views > 15) {
  print("You're popular!")
} else {
  print("Try to be more visible!")
}

# 3. Add else if statement
# Control structure for medium
if (medium == "LinkedIn") {
  print("Showing LinkedIn information")
} else if (medium == "Facebook") {
  print("Showing Facebook information")
} else {
  print("Unknown medium")
}

# Control structure for num_views
if (num_views > 15) {
  print("You're popular!")
} else if (num_views <= 15 & num_views > 10) {
  print("Your number of views is average")
} else {
  print("Try to be more visible!")
}

# 4. All together: relational operators, logical operators and control constructs
# Variables related to your last day of recordings
li <- 15
fb <- 9

# Code the control-flow construct
if (li >= 15 & fb >= 15) {
  sms <- 2 * (li + fb)
} else if (li < 10 & fb < 10) {
  sms <- 0.5 * (li + fb)
} else {
  sms <- li + fb
}

# Print the resulting sms to the console
sms


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Optimization Functions
# Copyright (C) 2011  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
# Solve LP problem, handling negative x
###############################################################################
# Tradional LP problem : http://lpsolve.sourceforge.net/5.5/LPBasics.htm
# maximize     C x
# subject to   A x <= B
#              x >= 0 - NOTE LP assumes all x >= 0
###############################################################################
# http://r.789695.n4.nabble.com/help-using-R-s-linprog-for-LP-td906987.html
# NOTE: Linear Programming (LP) assumes x >= 0
#
# The constraints x >= 0 are used in most linear programming realizations.
# Some bounds from below are needed. The trick to circumvent the restriction
# is as follows:
#
# Assume you know  x >= d  where some or all of the d_i can be negative.
# Replace x with  y = x - d >= 0  and minimize c'y with  Ay <= b - A d !
# Your solution is then  x = y + d , that is
#
# solveLP(cvec, bvec - Amat %*% dvec, Amat)$solution + dvec
#
# For portfolio weights, it is safe to assume that x.i >= -100
#' @export
###############################################################################
solve.LP.bounds <- function
(
	direction, 		# lp parameters
	objective.in, 	# lp parameters
	const.mat, 		# lp parameters
	const.dir,		# lp parameters
	const.rhs, 		# lp parameters
	binary.vec = 0,	# lp parameters
	lb = 0,			# vector with lower bounds
	ub = +Inf,		# vector with upper bounds
	default.lb = -100	# the smallest possible value for any variable
)
{
	# number variables
	n = len(objective.in)

	if( len(lb) == 1 ) lb = rep(lb, n)
	if( len(ub) == 1 ) ub = rep(ub, n)

	lb = ifna(lb, default.lb)
	ub = ifna(ub, +Inf)

	lb[ lb < default.lb ] = default.lb
	dvec = lb

	# add ub constraints
	index = which( ub < +Inf )
	if( len(index) > 0 ) {
		const.rhs = c(const.rhs, ub[index])
		const.dir = c(const.dir, rep('<=', len(index)))
		const.mat = rbind(const.mat, diag(n)[index, ])
	}

	# main logic
	if ( binary.vec[1] == 0 ) {
		sol = lp( direction, objective.in, const.mat, const.dir,
				const.rhs - const.mat %*% dvec )
	} else {
		dvec[binary.vec] = 0
		sol = lp( direction, objective.in, const.mat, const.dir,
				const.rhs - const.mat %*% dvec, binary.vec = binary.vec )

	}

	# update solution
	sol$solution = sol$solution + dvec
	sol$value = objective.in %*% sol$solution

	return( sol )
}

###############################################################################
# Solve QP problem, handling binary variables using Binary Branch and Bound
#' @export
###############################################################################
solve.QP.bounds <- function
(
	Dmat,				# solve.QP parameters
	dvec, 				# solve.QP parameters
	Amat, 				# solve.QP parameters
	bvec, 				# solve.QP parameters
	meq=0, 				# solve.QP parameters
	factorized=FALSE, 	# solve.QP parameters
	binary.vec = 0,		# vector with indices of binary variables
	lb = -Inf,			# vector with lower bounds
	ub = +Inf			# vector with upper bounds
)
{
	Amat1 = Amat
	bvec1 = bvec

	# number variables
	n = len(dvec)

	if( len(lb) == 1 ) lb = rep(lb, n)
	if( len(ub) == 1 ) ub = rep(ub, n)

	lb = ifna(lb, -Inf)
	ub = ifna(ub, +Inf)

	# add ub constraints, A^T b >= b_0
	index = which( ub < +Inf )
	if( len(index) > 0 ) {
		bvec = c(bvec, -ub[index])
		Amat = cbind(Amat, -diag(n)[, index])
	}

	# add lb constraints, A^T b >= b_0
	index = which( lb > -Inf )
	if( len(index) > 0 ) {
		bvec = c(bvec, lb[index])
		Amat = cbind(Amat, diag(n)[, index])
	}

	# main logic
	if ( binary.vec[1] == 0 ) {
		# logic to check for constant variables
		qp.data.final = solve.QP.remove.equality.constraints(Dmat, dvec, Amat, bvec, meq)
			Dmat = qp.data.final$Dmat
			dvec = qp.data.final$dvec
			Amat = qp.data.final$Amat
			bvec = qp.data.final$bvec
			meq = qp.data.final$meq

		# solve.QP: min(-d^T w.i + 1/2 w.i^T D w.i) subject to A^T w.i >= b_0
		sol = try(solve.QP(Dmat, dvec, Amat, bvec, meq, factorized),TRUE)

		# lot's of errors take place because covariance matrix is not positive defined
		if(inherits(sol, 'try-error')) {
#cat('solve.QP error\n')
#print(sol)
			ok = F
			sol = list()
		} else {
			# check that solve.QP solution satisfies constraints
			tol = 1e-3
			ok = T

			check = sol$solution %*% Amat - bvec
			if(meq > 0) ok = ok & all(abs(check[1:meq]) <= tol)
			ok = ok & all(check[-c(1:meq)] > -tol)
#if(!ok) cat('solve.QP violates constraints\n')
#if(!ok) print(sol$solution)
		}

		# try to solve problem one more time using ipop function from kernlab package
		if(!ok) {
			require(kernlab)
#cat('kernlab\n')
			index.constant.variables = which(!is.na(qp.data.final$solution))
			if( len(index.constant.variables) > 0 ) {
				# Amat1 and bvec1 might be incorrect
				Amat1 = Amat[,1:ncol(Amat1)]
				bvec1 = bvec[1:ncol(Amat1)]
				lb = lb[-index.constant.variables]
				ub = ub[-index.constant.variables]
			}

			# ipop: min(c'*x + 1/2 * x' * H * x) subject to b <= A * x <= b + r and l <= x <= u
			sv = ipop(c = matrix(-dvec), H = Dmat, A = t(Amat1),
					b = bvec1, l = ifna(lb,-100), u = ifna(ub,100),
					r = c(rep(0,meq), rep(100, len(bvec1) - meq))
				)
			sol$solution = primal(sv)
		}

		# logic to check for constant variables
		x = qp.data.final$solution
		x[qp.data.final$var.index] = sol$solution
		sol$solution = x

	} else {
		# use Binary Branch and Bound
		qp_data = qp_new(binary.vec, Dmat = Dmat, dvec = dvec,
						Amat=Amat, bvec=bvec, meq=meq, factorized=factorized)

		sol = binary_branch_bound(binary.vec, qp_data, qp_solve,
				control = bbb_control(silent=T, branchvar='max', searchdir='best' ))

		qp_delete(qp_data)

		sol$value = sol$fmin
		sol$solution = sol$xmin
	}

	return(sol)
}

###############################################################################
# QP interface for Binary Branch and Bound algorithm
###############################################################################
# control list for binary_branch_bound
#' @export
###############################################################################
bbb_control <- function
(
	itermax = 200, 			# maximum number of iterations
	depthmax = Inf, 		# maximum search depth
	bineps = 1e-4, 			# eps to determine whether a solution is 0/1
	precisioneps = 0, 		# stop condition for incremental improvement in best solution
	silent = T,				# quite or verbose
	branchvar = c('first', 'max','min'),
							# first = first free variable
							# max = variable with max frac part
							# min = variable with min frac part
	proborder = c('0', '1', 'mindiff'),
							# 0 = problems are put onto the stack '0' first, '1' next
							# 1 = problems are put onto the stack '1' first, '0' next
							# mindiff = problems are put onto the stack closest to '0' or '1' first
	searchdir = c('depth', 'breadth', 'best', 'normbest')
							# depth = depth first
							# breadth = breadth first
							# best = best first
							# normbest = best first with normalized cost
)
{
	# parse default arguments
	branchvar = switch(branchvar[1],
						'first' = 0,
						'max' = 1,
						'min' = 2,
						0)
	branchvar = iif( is.null(branchvar),0, branchvar)

	proborder = switch(proborder[1],
						'0' = 0,
						'1' = 1,
						'mindiff' = 2,
						0)
	proborder = iif( is.null(proborder),0, proborder)

	searchdir = switch(searchdir[1],
						'depth' = 0,
						'breadth' = 1,
						'best' = 2,
						'normbest' = 2,
						0)
	searchdir = iif( is.null(searchdir),0, searchdir)

	control = list(itermax = itermax, depthmax = depthmax, bineps = bineps, precisioneps = precisioneps, silent = silent,
				branchvar = branchvar,
				proborder = proborder,
				searchdir = searchdir)
	return(control)
}

###############################################################################
# Initialize QP
###############################################################################
qp_new <- function
(
	index_binvar, 	# index of binary variables
	Dmat, 			# paramters from solve.QP from quaprog library
	dvec,
	Amat,
	bvec,
	meq = 0,
	factorized = FALSE
)
{
	# add 0,1 bounds for the binary variables
		nbinvar = length(index_binvar)
		nx = nrow(Dmat)
		nbvec = length(bvec)

	# Note 0, -1 bounds 0 to 1
	Amat = cbind( Amat, diag(nx)[,index_binvar], -diag(nx)[,index_binvar] )
	bvec = c(bvec, rep(0,nx)[index_binvar], rep(1,nx)[index_binvar] )
		lb_bin_index = (1:nbinvar) + nbvec
		ub_bin_index = (1:nbinvar) + nbvec + nbinvar

	# create output
	qp_data = new.env()
		qp_data$Dmat = Dmat
		qp_data$dvec = dvec
		qp_data$Amat = Amat
		qp_data$bvec = bvec
		qp_data$meq = meq
		qp_data$factorized = factorized
		qp_data$x0 = rep(0,nx)

		qp_data$lb_bin_index = lb_bin_index
		qp_data$ub_bin_index = ub_bin_index
		qp_data$lb = bvec[lb_bin_index]
		qp_data$ub = bvec[ub_bin_index]

	return(qp_data)
}

###############################################################################
# Delete QP
###############################################################################
qp_delete <- function(qp_data)
{
	rm(list = ls(qp_data,all=TRUE), envir = qp_data)
}

###############################################################################
# Solve QP problem
###############################################################################
qp_solve <- function
(
	qp_data,
	lb,
	ub
)
{
	bvec = qp_data$bvec
	bvec[qp_data$lb_bin_index] = lb
	# Note 0, -1 bounds 0 to 1
	bvec[qp_data$ub_bin_index] = -ub

	# NEW logic to remove reduandant equality constraints in QP problem
	qp.data.final = solve.QP.remove.equality.constraints(qp_data$Dmat, qp_data$dvec,
							qp_data$Amat, bvec, qp_data$meq)
	# end of NEW logic

	sol = tryCatch( solve.QP(Dmat=qp.data.final$Dmat, dvec=qp.data.final$dvec, Amat=qp.data.final$Amat,
						bvec=qp.data.final$bvec, meq=qp.data.final$meq, factorized=qp_data$factorized),
		error=function( err ) FALSE,
	    warning=function( warn ) FALSE )

	if( !is.logical( sol ) ) {
		x = qp.data.final$solution
		x[qp.data.final$var.index] = sol$solution

		return(list( ok = TRUE, x = x, fval = sol$value ))
	} else {
		return(list( ok = FALSE ))
	}
}

###############################################################################
# Test QP interface to Binary Branch and Bound algorithm
###############################################################################
mbqp.test <- function()
{
	load.packages('quadprog')

	# Test problem
	# min         0.5*x'Q x + b' x
	# subject to  Cx <= d
	Q = diag(4)
	b	= c( 2, -3, -2, -3)
	C	= matrix(c(-1,  -1,  -1,  -1,
    				10,	5,   3,	4,
    				-1,	0,   0,	0),
    		3,4,byrow = TRUE)
	d = c(-2, 10,  0)

	vlb  = c(-1e10, 0, 0, 0);
	vub  = c( 1e10, 1, 1, 1);

	index_binvar = c(2, 3, 4);

	# Solve.QP
	# min(-d^T b + 1/2 b^T D b) : A^T b >= b_0
	# meq the first meq constraints are treated as equality constraints, all further as inequality constraints (defaults to 0).
	Dmat = Q
	dvec = -b
	Amat = -t(C)
	bvec = -d

	# add vlb / vub
	n = nrow(Dmat)
	Amat = cbind( Amat, diag(n), -diag(n) )
	bvec = c( bvec, vlb, -vub )

	sol = solve.QP(Dmat=Dmat, dvec=dvec, Amat=Amat, bvec=bvec, meq=0)
		xsol = sol$solution
		fsol = sol$value

	cat('QP.solve fsol =', fsol, 'xsol =', xsol, '\n')

	# Start Branch and Bound
	sol = solve.QP.bounds(Dmat=Dmat, dvec=dvec, Amat=Amat, bvec=bvec, meq=0, binary.vec = index_binvar)
		xsol = sol$solution
		fsol = sol$value

	cat('QP.solve Binary Branch and Bound fsol =', fsol, 'xsol =', xsol, '\n')

}

###############################################################################
# Oriingal version is too slow working on a new faster version
###############################################################################
# Logic to remove reduandant equality constraints in QP problem, based on qp_solve
solve.QP.remove.equality.constraints <- function
(
	Dmat,				# solve.QP parameters
	dvec, 				# solve.QP parameters
	Amat, 				# solve.QP parameters
	bvec, 				# solve.QP parameters
	meq=0 				# solve.QP parameters
)
{
	qp.data = list()
		qp.data$Amat = Amat
		qp.data$bvec = bvec
		qp.data$Dmat = Dmat
		qp.data$dvec = dvec
		qp.data$meq = meq

	Amat1 = t(qp.data$Amat)
	bvec1 = qp.data$bvec
	Dmat1 = qp.data$Dmat
	dvec1 = qp.data$dvec
	meq1 = qp.data$meq

#Amat - var are rows, constr are columns
#Amat1 - constr are rows, var are columns
# 	Amat = matrix(1:20,nr=4)
#	Amat1 = t(Amat)
#	(1+0*Amat1[2:4,])/ c(1,2,3)

	# default
	qp.data$solution = rep(NA, ncol(Amat1))
	qp.data$var.index = 1:ncol(Amat1)

while(T) {

	# 1. find columns with just one non-zero element
	one.non.zero.index = which( rowSums(Amat1!=0) == 1 )

	if( len(one.non.zero.index) == 0 ) break

	# 2. divide these columns, and corresponding bvec by column's abs value
	temp0 = rowSums(Amat1[one.non.zero.index,])
	temp = abs( temp0 )
	bvec1[one.non.zero.index] = bvec1[one.non.zero.index] / temp
	Amat1[one.non.zero.index,] = Amat1[one.non.zero.index,] / temp

	temp0.index = matrix(1:ncol(Amat1), nr=ncol(Amat1), nc=len(one.non.zero.index))[t(Amat1[one.non.zero.index,]!=0)]

#Amat - var are rows, constr are columns
#Amat1 - constr are rows, var are columns

	# 3. look for pairs among one.non.zero.index colums
	# x >= value , -x>= -value => x = value
	equality.constraints = rep(NA, ncol(Amat1))
	lb = ub = rep(NA, ncol(Amat1))

	# Make sure if there are multiple matches only keep max for lb and min for ub

	index = temp0 > 0
	#lb[temp0.index[index]] = bvec1[one.non.zero.index[index]]
	##temp = tapply(bvec1[one.non.zero.index[index]], temp0.index[index], max)
	##lb[ as.double(names(temp)) ] = temp
	temp = order(bvec1[one.non.zero.index[index]], decreasing = FALSE)
	lb[temp0.index[index][temp]] = bvec1[one.non.zero.index[index]][temp]

	index = temp0 < 0
	#ub[temp0.index[index]] = -bvec1[one.non.zero.index[index]]
	##temp = tapply(-bvec1[one.non.zero.index[index]], temp0.index[index], min)
	##ub[ as.double(names(temp)) ] = temp
	temp = order(-bvec1[one.non.zero.index[index]], decreasing = TRUE)
	ub[temp0.index[index][temp]] = -bvec1[one.non.zero.index[index]][temp]

#a = rep(0,5)
#a[c(2,2,2)] = c(2,1,0)

	# 4. remove variables
	remove.index = which(lb == ub)
	if( len(remove.index) > 0 ) {
		equality.constraints[remove.index] = lb[remove.index]

		# remove variables
		Dmat1 = Dmat1[-remove.index, -remove.index,drop=F]
		dvec1 = dvec1[-remove.index]
		bvec1 = bvec1 - Amat1[,remove.index,drop=F] %*% equality.constraints[remove.index]
		Amat1 = Amat1[,-remove.index,drop=F]

		qp.data$solution[ qp.data$var.index[remove.index] ] = lb[remove.index]
		qp.data$var.index = which(is.na(qp.data$solution))

		# check if there are variables left
		if( ncol(Amat1) > 0 ) {

			# remove constraints
			remove.index = which( rowSums(Amat1!=0) == 0 & bvec1 == 0 )
			if(len(remove.index)>0) {
				bvec1 = bvec1[-remove.index]
				Amat1 = Amat1[-remove.index,,drop=F]

				# handle euality constraints
				if( meq1 > 0 ) meq1 = meq1 - len(intersect((1:meq1), remove.index))
			}
		} else break

	} else break

	}	# while(T)

	# prepare return object
	qp.data$Amat = t(Amat1)
	qp.data$bvec = bvec1
	qp.data$Dmat = Dmat1
	qp.data$dvec = dvec1
	qp.data$meq = meq1

	return(qp.data)
}

###############################################################################
# Find and remove equality constraints in QP problem (slow)
###############################################################################
# Logic to remove reduandant equality constraints in QP problem, based on qp_solve
solve.QP.remove.equality.constraints12 <- function
(
	Dmat,				# solve.QP parameters
	dvec, 				# solve.QP parameters
	Amat, 				# solve.QP parameters
	bvec, 				# solve.QP parameters
	meq=0 				# solve.QP parameters
)
{
	qp.data.temp = list()
		qp.data.temp$Amat = Amat
		qp.data.temp$bvec = bvec
		qp.data.temp$Dmat = Dmat
		qp.data.temp$dvec = dvec
		qp.data.temp$meq = meq

	qp.data.temp = remove.equality.constraints.old(qp.data.temp)
	# if no equality constraints found go to optimization
	if( len(qp.data.temp$var.index) == len(qp.data.temp$solution) ) {
		qp.data.final = qp.data.temp
	} else {
		# test for equality constraints one more time
		qp.data.final = remove.equality.constraints.old(qp.data.temp)
			qp.data.temp$solution[qp.data.temp$var.index] = qp.data.final$solution
				qp.data.final$solution = qp.data.temp$solution
			qp.data.final$var.index = qp.data.temp$var.index[qp.data.final$var.index]
	}

	return(qp.data.final)
}

remove.equality.constraints.old <- function(qp.data)
{
	#qp.data1 = qp.data.temp
	Amat1 = qp.data$Amat
	bvec1 = qp.data$bvec
	Dmat1 = qp.data$Dmat
	dvec1 = qp.data$dvec
	meq1 = qp.data$meq

	# 1. find columns with just one non-zero element
	one.non.zero.index = which( colSums(Amat1!=0) == 1 )

	if( len(one.non.zero.index) == 0 ) {
		equality.constraints = rep(NA, nrow(Amat1))
		qp.data$solution = equality.constraints
		qp.data$var.index = which(is.na(equality.constraints))
		return(qp.data)
	}

	# 2. divide these columns, and corresponding bvec by column's abs value
	bvec1[one.non.zero.index] = bvec1[one.non.zero.index] / abs( colSums(Amat1[,one.non.zero.index]) )
	Amat1[,one.non.zero.index] = Amat1[,one.non.zero.index] / abs( Amat1[,one.non.zero.index] )
	Amat1[is.na(Amat1)] = 0

	# 3. look for pairs among one.non.zero.index colums
	# x >= value , -x>= -value => x = value
	equality.constraints = rep(NA, nrow(Amat1))
	remove.constraints = rep(NA, ncol(Amat1))

	#for( r in 1:nrow(Amat1) ) {
	for( r in which(rowSums(Amat1[,one.non.zero.index]!=0) > 1) ) {
		temp.index = which( Amat1[,one.non.zero.index][r,] != 0 )

		for( r1 in temp.index[-1] ) {
			temp.index1 = colSums(abs(
			rbind(Amat1,bvec1)[,one.non.zero.index[temp.index]] +
			rbind(Amat1,bvec1)[,one.non.zero.index[r1]])
			)

			if( any(temp.index1 == 0 ) ) {
				equality.constraints[r] =
					bvec1[one.non.zero.index[r1]] / Amat1[r,one.non.zero.index[r1]]

				remove.constraints[ one.non.zero.index[r1] ] = 1
				remove.constraints[ one.non.zero.index[ temp.index[ temp.index1 == 0]]] = 1

				break;
			}
		}
	}

	# 4. remove variables
	remove.index = which(!is.na(equality.constraints))
	if(len(remove.index)>0) {
		# remove variables
		Dmat1 = Dmat1[-remove.index, -remove.index,drop=F]
		dvec1 = dvec1[-remove.index]
		bvec1 = bvec1 - equality.constraints[remove.index] %*% Amat1[remove.index,,drop=F]
		Amat1 = Amat1[-remove.index,,drop=F]

		# remove constraints
		#remove.index1 = which( colSums(abs(Amat1)) == 0 & bvec1 == 0)
		remove.index1 = which(remove.constraints==1)
		if(len(remove.index1)>0) {
			bvec1 = bvec1[-remove.index1]
			Amat1 = Amat1[,-remove.index1,drop=F]

			# handle euality constraints
			if( meq1 > 0 ) meq1 = meq1 - len(intersect((1:meq1), remove.index1))
		}
	}

	# prepare return object
	qp.data$Amat = Amat1
	qp.data$bvec = bvec1
	qp.data$Dmat = Dmat1
	qp.data$dvec = dvec1
	qp.data$meq = meq1

	qp.data$solution = equality.constraints
	qp.data$var.index = which(is.na(equality.constraints))

	return(qp.data)
}

###############################################################################
# Run linear least squares regression with constraints
#' @export
###############################################################################
lm.constraint <- function
(
	x,
	y,
	constraints = NULL
)
{
	if( is.null(constraints) ) {
		fit = lm.fit(x, y)
		return( ols.summary(x, y, fit$coefficients) )
	} else {
    	temp = cov(cbind(y, x))
		Dmat = temp[-1,-1]
		dvec = temp[-1,1]

		sol = solve.QP.bounds(Dmat = Dmat, dvec = dvec ,
				Amat=constraints$A, bvec=constraints$b, constraints$meq,
				lb = constraints$lb, ub = constraints$ub)
		return( ols.summary(x, y, sol$solution) )
	}
}

###############################################################################
# Run linear least squares regression
#' @export
###############################################################################
ols <- function
(
	x,
	y,
	computeSummary=F
)
{
	xx = t(x) %*% x

	if(is.null(ncol(xx))) { xinv = inv1(xx)
	} else if(ncol(xx) == 1) { xinv = inv1(xx)
	} else if(ncol(xx) == 2) { xinv = inv2(xx)
	} else if(ncol(xx) == 3) { xinv = inv3(xx)
	} else { xinv = inv(xx) }

	coefficients = xinv %*% t(x) %*% y
	if(computeSummary) {
		return( ols.summary(x, y, coefficients, xinv) )
	} else {
		return(list(coefficients = coefficients))
	}
}

#' @export
ols.summary <- function
(
	x,
	y,
	coefficients,
	xinv = NULL
)
{
	n = length(y)
	p = length(coefficients)
	rdf = n-p

	# error
   	e = y - x %*% coefficients
    ess=sum(e^2)
	mss = sum((y - sum(y)/n)^2)
	r.squared = 1 - ess/mss
	#r.squared = 1 - (var(e)/var(y))
	#adj.r.squared = 1 - (1 - r.squared)*(n - 1)/(n - p - 1)

	if( !is.null(xinv) ) {
		s2=ess/(rdf)
		seb=sqrt(diag(s2*xinv))
		tratio=coefficients/seb

		return(list(coefficients = coefficients, seb = seb,tratio = tratio, r.squared = r.squared))
	} else {
		return(list(coefficients = coefficients, r.squared = r.squared))
	}
}

ols.test <- function() {
	x = matrix( rnorm(4*10), ncol=4)
	y = rnorm(10)

	summary(lm(y ~ x+0))
	ols(x, y, T)
}

###############################################################################
# Compute matrix inverse
###############################################################################
#' @export
inv <- function(x) { solve(x) }

#' @export
inv1 <- function(x) { 1/x }

#http://www.mathwords.com/i/inverse_of_a_matrix.htm
#' @export
inv2 <- function(x)
{
	matrix(c(x[2,2],-x[1,2],-x[2,1],x[1,1]),nrow=2,byrow=T) / (x[1,1]*x[2,2] - x[1,2]*x[2,1])
}

#http://www.dr-lex.be/random/matrix_inv.html
#' @export
inv3 <- function(x)
{
	matrix(c(x[3,3]*x[2,2]-x[3,2]*x[2,3],-(x[3,3]*x[1,2]-x[3,2]*x[1,3]),x[2,3]*x[1,2]-x[2,2]*x[1,3],
	-(x[3,3]*x[2,1]-x[3,1]*x[2,3]),x[3,3]*x[1,1]-x[3,1]*x[1,3],-(x[2,3]*x[1,1]-x[2,1]*x[1,3]),
	x[3,2]*x[2,1]-x[3,1]*x[2,2],-(x[3,2]*x[1,1]-x[3,1]*x[1,2]),x[2,2]*x[1,1]-x[2,1]*x[1,2]),nrow=3,byrow=T) /
	(x[1,1]*(x[3,3]*x[2,2]-x[3,2]*x[2,3])-x[2,1]*(x[3,3]*x[1,2]-x[3,2]*x[1,3])+x[3,1]*(x[2,3]*x[1,2]-x[2,2]*x[1,3]))
}

inv.test <- function() {
	m=matrix(c(4,3,3,2),nrow=2,byrow=T)
	inv2(m) %*% m
	inv(m) %*% m

	m = matrix(c(1,2,3,4,5,6,7,8,8),ncol=3,byrow=T)
	inv3(m) %*% m
	m %*% inv3(m)
	inv(m) %*% m

}

###############################################################################
# Maximum Distance Point on the curve
# http://stackoverflow.com/questions/2018178/finding-the-best-trade-off-point-on-a-curve
#' @export
###############################################################################
find.maximum.distance.point <- function
(
	y,
	x=1:len(y)
)
{
	allCoord = rbind(vec(y), vec(x))

	firstPoint = allCoord[,1]
	lineVec = allCoord[,len(y)] - firstPoint
	lineVecN = lineVec / sqrt(sum(lineVec^2))

	vecFromFirst = allCoord - firstPoint
	scalarProduct = lineVecN %*% vecFromFirst

	vecFromFirstParallel = t(scalarProduct) %*% lineVecN
	vecToLine = t(vecFromFirst) - vecFromFirstParallel
	distToLine = sqrt(rowSums(vecToLine^2,2))
	which.max(distToLine)
}


if(A>a) # true, 84 > 42
{
  cat(A, ">", a, "\n")
}


library(tidyverse)

train <-
  read_csv("./0_raw/train.csv")

test <-
  read_csv("./0_raw/test.csv")

features_final <-
  readRDS('./2_model/final_features.rds')

new_train <-
  train[c(features$features, 'NU_NOTA_MT', 'NU_INSCRICAO')] %>%
  mutate_at(vars(c('NU_NOTA_CH', 'NU_NOTA_CN', 'NU_NOTA_LC', 'NU_NOTA_REDACAO', 'NU_NOTA_MT')), fill_numeric_na) %>%
  mutate_at(vars(c('TP_PRESENCA_CH', 'TP_PRESENCA_CN', 'TP_PRESENCA_LC', 'TP_STATUS_REDACAO')), function(x){as.factor(ifelse(is.na(x), -1, x))})

new_test <-
  test[c(features$features, 'NU_INSCRICAO')] %>%
  mutate_at(vars(c('NU_NOTA_CH', 'NU_NOTA_CN', 'NU_NOTA_LC', 'NU_NOTA_REDACAO')), fill_numeric_na) %>%
  mutate_at(vars(c('TP_PRESENCA_CH', 'TP_PRESENCA_CN', 'TP_PRESENCA_LC', 'TP_STATUS_REDACAO')), function(x){as.factor(ifelse(is.na(x), -1, x))}) %>%
  mutate(NU_NOTA_MT = NA)

fill_numeric_na <- function(x){
  as.integer(ifelse(is.na(x), 0, x))
  }

recipe <-
  recipe(NU_NOTA_MT ~ ., data = new_train) %>%
  update_role(NU_INSCRICAO, new_role = "id variable") %>%
  remove_role(NU_INSCRICAO, old_role = "predictor") %>%
  step_normalize(all_numeric(), -all_outcomes(), -has_role('id variable')) %>%
  prep(.)

train_baked <-
  recipe %>%
  bake(new_data = new_train)

modl_ml <-
  rand_forest(mode = "regression", trees = 100) %>%
  set_engine("ranger", importance = "impurity")

fit_ml <-
  modl_ml %>%
  fit(NU_NOTA_MT ~ ., data = train_baked)

test_baked <-
  recipe %>%
  bake(new_data = new_test)

test_final <-
    new_test %>%
    select(NU_INSCRICAO, NU_NOTA_MT)
test_final$NU_NOTA_MT <- predict(fit_ml, new_test)$.pred
write_csv('./')


#===============================================================
# Create the adjacency matrix indicating which of our users
# follow which politicians, and do the correspondence analysis
# to generate the projection matrix.
#
# This script assumes:
#  - followers lists are stored in folder followers_lists/
#  - user list is stored in user_list.csv
#
#===============================================================

library(Matrix)
library(methods)  # it doesn't work without this, not sure why
library(ca)

#===============================================================
# CENSUS: M = 443
# Creates list of all IDs in followers_lists (i.e., senators,
# representatives, and governors)
#===============================================================

outfolder <- "followers_lists/"
files <- list.files(outfolder, full.names = TRUE)
census <- gsub(".*/(.*).csv", files, repl = "\\1")

m <- length(census)

#===============================================================
# USERS: N = 2,839,448
# Creates list of all IDs of users in tweet collection
#===============================================================

# Cast users to a one-dimensional list
users <- read.csv("user_list.csv", colClasses = c("numeric", "NULL"))
users <- users[0:nrow(users), ]
save(users, file = "users_list.Rdata")

n <- length(users)

#===============================================================
# CREATE MATRIX
# Rows: users from collection (nrow = 2839448)
# Columns: politicians (ncol = 443)
# x[i][j] will be 1 if user i follows politician j
#===============================================================

rows <- list()
columns <- list()

progress <- txtProgressBar(min = 1, max = m, style = 3)

for (j in 1:m) {
    # Load list of followers for this politician; cast to one-dimensional list
    followers <- read.csv(files[j], colClasses = ("numeric"))
    followers <- followers[1:nrow(followers), ]

    # Figure out which of our users follow them
    to_add <- which(users %in% followers)
    rows[[j]] <- to_add
    columns[[j]] <- rep(j, length(to_add))

    setTxtProgressBar(progress, j)
}

rows <- unlist(rows)
columns <- unlist(columns)

# Prepare matrix. Rows are users from our collection; columns are politicians.
y <- sparseMatrix(i = rows, j = columns)
rownames(y) <- users[1:dim(y)[1]]
colnames(y) <- census[1:m]

save(y, file="adj_matrix.Rdata")

#===============================================================
# CORRESPONDENCE ANALYSIS
# Take users who follow at least 5 of the politicians
# identified above, then run correspondence analysis.
# Matrix "res" is S (standardized residuals)
#===============================================================

y <- y[rowSums(y) > 4, ]
y <- as.matrix(y)
res <- ca(y, nd = 3)

save(res, file="correspondence.Rdata")