#' Diagonal Linear Discriminant Analysis (DLDA)
#'
#' Given a set of training data, this function builds the Diagonal Linear
#' Discriminant Analysis (DLDA) classifier, which is often attributed to Dudoit
#' et al. (2002). The DLDA classifier belongs to the family of Naive Bayes
#' classifiers, where the distributions of each class are assumed to be
#' multivariate normal and to share a common covariance matrix.
#'
#' The DLDA classifier is a modification to the well-known LDA classifier, where
#' the off-diagonal elements of the pooled sample covariance matrix are assumed
#' to be zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of `x`
#' contain the sample observations, and the columns contain the features for each
#' training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations belonging
#' to each class. Otherwise, `prior` should be a vector with the same length
#' as the number of classes in `y`. The `prior` probabilities should be
#' nonnegative and sum to one.
#'
#' @export
#'
#' @param x Matrix or data frame containing the training data. The rows are the
#' sample observations, and the columns are the features. Only complete data are
#' retained.
#' @param y Vector of class labels for each training observation. Only complete
#' data are retained.
#' @param prior Vector with prior probabilities for each class. If NULL
#' (default), then equal probabilities are used. See details.
#' @return  The model fitting function returns the fitted classifier. The
#' `predict()` method returns either a vector (`type = "class"`) or a data
#' frame (all other `type` values).
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]
#' dlda_out <- lda_diag(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(dlda_out, penguins[pred_rows, -1], type = "class")
#'
#' dlda_out2 <- lda_diag(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(dlda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
lda_diag <- function(x, ...) {
  UseMethod("lda_diag")
}

#' @importFrom stats complete.cases
#' @rdname lda_diag
#' @export
lda_diag.default <- function(x, y, prior = NULL, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x = x, y = y, prior = prior, pool = TRUE)

  # Creates an object of type 'lda_diag'
  # Use columns that pass filters
  obj$col_names <- names(obj$est[[1]]$xbar)
  obj <- new_discrim_object(obj, "lda_diag")

  obj
}

#' @param formula A formula of the form `groups ~ x1 + x2 + ...` That is,
#' the response is the grouping factor and the right hand side specifies the
#' (non-factor) discriminators.
#' @param data data frame from which variables specified in `formula` are
#' preferentially to be taken.
#' @rdname lda_diag
#' @importFrom stats model.frame model.matrix model.response
#' @export
lda_diag.formula <- function(formula, data, prior = NULL, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- lda_diag.default(x = x, y = y, prior = prior)
  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a DLDA classifier object.
#'
#' Summarizes the trained DLDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @export
#' @keywords internal
print.lda_diag <- function(x, ...) {
  cat("Diagonal LDA\n\n")

  print_basics(x, ...)
  invisible(x)
}

#' DLDA prediction of the class membership of a matrix of new observations.
#'
#' The DLDA classifier is a modification to LDA, where the off-diagonal elements
#' of the pooled sample covariance matrix are set to zero.
#'
#' @rdname lda_diag
#' @export
#' @param object Fitted model object
#' @param newdata Matrix or data frame of observations to predict. Each row
#' corresponds to a new observation.
#' @param type Prediction type: either `"class"`, `"prob"`, or `"score"`.
#' @param ... additional arguments (not currently used).
predict.lda_diag <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / object$var_pool) + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- replicate(n = object$num_groups, object$var_pool, simplify = FALSE)
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)
  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}


# R FizzBuzz
fizzBuzz <- function(f){
  if (f%%5 == 0 && f%%3 == 0) {
    print('FizzBuzz')
  }
  else if(f%%5 == 0) {
    print('Buzz')
  }
  else if(f%%3 == 0) {
    print('Fizz')
  }
  else {
    print(f)
  }
}
sapply(seq(from = 1, to = 100, by = 1), fizzBuzz)


y <- runif(1:10000,min=0,max=180)

#exponential
x <- rexp(1:10000,3)
k2 <- cbind(x*sin(y),x*cos(y))

#uniform
x2 <- runif(1:10000,min=0,max=3)
k <- cbind(x2*sin(y),x2*cos(y))

write.table(k2,"circular_exp",row.names=F,col.names=F)
write.table(k,"circular_uniform",row.names=F,col.names=F)


library(seriation)
args <- commandArgs(TRUE)
meth <- as.character(args[1])

ser <- seriate(x = dist(read.table(file="R/temp.txt")), method = meth)
order1 <- get_order(ser[1])
write.csv(order1, paste("R/","row.order",sep=""), row.names=FALSE)
dev.off()


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('ordinal')
options(prType='latex')

## ----varclus,h=3,w=6.5,cap='Hierarchical variable clustering using Spearman $\\rho^2$ as a \\index{similarity measure}similarity measure for all pairs of variables.  Note that since the \\co{hlt} variable was nominal, it is represented by two dummy variables here.',scap='Clustering clinical signs for WHO study'----
require(rms)
getHdata(ari)  # defines ari, Sc, Y, Y.death
vclust <-
  varclus(~ illd + hlt + slpm + slpl + wake + convul + hfa +
            hfb  + hfe + hap  + hcl  + hcm  + hcs    + hdi +
            fde  + chi + twb  + ldy  + apn  + lcw    + nfl +
            str  + gru + coh  + ccy  + jau  + omph   + csd +
            csa  + aro + qcr  + con  + att  + mvm    + afe +
            absu + stu + deh  + dcp  + crs  + abb    + abk +
            whz  + hdb + smi2 + abd  + conj + oto    + puskin,
          data=ari)
plot(vclust)  # Figure (*\ref{fig:ordinal-varclus}*)

## ----ordinality,w=5,h=4,mfrow=c(3,4),las=0,cap='Examination of the ordinality of $Y$ for each predictor by assessing how varying $Y$ relate to the mean $X$, and whether the trend is monotonic.  Solid lines connect the simple stratified means, and dashed lines connect the estimated expected value of $X | Y=j$ given that PO holds.  Estimated expected values from the CR model are marked with \\texttt{C}s.',scap='Examination of ordinality of $Y$ for each $X$'----
Sc <- transform(Sc,
                ausc = 1 * (ausc == 3),
                bul.conv = 1 * (bul.conv == 'TRUE'),
                abdominal = 1 * (abdominal == 'TRUE'))
plot.xmean.ordinaly(Y ~ age + abs(temp-37) + abs(rr-60) +
                    abs(hrat-125) + waz + bul.conv + drowsy +
                    agitated + reffort + ausc + feeding +
                    abdominal, data=Sc, cr=TRUE,
                    subn=FALSE, cex.points=.65)  # Figure (*\ref{fig:ordinal-ordinality}*)

## -----------------------------------------------------------------------------
Sc$ageg <- cut2(Sc$age, c(7, 60))

## -----------------------------------------------------------------------------
vsign.trans <- transcan(~ temp + hrat + rr, data=Sc,
                        imputed=TRUE, pl=FALSE)
Sc <- transform(Sc,
                temp = impute(vsign.trans, temp),
                hrat = impute(vsign.trans, hrat),
                rr   = impute(vsign.trans, rr))

## ----results='asis'-----------------------------------------------------------
f1 <- lrm(Y ~ ageg*(rcs(temp,5)+rcs(rr,5)+rcs(hrat,4)) +
          rcs(waz,4) + bul.conv + drowsy + agitated +
          reffort + ausc + feeding + abdominal,
          data=Sc, x=TRUE, y=TRUE)
# x=TRUE, y=TRUE used by resid() below
print(f1, coefs=5)

## ----results='asis'-----------------------------------------------------------
print(anova(f1), label='ordinal-anova.f1',
  caption='Wald statistics from the proportional odds model',
  size='smaller')   # Table (*\ref{ordinal-anova.f1}*)

## ----score-binary,mfrow=c(2,2),las=0,cap='Binary logistic model score residuals for binary events derived from two cutoffs of the ordinal response $Y$.  Note that the mean residuals, marked with closed circles, correspond closely to differences between solid and dashed lines at $Y=1,2$ in Figure~\\ref{fig:ordinal-ordinality}.  Score residual assessments for spline-expanded variables such as \\co{rr} would have required one plot per d.f.',scap='Score residuals for checking PO assumption'----
resid(f1, 'score.binary', pl=TRUE, which=c(17,18,20,21))
## Figure (*\ref{fig:ordinal-score-binary}*)

## ----partial,mfrow=c(3,4),las=0,left=-2,w=5,h=4,cap='Smoothed partial residuals corresponding to two cutoffs of $Y$, from a model in which all predictors were assumed to operate linearly and additively.  The smoothed curves estimate the actual predictor transformations needed, and parallelism relates to the PO assumption.  Solid lines denote $Y\\geq 1$ while dashed lines denote $Y\\geq 2$.',scap='Partial residual plots for PO model'----
f2 <- lrm(Y ~ age + temp + rr + hrat + waz +
          bul.conv + drowsy + agitated + reffort + ausc +
          feeding + abdominal, data=Sc, x=TRUE, y=TRUE)
resid(f2, 'partial', pl=TRUE, label.curves=FALSE) # Figure (*\ref{fig:ordinal-partial}*)

## ----cratios,w=5,h=4,las=0,mfrow=c(3,4),left=-2,cap='\\co{loess} smoothed partial residual plots for binary models that are components of an ordinal continuation ratio model.  Solid lines correspond to a model for $Y=0$, and dotted lines correspond to a model for $Y=1 | Y\\geq 1$.',scap='Partial residual plots for CR model'----
cr0 <- lrm(Y==0 ~ age + temp + rr + hrat + waz +
           bul.conv + drowsy + agitated + reffort + ausc +
           feeding + abdominal, data=Sc, x=TRUE, y=TRUE)
# Use the update function to save repeating model right-
# hand side.  An indicator variable for Y=1 is the
# response variable below
cr1 <- update(cr0, Y==1 ~ ., subset=Y>=1)
plot.lrm.partial(cr0, cr1, center=TRUE)  # Figure (*\ref{fig:ordinal-cratios}*)

## -----------------------------------------------------------------------------
u <- cr.setup(Y)
Sc.expanded <- Sc[u$subs, ]
y      <- u$y
cohort <- u$cohort

## ----eval=FALSE,echo=FALSE----------------------------------------------------
## # Another version of the function below
## perf <- function(fit) {
##   Sc$cohort <- 'all'
##   pred.y0 <- predict(fit, Sc, type='fitted')
##   pred.ygt0 <- 1 - pred.y0
##   s <- somers2(pred.ygt0, Y > 0)
##   list(fractions=round(c(mean(pred.ygt0 < .05),
##          mean(pred.ygt0 > .25),
##          mean(pred.ygt0 > .5)), 2),
##        somers=s)
## }

## ----results='asis'-----------------------------------------------------------
full <-
  lrm(y ~ cohort*(ageg*(rcs(temp,5) + rcs(rr,5)) +
      rcs(waz,4) + bul.conv + drowsy + agitated + reffort +
      ausc + feeding + abdominal + hydration + hxprob +
      pustular + crying + fever.ill + stop.breath + labor),
      data=Sc.expanded, x=TRUE, y=TRUE)
# x=TRUE, y=TRUE are for pentrace, validate, calibrate below
perf <- function(fit) {  # model performance for Y=0
  pr <- predict(fit, type='fitted')[cohort == 'all']
  s <- round(somers2(pr, y[cohort == 'all']), 3)
  pr <- 1 - pr   # Predict Prob[Y > 0] instead of Prob[Y = 0]
  f <- round(c(mean(pr < .05), mean(pr > .25),
               mean(pr > .5)), 2)
  f <- paste(f[1], ', ', f[2], ', and ', f[3], '.', sep='')
  list(somers=s, fractions=f)
}
perf.unpen <- perf(full)
print(full, coefs=5)
print(anova(full, cohort),  # Table (*\ref{ordinal-anova.cohort}*)
   caption='Wald statistics for \\co{cohort} in the CR model',
   size='smaller[2]', label='ordinal-anova.cohort')
an <- anova(full, india=FALSE, indnl=FALSE)
print(an, label='ordinal-anova.full',
  caption='Wald statistics for the continuation ratio model.
   Interactions with \\co{cohort} assess non-proportional
   hazards', caption.lot='Wald statistics for $Y$ in the
                   continuation ratio model',
      size='smaller[2]')   # Table (*\ref{ordinal-anova.full}*)

## ----echo=FALSE, results='hide'-----------------------------------------------
anova(full)

## ----pentrace,cache=TRUE------------------------------------------------------
d <- options(digits=4)
pentrace(full,
         list(simple=c(0,.025,.05,.075,.1),
              interaction=c(0,10,50,100,125,150)))
options(d)

## ----fullpen,results='asis'---------------------------------------------------
full.pen <-
  update(full,
         penalty=list(simple=.05, interaction=125))
print(full.pen, coefs=FALSE)

## ----full-pen-anova,cap='Importance of predictors in full penalized model, as judged by partial Wald $\\chi^2$ minus the predictor d.f.  The Wald $\\chi^2$ values for each line in the dot plot include contributions from all higher-order effects.  Interaction effects by themselves have been removed as has the \\co{cohort} effect.',scap='Importance of predictors in penalized ordinal model'----
effective.df(full.pen)
## Compute discrimination for Y=0 vs. Y>0
perf.pen <- perf(full.pen)   # Figure (*\ref{fig:ordinal-full-pen-anova}*)
# Exclude interactions and cohort effects from plot
plot(anova(full.pen), cex.labels=0.75, rm.ia=TRUE,
     rm.other='cohort  (Factor+Higher Order Factors)')

## ----echo=FALSE---------------------------------------------------------------
# Workaround because \Sexpr below bombed
cat(perf.pen$fractions, '\n', file='fractions.tex')

## ----lfullpen,results='asis'--------------------------------------------------
print(full.pen, which=1:21)

## ----eval=FALSE,echo=FALSE----------------------------------------------------
## # To compare with how this was done in the first edition; didn't make a
## # difference; second plot is lower than original; figure out ref.zero changes
## dd <- datadist(Sc.expanded); dd <- datadist(dd, cohort)
## options(datadist='dd')
##
## p <- Predict(full.pen, temp, ageg, cohort='all', ref.zero=TRUE, conf.int=FALSE)
## p1 <- plot(p, adj.subtitle=FALSE, ylim=c(-2.5, 1))
## p <- Predict(full.pen, temp, ageg, cohort='Y>=1', ref.zero=TRUE, conf.int=FALSE)
## p2 <- plot(p, adj.subtitle=FALSE, ylim=c(-2.5, 1))
## print(p1, split=c(1, 1, 1, 2), more=TRUE)
## print(p2, split=c(1, 2, 1, 2), more=FALSE)

## ----shapes-age,w=4,h=5,cap='Centered effects of predictors on the log odds, showing the effects of two predictors with interaction effects for the \\co{age} intervals noted. The title \\co{all} refers to the prediction of $Y=0 | Y \\geq 0$, that is, $Y=0$.  \\co{Y$>$=1} refers to predicting the probability of $Y=1 | Y \\geq 1$.',scap='Shapes of effects of two predictors in ordinal model'----
yl <- c(-3, 1)    # put all plots on common y-axis scale

# Plot predictors that interact with another predictor
# Vary ageg over all age groups, then vary temp over its
# default range (10th smallest to 10th largest values in
# data).  Make a separate plot for each 'cohort'
# ref.zero centers effects using median x

dd <- datadist(Sc.expanded); dd <- datadist(dd, cohort)
options(datadist='dd')

p1 <- Predict(full.pen, temp, ageg, cohort,
             ref.zero=TRUE, conf.int=FALSE)
p2 <- Predict(full.pen, rr,   ageg, cohort,
              ref.zero=TRUE, conf.int=FALSE)
p <- rbind(temp=p1, rr=p2)   # Figure (*\ref{fig:ordinal-shapes-age}*):
source('https://raw.githubusercontent.com/harrelfe/rscripts/master/graphicsSet.r')
ggplot(p, ~ cohort, groups='ageg', varypred=TRUE,
       ylim=yl, layout=c(2, 1), legend.position=c(.85,.8),
       addlayer=ltheme(width=3, height=3, text=2.5, title=2.5),
       adj.subtitle=FALSE)   # ltheme defined with source()

## ----shapes-yeq1, w=6, h=5.5, cap='Centered effects of predictors on the log odds, for predicting $Y=1|Y\\geq 1$',scap='Shapes of effects of other predictors for $Y=1|Y\\geq 1$'----
# For each predictor that only interacts with cohort, show
# the differing effects of the predictor for predicting
# Pr(Y=0) and Pr(Y=1 given Y exceeds 0) on the same graph

dd$limits['Adjust to','cohort'] <- 'Y>=1'
v <- Cs(waz, bul.conv, drowsy, agitated, reffort, ausc,
        feeding, abdominal, hydration, hxprob, pustular,
        crying)
yeq1 <- Predict(full.pen, name=v, ref.zero=TRUE)
yl <- c(-1.5, 1.5)
ggplot(yeq1, ylim=yl, sepdiscrete='vertical')   # Figure (*\ref{fig:ordinal-shapes-yeq1}*)

## ----shapes-all, w=6, h=5.5, cap='Centered effects of predictors on the log odds, for predicting $Y\\geq 1$.  No plot was made for the \\co{fever.ill, stop.breath}. or \\co{labor} cluster scores.',scap='Shapes of effects of other predictors in ordinal model for $Y\\geq 1$'----
dd$limits['Adjust to','cohort'] <- 'all'  # original default
all <- Predict(full.pen, name=v, ref.zero=TRUE)
ggplot(all, ylim=yl, sepdiscrete='vertical')  # Figure (*\ref{fig:ordinal-shapes-all}*)

## ----approxmod----------------------------------------------------------------
plogit  <- predict(full.pen)
f <- ols(plogit ~ ageg*(rcs(temp,5) + rcs(rr,5)) +
         rcs(waz,4) + bul.conv + drowsy + agitated +
         reffort + ausc + feeding + abdominal + hydration +
         hxprob + pustular + crying + fever.ill +
         stop.breath + labor,
         subset=cohort=='all', data=Sc.expanded, sigma=1)

# Do fast backward stepdown
w <- options(width=120)
fastbw(f, aics=1e10)
options(w)
# 1e10 causes all variables to eventually be
# deleted so can see most important ones in order

# Fit an approximation to the full penalized model using
# most important variables
full.approx <-
  ols(plogit ~ rcs(temp,5) + ageg*rcs(rr,5) +
      rcs(waz,4) + bul.conv + drowsy + reffort +
      ausc + feeding,
      subset=cohort=='all', data=Sc.expanded)
p <- predict(full.approx)
abserr <- mean(abs(p - plogit[cohort == 'all']))
Dxy <- somers2(p, y[cohort == 'all'])['Dxy']

## ----nomogram-approx,h=6,w=6,ps=10,cap=paste("Nomogram for predicting $\\Pr(Y>0)$ from the penalized extended CR model, using an \\index{model!approximate}approximate model fitted using ordinary least squares ($R^{2}=",round(full.approx$stats['R2'],3),"$ against the full model's predicted logits)."),scap='Nomogram for extended CR model'----
f <- full.approx
f$coefficients      <- -f$coefficients
f$linear.predictors <- -f$linear.predictors

n <- nomogram(f,
              temp=32:41, rr=seq(20,120,by=10),
              waz=seq(-1.5,2,by=.5),
              fun=plogis, funlabel='Pr(Y>0)',
              fun.at=c(.02,.05,seq(.1,.9,by=.1),.95,.98))
# Print n to see point tables
plot(n, lmgp=.2, cex.axis=.6)  # Figure (*\ref{fig:ordinal-nomogram-approx}*)
newsubject <-
  data.frame(ageg='[ 0, 7)', rr=30, temp=39, waz=0, drowsy=5,
             reffort=2, bul.conv=0, ausc=0, feeding=0)
xb <- predict(f, newsubject)

## ----validate,results='asis',cache=TRUE---------------------------------------
set.seed(1)   # so can reproduce results
v <- validate(full.pen, B=200, cluster=u$subs,
              subset=cohort=='all')
print(v, digits=2, size='smaller')
v <- round(v, 3)

## ----calibrate,cache=TRUE,ps=9,cap="Bootstrap calibration curve for the full penalized extended CR model.  $200$ bootstrap repetitions were used in conjunction with the \\co{loess} smoother.~\\cite{cle79}  Also shown is a ``rug plot'' to demonstrate how effective this model is in discriminating patients into low- and high-risk groups for $\\Pr(Y=0)$ (which corresponds with the derived variable value $y=1$ when \\co{cohort='all'}).",scap='Bootstrap calibration curve for CR model'----
cal <- calibrate(full.pen, B=200, cluster=u$subs,
                 subset=cohort=='all')
err <- plot(cal)  # Figure (*\ref{fig:ordinal-calibrate}*)

## ----eval=FALSE---------------------------------------------------------------
## sfdm <- as.integer(sfdm2) - 1

## ----eval=FALSE---------------------------------------------------------------
## sf <- function(y)
##   c('Y>=1'=qlogis(mean(y >= 1)),
##     'Y>=2'=qlogis(mean(y >= 2)),
##     'Y>=3'=qlogis(mean(y >= 3)),
##     'Y>=4'=qlogis(mean(y >= 4)))

## ----eval=FALSE---------------------------------------------------------------
## for(i in 1:4)
##   plsmo(age, sfdm >= i, add=i>1,
##         ylim=c(.2,.8), ylab='Proportion Y>=j')
## for(i in 1:4)
##   plsmo(age, sfdm >= i, add=i>1, fun=qlogis,
##         ylim=qlogis(c(.2,.8)), ylab='logit')


# Estimate Z from catch curves using 4 year moving window with cohort-specific coefficients
# based on Sinclair 2001 ICES J Mar Sci 58: 1-10

# matrix has year in rows and age in columns
calc_Sinclair_Z <- function(mat){
  res <- list()
  mat <- as.matrix(mat)
  if (all(is.na(mat))){
    res$error <- TRUE
    return(res)
  }
  year <- as.numeric(rownames(mat))
  age <- as.numeric(colnames(mat))
  ny <- length(year)
  est.Sinclair.Z <- matrix(NA, nrow=(ny-3), ncol=3)
  plot.year <- rep(NA, ny-3)
  for (i in 1:(ny-3)){
    submat <- mat[year %in% year[i:(i+3)],]
    data <- reshape2::melt(submat)
    colnames(data) <- c("Year","Age","Value")
    data$cohort <- data$Year - data$Age
    data$Value[data$Value == 0] <- NA
    data <- data[!is.na(data$Value) ,]
    data$lnVal <- log(data$Value)
    can.calc <- FALSE
    if (length(data[,1]) >= 2){
      if (max(table(data$cohort)) >= 3){
        can.calc <- TRUE
      }
    }
    if (can.calc == TRUE){
      my.lm <- lm(data$lnVal ~ as.factor(data$cohort) + data$Age)
      data$pred <- predict(my.lm)
      data$resid <- residuals(my.lm)
      res[[i]] <- data
      est.Sinclair.Z[i,1] <- -1 * my.lm$coefficients[names(my.lm$coefficients) == "data$Age"]
      est.Sinclair.Z[i,2:3] <- -1 * rev(confint(my.lm, "data$Age", level=0.90))
    }
    else{
      res[[i]] <- data
      est.Sinclair.Z[i,] <- rep(NA, 3)
    }
    plot.year[i] <- year[i] + 1.5
  }
  colnames(est.Sinclair.Z) <- c("Sinclair_Z","low90%","high90%")
  res$est.Sinclair.Z <- est.Sinclair.Z
  res$plot.year <- plot.year
  res$error <- FALSE
  return(res)
}

#-------------------------------------------------------------------------------------
# function to plot the results from calc_Sinclair_Z
# res is a list generated by the function calc_Sinclair_Z
plot_Sinclair_Z <- function(res,est.Z.name,regress.name,resid.name,my.title,save.plots,od,plotf){
  # first the plot of estimated Z with CI over time
  est.Z <- res$est.Sinclair.Z
  if (!all(is.na(est.Z))){
    par(mfcol=c(1,1), oma=rep(1,4), mar=rep(4,4))
    plot.year <- res$plot.year
    Hmisc::errbar(plot.year,est.Z[,1],est.Z[,3],est.Z[,2],ylim=c(0,max(est.Z, na.rm=T)),xlab="Year",ylab="Sinclair Z")
    if(!is.na(my.title)) title(main=my.title, outer=F)
    if(save.plots) savePlot(paste0(od,est.Z.name,".",plotf), type=plotf)
  }

  # plot the individual regressions
  ny <- length(res$plot.year)
  np.row <- 3             # number of plot rows
  np.col <- 3             # number of plot columns
  np.p <- np.row * np.col # number of plots per page
  par(mfcol=c(np.row, np.col))
  my.col <- 1:100
  my.col[7] <- "blue"
  icount <- 0
  for (i in 1:ny){
    data <- res[[i]]
    if (!is.na(res$est.Sinclair.Z[i,1])){
      icount <- icount + 1
      n.coh <- length(unique(data$cohort))
      i.coh <- (data$cohort-min(data$cohort, na.rm=T)+1)
      plot(data$Age,data$lnVal,pch=i.coh,col=my.col[i.coh],xlab="Age",ylab="ln Val")
      title(main=paste0("Years ",min(data$Year)," to ",max(data$Year),"\nZ = ",round(res$est.Sinclair.Z[i,1],3)), outer=F)
      for (j in 1:n.coh){
        subcoh <- data[i.coh == j,]
        if (length(subcoh$lnVal) >= 2){
          lines(subcoh$Age,subcoh$pred,col=my.col[j],lty=j)
        }
      }
      if(save.plots == T & (icount %% np.p) == 0){
        savePlot(paste0(od,regress.name,"_",i,".",plotf), type=plotf)
      }
    }
    if (save.plots == TRUE & i == ny) savePlot(paste0(od,regress.name,"_",i,".",plotf), type=plotf)
  }
  par(mfcol=c(1,1))

  # plot the distribution of residuals by age
  if (!all(is.na(est.Z))){
    resids <- matrix(NA, nrow=0, ncol=2)
    colnames(resids) <- c("Age","Resid")
    for (i in 1:ny){
      if (!is.na(res$est.Sinclair.Z[i,1])){
        data <- res[[i]]
        resids <- rbind(resids,cbind(data$Age,data$resid))
      }
    }
    boxplot(resids[,2] ~ resids[,1],xlab="Age",ylab="Residual")
    abline(h=0, col="red", lty=2)
    if(!is.na(my.title)) title(main=my.title, outer=F)
    if(save.plots) savePlot(paste0(od,resid.name,".",plotf), type=plotf)
  }
  else{
    resids <- NA
  }

  return(resids)
}
#-------------------------------------------------------------------------------------
# function to remove ages from matrix of index catch at age, used by get_Sinclair_Z
drop_partially_selected_ages <- function(mat,sel,sel.start.age,sel.end.age,sel.cutoff){
  sel2 <- sel[sel.start.age:sel.end.age]
  age.col <- 1:length(sel2)
  drop.col <- age.col[sel2 < sel.cutoff]
  if (length(drop.col) > 0) mat[,drop.col] <- NA
  return(mat)
}
#-------------------------------------------------------------------------------
#' Get Sinclair Z
#'
#' Set of functions to prepare index matrices and compute and plot Sinclair Z. Estimate Z from catch curves using 4 year moving window with cohort-specific coefficients. Based on Sinclair 2001 ICES J Mar Sci 58: 1-10. Note hard wired to use only ages that are at least 90 percent selected.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param index.names names of indices
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

get_Sinclair_Z <- function(asap,a1,index.names,save.plots,od,plotf){
  asap.name <- a1$asap.name
  index.mats <- ConvertSurveyToAtAge(asap)
  nages <- asap$parms$nages
  Sinclair.Z <- NA
  for (j in 1:length(index.mats$ob)){
    if (asap$control.parms$index.age.comp.flag[j] == 1){  # used age composition for the index
      mat <- index.mats$ob[[j]]
      sel.start.age <- asap$control.parms$index.sel.start.age[j]
      sel.end.age <- asap$control.parms$index.sel.end.age[j]
      mat <- drop_partially_selected_ages(mat,asap$index.sel[j,],sel.start.age,sel.end.age,0.90)
      if (sel.end.age == nages) mat[,length(mat[1,])] <- NA # drop oldest age because plus group in ASAP
      Sinclair.Z <- calc_Sinclair_Z(mat)
      if (Sinclair.Z$error == FALSE){
        est.Z.name <- paste0("Sinclair_Z_estimates_index_",j)
        regress.name <- paste0("Sinclair_Z_regress_index_",j)
        resid.name <- paste0("Sinclair_Z_resids_index_",j)
        resids <- plot_Sinclair_Z(Sinclair.Z,est.Z.name,regress.name,resid.name,index.names[j],
                                  save.plots,od,plotf)
        Sinclair.Z.table <- cbind(Sinclair.Z$plot.year,Sinclair.Z$est.Sinclair.Z)
        write.csv(Sinclair.Z.table, file=paste0(od,"Sinclair_Z_index_",j,"_",asap.name,".csv"), row.names=F)
      }
    }
  }
  return(Sinclair.Z)
}


> library(sampling)
> train <- strata(data, stratanames = ("landmark"),
+        size = c(14076*9/10, 1009*9/10), method="srswor")
> traindata <- data[train$ID_unit,]
> testdata <- data[-train$ID_unit,]
> table(traindata$landmark)

    N     Y
12668   908
> prop.table(table(traindata$landmark))

         N          Y
0.93311727 0.06688273
> #train <- sample(nrow(data), 9/10*15085)
> #traindata <- data[train,]
> #testdata <- data[-train,]
> library(DMwR)
> smotedata <- SMOTE(landmark ~ ., traindata, perc.over = 150,perc.under = 200)
> table(smotedata$landmark)

   N    Y
1816 1816
> prop.table(table(smotedata$landmark))

  N   Y
0.5 0.5
> library(randomForest)
> set.seed(100)
> rf_ntree <- randomForest(landmark~., data = smotedata, ntree = 2000, importance = TRUE)
> plot(rf_ntree)
> pred <- predict(object = rf_ntree,newdata = testdata)
> roc.curve(testdata$landmark, pred)
Area under the curve (AUC): 0.841
> table(testdata$landmark,pred)
   pred
       N    Y
  N 1170  238
  Y   15   86
> importance(rf_ntree,type = 1, scale = TRUE)
                                     MeanDecreaseAccuracy
feature.level                                   150.16796
highest.road.level                               43.49751
road.density                                     76.24545
GDP.level                                        49.38073
same.features.in.500.buffer                      72.34098
different.features.in.500.buffer                 73.34801
traffic.stations.nearby.in.Baidu.Map             60.08727
crowd.density                                    76.32505
Bing.search.results                              94.88013
Weibo.search.results                            110.44568
Baidu.Map.poi                                    34.79795
building                                         65.54107
category_2                                       79.69715
category_1                                       45.92556
urban.centrality                                 72.11220
> importance(rf_ntree,type = 2, scale = TRUE)
                                     MeanDecreaseGini
feature.level                               357.25208
highest.road.level                           50.71455
road.density                                103.75986
GDP.level                                    60.69813
same.features.in.500.buffer                  94.75692
different.features.in.500.buffer             95.27267
traffic.stations.nearby.in.Baidu.Map         86.45636
crowd.density                               111.54738
Bing.search.results                         196.17276
Weibo.search.results                        214.39647
Baidu.Map.poi                                19.52847
building                                    120.37494
category_2                                  163.00821
category_1                                   50.15126
urban.centrality                             89.25954
> varImpPlot(rf_ntree)


subroutine mnnd(x,y,n,dminbig,dminav)
#
# Mean nearest neighbour distance.  Called by .Fortran()
# from mnnd.R.
#
implicit double precision(a-h,o-z)
dimension x(n), y(n)

dminav = 0.d0
do i = 1,n {
	dmin = dminbig
	do j = 1,n {
		if(i!=j) {
			d = (x(i)-x(j))**2 + (y(i)-y(j))**2
			if(d < dmin) dmin = d
		}
	}
	dminav = dminav + sqrt(dmin)
}

dminav = dminav/n

return
end


Identity_matrix=function(size){
  x=matrix(0,size,size)
  for (i in 1:size) {
    x[i,i]=1
  }
  return(x)
}


df <- read.csv("train.csv", sep=";")

ggplot(df, aes(read, math, col = gender))+
  geom_point()+
  facet_grid(.~hon)+
  theme(axis.text=element_text(size=25),
        axis.title=element_text(size=25, face="bold"))

fit <- glm(hon~read + math + gender, df, family = "binomial")
summary(fit)

exp(fit$coefficients)

head(predict(object = fit))

head(round(predict(object = fit, type = "response")*100))

df$prob <- predict(object = fit, type = "response")

# trouble №1

ddf <- glm(am ~ disp+vs+mpg, mtcars, family = "binomial")
print(ddf$coefficients)

# trouble №2
df <- data.frame(ToothGrowth)

library("ggplot2")

ggplot(ToothGrowth, aes(x = supp,y=len ))+
  geom_boxplot(aes(fill = factor(dose)))

obj

library(ROCR)

pred_fit <- prediction(df$prob, df$hon)
pref_fit <- performance(pred_fit, "tpr","fpr")
plot(pref_fit, colorize = T, print.cutoffs.at= seq(0.1, by=0.1))


library('xgboost', warn.conflicts = F, quietly = T)

# Runs xbg CV to tune params
# returns hyperparameter table, RMSEs, Pearson correlations,
# and final model trained on all data using lowest RMSE
"my.xgb.cv.tune" <- function(x, y,nfolds=5,
                        # max_depth = c(3, 4, 5, 6),
                        # eta = c(.05, .1, .2, .3),
                        # subsample = c(0.25,0.5,.75,1),
                        # nrounds=c(100,200,500,1000),
                        max_depth = c(3, 4),
                        eta = c(.05, .1),
                        subsample = c(0.25,0.5),
                        nrounds=c(10,20),
                        params=NULL,
                        verbose=0) {
  # only load xgboost if needed for xgb
  # this is for faster runtime
  # and fewer dependencies for basic use case
  library('xgboost', warn.conflicts = F, quietly = T)

  # https://www.r-bloggers.com/2020/11/r-xgboost-regression/
  #create hyperparameter grid
  # override values with params list if provided
  if(!is.null(params)){
    if('max_depth' %in% names(params)) max_depth <- params$max_depth
    if('eta' %in% names(params)) eta <- params$eta
    if('subsample' %in% names(params)) subsample <- params$subsample
    if('nrounds' %in% names(params)) nrounds <- params$nrounds
  }

  hyper.grid <- expand.grid(max_depth = max_depth,
                            eta = eta,
                            subsample = subsample,
                            nrounds = nrounds)

  cors <- numeric(nrow(hyper.grid))
  rmses <- numeric(nrow(hyper.grid))
  fold.ix <- sample(rep(1:nfolds,length=nrow(x)))
  yhat <- y

  # if only one value of each hyper parameter provided,
  # Skip tuning and just train once on all data
  if(nrow(hyper.grid) == 1){
    best.ix <- 1
    # Train once on whole set using best params
    m.xbg <- xgboost(data = x,
                     label = y,
                     objective = "reg:squarederror",
                     nrounds=hyper.grid[1,'nrounds'],
                     eta=hyper.grid[1,'eta'],
                     subsample=hyper.grid[1,'subsample'],
                     max_depth=hyper.grid[1,'max_depth'],
                     verbose = FALSE)
    yhat <- predict(m.xbg,x)
  } else {
    if(verbose > 0) cat('Of', nrow(hyper.grid), 'iterations: ')
    for(i in 1:nrow(hyper.grid)){
      if(verbose > 0) cat(i,'')
      for(k in 1:nfolds){
        in.fold <- fold.ix == k
        max_depth <-
          eta <- hyper.grid[i,'eta']
        subsample <- hyper.grid[i,'subsample']
        nrounds <- hyper.grid[i,'nrounds']

        m.xbg <- xgboost(data = x[in.fold,],
                         label = y[in.fold],
                         objective = "reg:squarederror",
                         nrounds=hyper.grid[i,'nrounds'],
                         eta=hyper.grid[i,'eta'],
                         subsample=hyper.grid[i,'subsample'],
                         max_depth=hyper.grid[i,'max_depth'],
                         verbose = FALSE)

        yhat[!in.fold] <- predict(m.xbg, x[!in.fold,])
      }
      cors[i] <- cor(yhat,y)
      rmses[i] <- sqrt(mean((yhat - y)^2))
    }
    if(verbose > 0) cat('\n')
    best.ix <- which.min(rmses)

    # Train once on whole set using best params
    m.xbg <- xgboost(data = x,
                     label = y,
                     objective = "reg:squarederror",
                     nrounds=hyper.grid[best.ix,'nrounds'],
                     eta=hyper.grid[best.ix,'eta'],
                     subsample=hyper.grid[best.ix,'subsample'],
                     max_depth=hyper.grid[best.ix,'max_depth'],
                     verbose = FALSE)
  }
  best.nrounds   <- hyper.grid$nrounds[  best.ix]
  best.eta       <- hyper.grid$eta[      best.ix]
  best.subsample <- hyper.grid$subsample[best.ix]
  best.max_depth <- hyper.grid$max_depth[best.ix]

  yhat.fitted <- predict(m.xbg,x)
  rmse.fitted <- sqrt(mean((yhat.fitted - y)^2))
  mape.fitted <- 100*mean(abs(yhat.fitted - y)/y)
  mape.cv <- 100*mean(abs(yhat - y)/y)
  if(nfolds==1) rmses = rmse.fitted

  return(list(hyper.grid=hyper.grid,
              cors=cors,
              rmses=rmses,
              rmse.cv=min(rmses),
              rmse=rmse.fitted,
              final.model=m.xbg,
              y=y,
              yhat.cv=yhat,
              yhat=yhat.fitted,
              mape.cv=mape.cv,
              mape=mape.fitted,
              best.params=list(nrounds=best.nrounds,
                               eta=best.eta,
                               subsample=best.subsample,
                               max_depth=best.max_depth)
              )
         )
}


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

# Scaling and splitting
library(caTools)
ds[,1:2] = scale(ds[,1:2])

split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

#SVM
library(e1071)

clf = svm(Purchased ~ .,
          data = train,
          kernel = 'radial',
          type = 'C-classification')

y_pred = predict(clf, type = 'response', newdata = test[-3])
cm

# Confusion matrix
cm = table(test[, 3], y_pred)

plot(clf, data = train)


# Data Wrangling in R
# 5.1 Detecting Outliers
#

# Load the tidyverse
library(tidyverse)

# Read in the Medicare payments dataset
names <- c("DRG", "ProviderID", "Name", "Address", "City", "State", "ZIP", "Region", "Discharges", "AverageCharges", "AverageTotalPayments",
           "AverageMedicarePayments")
types = 'ccccccccinnn'
inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names, skip=1, col_types = types)

# Let's look at a histogram
ggplot(data=inpatient) +
  geom_histogram(mapping=aes(x=AverageCharges))

# What if we change the limit of the y axis
ggplot(data=inpatient) +
  geom_histogram(mapping=aes(x=AverageCharges)) +
  coord_cartesian(ylim=c(0,25))

# We could also view this with a single boxplot
ggplot(data=inpatient) +
  geom_boxplot(mapping=aes("charges",AverageCharges))

# Or we can use a series of boxplots broken out by state
ggplot(data=inpatient) +
  geom_boxplot(mapping=aes(State,AverageCharges))

# Plenty to investigate here, but let's dig in to those over $500,000
highCharges <- filter(inpatient, AverageCharges>500000)

unique(highCharges$DRG)

ggplot(data=highCharges) +
  geom_point(mapping=aes(DRG,AverageCharges)) +
  theme(axis.text.x = element_text(angle = 90, vjust = 1, hjust=1))


suppressPackageStartupMessages(library(float))

tol = 1e-6

x = matrix(1:6, 3, 2)
s = fl(x)

test = dbl(rep(s, 5))
truth = rep(x, 5)
stopifnot(all.equal(test, truth, tol=tol))


#==============================================================================
#	Test for glmer
#==============================================================================

source("tests.r")

test <- glm.type.test.runner$new(
	"glmer",
	families = c(
		"Gamma", "inverse.gaussian", "poisson", "binomial"
	)
)

test$test.info$formulae <- list(
	gaussian = Sepal.Length ~ Petal.Length + (1 | Species),
	Gamma = Sepal.Length ~ Petal.Length + (1 | Species),
	inverse.gaussian = Sepal.Length ~ Petal.Length + (1 | Species),
	poisson = n ~ Petal.Length + (1 | Species),
	quasipoisson = bin ~ Petal.Length + (1 | Species),
	binomial = bin ~ Petal.Length + (1 | Species),
	quasibinomial = bin ~ Petal.Length + (1 | Species),
	quasi = Sepal.Length ~ Petal.Length + (1 | Species)
)

test$run()
rm(test)


library(npowerPrioR)
source("../Linear_Regression/data_regression_NIG_scenario_1.r")

lm.data <- list(
  N0 = N_0,
  P = P,
  X0 = X_0,
  y0 = y_0,
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  a_0 = NULL
)
invlambda0 <- solve(lm.data$lambda_0)
###
get_mal_NIG_regression <- function(y0, X0, n0, mu0, lambda0, alpha0, beta0, a_0){
  P <- ncol(X0)
  if(length(mu0) != P) stop("mu0 is not the same dimension as X")
  Xstar <- sqrt(a_0) * X0
  ystar <- sqrt(a_0) * y0
  lambda_n <- t(Xstar)%*%Xstar + lambda0
  mu_n <- solve(lambda_n) %*% (lambda0%*%mu0 + t(Xstar)%*%ystar)
  alpha_n <-  as + (n0*a_0)/2
  beta_n <- beta0 + .5 * ( t(ystar)%*%ystar + t(mu0)%*%lambda0%*%mu0 - t(mu_n)%*%lambda_n%*%mu_n )
  det0 <- det(lambda0)
  det1 <- det(lambda_n)
  ans <- -(a_0 * n0/2) * log(2*pi) + .5 * (log(det0) - log(det1)) + (alpha0 * log(beta0) - alpha_n * log(beta_n) ) + (lgamma(alpha_n)-lgamma(alpha0))
  return(ans)
}
#
l_a0 <- function(x) {
  get_mal_NIG_regression(
    y0 = lm.data$y0,
    X0 = lm.data$X0,
    n0 = lm.data$N0,
    mu0 = lm.data$mu_beta,
    lambda0 = invlambda0,
    alpha0 = lm.data$alpha0,
    beta0 = lm.data$beta0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)

########

maxA <- 1
prior <- stan_model("../Linear_Regression/stan/simple_linear_regression_NIG_prior.stan")

# direct method
J <- 20
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10,
                                       stan.list = lm.data, pars = c("beta", "sigma_sq"))
)

# VR2018
Delta.a <- 0.01
a0s.vr2018 <- seq(0, maxA, by = Delta.a)

vr2018.time <- system.time(
  vr2018.estimates <-  create_lc_df_derivOnly(a0_grid = a0s.vr2018,
                              compiled.model.prior = prior,
                              stan.list = lm.data, pars = c("beta", "sigma_sq") )
)

write.csv(vr2018.estimates$result,
          file = "Gaussian_VR2018.csv", row.names = FALSE)
adaptive.time
vr2018.time
###
## Now the approximations
adapt.gam <-  mgcv::gam(lc_a0 ~ s(a0, k = J), data = adaptive.ca0.estimates$result)
vr2018.estimates$result$la0_est <- cumsum(vr2018.estimates$result$deriv_lc) * Delta.a

## Finally, comparisons

K <- 20000
pred.a0s <- seq(0, maxA, length.out = K)

true.la0s <- l_a0(pred.a0s)

adaptive.preds <- predict(adapt.gam, newdata = data.frame(a0 = pred.a0s))

vr2018.preds <- approx(x = vr2018.estimates$result$a0,
                          y =  vr2018.estimates$result$la0_est,
                          xout =  pred.a0s)

plot(vr2018.preds, type = "l", lwd = 5,
     col = 3,
     xlab = expression(a[0]), ylab = "Log-normalising constant")
lines(pred.a0s, adaptive.preds, col = 2, lwd = 5)
lines(pred.a0s, true.la0s, lwd = 5, lty = 2, add = TRUE)
legend(x = "topleft", legend =  c("GAM", "VR2018", "True"),
       col = c(2, 3, 1), lwd  = 2, lty = c(1, 1, 2), bty = 'n')

preds.list <- list(
  adaptive = adaptive.preds,
  VR2018 = vr2018.preds$y
)

ntrue.la0s <- true.la0s

lapply(preds.list, function(pred) sqrt(mean( ( pred- ntrue.la0s)^2 )) )
lapply(preds.list, function(pred) mean( abs( pred- ntrue.la0s) ))


library(dplyr)
library(sjmisc)
library(sjPlot)
library(ggplot2)

data("mtcars")

names (mtcars)
head(mtcars)

newmtcars <- select (mtcars,c("am","gear","carb"))

##plot  a correlation matrix for all variabless
sjp.corr (newmtcars)

sjt.corr (newmtcars,show.p = TRUE,p.numeric = TRUE)


# create_allocation_df.r
# Author: David Van Riper
# Created: 2020-09-30
#
# This script creates data frames that will be used in gt() tables created in the RMD.
require(tidyverse)
require(gt)

#### Constants ####
data_path <- "data/"

# files
geog_file <- "geog_level_alloc.csv"
ddp_query_file <- "ddp_query_alloc.csv"
v20200527_file <- "v20200527_query_alloc.csv"

# dp parameters
p_epsilon = 4.0
sensitivity = 2

#### Load data ####
geog_alloc <- read_csv(paste0(data_path, geog_file))
ddp_alloc <- read_csv(paste0(data_path, ddp_query_file))
v20200527_alloc <- read_csv(paste0(data_path, v20200527_file))

#### Factor the geog_level variable to keep correct order ####
geog_alloc$geog_level <- factor(geog_alloc$geog_level, levels = c("Nation_State", "County_Block"), labels = c("Nation_State", "County_Block"))

#### Generate geog * crosses ####
ddp_tbls <- crossing(geog_alloc, ddp_alloc)
v20200527_tbls <- crossing(geog_alloc, v20200527_alloc)

#### Generate the scale values ####
ddp_tbls <- ddp_tbls %>%
  mutate(epsilon_fraction = geog_allocation * allocation * p_epsilon,
         s = sensitivity / epsilon_fraction)

v20200527_tbls <- v20200527_tbls %>%
  mutate(epsilon_fraction = geog_allocation * allocation * p_epsilon,
         s = sensitivity / epsilon_fraction)

#### Generate the standard deviation for each row ####
ddp_tbls <- ddp_tbls %>%
  mutate(sd = sqrt(2 * s^2))

v20200527_tbls <- v20200527_tbls %>%
  mutate(sd = sqrt(2 * s^2))

#### Add a type variable to differentiate after bind_row ####
ddp_tbls <- ddp_tbls %>%
  mutate(vintage = "ddp")

v20200527_tbls <- v20200527_tbls %>%
  mutate(vintage = "v20200527")

#### Bind dfs together ####
query_allocs <- bind_rows(ddp_tbls, v20200527_tbls)

#### Create wide df on geog var/scale/sd
query_allocs_wide <- query_allocs %>%
  pivot_wider(id_cols = c(query, vintage), names_from = geog_level, values_from = c(num_categories, allocation, s, sd)) %>%
  select(vintage, query, num_categories = num_categories_Nation_State, allocation = allocation_Nation_State,s_Nation_State, sd_Nation_State, s_County_Block, sd_County_Block, -allocation_County_Block, -num_categories_County_Block)

#### Clean up ####
rm(ddp_tbls)
rm(ddp_alloc)
rm(geog_alloc)
rm(v20200527_alloc)
rm(v20200527_tbls)
rm(query_allocs)


# ************************************************
### simon munzert
### panel data I
# ************************************************

source("packages.r")
source("functions.r")

## CRAN Task View on econometrics (including panel data models)
browseURL("https://cran.r-project.org/web/views/Econometrics.html")

# ************************************************
# Example: Comparative Political Dataset ---------

dat <- read_dta("../data/CPDS-1960-2015.dta")
dat <- filter(dat, emu == 1) # only EMU countries

hist(dat$gov_left2)
hist(dat$socexp_t_pmp)

# plot small multiples of share of left parties and social expenditures
ggplot(data=dat, aes(x=year,y=gov_left2)) +
  geom_line(stat="identity") +
  ylim(0, 100) +
  labs(y = "Left parties in government (% seats in parliament)",
       x = "Year") +
  geom_line(data = dat, aes(x = year, y = socexp_t_pmp*5), color = "blue") +
  scale_y_continuous(sec.axis = sec_axis(~./5, name = "Social expenditures [%GDP]")) +
  facet_wrap(~iso, ncol = 6) +
  theme(axis.text.x = element_text(angle=90))
#ggsave("../output/cpds-govleft-exp.pdf", width = 20, height = 12, units = "cm")

# select variables
?select
dat <- dplyr::select(dat, year, country, iso, eu, emu, gov_left2, socexp_t_pmp, instcons, unemp)
head(dat)

# make data frame wide
dat_wide <- reshape(as.data.frame(dat), direction = "wide", timevar = "year", idvar = c("country", "iso"))
View(dat_wide)

# make data frame long
dat_long <- reshape(dat_wide, idvar = c("country", "iso"), varying = 3:104, direction = "long")

# ************************************************
# Pooled cross-sections example: -----------------
# Fertility across time in the US ----------------

data("fertil1")
?fertil1

summary(lm(kids ~ age + educ + black + age + I(age^2) + east + northcen + west + farm + othrural + town + smcity + y74 + y76 + y78 + y80 + y82 + y84, data = fertil1))

# dealing with multiple dummies across many models can be cumbersome - here's an alternative way to construct your formula:
controls <- c("age", "educ", "black", "age", "I(age^2)", "east", "northcen", "west", "farm", "othrural", "town", "smcity")
year_dummies <- paste0("y", seq(74, 84, 2))
fmla <- paste("kids", paste(c(controls, year_dummies), collapse = " + "), sep = " ~ ")
summary(lm(as.formula(fmla), data = fertil1))

# questions:
  # where is y72?
  # which years have no significant difference from 1972?
  # did fertility change much over time? when?
  # why is age squared?
  # how would you model changes in an effect over time?

# ************************************************
# Diff-in-diff example: --------------------------
# Workers' compensation and injury duration ------

data("injury")
?injury

# inspect dependent variable
summary(injury$durat)
hist(injury$durat)
injury$ldurat <- log(injury$durat)
hist(injury$ldurat)

# visualize difference in both samples
dat <- filter(injury, afchnge == 0)
plot1 <- ggplot(dat, aes(x = ldurat)) +
  geom_histogram(data = filter(dat, highearn == 0), fill = "red", alpha = 0.2) +
  geom_histogram(data = filter(dat, highearn == 1), fill = "blue", alpha = 0.2)

dat <- filter(injury, afchnge == 1)
plot2 <- ggplot(dat, aes(x = ldurat)) +
  geom_histogram(data = filter(dat, highearn == 0), fill = "red", alpha = 0.2) +
  geom_histogram(data = filter(dat, highearn == 1), fill = "blue", alpha = 0.2)

grid.arrange(plot1, plot2, ncol=2)

# separate models by year
summary(lm(ldurat ~ highearn, data = filter(injury, afchnge == 0)))
summary(lm(ldurat ~ highearn, data = filter(injury, afchnge == 1)))

# diff-in-diff model
summary(lm(ldurat ~ highearn*afchnge, data = injury))

# ************************************************
# Differencing example: --------------------------
# Sleeping vs. working ---------------------------

data("slp75_81")
?slp75_81
dat <- slp75_81

dat$slpnap_d <- dat$slpnap81 - dat$slpnap75 # differencing the data - super easy in wide format!
plot(dat$slpnap_d, dat$cslpnap) # should be the same

# bring into long format (only necessary for first task - and to prove how cumbersome reshaping can be)
dat$age81 <- dat$age75 + 6
dat_wide <- dplyr::select(dat, male, age75, educ75, gdhlth75, marr75, slpnap75, totwrk75, yngkid75, age81, educ81, gdhlth81, marr81, slpnap81, totwrk81, yngkid81) %>% as.data.frame()
names(dat_wide)
dat_long <- reshape(dat_wide, varying = 2:15, v.names = c("age", "educ", "gdhlth", "marr", "slpnap", "totwrk", "yngkid"), idvar = "id_var", direction = "long")

# estimate model with pooled data, no differencing
summary(lm(slpnap ~ totwrk + educ + marr + yngkid + gdhlth, data = dat_long))

# first-difference model
summary(lm(cslpnap ~ ctotwrk + ceduc + cmarr + cyngkid + cgdhlth, data = dat))

# ************************************************
# Tidying data frames with tidyr -----------------

# Hadley Wickham's paper on tidy data:
browseURL("https://www.jstatsoft.org/article/view/v059i10")

# Wickham is proponent of "one column, one variable" paradigm
# corresponds to "long" format for panel data sets
# fit nicely with dplyr, ggplot and similar packages that operate on data frames
# tidyr essentially provides yet another set of functions to deal with reshaping data frames to fit these rules:
  # each variable must have its own column
  # each observation must have its own row
  # each value must have its own cell

# related to reshape2 and reshape, although tidyr is not designed for general reshaping
# gather() ~ melt()
  # --> takes multiple columns and gathers them into key-value pairs
  # --> wide to long
# spread() ~ cast()
  # --> takes two columns (key and value) and spreads in to multiple columns
  # --> long to wide

# additional functions:
# separate()
  # --> pull apart a column that represents multiple variables
# unite()
  # --> complement to separate()

# example: gather()
# demo("so-17481212")
race <- read.table(header = TRUE, check.names = FALSE, text = "
                   Name    50  100  150  200  250  300  350
                   Carla  1.2  1.8  2.2  2.3  3.0  2.5  1.8
                   Mace   1.5  1.1  1.9  2.0  3.6  3.0  2.5
                   Lea    1.7  1.6  2.3  2.7  2.6  2.2  2.6
                   Karen  1.3  1.7  1.9  2.2  3.2  1.5  1.9
                   ")
race
race_long <- gather(race, key = Time, value = Score, -Name, convert = TRUE)
race_long
race_long %>% arrange(Name, Time)

# example: spread()
# demo("so-16032858")
results <- data.frame(
  Ind = paste0("Ind", 1:10),
  Treatment = rep(c("Treat", "Cont"), each = 10),
  value = 1:20
)
results
spread(results, key = Treatment, value = value)

# example: separate()
df <- data.frame(x = c(NA, "a.b", "a.d", "b.c"))
df %>% separate(x, c("A", "B"))
df %>% separate(x, c("A", "B"), sep = -2)
df %>% separate(x, c("A", "B"), sep = "\\.")

# example 2: separate() - every row doesn't split into the same number of pieces
df <- data.frame(x = c("a", "a b", "a b c", NA))
df %>% separate(x, c("a", "b"))
# the same behaviour but no warnings, fill with missing values on specified side
df %>% separate(x, c("a", "b"), extra = "drop", fill = "right")
df %>% separate(x, c("a", "b"), extra = "drop", fill = "left")
# do not drop extra pieces, only splits at most length(into) times
df %>% separate(x, c("a", "b"), extra = "merge", fill = "right")
df %>% separate(x, c("a", "b", "c"), extra = "merge", fill = "right")

# example: separate_rows()
df <- data.frame(
  x = 1:3,
  y = c("a", "d,e,f", "g,h"),
  z = c("1", "2,3,4", "5,6"),
  stringsAsFactors = FALSE
)
df
separate_rows(df, y, z, convert = TRUE)

# example: unite()
df <- data.frame(
  country = rep(c("Afghan", "Brazil", "China"), each = 2),
  century = rep(c("19", "20"), 3),
  year = rep(c("99", "00"), 3),
  stringsAsFactors = FALSE
)
df
unite(df, century, year, col = "year", sep = "")


#' View patient clusters using multi-dimensional scaling.
#'
#' This function plots the provided patient similarity matrix in a lower dimensional space
#' using multi-dimensional scaling, which is well suited for similarity metrics.
#' @param patientSim - The patient similarity matrix.
#' @param diagnoses - A character vector of diagnostic labels associated with the rownames of patientSim.
#' @param k - The number of dimension you want to plot your data using multi-dimensional scaling.
#' @param diag - The diagnosis associated with positive controls in your data.
#' @return p - a plotly scatter plot colored by provided diagnostic labels.
#' @export plot.mdsSim
#' @usage plot.mdsSim(patientSim, diagnoses, k, diag)
#' @examples
#' # if you have diagnostic labels associated with the colnames(data_mx), send them using diagnoses parameter
#' p = plot.mdsSim(patientSim, diagnoses, k=2, diag="diseased")
#' p
#' p = plot.mdsSim(patientSim, diagnoses, k=3, diag="diseased")
#' p
plot.mdsSim = function(patientSim, diagnoses, k, diag) {
  if (!(k %in% c(2,3))) {
    print("K must be either 2-dimensions or 3-dimensions.")
    return(0)
  }

  if (is.null(diagnoses)) {
    print("To view patient clusters, please provide clinical labels, corresponding to each patient in the provided similarity matrix.")
    return(0)
  }

  fitSim = cmdscale(patientSim, eig=FALSE, k=k)
  x = round(fitSim[,1], 2)
  y = round(fitSim[,2], 2)
  if (k==3) {
    z = round(fitSim[,3], 2)
    df = data.frame(x=x, y=y, z=z, color=diagnoses, label=colnames(patientSim))
    p = plot_ly(df, x=~x, y=~y, z=~z, color=~color, text=~label, marker = list(size = 20))
  } else {
    df = data.frame(x=x, y=y, color=diagnoses, label=colnames(patientSim))
    p = plot_ly(df, x=~x, y=~y, color=~color, text=~label, marker = list(size = 20))
  }

  # Do K-means here
  #dis.centroid = apply(patientSim[which(diagnoses==diag),], 2, mean)
  #negCntl.centroid = apply(patientSim[which(diagnoses=="negCntl"),], 2, mean)
  #kmns = kmeans(patientSim, centers = rbind(dis.centroid, negCntl.centroid))
  #dcntd = diagnoses[which(colnames(patientSim) %in% names(kmns$cluster[which(kmns$cluster==1)]))]
  #ncntd = diagnoses[which(colnames(patientSim) %in% names(kmns$cluster[which(kmns$cluster==2)]))]

  #rownames(df) = df[,"label"]
  #min(df[dcntd,"x"])
  #max(df[dcntd,"x"])
  #min(df[dcntd,"y"])
  #max(df[dcntd,"y"])

  #min(df[ncntd,"x"])
  #max(df[ncntd,"x"])
  #min(df[ncntd,"y"])
  #max(df[ncntd,"y"])

  # https://plot.ly/r/shapes/
  # Circles are centered around ((x0+x1)/2, (y0+y1)/2))
  #p = layout(p, title = sprintf("Kmeans Clustering of Patient Distances from MolPhenoMatch"),
  #           shapes = list(
  #             list(type = 'circle',
  #                  xref = 'x', x0 = .2, x1 = .7,
  #                  yref = 'y', y0 = 20, y1 = 3000,
  #                  fillcolor = 'rgb(50, 20, 90)', line = list(color = 'rgb(50, 20, 90)'),
  #                  opacity = 0.2),
  #             list(type = 'circle',
  #                  xref = 'x', x0 = .75, x1 = 1.5,
  #                  yref = 'y', y0 = 2500, y1 = 7500,
  #                  fillcolor = 'rgb(30, 100, 120)', line = list(color = 'rgb(30, 100, 120)'),
  #                  opacity = 0.2)))

  return(p)
}


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  set.seed(1234)
  x = matrix(rnorm(30), 10)
  cv = cov(x)
  cr = cor(x)
} else {
  x = NULL
}

dx = expand(x)

cv_test = cov(dx)
cr_test = cor(dx)

comm.print(all.equal(cv, cv_test))
comm.print(all.equal(cr, cr_test))

finalize()


# Run the code below to set up the data
# Make a scatterplot using the unisex_data with Male on the x axis and Female on the y
# Color the points by name
# Use geom_smooth(method="lm", se=FALSE) to add a trend line for each name

# Bonus: Look at the options for geom_smooth and try other settings

library(tidyverse)

# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
unisex_data <- unisex_data %>%
  select(-prop) %>%
  spread(sex, n, fill=0)

# Look at the data
unisex_data

# make a scatterplot
ggplot(unisex_data, aes(x=Male, y=Female, color=name)) +
  geom_point() +
  geom_smooth(method="lm", se=FALSE)


library(nloptr)
library(rlist)
library(Rlab)
library(RJSONIO)

source("likelihood_method//model_fitting.r")
source("visualization.r")
# load data and initialize parameters
load("CasosAjustados_Diagnostico.Rda")
aux = rep(1,length(data$`Estimados Totales`))
aux[26] = 0
params = list(
  "regularization_weights" = aux,
  "lambda_min" = 1/40,
  "lambda_max" = 1/4,
  "beta_min" = 0.1,
  "beta_max" = 0.7,
  "N0_min" = 0,
  "N0_max" = 5,
  "t0" = 1
)
bootstrap_params = list(
  "number_samples" = 500,
  "window_size" = 10,
  "confidence" = 0.95
)

observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
observed_I = observed_I[params$t0:length(observed_I)]

LossFunction=NULL
castigos=0:80
for(C in castigos){
  print(C)
  params$beta0 = runif(length(observed_I), params$beta_min, params$beta_max)
  params$lambda0 = runif(1, params$lambda_min, params$lambda_max)
  params$N00 = runif(1, params$N0_min, params$N0_max)
  sol=fit(observed_I, params$beta0[1:length(observed_I)], params$beta_min, params$beta_max, params$lambda0, params$lambda_min,
          params$lambda_max, params$N00, params$N0_min, params$N0_max, Castigo=C, ignore_beta_diff)
  LossFunction=c(LossFunction,sol$likelihood)
  beta0=sol$beta
  timestamp = format(Sys.time(), "%Y%m%d%H%M")
  out_dir = paste("likelihood_method", "tuned", timestamp, sep="/")
  dir.create(out_dir, recursive=TRUE)
  write(toJSON(params), paste(out_dir, "params.json", sep="/"))
  write(toJSON(model), paste(out_dir, "model.json", sep="/"))
  # plot reproduction number series
  R = model$beta / model$lambda
  png(paste(out_dir, "R(t).png", sep="/"))
  plot(R, xlab="t", ylab="R(t)", type="l")
  dev.off()
  # plot expected new cases with confidence intervals
  expected_I = get_expected_I(model$beta, model$N0, model$lambda)

  b_samples = bootstrap_samples(expected_I, observed_I,
                                bootstrap_params$number_samples,
                                bootstrap_params$window_size)

  plot_I_intervals(expected_I, observed_I, b_samples, confidence=bootstrap_params$confidence, out_dir)

}

#Calcular Likelihood Ratio Test

LRTest=2*(LossFunction-LossFunction[1])

prob=pchisq(LRTest,length(beta), lower.tail=TRUE)
plot(castigos,prob)
lines(castigos,castigos*0+0.95, type="l", col="red")
#Elegir Parametro de suavizamiento
C_opt=min(castigos[prob>0.95])

sol=fit(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
        lambda_max, N00, N0_min, N0_max, Castigo=C, ignore_beta_diff)

serie=1:length(observed_I)
#Beta estimado vs. Beta teorico
plot(serie, beta, type="l")
lines(serie, sol$beta, type="l", col="red")
#Ajuste
plot(serie, observed_I, type="l")
lines(serie, get_expected(sol$beta, N0, lambda)$I, type="l", col="red")

b_samples = bootstrap_samples(get_expected(sol$beta, N0, lambda)$I, observed_I,
                              bootstrap_params$number_samples,
                              bootstrap_params$window_size)
timestamp = format(Sys.time(), "%Y%m%d%H%M")
out_dir = paste("original", "tuned", timestamp, sep="/")
dir.create(out_dir, recursive=TRUE)
plot_I_intervals(get_expected(sol$beta, N0, lambda)$I, observed_I, b_samples, confidence=bootstrap_params$confidence, out_dir)


#Test correlations otus X environmental variables
#### Only using Vegan:
library(vegan)
info_data <- read.csv("C:/Gresham/Project_Gravimondo/Project_Impact_2/Supplemental/unassigned_csv/level-7_TSS.csv", row.names=1)

info_data <- read.csv("C:/Gresham/Project_Gravimondo/Project_Impact_2/PeerJ_Submission/Otu_frequency_TSS.csv", row.names=1)
Environmental_variables <- read.delim("C:/Gresham/Project_Gravimondo/Project_Impact_2/metadata/env_variables_expanded.txt", row.names = 1)

Otu_veg <- t(info_data) # Samples become rows and OTUs are columns
Otus.pca <- rda(Otu_veg)
OTUs_dist <- vegdist(Otu_veg) # Creates distance matrix of the OTUs
#Plot PCA
PCA_plot<-ordiplot(Otus.pca)
PCA_plot
# Plotting environmental variables
Envdt <- Environmental_variables
#Envdt <- Environmental_variables[,2:20]
Tax_env <- envfit(OTUs_dist, Envdt, permu=999)
Tax_env
plot(Tax_env, p.max = 0.1, col = "blue")
plot(Tax_env, p.max = 0.05, col = "red")

# add labels to the samples in the ordiplot
orditorp(PCA_plot, "site", pch="+", pcol="grey")

# ----
## Bray-Curtis distances between samples
taxa_counts <- read.delim("C:/Gresham/Project_Gravimondo/Project_Impact_2/qiime_results/asv2taxa_feature_taxonomy.tab", sep='\t')
my_varespec = taxa_counts
rownames(my_varespec) <- my_varespec$taxa
my_varespec <- my_varespec[-c(1)]

my_varespec <- as.data.frame(t(my_varespec))
my_dis <- vegdist(my_varespec)

## groups 3 and 3
my_groups <- factor(c(rep(1,3), rep(2,3)), labels = c("Pristine","Impacted"))

## Calculate multivariate dispersions
my_mod <- betadisper(my_dis, my_groups)

## Perform test
anova(my_mod)


pspline <- function(data, argvals.new = NULL, knots = 35,
                    # knots.option="equally-spaced",
                    p = 3, m = 2, lambda = NULL,
                    search.length = 100,
                    lower = -20, upper = 20) {

  # require(splines)
  # source("pspline.setting.weight.R")

  ## read in data
  check.data(data)
  Y <- data$y
  t <- data$argvals
  subj <- data$subj
  tnew <- argvals.new
  if (is.null(tnew)) {
    tnew <- t
  }
  ###
  J <- length(Y)
  if (is.null(t)) t <- (1:J) / J - 1 / 2 / J ## if NULL, assume equally spaced
  subj_unique <- unique(subj)
  n <- length(subj_unique)
  WY <- Y
  N <- rep(NA, n)
  W <- 0 * Y
  for (i in 1:n) {
    seq <- (1:J)[subj == subj_unique[i]]
    N[i] <- length(seq)
    WY[seq] <- Y[seq] / N[i]
    W[seq] <- 1 / N[i]
  }

  p.p <- p
  m.p <- m

  ######### precalculation for smoothing ############
  knots.option <- "equally-spaced"
  knots <- construct.knots(t, knots, knots.option, p)

  List <- pspline.setting(t, knots = knots, p.p, m.p, weight = W, knots.option = knots.option)
  AS <- as.matrix(List$A)
  s <- List$s
  Sigi.sqrt <- List$Sigi.sqrt
  U <- List$U
  B <- List$B
  Bnew <- spline.des(knots = knots, x = tnew, ord = p.p + 1, outer.ok = TRUE, sparse = TRUE)$design

  AStY <- as.vector(t(AS) %*% Y)
  AStWY <- as.vector(t(AS) %*% WY)
  AStAS <- as.matrix(t(AS) %*% AS)
  AStAS_eigen <- eigen(AStAS)
  AStAS_eigen$values[AStAS_eigen$values <= 0] <- 0
  AStAS_half <- AStAS_eigen$vectors %*% diag(sqrt(AStAS_eigen$values)) %*% t(AStAS_eigen$vectors)

  ## calculate Term1
  AStAS_N <- matrix(NA, n, length(s)^2)
  ASitYi <- matrix(NA, n, length(s))
  Term1 <- matrix(0, length(s), length(s))
  Term0 <- rep(0, length(s))
  for (i in 1:n) {
    seq <- (1:J)[subj == subj_unique[i]]
    ASi <- matrix(AS[seq, ], N[i])
    ASitASi <- t(ASi) %*% ASi
    AStAS_N[i, ] <- as.vector(ASitASi)
    temp <- as.vector(t(ASi) %*% Y[seq] / N[i])
    ASitYi[i, ] <- temp
    Term1 <- Term1 + diag(temp) %*% as.matrix(ASitASi %*% diag(AStWY))
    Term0 <- Term0 + temp^2 * N[i]
  }

  pspline_gcv <- function(x) {
    lambda <- exp(x)
    lambda_s <- 1 / (1 + lambda * s)
    gcv <- sum((AStAS_half %*% (lambda_s * AStWY))^2) - 2 * sum(lambda_s * (AStY * AStWY))
    gcv <- gcv + 2 * sum(lambda_s * Term0)
    gcv <- gcv - 4 * sum(lambda_s * (Term1 %*% lambda_s))
    for (i in 1:n) {
      gcv <- gcv + 2 * sum((sqrt(lambda_s) * (matrix(AStAS_N[i, ], length(s), length(s)) %*% (lambda_s * AStWY)))^2) / N[i]
    }
    return(gcv)
  }

  if (is.null(lambda)) {
    Lambda <- seq(lower, upper, length = search.length)
    Length <- length(Lambda)
    Gcv <- rep(0, Length)
    for (i in 1:Length) {
      Gcv[i] <- pspline_gcv(Lambda[i])
    }
    i0 <- which.min(Gcv)
    lambda <- exp(Lambda[i0])
  }

  theta <- (Sigi.sqrt %*% U) %*% (1 / (1 + lambda * s) * AStWY)

  res <- list(
    fitted.values = as.vector(B %*% theta), B = B, theta = theta, s = s,
    knots = knots, p = p, m = m,
    lambda = lambda, argvals.new = tnew, mu.new = as.vector(Bnew %*% theta)
  )
  class(res) <- "pspline.face"
  return(res)
}


# Example : 1   Chapter : 8.3     Page No: 432
# Positive Markov matrix Application.
A<-matrix(c(0.8,0.2,0.05,0.95),ncol=2)
u0<-c(0.02,0.98)
u1<-A%*%u0
print(u1)
u2<-A%*%u1
print(u2)


require(rms)
set.seed(1)
n <- 100
y <- sample(1 : 10, n, TRUE)
x1 <- runif(n)
x2 <- runif(n)
f <- lrm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
g <- orm(y ~ x1 + x2, x=TRUE, y=TRUE, eps=.001)
max(abs(coef(f) - coef(g)))
max(abs(vcov(f) - vcov(g, intercepts='all')))

options(digits=4)
dm <- function(x) if(length(dim(x))) dim(x) else length(x)
for(type in c('li.shepherd', 'ordinary', 'score', 'pearson',
              'deviance', 'pseudo.dep', 'partial',
              'dfbeta', 'dfbetas', 'dffit', 'dffits', 'hat', 'gof', 'lp1')) {
  cat(type)
  rf <- resid(f, type=type)
  cat(' lrm dim', dm(rf))
  rg <- resid(g, type=type)
  cat(' orm dim', dm(rg))
  cat(' max |difference|', max(abs(rf - rg)), '\n')
}

options(digits=7)
diag(vcov(f)) / diag(vcov(g, intercepts='all'))
diag(vcov(robcov(f))) / diag(vcov(robcov(g), intercepts='all'))

rf <- robcov(f)
rg <- robcov(g)
max(abs(rf$var - rg$var))

max(abs(vcov(rf, intercepts='all') - vcov(rg, intercepts='all')))
vcov(rf, regcoef.only=TRUE, intercepts='none')
vcov(rg, regcoef.only=TRUE, intercepts='none')


# Function 'loadStockData'
# Killian Martin--Horgassan
# 10-03-2015

# Load the data for the five stocks into a data frame,
# processes it into yielding the log-gross returns

source("logGrossReturns.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.

loadStockData <- function(CHOICE = 3) {

	STOCK1 <- read.csv("WeeklyBNP.csv", header = FALSE)
	STOCK2 <- read.csv("WeeklyCarrefour.csv", header = FALSE)
	STOCK3 <- read.csv("WeeklyLVMH.csv", header = FALSE)
	STOCK4 <- read.csv("WeeklySanofi.csv", header = FALSE)
	STOCK5 <- read.csv("WeeklyTotal.csv", header = FALSE)

	V1 <- logGrossReturns(rev(STOCK1[[CHOICE]]))
	V2 <- logGrossReturns(rev(STOCK2[[CHOICE]]))
	V3 <- logGrossReturns(rev(STOCK3[[CHOICE]]))
	V4 <- logGrossReturns(rev(STOCK4[[CHOICE]]))
	V5 <- logGrossReturns(rev(STOCK5[[CHOICE]]))

	# Building the data frame
	df <- data.frame(V1, V2, V3, V4, V5)

	output <- df
}


## 1. Revisiting Logical literals ##

FALSE
TRUE
FALSE

## 2. Relational operators ##

12L > 24L
10.50 == 21.15

## 3. Comparing Arithmetic Expressions ##

apple_sold <- 12.10 * 12L
lemon_sold <- 4.99 * 24L
logical_var <- apple_sold  == lemon_sold

## 4. Logical operators ##

TRUE
FALSE
TRUE

## 5. Combining logical expression ##

apple_profit <- 12.10 - 10.50
mango_profit <- 24.90 - 21.15
lemon_profit <- 4.99 - 3.20
logical_var <- apple_profit <= mango_profit || lemon_profit

Data Analyst in R/Step 1 - Introduction to R/1. Introduction to Data Analysis in R/3. Logical Expressions in R.r


#######################
## Section 6, Part 1 ##
#######################

#install.packages("pglm")
#install.packages("mlogit")
#install.packages("statmod")

library(pglm)
library(mlogit)
library(statmod)
library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

Scot.panel <- read.csv("Scottish_Ref.csv")

# scotReferendumIntention 1 = leave, 0 = stay
# euRefVote 1 = stay, 0 = leave (reverse coded from original survey question)

###############
## Table 6.1 ##
###############

# quadrature
re.logit.quad <- pglm(scotReferendumIntention ~ euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, model=("random"), effect=("individual"), R=64, index=c("id", "wave"), family=binomial(link="logit"), data=Scot.panel)
re.logit.quad.results <- cbind(re.logit.quad$estimate, sqrt(diag(vcov(re.logit.quad))), confint.default(re.logit.quad, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(re.logit.quad.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(re.logit.quad.results, digits=3)))
print(N)
print(O)

# simulation

Scot.panel.long <- mlogit.data(Scot.panel, choice="scotReferendumIntention", shape="wide", id="id")
Scot.panel.long$constant <- as.numeric(as.character(Scot.panel.long$alt))
re.logit.sim <- mlogit(scotReferendumIntention ~ constant | 0+euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, rpar=c(constant='n'), panel=TRUE, index="id", R=500, data=Scot.panel.long, reflevel="0")
re.logit.sim.results <- cbind(re.logit.sim$coefficients, sqrt(diag(vcov(re.logit.sim))), confint.default(re.logit.sim, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(re.logit.sim.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(re.logit.sim.results, digits=3)))
print(N)
print(O)

# logit

pooled.logit <- glm(scotReferendumIntention ~ euRefVote+postEUref+postEUVote+satDemScot+riskUnemployment+Scottish, family=binomial(link="logit"), data=Scot.panel)
pooled.logit.results <- cbind(pooled.logit$coefficients, sqrt(diag(vcov(pooled.logit))), confint.default(pooled.logit, level=0.95))
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(pooled.logit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(pooled.logit.results, digits=3)))
print(N)
print(O)

################
## Figure 6.1 ##
################

beta.re <- re.logit.quad$estimate
beta.re0 <- re.logit.quad$estimate[-grep("sigma", names(re.logit.quad$estimate))]
beta.pooled <- pooled.logit$coefficients

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

betadraw.pooled <- mvrnorm(ndraws, beta.pooled, vcov(pooled.logit))
betadraw.re0 <- as.matrix(betadraw[,-grep("sigma", names(re.logit.quad$estimate))])

baseline.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = median(euRefVote),
postEUref = median(postEUref),
postEUVote = median(postEUVote),
satDemScot = median(satDemScot),
riskUnemployment = median(riskUnemployment),
Scottish = median(Scottish)
))

satdemcol <- grep("satDemScot", colnames(baseline.x))
satdem.range <- seq(0, 5, 0.1)

probs.re <- matrix (0, ndraws, length(satdem.range))
probs.re0 <- matrix (0, ndraws, length(satdem.range))
probs.pooled <- matrix (0, ndraws, length(satdem.range))

probs.mean <- matrix(0, length(satdem.range), 3)

R <- 64
# the command "gauss.quad.prob" gives the "probabilist" version of the Hermite polynomial (the command "gauss.quad" gives the "physicist" version)
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

for (i in 1:length(satdem.range)) {

	baseline.x[satdemcol] <- satdem.range[i]

	for (j in 1:length(intpoints)) {

		x.re <- cbind(baseline.x, intpoints[j])
		p.re <- plogis(beta.re %*% t(x.re)) * intweights[j]
		probs.mean[i,1] <- probs.mean[i,1] + p.re

		p.draw.re <- plogis(betadraw %*% t(x.re)) * intweights[j]
		probs.re[,i] <- probs.re[,i] + p.draw.re
	}

	probs.mean[i,2] <- plogis(beta.pooled %*% t(baseline.x))
	probs.mean[i,3] <- plogis(beta.re0 %*% t(baseline.x))

	probs.pooled[,i] <- plogis(betadraw.pooled %*% t(baseline.x))
	probs.re0[,i] <- plogis(betadraw.re0 %*% t(baseline.x))

}

# random effects, pooled logit, random effect (v=0)
colors <- c("#FC660080", "#004D7380", "#86AC4180")

pdf("fig61.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.5), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(probs.mean[,1] ~ satdem.range, xlim=c(1,4), ylim=c(0, 1), type="n", xaxt="n", xlab="Satisfaction with Democracy", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(1, 2, 3, 4))
for (i in 1:length(satdem.range)){
	points(probs.re[i,] ~ satdem.range, type="l", col=colors[1], lwd=1)
	points(probs.pooled[i,] ~ satdem.range, type="l", col=colors[2], lwd=1)
	points(probs.re0[i,] ~ satdem.range, type="l", col=colors[3], lwd=1)
}
lines(probs.mean[,1]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
lines(probs.mean[,2]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
lines(probs.mean[,3]~satdem.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Random", side=4, at=probs.mean[42,1] + 0.035, cex=1.1, las=1, line=0.5)
mtext("Effects", side=4, at=probs.mean[42,1], cex=1.1, las=1, line=0.5)
mtext("Logit", side=4, at=(probs.mean[42,1] - 0.035), cex=1.1, las=1, line=0.5)
mtext("Pooled Logit", side=4, at=probs.mean[42,2], cex=1.1, las=1, line=0.5)
mtext("Random", side=4, at=probs.mean[42,3]+0.035, cex=1.1, las=1, line=0.5)
mtext("Effects", side=4, at=probs.mean[42,3], cex=1.1, las=1, line=0.5)
mtext(expression(paste("Logit (", alpha," = 0)", sep="")), side=4, at=(probs.mean[42,3] - 0.035), cex=1.1, las=1, line=0.5)
dev.off()

###############
## Table 6.2 ##
###############

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = median(euRefVote),
postEUref = median(postEUref),
postEUVote = median(postEUVote),
satDemScot = median(satDemScot),
riskUnemployment = median(riskUnemployment),
Scottish = median(Scottish)
))

x.remain.pre <- baseline.x
x.remain.pre[names(x.remain.pre)=="euRefVote"] <- 1
x.remain.pre[names(x.remain.pre)=="postEUref"] <- 0
x.remain.pre[names(x.remain.pre)=="postEUVote"] <- 0

x.remain.post <- baseline.x
x.remain.post[names(x.remain.post)=="euRefVote"] <- 1
x.remain.post[names(x.remain.post)=="postEUref"] <- 1
x.remain.post[names(x.remain.post)=="postEUVote"] <- 1

x.leave.pre <- baseline.x
x.leave.pre[names(x.leave.pre)=="euRefVote"] <- 0
x.leave.pre[names(x.leave.pre)=="postEUref"] <- 0
x.leave.pre[names(x.leave.pre)=="postEUVote"] <- 0

x.leave.post <- baseline.x
x.leave.post[names(x.leave.post)=="euRefVote"] <- 0
x.leave.post[names(x.leave.post)=="postEUref"] <- 1
x.leave.post[names(x.leave.post)=="postEUVote"] <- 0

probs <- matrix(0, ndraws, 7)

## quadrature
R <- 64

quadpoints <- gauss.quad.prob(64, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

## could use simulation instead
#install.packages("randtoolbox")
#library(randtoolbox)
#R <- 250
#halton.seq <- halton(R)
#intpoints <- qnorm(halton.seq)
#intweights <- rep(1/R, R)

for (i in 1:R) {

	x.remain.pre.q <- cbind(x.remain.pre, intpoints[i])
	x.remain.post.q <- cbind(x.remain.post, intpoints[i])
	x.leave.pre.q <- cbind(x.leave.pre, intpoints[i])
	x.leave.post.q <- cbind(x.leave.post, intpoints[i])

	p.remain.pre <- plogis(betadraw %*% t(x.remain.pre.q)) * intweights[i]
	p.remain.post <- plogis(betadraw %*% t(x.remain.post.q)) * intweights[i]
	p.leave.pre <- plogis(betadraw %*% t(x.leave.pre.q)) * intweights[i]
	p.leave.post <- plogis(betadraw %*% t(x.leave.post.q)) * intweights[i]

	probs[,1] <- probs[,1] + p.remain.pre
	probs[,2] <- probs[,2] + p.remain.post
	probs[,3] <- probs[,3] + p.leave.pre
	probs[,4] <- probs[,4] + p.leave.post

}

probs[,5] <- probs[,2] - probs[,1]
probs[,6] <- probs[,4] - probs[,3]
probs[,7] <- probs[,5] - probs[,6]

all.results <- probs
quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Remain: Pre Brexit", "Remain: Post Brexit", "Remain: Difference", "Leave: Pre Brexit", "Leave: Post Brexit", "Leave: Difference", "Diff in Diff")
print(round(first.differences, digits=3))

###############
## Table 6.3 ##
###############

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

R <- 64
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

observed.x <- with(Scot.panel, data.frame(
constant = 1,
euRefVote = euRefVote,
postEUref = postEUref,
postEUVote = postEUVote,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish
))

mean.x <- colMeans(observed.x)

id.weights <- Scot.panel$sample_weight

mem <- 0
ame.all <- matrix(0, nrow(betadraw), nrow(observed.x))

mem.predprob <- matrix(0, nrow(betadraw), 1)
ame.predprob <- matrix(0, nrow(betadraw), nrow(observed.x))

for (i in 1:R) {

	# MEM
	x.mean.all <- cbind(t(mean.x), intpoints[i])
	predprob.mean <- plogis(betadraw %*% t(x.mean.all))
	predprob.mean.q <- predprob.mean * intweights[i]
	mem.predprob <- mem.predprob + (predprob.mean.q)
	mem.temp <- predprob.mean * (1 - predprob.mean) * betadraw[,"satDemScot"]
	mem <- mem + (mem.temp * intweights[i])

	# AME
	x.vars.all <- cbind(observed.x, intpoints[i])
	predprobs <- plogis(betadraw %*% t(x.vars.all))
	ame.predprob <- ame.predprob + (predprobs * intweights[i])
	ame.temp <- predprobs * (1 - predprobs) * betadraw[,"satDemScot"]
	ame.all <- ame.all + (ame.temp * intweights[i])

}

ame <- colSums(apply(ame.all, 1, function(x){x * id.weights}))/sum(id.weights)
elas <- t(ame.all) * observed.x[,"satDemScot"] * t(1/ame.predprob)
avg.elas <- colSums(apply(elas, 2, function(x){x * id.weights}))/sum(id.weights)
mem.elas <- mem * (mean.x["satDemScot"]/mem.predprob)

all.results <- cbind(ame, mem, avg.elas, mem.elas)
quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
marginal.effects <- cbind(t(quantiles), sds)
colnames(marginal.effects) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(marginal.effects) <- c("AME", "MEM", "Average Elasticity", "Elasticity at the Mean")
print(round(marginal.effects, digits=3))

###############
## Table 6.4 ##
###############

## Population Odds Ratios

ndraws <- 1000
beta <- re.logit.quad$estimate
covmat.beta <- vcov(re.logit.quad)
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

R <- 64
quadpoints <- gauss.quad.prob(R, dist="normal")
intpoints <- quadpoints$nodes
intweights <- quadpoints$weights

observed.x <- with(Scot.panel, data.frame(
Intercept = 1,
euRefVote = euRefVote,
postEUref = postEUref,
postEUVote = postEUVote,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish
))

id.weights <- Scot.panel$sample_weight

OR.pop <- matrix(NA, ncol(observed.x), 4)

p.0 <- matrix(0, nrow(betadraw), nrow(observed.x))

# calculate baseline
for (j in 1:R) {

	x.vars.all <- cbind(observed.x, intpoints[j])
	p0 <- plogis(betadraw %*% t(x.vars.all))
	p.0 <- p.0 + (p0 * intweights[j])

}

# increment each variable by 1, calculate odds ratios
for (i in 1:ncol(observed.x)) {

	p.1 <- matrix(0, nrow(betadraw), nrow(observed.x))
	observed.x1 <- observed.x
	observed.x1[,i] <- observed.x1[,i] + 1

	if (i==4) {
	observed.x1[,2] <- observed.x1[,2] + 1
	observed.x1[,3] <- observed.x1[,3] + 1
	}

	for (j in 1:length(intpoints)) {

		x1.vars.all <- cbind(observed.x1, intpoints[j])
		p1 <- plogis(betadraw %*% t(x1.vars.all))
		p.1 <- p.1 + (p1 * intweights[j])

	}

		OR.temp <- (p.1 / (1 - p.1)) / (p.0 / (1 - p.0))
		OR.temp.w <- colSums(apply(OR.temp, 1, function(x){x * id.weights}))/sum(id.weights)
		OR.pop[i,1:3] <- quantile(OR.temp.w, probs=c(0.5, 0.025, 0.975))
		OR.pop[i,4] <- sd(OR.temp)

}

N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
colnames(OR.pop) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(OR.pop) <- names(observed.x)
print((round(OR.pop, digits=3)))
print(N)
print(O)

## Subject-Specific Odds ratios

betadraw.or <- betadraw[,-grep("sigma|(Intercept)|postEUVote", colnames(betadraw))]
postEUVote <- betadraw[,grep("euRefVote", colnames(betadraw))] + betadraw[,grep("postEUref", colnames(betadraw))] + betadraw[,grep("postEUVote", colnames(betadraw))]
betadraw.or <- cbind(betadraw.or, postEUVote)

exp.betadraw <- exp(betadraw.or)
N <- length(unique(Scot.panel$id))
O <- nrow(Scot.panel)
quantiles <- apply(exp.betadraw, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(exp.betadraw, 2, sd)
odds.ratios <- cbind(t(quantiles), sds)
colnames(odds.ratios) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(odds.ratios) <- colnames(exp.betadraw)
print(round(odds.ratios, digits=3))
print(N)
print(O)

## approximation from Zeger et al. 1988, p. 1054 ##

c <- ((16*sqrt(3))/(15*pi))
scale.pa <- sqrt(1 + c^2 * re.logit.quad$estimate[grep("sigma", names(re.logit.quad$estimate))]^2)
beta.Zeger <- apply(betadraw.or, 2, function(x){x/scale.pa})
exp.beta.Zeger <- exp(beta.Zeger)
quantiles.Zeger <- apply(exp.beta.Zeger, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds.Zeger <- apply(exp.beta.Zeger, 2, sd)
Zeger.adj <- cbind(t(quantiles.Zeger), sds.Zeger)
colnames(Zeger.adj) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(Zeger.adj) <- colnames(exp.beta.Zeger)
print(round(Zeger.adj, digits=3))

## approximation from Hedeker et al. 2018 ##

betadraw.H <- betadraw[,-grep("sigma|postEUVote", colnames(betadraw))]
postEUVote <- betadraw[,grep("euRefVote", colnames(betadraw))] + betadraw[,grep("postEUref", colnames(betadraw))] + betadraw[,grep("postEUVote", colnames(betadraw))]
sigma <- betadraw[,grep("sigma", colnames(betadraw))]
betadraw.H <- cbind(betadraw.H, postEUVote, sigma)

observed.H <- with(Scot.panel, data.frame(
Intercept = 1,
euRefVote = euRefVote,
postEUref = postEUref,
satDemScot = satDemScot,
riskUnemployment = riskUnemployment,
Scottish = Scottish,
postEUVote = postEUVote
))

predprobs <- matrix(0, nrow(betadraw.H), nrow(observed.H))

for (i in 1:R) {

	x.vars.all <- cbind(observed.H, intpoints[i])
	predprobs.temp <- plogis(betadraw.H %*% t(x.vars.all))
	predprobs <- predprobs + (predprobs.temp * intweights[i])

}

X <- as.matrix(observed.H)
lambda.matrix <- log(predprobs/(1 - predprobs))
beta.Hedeker <- apply(lambda.matrix, 1, function(x){solve(t(X) %*% X) %*% (t(X) %*% x)})
exp.beta.Hedeker <- exp(beta.Hedeker)
quantiles.Hedeker <- apply(exp.beta.Hedeker, 1, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds.Hedeker <- apply(exp.beta.Hedeker, 1, sd)
Hedeker.adj <- cbind(t(quantiles.Hedeker), sds.Hedeker)
colnames(Hedeker.adj) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(Hedeker.adj) <- colnames(observed.H)
Hedeker.adj <- Hedeker.adj[-1,]  # remove constant term
print(round(Hedeker.adj, digits=3))


target <- sample(1:9,4)
bulls <- 0
cows <- 0
attempts <- 0
while (bulls != 4)
  {
  input <- readline("Guess a 4-digit number with no duplicate digits or 0s: ")
  if (nchar(input) == 4)
    {
    input <- as.integer(strsplit(input,"")[[1]])
    if ((sum(is.na(input)+sum(input==0))>=1) | (length(table(input)) != 4)) {print("Malformed input!")} else {
      bulls <- sum(input == target)
      cows <- sum(input %in% target)-bulls
      cat("\n",bulls," Bull(s) and ",cows, " Cow(s)\n")
      attempts <- attempts + 1
      }
    } else {print("Malformed input!")}
  }
print(paste("You won in",attempts,"attempt(s)!"))


import_package("dplyr", attach=TRUE)
import_package("ggplot2", attach=TRUE)
import_package("ggraph", attach=TRUE)
.st = import('../../stats')

#' Plot a correlation matrix
#'
#' @param mat  data matrix [samples x features]
#' @return     ggplot2 object
plot_cor_matrix = function(mat, title=NULL) {
    p.mat = .st$cor$test(mat)
    cmat = cor(mat)

    col = colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
    corrplot::corrplot(cmat, method="color", col=col(200),
        type="upper", order="hclust", mar=c(0,0,2,0), # title cut off otherwise
        addCoef.col = "black", # add coefficient of correlation
        tl.col="black", tl.srt=45, #text label color and rotation
        p.mat = p.mat, sig.level = 0.05, insig = "blank",
        diag=FALSE, title=title)
}

#' Infer partial correlation network using GeneNet
#'
#' @param mat  data matrix [features x samples]
#' @param fdr  FDR cutoff for each individual bootstrap
#' @return     data.frame with node1, node2, pval, qval
pcor = function(mat, fdr=1) {
    pm = GeneNet::ggm.estimate.pcor(t(mat), lambda=0)
    pm = GeneNet::network.test.edges(pm, direct=FALSE, plot=FALSE, verbose=TRUE)
    pm$node1 = factor(rownames(mat)[pm$node1])
    pm$node2 = factor(rownames(mat)[pm$node2])

    pm %>%
        filter(qval < fdr + .Machine$double.eps) %>%
        select(node1, node2, pcor, pval, qval)
}

#' Plot correlation network
#'
#' @param mat  data matrix [samples x features]
#' @param pval p-value cutoff
#' @param fdr  FDR cutoff for each individual bootstrap
#' @return     ggplot2 object
plot_pcor_net = function(pm, pval=1, fdr=1, node_text=6, edge_text=2.5, layout="auto") {
    pval_filter = pval
    dirx = factor(sign(pm$pcor))
    levels(dirx) = c("red", "blue")
    g = pm %>%
        mutate(dir = dirx, #factor(sign(pcor)),
               lab = sprintf("pcor %.2f\np %.2g", pcor, pval)) %>%
        tidygraph::as_tbl_graph() %>%
        tidygraph::activate(edges) %>%
        tidygraph::filter(pval <= pval_filter, qval <= fdr)

    p = ggraph::ggraph(g, layout=layout) # no edges produce plotting error if geom_edge_link set
    if (igraph::gsize(g) > 0)
        p = p +
            ggraph::geom_edge_link(aes(label=lab, width=pcor^2*10, color=dir,
                alpha=abs(pcor)/2), angle_calc='along', label_size=edge_text)
    p = p +
        ggraph::geom_node_text(aes(label=name), size=node_text) +
        theme_void() +
        ggtitle(sprintf("p<%.2g, FDR<%.2g", pval, fdr))
}

#' Plot bootstrapped correlation network
#'
#' @param mat  data matrix [samples x features]
#' @param fdr  FDR cutoff for each individual bootstrap
#' @param n    number of bootstraps
#' @param noise  Standard deviations of noise to add to data
#' @param show_edge_if  logical indicating how often an edge must be < fdr
#' @return     ggplot2 object
plot_bootstrapped_pcor = function(mat, fdr=0.3, n=100, noise=0.01, show_edge_if=round(n/10), layout="auto") {
    do_bs = function(mat) {
        mat = mat[sample(seq_len(nrow(mat)), replace=TRUE),]
        sds = apply(mat, 2, sd)
        mat = t(t(mat) + sds * noise * rnorm(length(mat)))
        pm = pcor(t(mat), fdr=fdr)
    }
    bs = replicate(n, do_bs(mat), simplify=FALSE)
    g = bs %>%
        dplyr::bind_rows() %>%
        group_by(node1, node2) %>%
        summarize(pcor = median(pcor),
                  dir = as.factor(sign(median(pcor))),
                  n = n()) %>%
        filter(n >= show_edge_if) %>%
        tidygraph::as_tbl_graph()

    ggraph(g, layout=layout) +
        geom_edge_link(aes(label=n, color=dir, alpha=abs(pcor), width=n/10)) +#,
                       #angle_calc='along', size=2.5) +
        geom_node_text(aes(label=name), size=6) +
        theme_void() +
        ggtitle(sprintf("%i bootstraps, edges if fdr<%.2f in at least %i runs",
                        n, fdr, show_edge_if))
}

#' Plot the partial correlations for one variable
#'
#' @param pm     data.frame with fields: node1, node2, pcor, pval
#' @param field  Character vector of field to use as anchor (in node1 or node2)
plot_pcor_table = function(pm, field) {
    res = pm %>%
        mutate(full = paste0(node1, node2)) %>%
        filter(grepl(field, full)) %>%
        arrange(qval, pval) %>%
        transmute(node = sub(field, "", full),
                  pcor = sprintf("%.2f", pcor),
                  pval = sprintf("%.2g", pval),
                  #pval = metap::two2one(pval, invert=pcor<0),
                  fdr = sprintf("%.2g", p.adjust(pval, method="fdr")))

    gridExtra::grid.arrange(top=paste("Full-rank partial correlations with",
                            field, "(two-sided test)"),
                            gridExtra::tableGrob(res))
}


library(ggplot2)
library(reshape2)
library(rstan)

printvar <- function(v) {
  	name <- deparse(substitute(v))
  	print(paste(name, ":", v))
}

load(file = "sc2-script.RData")

q <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
		geom_point(aes(y = c(infec_counts[1:(Tlim+1)], rep(NA,T-Tlim)))) +
		theme_bw()

ggsave(q, filename="dataplot.pdf", height=4, width=6.5)

statedata <- data.frame( if2data$statemeans )
names(statedata) <- c("S","I","R")

statepart <- c(statedata[,'I'],rep(NA,T-Tlim))
qif2 <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection counts") +
			geom_point(aes(y = datapart)) +
			geom_line(aes(y = statepart), linetype = "dashed") +
			theme_bw()

ggsave(qif2, filename="if2fit.pdf", height=4, width=6.5)

## Without observation noise
##

pdata <- data.frame(parabootdata)
pforecast <- pdata[,paste("counts", 2:(T-Tlim+1), sep = "")]

meanTraj 	<- colMeans(pforecast)
quantTraj 	<- t(apply(pforecast, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

meanTrajpart 	<- c(rep(NA, Tlim+1), meanTraj)
quantTrajpart 	<- rbind(matrix(NA, nrow = Tlim+1, ncol = 2), quantTraj)

qif2forecast <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
					geom_ribbon(aes(ymin = quantTrajpart[,'025'], ymax=quantTrajpart[,'975']), alpha=0.1) +
					geom_line(aes(y = meanTrajpart), linetype = "dotted") +
    				geom_point(aes(y = datapart)) +
					geom_line(aes(y = statepart), linetype = "dashed") +
					theme_bw()

ggsave(qif2forecast, filename="if2forecast.pdf", height=4, width=6.5)

truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
estfuture   <- meanTraj
err <- estfuture - truefuture
if2sse <- sum(err^2)
printvar(if2sse)

## With observation noise
##

pdata <- data.frame(parabootdata)
pforecast <- pdata[,paste("counts", 2:(T-Tlim+1), sep = "")]
psigma <- pdata[,"sigma"]

#pcounts <- sapply(1:nTraj, function(i) pforecast[i,1:(T-Tlim)] + rnorm(T-Tlim, 0, psigma[i]))
#pcounts <- ifelse(pcounts < 0, 0, pcounts)
noise <- t(as.matrix(sapply(psigma, function(sigma) rnorm(T-Tlim, 0, sigma))))
pcounts <- pforecast + noise
pcounts[as.matrix(pcounts) < 0] <- 0

meanTraj 	<- colMeans(pcounts)
quantTraj 	<- t(apply(pcounts, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

meanTrajpart 	<- c(rep(NA, Tlim+1), meanTraj)
quantTrajpart 	<- rbind(matrix(NA, nrow = Tlim+1, ncol = 2), quantTraj)

qif2forecast_c <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
					geom_ribbon(aes(ymin = quantTrajpart[,'025'], ymax=quantTrajpart[,'975']), alpha=0.1) +
					geom_line(aes(y = meanTrajpart), linetype = "dotted") +
    				geom_point(aes(y = datapart)) +
					geom_line(aes(y = statepart), linetype = "dashed") +
					theme_bw()

ggsave(qif2forecast_c, filename="if2forecast_c.pdf", height=4, width=6.5)

## Combined

pdata <- data.frame(parabootdata)
pforecast <- pdata[,paste("counts", 2:(T-Tlim+1), sep = "")]

meanTraj 	<- colMeans(pforecast)
quantTraj 	<- t(apply(pforecast, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

meanTrajpart_n 	<- c(rep(NA, Tlim+1), meanTraj)
quantTrajpart_n 	<- rbind(matrix(NA, nrow = Tlim+1, ncol = 2), quantTraj)

qif2combined <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
					geom_ribbon(aes(ymin = quantTrajpart[,'025'], ymax=quantTrajpart[,'975']), alpha=0.1) +
					geom_ribbon(aes(ymin = quantTrajpart_n[,'025'], ymax=quantTrajpart_n[,'975']), alpha=0.2) +
					geom_line(aes(y = meanTrajpart_n), linetype = "dotted") +
    				geom_point(aes(y = datapart)) +
					geom_line(aes(y = statepart), linetype = "dashed") +
					theme_bw()

ggsave(qif2combined, filename="if2combined.pdf", height=4, width=6.5)

## HMCMC
##

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
               			r = melt(exfit[,,'r'])$value,
               			sigma = melt(exfit[,,'sigma'])$value,
               			eta = melt(exfit[,,'eta'])$value,
               			berr = melt(exfit[,,'berr'])$value,
               			Sinit = melt(exfit[,,'y0[1]'])$value,
               			Iinit = melt(exfit[,,'y0[2]'])$value,
               			Rinit = melt(exfit[,,'y0[3]'])$value )

for (j in 1:datlen) {
	varname <- paste('Bnoise[', j, ']', sep = '')
	paramdata[[varname]] <- melt( exfit[,,varname] )$value
}

# sample from parameter distributions

pardatlen 	<- dim(paramdata)[1]
inds 	    <- sample.int(pardatlen,nTraj,replace = TRUE)
params 	    <- paramdata[inds,]

bootstrapdata <- matrix(NA, nrow = nTraj, ncol = T+1)

for (i in 1:nTraj) {

	paramset <- params[i,]

	init_cond <- c(S = paramset$Sinit,
	               I = paramset$Iinit,
	               R = paramset$Rinit)
	pars <- c(R0 = paramset$R0,
	          r = paramset$r,
	          N = 500.0,
	          eta = paramset$eta,
	          berr = paramset$berr)

	berrvec <- numeric(datlen)
	for (j in 1:datlen) {
		varname <- paste("Bnoise[", j, "]", sep = "")
		berrvec[j] <- paramset[[varname]]
	}

	sdeout <- StocSIRstan(init_cond, pars, T, steps, berrvec, datlen)
	colnames(sdeout) <- c('S','I','R','B')

	bootstrapdata[i,] <- sdeout[,'I']

}

# remove NaN rows
bootstrapdata <- bootstrapdata[complete.cases(bootstrapdata),]

meanTraj 	<- colMeans(bootstrapdata, na.rm = FALSE)
quantTraj 	<- t( apply(bootstrapdata, 2, quantile, probs = c(0.025,0.975), na.rm = FALSE) )
colnames(quantTraj) <- c("025","975")

qhmcforecast <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
					geom_ribbon(aes( ymin = c(rep(NA, Tlim+1), quantTraj[(Tlim+2):(T+1),'025']),
					                 ymax = c(rep(NA, Tlim+1), quantTraj[(Tlim+2):(T+1),'975']),
									 alpha=0.2) ) +
					geom_line(aes(y = meanTraj), linetype = "dashed") +
					geom_point(aes(y = datapart)) +
					theme_bw() +
					theme(legend.position="none")

ggsave(qhmcforecast, filename="hmcforecast.pdf", height=4, width=6.5)

truefuture  <- sdeout_true[(Tlim+2):(T+1),'I']
estfuture   <- meanTraj[(Tlim+2):(T+1)]

err <- estfuture - truefuture
hmcsse <- sum(err^2)
printvar(hmcsse)


## ============================================================================================
##
## readCancerData
##   - Read preprocessed data (log2  normalized data + background information),
##     compute log2 differences in gene expression and extract information from background
##
## Auxilliary functions:
##   mapToGenes
##   makeListWithData
##
## ============================================================================================

mapToGenes <- function(data) {
  ## Map to gene symbol
  nuIDs <- rownames(data)
  mappingInfo <- nuID2RefSeqID(nuIDs, lib.mapping='lumiHumanIDMapping', returnAllInfo=TRUE)
  geneName <- as.character(mappingInfo[,3])
  geneName <- geneName[geneName!=""]

  ## Compute mean of probes for each gene
  exprs0 <- data
  uGeneNames <- unique(geneName)
  exprs <- matrix(NA, ncol=ncol(exprs0), nrow=length(uGeneNames))
  colnames(exprs) <- colnames(exprs0)
  rownames(exprs) <- uGeneNames
  for (j in 1:length(uGeneNames))
    exprs[j,] <- colMeans(exprs0[mappingInfo[,3]==uGeneNames[j], ,drop=F])

  exprs
}

makeListWithData <- function(data, withoutSpread, withSpread, followUpTime, isCase) {

  data <- mapToGenes(data)

  ## Compute log2 differences and standardize data (three different standardizations)
  withoutSpread <- withoutSpread[isCase]
  withSpread <- withSpread[isCase]
  followUpTime <- followUpTime[isCase]
  ##
  dataN1 <- data[,isCase] - (data[,!isCase]) ## case - ctrl, no standardization
  sd <- apply(dataN1, 1, sd)
  mu <- rowMeans(dataN1)
  dataN2 <- apply(dataN1, 2, function(x){(x-mu)/sd}) ## standardize to mean=0, sd=1
  dataN3 <- apply(dataN1, 2, function(x){x/sd}) ## Assume mean 0, standardize to sd=1

  ## Sort data with respect to followUpTime
  sortList <- sort.list(followUpTime)
  withoutSpread <- withoutSpread[sortList]
  withSpread <- withSpread[sortList]
  followUpTime <- followUpTime[sortList]
  dataN1 <- dataN1[,sortList]
  dataN2 <- dataN2[,sortList]
  dataN3 <- dataN3[,sortList]

  list(withoutSpread=withoutSpread,
       withSpread=withSpread,
       followUpTime=followUpTime,
       weight=matrix(1,nrow=3, ncol=nrow(dataN1)),
       dataN1=dataN1,
       dataN2=dataN2,
       dataN3=dataN3)
}

readCancerData <- function() {

  ## === Read data and background ===
  load(file="../Data/prospectiveCancerData.R")
  data <- normdata  # normdata  is the gene expression matrix
  ## The backgound matrix:
  ## Rearrange columns in data and rows in background so that case and ctrl of the same pair are adjacent
  # ind = individuals to include
  data <- data[, ind]
  background <- background[ind, ]
  ## Now the case and control from a case-control pair are found in neighboring columns, i.e. log-differences
  ## are computed as data[, background[,"Case_ctrl"]=="case"] - data[, background[,"Case_ctrl"]=="ctrl"]:

  ## === Find followUpTime ===
  n <- length(background[,"diagnosisdate"])
  followUpTime <- rep(NA, n)
  for (i in 1:n)
    if (background[i,"diagnosisdate"]!="") {
      date1 <- getDate(background[i,"freezing_date"])
      date2 <- getDate(background[i,"diagnosisdate"])
      followUpTime[i] <- round(difftime(date2,date1,units="days") )
    }

  ## === Define strata - withoutSpread and withSpread ===
  withSpread <- background[,"Case_ctrl"]=="case" & background[,"metastasis"]>0
  withoutSpread <- background[,"Case_ctrl"]=="case" & background[,"metastasis"]==0

  ## === Define isCase ===
  isCase <- background[,"Case_ctrl"]=="case"

  makeListWithData(data, withoutSpread, withSpread, followUpTime, isCase)
}