### RD design functions
###peter crosta pmcrosta at gmail dot com
## This file consists of only functions that are used in the
## RD analysis. It will be sourced

###########MOST FUNCTIONS ARE DEPENDENT ON maxbin AND binwidth (h) ###########################

## Create class binlist for numeric breaks
setClass("binlist", representation(breaks="numeric", right="numeric", left="numeric"))

getbins <- function(binwidth, maxbin) {
  rightbins <- seq(binwidth, maxbin, binwidth)
  leftbins <- -rev(seq(0, maxbin, binwidth))

  breakbins <- c(sort(leftbins), rightbins)

  z <- new("binlist")
  z@breaks <- breakbins[abs(breakbins)<=maxbin]
  z@right <- rightbins[rightbins<=maxbin]
  z@left <- leftbins[leftbins>=-maxbin]

  return(z)
}

# -244 to 121 might matter, days before and after Sep 1
mainhist <- function(binwidth, maxbin, yesplot=TRUE, emcp=emc) {
  breaks <- getbins(binwidth, maxbin)@breaks
  emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)
  maxbin.hist <- hist(emcp[emcdum==1], breaks=breaks, plot=yesplot, main=paste("Histogram of birth date (centered): Binwidth=",binwidth, ", ", length(breaks)-1, " bins", sep=""), xlim=c(min(breaks), max(breaks)), xlab="Centered Birth Date")
  if (yesplot) abline(v=0, lty=2, lwd=2, col="darkgrey")
  binmids <- maxbin.hist$mids
}

####this function is built from McCrary(2008); tests discontinuity of density
mccrary <- function(binwidth, maxbin, nn, emcp=emc) {
    f.triangle <- function(x) { ifelse(abs(x)<1, 1-abs(x), 0) }

    breaks <- getbins(binwidth, maxbin)@breaks
    emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)
    maxbin.hist <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)
    binmids <- maxbin.hist$mids

    totaln <- sum(maxbin.hist$counts)
    Xj <- binmids
    Yj <- maxbin.hist$counts / (totaln*binwidth)

    ##set bandwidth (nearest neighbors); #nn <-20; this is argument in func call

    ##first step histogram
    plot(Xj, Yj, xlab="Bin midpoints", ylab="Normalized cell size", main=paste("First step histogram for McCrary(2008)\nbinwidth=",binwidth, " bandwidth=", nn, sep=""))

    ##local fit right and plot
    right.locfit <- locfit.raw(lp(Xj[Xj > 0], h=nn, deg=1), Yj[Xj > 0], kern='tria', family="gaussian")
    plot(right.locfit, add=TRUE, col="red")

    ###weighted reg around boundary point with triang kernel to get intercept term
    wt <- f.triangle((Xj[Xj > 0]-rep(0, length( Xj[Xj > 0])))/nn)
    wt <- (wt/(sum(wt)))*length(wt)
    templm <- lm(Yj[Xj > 0]~Xj[Xj > 0], weight=wt)
    fr <- coef(templm)[1]

    #local fit left and plot
    left.locfit <- locfit.raw(lp(Xj[Xj <= 0], h=nn, deg=1), Yj[Xj <= 0], kern='tria', family="gaussian")
    plot(left.locfit, add=TRUE, col="red")

    ###weighted reg around boundary point with trian kernel to get intercept term
    wt <- f.triangle((Xj[Xj <= 0]-rep(0,length(Xj[Xj <= 0])))/nn)
    wt <- (wt/(sum(wt)))*length(wt) #like aweights in stata
    templm <- lm(Yj[Xj <= 0]~Xj[Xj <= 0], weight=wt)
    fl <- coef(templm)[1]

    abline(v=0, lty=2, lwd=2, col="darkgrey")

    thetahat <- log(fr) - log(fl)
    sethetahat <- sqrt( (1/(totaln*nn)) * (24/5) * ((1/fr) + (1/fl)) )

    legend("topright", bg="white", cex=.9, pt.cex=.9, c("Cutoff", "Bin-mid regression with triangular kernel"), lty=c(2, 1), lwd=c(2, 1), col=c("darkgrey", "red"))
    text(-maxbin+30, max(Yj)*.92, paste("theta-hat =", round(thetahat, 4), "\nstd. err. = ", round(sethetahat,4)))
    return(cat(binwidth, "\t", maxbin, "\t", nn, "\t", thetahat, "\t", sethetahat, "\n"))
}

#####function to generate prop tests to look at subgroup covariate differences around cutoff (like gifted and atrisk)
prettyprop <- function(binwidth, maxbin, covariate, emcp=emc, lab="") {
    breaks <- getbins(binwidth, maxbin)@breaks
    emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

    covariate <- covariate[emcdum==1]
    cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)

    afters<-which(cutbybreak %in% tail(levels(cutbybreak), maxbin))
    befores<-which(cutbybreak %in% head(levels(cutbybreak), maxbin))

    x1 <- sum(covariate[befores], na.rm=TRUE)
    x2 <- sum(covariate[afters], na.rm=TRUE)
    n1 <- length(na.omit(covariate[befores]))
    n2 <- length(na.omit(covariate[afters]))

    pt <- prop.test(c(x1,x2), c(n1, n2))
    return(paste(lab, round(pt$estimate[1], 3), round(pt$estimate[2], 3), round(diff(pt$estimate), 3), round(pt$p.value, 3), n1, n2, sep=', '))
}

######## similar to prettyprop, but for variables that take a t-test
ttest <- function(binwidth, maxbin, covariate, emcp=emc, lab="") {
    breaks <- getbins(binwidth, maxbin)@breaks
    emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

    covariate <- covariate[emcdum==1]
    cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)

    afters<-which(cutbybreak %in% tail(levels(cutbybreak), maxbin))
    befores<-which(cutbybreak %in% head(levels(cutbybreak), maxbin))

    x1 <- covariate[befores]
    x2 <- covariate[afters]
    tt <- t.test(x1, x2)

    return(paste(lab, round(tt$estimate[1], 3), round(tt$estimate[2], 3), round(-diff(tt$estimate), 3), round(tt$p.value, 3), length(na.omit(x1)), length(na.omit(x2)), sep=","))
}

covfunc <- function(binwidth, maxbin, covariate, ylabcov, use.loess=FALSE, emcp=emc, YLIM=TRUE, nn=10, g) {

    breaks <- getbins(binwidth, maxbin)@breaks
    emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

    cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)
    binmids <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)$mids

    binned.covariate <- tapply(covariate[emcdum==1], cutbybreak, function(x) mean(x, na.rm=TRUE))
    forcing <- ifelse(binmids>0, 1, 0)
    tx <- which(forcing==1)
    forcing.sample <- ifelse(emcp>0, 1, 0)

    if (YLIM) {
        plot(binned.covariate~binmids, col=NULL, xlab="Birth date (centered)", ylab=ylabcov, main=paste(ylabcov, " Grade ",g, "\nBinwidth=",binwidth, ", ", length(breaks)-1, " bins", sep=""), xaxt='n', ylim=c(0, 1))
    } else plot(binned.covariate~binmids, col=NULL, xlab="Birth date (centered)", ylab=ylabcov, main=paste(ylabcov, " Grade ",g, "\nBinwidth=",binwidth, ", ", length(breaks)-1, " bins", sep=""), axes=FALSE)

    points(binmids[tx], binned.covariate[tx], col="blue4", pch=4)
    points(binmids[-tx], binned.covariate[-tx], col="darkorange", pch=16)
    axis(1, at=seq(-maxbin, maxbin, as.integer(maxbin/10)))

    if (!YLIM) axis(2, at=round(seq(min(binned.covariate, na.rm=TRUE), max(binned.covariate, na.rm=TRUE), diff(range(binned.covariate, na.rm=TRUE))/10),2))

    abline(v=0, lty=2, lwd=2, col="darkgrey")

    if (ylabcov %in% covstlab) {
      pval <- ttest(1, binwidth, covariate, emcp)
    } else {
      pval <- prettyprop(1, binwidth, covariate, emcp)
    }
    pvalsplit <- as.numeric(unlist(strsplit(pval, split=",")))
    cat(pvalsplit, "\n")

    if (use.loess) {
      f.triangle <- function(x) { ifelse(abs(x)<1, 1-abs(x), 0) }
      Yj <- binned.covariate
      Xj <- binmids[which(!is.na(Yj))]
      Yj <- binned.covariate[which(!is.na(Yj))]

      #changed so this is now argument
      #nn<-binwidth*3

      ##local fit right and plot
      right.locfit <- locfit.raw(lp(Xj[Xj > 0], h=nn, deg=1), Yj[Xj > 0], kern="tria", family="gaussian")
      plot(right.locfit, add=TRUE, col="green")
      #local fit left and plot
      left.locfit <- locfit.raw(lp(Xj[Xj <= 0], h=nn, deg=1), Yj[Xj <= 0], kern='tria', family="gaussian")
      plot(left.locfit, add=TRUE, col="green")

      text(-maxbin/2, quantile(binned.covariate, na.rm=TRUE)[4], cex=0.8, paste("1 binwidth difference at cutoff =", round(pvalsplit[4],3), "\np-val=", round(pvalsplit[5],3)))
      #Add legend.
      legend("topright", bg="white", cex=.9, pt.cex=.9, c("Older", "Younger", "Cutoff", "Piecewise loess"), lty=c(NA, NA, 2, 1), lwd=c(NA, NA, 2, 1), col=c("blue4", "darkorange", "darkgrey", "green"), pch=c(4, 16, NA, NA, NA))
    }  else {
        ##run simple regression model and add curves to plot
        model <- lm(covariate~forcing.sample + emcp + I(emcp^2), subset=emcdum==1)
        coefs <- coefficients(model)
        curve(coefs[1] + coefs[3]*x + coefs[4]*x^2, -maxbin, 0, add=T, col="red")
        curve(coefs[1] + coefs[2] + coefs[3]*x + coefs[4]*x, 0, maxbin, add=T, col="red")
        legend("topright", bg="white", cex=.9, pt.cex=.9, c("Older", "Younger", "Cutoff", "Piecewise OLS"), lty=c(NA, NA, 2, 1), lwd=c(NA, NA, 2, 1), col=c("blue4", "darkorange", "darkgrey", "red"), pch=c(4, 16, NA, NA))
        text(-maxbin/2, quantile(binned.covariate, na.rm=TRUE)[4], cex=0.8, paste("OLS difference at cutoff = ", round(coefs[2], 3), "(", round(sqrt(vcov(model)[2,2]), 3), ")",sep=""))
    }

}

outvforce <- function(binwidth, maxbin, covariate, ylabcov, use.loess=FALSE, emcp=emc, YLIM=TRUE, nn=10, g, change=FALSE) {

  ###Plot of outcome vs. forcing variable
  breaks <- getbins(binwidth, maxbin)@breaks
  emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

  cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)
  binmids <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)$mids

  ##group means with binwidth of ; midpoints for horiz axis supplied by hist
  binned.covariate <- tapply(covariate[emcdum==1], cutbybreak, function(x) mean(x, na.rm=TRUE))
  forcing <- ifelse(binmids>0, 1, 0)
  tx <- which(forcing==1)
  forcing.sample <- ifelse(emcp>0, 1, 0)

  if (change) {
    maintit=paste(ylabcov, " Grade ",g-1, " to ", g, "\nBinwidth=",binwidth, ", ", length(breaks)-1, " bins", sep="")
  } else maintit=paste(ylabcov, " Grade ",g, "\nBinwidth=",binwidth, ", ", length(breaks)-1, " bins", sep="")

  if (YLIM) {
        plot(binned.covariate~binmids, col=NULL, xlab="Birth date (centered)", ylab=ylabcov, main=maintit, xaxt='n', ylim=c(0, 1))
  } else plot(binned.covariate~binmids, col=NULL, xlab="Birth date (centered)", ylab=ylabcov, main=maintit, axes=FALSE)

  points(binmids[tx], binned.covariate[tx], col="blue4", pch=4)
  points(binmids[-tx], binned.covariate[-tx], col="darkorange", pch=16)
  axis(1, at=seq(-maxbin, maxbin, as.integer(maxbin/10)))

  if (!YLIM) axis(2, at=round(seq(min(binned.covariate, na.rm=TRUE), max(binned.covariate, na.rm=TRUE), diff(range(binned.covariate, na.rm=TRUE))/10),2))

  abline(v=0, lty=2, lwd=2, col="darkgrey")

 if (ylabcov %in% covstlab) {
      pval <- ttest(1, binwidth, covariate, emcp)
    } else {
      pval <- prettyprop(1, binwidth, covariate, emcp)
    }
    pvalsplit <- as.numeric(unlist(strsplit(pval, split=",")))
    cat(pvalsplit, "\n")

    ### LAST MOD IS HERE
    if (use.loess) {
    f.triangle <- function(x) { ifelse(abs(x)<1, 1-abs(x), 0) }
    Yj <- binned.covariate
    Xj <- binmids[which(!is.na(Yj))]
    Yj <- binned.covariate[which(!is.na(Yj))]

    #changed so this is now argument
    #nn<-binwidth*3

    ##local fit right and plot
    right.locfit <- locfit.raw(lp(Xj[Xj > 0], h=nn, deg=1), Yj[Xj > 0], kern='tria', family="gaussian")
    plot(right.locfit, add=TRUE, col="green")

    #local fit left and plot
    left.locfit <- locfit.raw(lp(Xj[Xj <= 0], h=nn, deg=1), Yj[Xj <= 0], kern='tria', family="gaussian")
    plot(left.locfit, add=TRUE, col="green")

    text(-maxbin/2, quantile(binned.covariate, na.rm=TRUE)[4], paste("1 binwidth difference at cutoff =", round(pvalsplit[4],3), "\np-val=", round(pvalsplit[5],3)))
    #Add legend.
      legend("topright", bg="white", cex=.9, pt.cex=.9, c("Older", "Younger", "Cutoff", "Piecewise loess"), lty=c(NA, NA, 2, 1), lwd=c(NA, NA, 2, 1), col=c("blue4", "darkorange", "darkgrey", "green"), pch=c(4, 16, NA, NA, NA))
    }  else {
    ##run simple regression model and add curves to plot
    model <- lm(binned.covariate~forcing + binmids + I(binmids^2), subset=emcdum==1)
    #model <- lm(covariate~forcing.sample + emcp + I(emcp^2), subset=emcdum==1)
    coefs <- coefficients(model)
    curve(coefs[1] + coefs[3]*x + coefs[4]*x^2, -maxbin, 0, add=T, col="red")
    curve(coefs[1] + coefs[2] + coefs[3]*x + coefs[4]*x, 0, maxbin, add=T, col="red")
    legend("topright", bg="white", cex=.9, pt.cex=.9, c("Older", "Younger", "Cutoff", "Piecewise OLS"), lty=c(NA, NA, 2, 1), lwd=c(NA, NA, 2, 1), col=c("blue4", "darkorange", "darkgrey", "red"), pch=c(4, 16, NA, NA))
        text(-maxbin/2, quantile(binned.covariate, na.rm=TRUE)[4], cex=0.8, paste("OLS difference\nat cutoff = ", round(coefs[2], 3), "(", round(sqrt(vcov(model)[2,2]), 3), ")",sep=""))
    }
}

##********************************************************************COVARIATES******************
#x11(height=10, width=10)

clx <- function(fm, dfcw, cluster){
         # R-codes (www.r-project.org) for computing
         # clustered-standard errors. Mahmood Arai, Jan 26, 2008.

	 # The arguments of the function are:
         # fitted model, cluster1 and cluster2
         # You need to install libraries `sandwich' and `lmtest'

         # reweighting the var-cov matrix for the within model
         #library(sandwich);library(lmtest)
         M <- length(unique(cluster))
         N <- length(cluster)
         K <- fm$rank
         dfc <- (M/(M-1))*((N-1)/(N-K))
         uj  <- apply(estfun(fm),2, function(x) tapply(x, cluster, sum));
         vcovCL <- dfc*sandwich(fm, meat=crossprod(uj)/N)*dfcw
         coeftest(fm, vcovCL)
}

mclx <- function(fm, dfcw, cluster1, cluster2){
         # R-codes (www.r-project.org) for computing multi-way
         # clustered-standard errors. Mahmood Arai, Jan 26, 2008.
         # See: Thompson (2006), Cameron, Gelbach and Miller (2006)
         # and Petersen (2006).
	 # reweighting the var-cov matrix for the within model

         # The arguments of the function are:
         # fitted model, cluster1 and cluster2
         # You need to install libraries `sandwich' and `lmtest'

         library(sandwich);library(lmtest)
         cluster12 = paste(cluster1,cluster2, sep="")
         M1  <- length(unique(cluster1))
         M2  <- length(unique(cluster2))
         M12 <- length(unique(cluster12))
         N   <- length(cluster1)
         K   <- fm$rank
         dfc1  <- (M1/(M1-1))*((N-1)/(N-K))
         dfc2  <- (M2/(M2-1))*((N-1)/(N-K))
         dfc12 <- (M12/(M12-1))*((N-1)/(N-K))
         u1j   <- apply(estfun(fm), 2, function(x) tapply(x, cluster1,  sum))
         u2j   <- apply(estfun(fm), 2, function(x) tapply(x, cluster2,  sum))
         u12j  <- apply(estfun(fm), 2, function(x) tapply(x, cluster12, sum))
         vc1   <-  dfc1*sandwich(fm, meat=crossprod(u1j)/N )
         vc2   <-  dfc2*sandwich(fm, meat=crossprod(u2j)/N )
         vc12  <- dfc12*sandwich(fm, meat=crossprod(u12j)/N)
         vcovMCL <- (vc1 + vc2 - vc12)*dfcw
         coeftest(fm, vcovMCL)
}

leecard <- function(binwidth, maxbin, outcome, testtype, emcp=emc) {
    ## outcome = const + B1*age + B2*Cutoff + e
    ## outcome = const + B1*emcp + B2*forcing.sample + e

  breaks <- getbins(binwidth, maxbin)@breaks
  emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

  cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)
  binmids <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)$mids

  emcbinmids <- findInterval(emcp[emcdum==1], binmids, rightmost.closed=TRUE)
  emcmids <-  binmids[emcbinmids]

  #binned.outcome <- tapply(outcome[emcdum==1], cutbybreak, function(x) mean(x, na.rm=TRUE))
  #binned.variance <- tapply(outcome[emcdum==1], cutbybreak, function(x) var(x, na.rm=TRUE))

  #binned.test <- tapply(outcome[emcdum==1], cutbybreak, function(x) table(!is.na(x)))
  #Nj <- binned.takers <- unlist(lapply(binned.test, function(x) sum(x["TRUE"])))
  #binned.takers <- binned.takers / (sum(binned.takers) / length(binned.takers))
  #nomissbin <- sapply(names(unlist(binned.takers)), function(x) substr(x, start=1, stop=nchar(x)-5))

  forcing <- ifelse(binmids>0, 1, 0)
  tx <- which(forcing==1)
  forcing.sample <- ifelse(emcp>0, 1, 0)

  #leftcut <- sort(getbins(binwidth, maxbin)@left)[1]
  #rightcut <- sort(getbins(binwidth, maxbin)@right, decreasing=TRUE)[1]
  #rightobs <- ifelse(emc > 0 & emc <= rightcut, 1, 0)
  #leftobs <- ifelse(emc <= 0 & emc > leftcut, 1, 0)
  #obs <- ifelse(emc >= leftcut & emc <= rightcut, 1, 0)
  test <- outcome[emcdum==1][emcbinmids!=0]
  alpha <- forcing.sample[emcdum==1][emcbinmids!=0]

  ##for GOF test
  Unrestricted <- lm(test~alpha+as.factor(emcmids))
  #coef on forcing.sample is NA
  J <- Unrestricted$rank
  N <- dim(Unrestricted$model)[1]
  ESSur <- sum(Unrestricted$residuals^2)

  ####global polynomial models over microdata with cluster consistent standard errors and a GOF test (Card and Lee 2008)
  #p0.T <- lm(outcome~forcing.sample, subset=emcdum==1)
  #clx(p0.T, 1, clustersub)  #cluster consistent standard errors
  #sqrt(vcovHC(p0.T, "HC")) #robust Heteroskedasticity-consistent standard errors
  #K <- p0.T$rank
  #ESSr <- sum(p0.T$residuals^2)
  #G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  #print(pval <- pf(G, J-K, N-J))  GOODNESS OF FIT TEST

  cat("LeeCard GOF Tests", "P-values from F-test", "Polynomial order\n", sep=", ")
  p1.T <- lm(test~alpha+emcmids)
  clustersub <- emcp[attributes(p1.T$model)$row.names]
  c1<-clx(p1.T, 1, clustersub)
  K <- p1.T$rank
  ESSr <- sum(p1.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ") #

  p2.T <- p3.T <- update(p1.T, . ~ . + I(emcmids^2))
  clustersub <- emcp[attributes(p2.T$model)$row.names]
  c2<-clx(p2.T, 1, clustersub)
  K <- p2.T$rank
  ESSr <- sum(p2.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  p3.T <- update(p2.T, . ~ . + I(emcmids^3))
  clustersub <- emcp[attributes(p3.T$model)$row.names]
  c3<-clx(p3.T, 1,clustersub)
  K <- p3.T$rank
  ESSr <- sum(p3.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  p4.T <- update(p3.T, . ~ . + I(emcmids^4))
  clustersub <- emcp[attributes(p4.T$model)$row.names]
  clx(p4.T, 1, clustersub)
  K <- p4.T$rank
  ESSr <- sum(p4.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  p5.T <- update(p4.T, . ~ . + I(emcmids^5))
  clustersub <- emcp[attributes(p5.T$model)$row.names]
  clx(p5.T, 1, clustersub)
  K <- p5.T$rank
  ESSr <- sum(p5.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  p6.T <- update(p5.T, . ~ . + I(emcmids^6))
  clustersub <- emcp[attributes(p6.T$model)$row.names]
  clx(p6.T, 1, clustersub)
  K <- p6.T$rank
  ESSr <- sum(p6.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  p7.T <- update(p6.T, . ~ . + I(emcmids^7))
  clustersub <- emcp[attributes(p7.T$model)$row.names]
  clx(p7.T, 1, clustersub)
  K <- p7.T$rank
  ESSr <- sum(p7.T$residuals^2)
  G = ((ESSr-ESSur)/(J-K)) / (ESSur / (N-J)) # ~F(J-K, N-J)
  cat(pval <- pf(G, J-K, N-J), K-2, "\n", sep=", ")

  ################################### Global fits end

  ## regs run on collapsed to cell level data with heteroskedasticity-consistent standard errors.
  ##Also include variance correction factor as in Card and Lee 2008 equations 12 and 13.
  ## Omit for now

  #p0.C <- lm(binned.outcome~forcing, weights=binned.takers)
  #sqrt(vcovHC(p0.C, "HC")) #robust Heteroskedasticity-consistent standard errors: about equal to clx(p0.T, 1, clustersub)
  #sigmahat2_a <- 2*(sum(p0.C$residuals^2)/sum(Nj) - sum(binned.variance, na.rm=T)/sum(Nj))  #maybe this one?
  #newstderror <- vcovHC(p0.C, "HC")[2,2] + sigmahat2_a

  #p1.C <- lm(binned.outcome~forcing*breaks[2:81], weights=binned.takers)
  #sqrt(vcovHC(p1.C, "HC"))
  #sigmahat2_a <- 2*(sum(p1.C$residuals^2 * Nj[1:79]) / sum(Nj)  - sum(binned.variance, na.rm=T)/sum(Nj)) #maybe this one?
  #newstderror <- vcovHC(p1.C, "HC")[2,2] + sigmahat2_a

  #p2.C <- lm(outcome~forcing.sample*emc + forcing.sample*I(emc^2), subset=obs==1)
  return(list(c1, c2, c3))
}

srdregs <- function(binwidth, maxbin, outcome, testtype, emcp=emc, coefs=1, use.coefs=FALSE) {
    ## outcome = const + B1*age + B2*Cutoff + e
    ## outcome = const + B1*emcp + B2*forcing.sample + e

  breaks <- getbins(binwidth, maxbin)@breaks
  emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

  cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)
  binmids <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)$mids

  emcbinmids <- findInterval(emcp[emcdum==1], binmids, rightmost.closed=TRUE)
  emcmids <-  binmids[emcbinmids]

  forcing <- ifelse(binmids>0, 1, 0)
  #tx <- which(forcing==1)
  forcing.sample <- ifelse(emcp>0, 1, 0)

  test <- outcome[emcdum==1][emcbinmids!=0]
  alpha <- forcing.sample[emcdum==1][emcbinmids!=0]
  if (use.coefs){
    beta <- coefs[emcdum==1,][emcbinmids!=0,]
    sr.model <- lm(test~alpha+emcmids+I(emcmids^2)+beta)
  } else sr.model <- lm(test~alpha+emcmids+I(emcmids^2))

  clustersub <- emcp[attributes(sr.model$model)$row.names]
  adjrsq <- summary(sr.model)$adj.r.squared

  ##temporary fix for now until I figure out prob with sandwich estimator
  a<-try(print(clx(sr.model, 1, clustersub)), silent=TRUE)
  if (class(a)=="try-error") print(summary(sr.model))
  cat("N=",length(clustersub), " Adj. R-sq=", adjrsq, '\n\n', sep='')

}

frdregs <- function(binwidth, maxbin, outcome, testtype, emcp=emc, coefs=1, use.coefs=FALSE, instr) {
    ## outcome = const + B1*age + B2*Cutoff + e
    ## outcome = const + B1*emcp + B2*forcing.sample + e
    ## forcing.sample =  const+A1*age

  breaks <- getbins(binwidth, maxbin)@breaks
  emcdum <- ifelse(emcp >= min(breaks) & emcp <= max(breaks), 1, 0)

  cutbybreak <- cut(emcp[emcdum==1], breaks=breaks)
  binmids <- hist(emcp[emcdum==1], breaks=breaks, plot=FALSE)$mids

  emcbinmids <- findInterval(emcp[emcdum==1], binmids, rightmost.closed=TRUE)
  emcmids <-  binmids[emcbinmids]

  forcing <- ifelse(binmids>0, 1, 0)
  #tx <- which(forcing==1)
  forcing.sample <- ifelse(emcp>0, 1, 0)

  test <- outcome[emcdum==1][emcbinmids!=0]
  alpha <- forcing.sample[emcdum==1][emcbinmids!=0]
  instrument <- instr[emcdum==1][emcbinmids!=0]

  if (use.coefs){
    beta <- coefs[emcdum==1,][emcbinmids!=0,]
    mf <- data.frame(test, alpha, instrument, emcmids, beta)
    form1 <- as.formula(paste("test~emcmids+I(emcmids^2)+alpha+",
                   paste(colnames(mf[,5:dim(mf)[2]]), collapse="+"),
                         " | instrument+emcmids+I(emcmids^2)+",paste(colnames(mf[,5:dim(mf)[2]]), collapse="+"), sep=''))
    sr.model <- ivreg(form1, data=mf)
  } else {
    mf <- data.frame(test, alpha, instrument, emcmids)
    sr.model <- ivreg(test~emcmids+I(emcmids^2)+alpha | instrument+emcmids+I(emcmids^2), data=mf)
  }

  clustersub <- emcp[attributes(sr.model$model)$row.names]
  adjrsq <- summary(sr.model)$adj.r.squared

  ##temporary fix for now until I figure out prob with sandwich estimator
  a<-try(print(clx(sr.model, 1, clustersub)), silent=TRUE)
  if (class(a)=="try-error") print(summary(sr.model))
  cat("N=",length(clustersub), " Adj. R-sq=", adjrsq, '\n\n', sep='')

}

##$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ FUNCTIONS END $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$##


# source("uvoz/uvoz.r")

ustvari.sestavine <- function() {
  attach(sestavine)
  #Izračuna, koliko sestavin iz seznama vsaka jed vsebuje
  St.sestavin <- apply(sestavine[-1], 1, sum)

  #V katere kategorije vse jih delimo
  kategorije <- c("podpovprečno", "povprečno", "nadpovprečno")
  razvrstitev <- character(length(St.sestavin))
  razvrstitev[St.sestavin>3] <- "nadpovprečno"
  razvrstitev[St.sestavin==2|St.sestavin==3] <- "povprečno"
  razvrstitev[St.sestavin<2] <- "podpovprečno"
  Razvrstitev <- factor(razvrstitev, levels = kategorije, ordered = TRUE)
  koncni <- data.frame(JED = Jed, BEEF.PATTY, SHREDDED.LETTUCE, CHEESE, PICKLE.SLICES, REGULAR.BUN, MCCHICKEN.PATTY, ST.SESTAVIN.S.SEZNAMA = St.sestavin, RAZVRSTITEV = Razvrstitev)
  detach(sestavine)
  return(koncni)
}

ustvari.nutrition <- function() {
  attach(nutrition)

  Serving.Size..g. <- gsub("[( g)]", "", Serving.Size..g., ignore.case=TRUE)
  Serving.Size..g. <- as.numeric(Serving.Size..g.)

  #Število kalorij glede na maso jedi
  Razmerje <- Calories / Serving.Size..g.

  kategorije <- c("najmanjše", "nizko", "srednje", "visoko", "največje")
  razvrstitev <- character(length(Razmerje))
  razvrstitev[Razmerje>(mean(Razmerje)+sd(Razmerje))] <- "visoko"
  razvrstitev[Razmerje<=(mean(Razmerje)+sd(Razmerje))&Razmerje>=(mean(Razmerje)-sd(Razmerje))] <- "srednje"
  razvrstitev[Razmerje<(mean(Razmerje)-sd(Razmerje))] <- "nizko"
  razvrstitev[max(Razmerje)] <- "največje"
  razvrstitev[min(Razmerje)] <- "najmanjše"

  Razvrstitev <- factor(razvrstitev, levels = kategorije, ordered = TRUE)

  koncni <- data.frame(Jed, Serving.Size..g., Calories, Calories.From.Fat, Total.Fat..g., Part.of.Daily.Value, Saturated.Fat..g., Part.of.Daily.Value.1, Trans.Fat..g., Cholesterol..mg., Part.of.Daily.Value.2, Sodium..mg., Part.of.Daily.Value.3, Carbohydrates..g., Part.of.Daily.Value.4, Dietary.Fiber..g., Part.of.Daily.Value.5, Sugars..g., Protein..g., Vitamin.A, Vitamin.C, Calcium, Iron, Calories.per.Serving.Size = Razvrstitev)
  detach(nutrition)
  return(koncni)
}

sestavine <- ustvari.sestavine()
nutrition <- ustvari.nutrition()

rownames(sestavine) <- sestavine$JED
#Rownames za nutrition ne deluje, ker se nekateri elementi ponovijo 2-krat. Te bom še v prihodnosti odstranil ter dodal nove.

#Lahko bi tudi odstranili stolpec "JED" z sestavine <- sestavine[-1]


options("matprod"="blas")

gemm_mflops = function(n, t, digits=2) round(2*n*n*n / 1000 / 1000, digits=digits)

args = commandArgs(trailingOnly=TRUE)
args = as.numeric(args)
if (length(args) != 4 || anyNA(args) || any(is.null(args))){
  stop("Usage is 'Rscript start_size end_size by num_iter'")
}

sizes = seq(from=args[1], to=args[2], by=args[3])

cat("      SIZE")
cat("             Flops")
cat("                   Time\n")

for (iter in seq_len(args[4])){
  for (n in sizes){
    x = runif(n*n)
    dim(x) = c(n, n)
    y = runif(n*n)
    dim(y) = c(n, n)

    t = system.time({ret = x %*% y})[3]

    cat(sprintf("%18s : ", paste0(n, "x", n)))

    cat(sprintf("%10.2f ", gemm_mflops(n, t)))
    cat("MFlops ")

    cat(sprintf("%10.6f ", t))
    cat("sec")

    cat("\n")

    rm(ret, x, y, n, t)
    invisible(gc(verbose=FALSE, reset=TRUE, full=TRUE))
  }
}


# plot_density_log.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Plots density of log values segreggated by sign, ignoring diagonal
# coefficients and zeroes.

plot.density.log <- function( x.data, x.label, plot.file.path, asp )
{
    # get values avoiding matrix diagonal
    x.data.n <- nrow( x.data )
    x.dat <- x.data[ -( 1 + 0:(x.data.n-1) * (x.data.n+1) ) ]

    # remove other zero values
    x.dat <- x.dat[ x.dat != 0 ]

    x.ggdata <- data.frame( log.abs.x = log10( abs( x.dat ) ),
        sign = factor( sign( x.dat ), levels = c( -1, 0, 1 ) ) )

    scale.color.value <- c( "-1" = asp$density.color.single,
        "1" = asp$density.color.single )

    scale.linetype.value <- c( "-1" = "dashed", "1" = "solid" )

    x.ggplot <- ggplot( x.ggdata, aes( x = .data$log.abs.x, color = .data$sign,
            fill = .data$sign, linetype = .data$sign ) ) +
        geom_density( alpha = 0.1, size = asp$figure.density.line.size ) +
        scale_color_manual( values = scale.color.value ) +
        scale_fill_manual( values = scale.color.value ) +
        scale_linetype_manual( values = scale.linetype.value ) +
        labs( x = sprintf( "log10( Absolute %s )", x.label ), y = "Density" ) +
        theme_bw() +
        theme( plot.margin = margin( asp$figure.margin,
                asp$figure.margin, asp$figure.margin,
                asp$figure.margin ),
            axis.ticks = element_line( size = asp$figure.panel.line.size ),
            axis.text = element_text( size = asp$figure.axis.text.size ),
            axis.title = element_text( size = asp$figure.axis.title.size ),
            panel.border = element_rect( size = asp$figure.panel.line.size ),
            panel.grid.major = element_blank(),
            panel.grid.minor = element_blank(),
            legend.position = "none" )

    ggsave( plot.file.path, plot = x.ggplot,
        width = asp$figure.width, height = asp$figure.height )
}

# Plots density of log values, together for initial and final steps of
# autospill, and calculation with positive and negative populations.

plot.density.log.together <- function( x.table, x.label, plot.file.path, asp )
{

    # get values avoiding matrix diagonal
    x.data <- lapply( x.table, function( xt ) {
        xt.n <- nrow( xt )
        xt[ -( 1 + 0:(xt.n-1) * (xt.n+1) ) ]
    } )
    x.data.n <- length( x.data )

    # remove other zero values
    x.data <- lapply( x.data, function( xd )
        xd[ xd != 0 ]
    )

    x.ggdata <- lapply( 1 : x.data.n, function( xd.idx ) {
        data.frame( log.abs.x = log10( abs( x.data[[ xd.idx ]] ) ),
            sign = sign( x.data[[ xd.idx ]] ) * xd.idx )
    } )
    x.ggdata <- do.call( rbind, x.ggdata )
    x.ggdata$sign <- factor( x.ggdata$sign,
        levels = c( 0, rep( 1:x.data.n, each = 2 ) * c( -1, 1 ) ) )

    scale.color.value <- c(
        "-1" = asp$density.color.initial, "1" = asp$density.color.initial,
        "-2" = asp$density.color.final, "2" = asp$density.color.final,
        "-3" = asp$density.color.posnegpop, "3" = asp$density.color.posnegpop
    )

    scale.linetype.value <- c(
        "-1" = "dashed", "1" = "solid",
        "-2" = "dashed", "2" = "solid",
        "-3" = "dashed" , "3"= "solid"
    )

    x.ggplot <- ggplot( x.ggdata, aes( x = .data$log.abs.x, color = .data$sign,
            fill = .data$sign, linetype = .data$sign ) ) +
        geom_density( alpha = 0.1, size = asp$figure.density.line.size ) +
        scale_color_manual( values = scale.color.value ) +
        scale_fill_manual( values = scale.color.value  ) +
        scale_linetype_manual( values = scale.linetype.value ) +
        labs( x = sprintf( "log10( Absolute %s )", x.label ), y = "Density" ) +
        theme_bw() +
        theme( plot.margin = margin( asp$figure.margin,
            asp$figure.margin, asp$figure.margin,
            asp$figure.margin ),
            axis.ticks = element_line( size = asp$figure.panel.line.size ),
            axis.text = element_text( size = asp$figure.axis.text.size ),
            axis.title = element_text( size = asp$figure.axis.title.size ),
            panel.border = element_rect( size = asp$figure.panel.line.size ),
            panel.grid.major = element_blank(),
            panel.grid.minor = element_blank(),
            legend.position = "none" )

    ggsave( plot.file.path, plot = x.ggplot,
        width = asp$figure.width, height = asp$figure.height )
}


suppressMessages(library(float))

set.seed(1234)
row_scaling_factor = 4

ompthreads = function()
{
  threads = as.numeric(Sys.getenv("OMP_NUM_THREADS"))
  if (is.na(threads))
    0L
  else
    threads
}

m = 2500 * row_scaling_factor
n = 2500
x = matrix(runif(m*n), m, n)

t_dbl = system.time(out_double <- qr.R(qr(x, LAPACK=TRUE)))
t_flt = system.time(out_float <- dbl(qr.R(qr(fl(x)))))

cat("method,m,n,size,threads,t_dbl_min,t_dbl_mean,t_dbl_max,t_flt_min,t_flt_mean,t_flt_max\n")
data = paste(
  "stack", m, n, 1, ompthreads(),
  t_dbl[[3]], t_dbl[[3]], t_dbl[[3]],
  t_flt[[3]], t_flt[[3]], t_flt[[3]],
  sep=","
)
cat(data)
cat("\n")


score <- function(input) {
    if ((input[3]) <= (2.45)) {
        var0 <- c(1.0, 0.0, 0.0)
    } else {
        if ((input[4]) <= (1.75)) {
            if ((input[3]) <= (4.95)) {
                if ((input[4]) <= (1.6500001)) {
                    var0 <- c(0.0, 1.0, 0.0)
                } else {
                    var0 <- c(0.0, 0.0, 1.0)
                }
            } else {
                var0 <- c(0.0, 0.3333333333333333, 0.6666666666666666)
            }
        } else {
            var0 <- c(0.0, 0.021739130434782608, 0.9782608695652174)
        }
    }
    return(var0)
}


# 4. faza: Analiza podatkov

cat("Rišem zemljevid...\n")
pdf("slike/Rekordi.pdf", width=6, height=4)
attach(rekordi)
drzave <- unique(Drzava)
barve <- rainbow(length(drzave))
plot(Leto, Dolzina_m, xlim=c(1994, 2020), ylim=c(200, 280),
     col = barve[match(Drzava, drzave)],
     pch = ifelse(Lokacija == "Planica", 18, 15))
lin <- lm(Dolzina_m ~ Leto)
abline(lin)
detach(rekordi)
title("Rekordi od leta 1994 do 2015")
dev.off()
premica <- function(x) {

  2.245608*x-4270.83226
}

pdf("slike/Rekordi1.pdf", width=6, height=4)

rekordi1 <- rekordi[-c(1,2),]

attach(rekordi1)
drzave <- unique(Drzava)
barve <- rainbow(length(drzave))
plot(Leto, Dolzina_m, xlim=c(1994, 2020), ylim=c(200, 280),
     col = barve[match(Drzava, drzave)],
     pch = ifelse(Lokacija == "Planica", 18, 15))
linn <- lm(Dolzina_m ~ Leto)
abline(linn)
detach(rekordi1)
title("Rekordi od leta 1994 do 2014")
dev.off()
premica <- function(x) {

  2.460698*x-4701.097011
}


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('continuousY', cache=TRUE)
knitr::read_chunk('~/doc/rms/continuousY/shared.R')

## ----lmassump,h=3.25,w=7,mfrow=c(1,2),ps=10,mgp=c(.5, .365, 0),left=1,cap='Assumptions of the linear model (left panel) and semiparametric ordinal probit or logit (proportional odds) models (right panel).  Ordinal models do not assume any shape for the distribution of $Y$ for a given $X$; they only assume parallelism.  The linear model can relax the parallelism assumption if $\\sigma$ is allowed to vary, but in practice it is difficult to know how to vary it except for the unequal variance two-sample $t$-test.',scap='Assumptions of linear vs.\\ semiparametric models',echo=FALSE----
pinv <- expression(paste(Phi^{-1},  '(F(y', '|', 'X))'))
plot(0, 0, xlim=c(0, 1), ylim=c(-2, 2), type='n', axes=FALSE,
     xlab=expression(y), ylab='')
mtext(pinv, side=2, line=1)
axis(1, labels=FALSE, lwd.ticks=0)
axis(2, labels=FALSE, lwd.ticks=0)
abline(a=-1.5, b=1)
abline(a=0, b=1)
arrows(.5, -1.5+.5, .5, 0+.5, code=3, length=.1)
text(.525, .5*(-1.5+.5+.5), expression(-Delta*X*beta/sigma), adj=0)
g <- function(x) -2.2606955+11.125231*x-37.772783*x^2+56.776436*x^3-
  26.861103*x^4
x <- seq(0, .9, length=150)
pinv <- expression(atop(paste(Phi^{-1},  '(F(y', '|', 'X))'),
    paste(logit, '(F(y', '|', 'X))')))
plot(0, 0, xlim=c(0, 1), ylim=c(-2, 2), type='n', axes=FALSE,
     xlab=expression(y), ylab='')
mtext(pinv, side=2, line=1)
axis(1, labels=FALSE, lwd.ticks=FALSE)
axis(2, labels=FALSE, lwd.ticks=FALSE)
lines(x, g(x))
lines(x, g(x)+1.5)
arrows(.5, g(.5), .5, g(.5)+1.5, code=3, length=.1)
text(.525, .5*(g(.55) + g(.55)+1.5), expression(-Delta*X*beta), adj=0)

## ----desc,results='asis',cache=FALSE------------------------------------------
require(rms)
options(prType='latex')   # for print, summary, anova
getHdata(nhgh)
w <- subset(nhgh, age >= 21 & dx==0 & tx==0, select=-c(dx,tx))
latex(describe(w), file='')
dd <- datadist(w); options(datadist='dd')

## ----lookdist,w=5.5,h=5.5,cap='Examination of normality and constant variance assumption, and assumptions for various ordinal models',scap='Examining normality and ordinal model assumptions'----
f <- ols(gh ~ rcs(age,5) + sex + re + rcs(bmi, 3), data=w)
pgh <- fitted(f)

p <- function(fun, row, col) {
  f <- substitute(fun); g <- function(F) eval(f)
  z <- Ecdf(~ gh, groups=cut2(pgh, g=6),
            fun=function(F) g(1 - F),
            ylab=as.expression(f), xlim=c(4.5, 7.75), data=w,
            label.curve=FALSE)
  print(z, split=c(col, row, 2, 2), more=row < 2 | col < 2)
}
p(log(F/(1-F)),   1, 1)
p(qnorm(F),       1, 2)
p(-log(-log(F)),  2, 1)
p(log(-log(1-F)), 2, 2)
# Get slopes of pgh for some cutoffs of Y
# Use glm complementary log-log link on Prob(Y < cutoff) to
# get log-log link on Prob(Y >= cutoff)
r <- NULL
for(link in c('logit','probit','cloglog'))
  for(k in c(5, 5.5, 6)) {
    co <- coef(glm(gh < k ~ pgh, data=w, family=binomial(link)))
    r <- rbind(r, data.frame(link=link, cutoff=k,
                             slope=round(co[2],2)))
}
print(r, row.names=FALSE)

## ----comparemany,cache=TRUE,h=6.5,w=6.75,cap='Three estimated quantiles and estimated mean using 6 methods, compared against caliper-matched sample quantiles/means (circles).  Numbers are mean absolute differences between predicted and sample quantities using overlapping intervals of age and caliper matching\\index{caliper matching}.  QR:quantile regression.',scap='Six methods for estimating quantiles or means.'----
ag <- 25:75
lag <- length(ag)
q2 <- q3 <- p90 <- means <- numeric(lag)
for(i in 1:lag) {
  s <- which(abs(w$age - ag[i]) < 5)
  y <- w$gh[s]
  a <- quantile(y, probs=c(.5, .75, .9))
  q2[i]    <- a[1]
  q3[i]    <- a[2]
  p90[i]   <- a[3]
  means[i] <- mean(y)
}
fams <- c('logistic', 'probit', 'loglog', 'cloglog')
fe   <- function(pred, target) mean(abs(pred$yhat - target))
mod  <- gh ~ rcs(age,6)
P    <- Er <- list()
for(est in c('q2', 'q3', 'p90', 'mean')) {
  meth <- if(est == 'mean') 'ols' else 'QR'
  p <- list()
  er <- rep(NA, 5)
  names(er) <- c(fams, meth)
  for(family in fams) {
    h  <- orm(mod, family=family, data=w)
    fun <- if(est == 'mean') Mean(h)
    else {
      qu <- Quantile(h)
      switch(est, q2  = function(x) qu(.5,  x),
                  q3  = function(x) qu(.75, x),
                  p90 = function(x) qu(.9,  x))
    }
    p[[family]] <- z <- Predict(h, age=ag, fun=fun, conf.int=FALSE)
    er[family] <- fe(z, switch(est, mean=means, q2=q2, q3=q3, p90=p90))
  }
  h <- switch(est,
              mean= ols(mod, data=w),
              q2  = Rq (mod, data=w),
              q3  = Rq (mod, tau=0.75, data=w),
              p90 = Rq (mod, tau=0.90, data=w))
  p[[meth]] <- z <- Predict(h, age=ag, conf.int=FALSE)
  er[meth] <- fe(z, switch(est, mean=means, q2=q2, q3=q3, p90=p90))

  Er[[est]] <- er
  pr <- do.call('rbind', p)
  pr$est <- est
  P <- rbind.data.frame(P, pr)
}

xyplot(yhat ~ age | est, groups=.set., data=P, type='l', # Figure (*\ref{fig:continuousY-comparemany}*)
       auto.key=list(x=.75, y=.2, points=FALSE, lines=TRUE),
       panel=function(..., subscripts) {
         panel.xyplot(..., subscripts=subscripts)
         est <- P$est[subscripts[1]]
         lpoints(ag, switch(est, mean=means, q2=q2, q3=q3, p90=p90),
                 col=gray(.7))
         er <- format(round(Er[[est]],3), nsmall=3)
         ltext(26, 6.15, paste(names(er), collapse='\n'),
               cex=.7, adj=0)
         ltext(40, 6.15, paste(er, collapse='\n'),
               cex=.7, adj=1)})

## ----predobs,w=4.75,h=4,cap='Observed (dashed lines, open circles) and predicted (solid lines, closed circles) exceedance probability distributions from a model using 6-tiles of OLS-predicted \\hba.  Key shows quantile group intervals of predicted mean \\hba.',scap='Observed and predicted distributions'----
w$pghg <- cut2(pgh, g=6)
f  <- orm(gh ~ pghg, family=loglog, data=w)
lp <- predict(f, newdata=data.frame(pghg=levels(w$pghg)))
ep <- ExProb(f)  # Exceedance prob. functn. generator in rms
z  <- ep(lp)
j  <- order(w$pghg)  # puts in order of lp (levels of pghg)
plot(z, xlim=c(4, 7.5), data=w[j,c('pghg', 'gh')]) # Fig. (*\ref{fig:continuousY-predobs}*)

## ----lookprobit,w=3,h=2.5,bty='l',cap='Estimated intercepts from probit model.  Linearity would have indicated Gaussian residuals.',scap='Estimated intercepts from probit model'----
f <- orm(gh ~ rcs(age,6), family=probit, data=w)
g <- ols(gh ~ rcs(age,6), data=w)
s <- g$stats['Sigma']
yu <- f$yunique[-1]
r <- quantile(w$gh, c(.005, .995))
alphas <- coef(f)[1:num.intercepts(f)]
plot(-yu / s, alphas, type='l', xlim=rev(- r / s), # Fig. (*\ref{fig:continuousY-lookprobit}*)
     xlab=expression(-y/hat(sigma)), ylab=expression(alpha[y]))

## ----htwtcoef,results='asis'--------------------------------------------------
f <- orm(gh ~ rcs(age,5) + log(ht) + log(wt),
         family=loglog, data=w)
f

## ----aichtwt------------------------------------------------------------------
aic <- NULL
for(mod in list(gh ~ rcs(age,5) + rcs(log(bmi),5),
                gh ~ rcs(age,5) + rcs(log(ht),5) + rcs(log(wt),5),
                gh ~ rcs(age,5) + rcs(log(ht),4) * rcs(log(wt),4)))
  aic <- c(aic, AIC(orm(mod, family=loglog, data=w)))
print(aic)

## ----coxhtwtcoef,results='asis'-----------------------------------------------
print(cph(Surv(gh) ~ rcs(age,5) + log(ht) + log(wt), data=w))

## ----redun,cap='Variable clustering for all potential predictors'-------------
v <- varclus(~ wt + ht + bmi + leg + arml + armc + waist +
             tri + sub + age + sex + re, data=w)
plot(v)   # Figure (*\ref{fig:continuousY-redun}*)
# Omit wt so it won't be removed before bmi
redun(~ ht + bmi + leg + arml + armc + waist + tri + sub,
      data=w, r2=.75)

## ----htchange,fig.align='right',cap="Estimated median height as a smooth function of age, allowing age to interact with sex, from a proportional odds model",scap="Median height vs.\\ age"----
f <- orm(ht ~ rcs(age,4)*sex, data=w)  # Prop. odds model
qu <- Quantile(f); med <- function(x) qu(.5, x)
ggplot(Predict(f, age, sex, fun=med, conf.int=FALSE),
       ylab='Predicted Median Height, cm')

## ----allocadf,w=4,cap='Generalized squared rank correlations',top=1-----------
s <- spearman2(gh ~ age + sex + re + wt + leg + arml + armc +
               waist + tri + sub, data=w, p=2)
plot(s)

## ----fitfullcasewise,results='asis'-------------------------------------------
f <- orm(gh ~ rcs(age,5) + sex + re + rcs(wt,3) + rcs(leg,3) + arml +
         rcs(armc,3) + rcs(waist,4) + tri + rcs(sub,3),
         family=loglog, data=w, x=TRUE, y=TRUE)
print(f, coefs=FALSE)
## Composite test:
anova(f, leg, arml, armc, waist, tri, sub)

## ----casewisemeanmed,h=4,w=5,cap='Estimated mean and 0.5 and 0.9 quantiles from the log-log ordinal model using casewise deletion, along with predictions of 0.5 and 0.9 quantiles from quantile regression (QR).  Age is varied and other predictors are held constant to medians/modes.',scap='Estimated mean and quantiles from casewise deletion model.'----
M      <- Mean(f)
qu     <- Quantile(f)
med    <- function(x) qu(.5, x)
p90    <- function(x) qu(.9, x)
fq     <- Rq(formula(f), data=w)
fq90   <- Rq(formula(f), data=w, tau=.9)
pmean  <- Predict(f,    age, fun=M,   conf.int=FALSE)
pmed   <- Predict(f,    age, fun=med, conf.int=FALSE)
p90    <- Predict(f,    age, fun=p90, conf.int=FALSE)
pmedqr <- Predict(fq,   age, conf.int=FALSE)
p90qr  <- Predict(fq90, age, conf.int=FALSE)
z <- rbind('orm mean'=pmean, 'orm median'=pmed, 'orm P90'=p90,
           'QR median'=pmedqr, 'QR P90'=p90qr)
ggplot(z, groups='.set.',
       adj.subtitle=FALSE, legend.label=FALSE)

## ----prbw---------------------------------------------------------------------
print(fastbw(f, rule='p'), estimates=FALSE)

## ----valbworm,cache=TRUE------------------------------------------------------
set.seed(13)  # so can reproduce results
v <- validate(f, B=100, bw=TRUE, estimates=FALSE, rule='p')

## ----prval,results='asis'-----------------------------------------------------
# Show number of variables selected in first 30 boots
latex(v, B=30, file='', size='small')

## ----sanova,cache=TRUE,results='asis',cap='ANOVA for reduced model, after multiple imputation, with addition of a combined effect for four size variables',scap='ANOVA for reduced model'----
a <- aregImpute(~ gh + wt + ht + bmi + leg + arml + armc + waist +
                tri + sub + age +re, data=w, n.impute=5, pr=FALSE)
g <- fit.mult.impute(gh ~ rcs(age,5) + re + rcs(leg,3) +
                     rcs(waist,4) + tri + rcs(sub,4),
                     orm, a, family=loglog, data=w, pr=FALSE)
print(g, needspace='1.5in')
an <- anova(g)
print(an, caption='ANOVA for reduced model after multiple imputation, with addition of a combined effect for four size variables')
b  <- anova(g, leg, waist, tri, sub)
# Add new lines to the plot with combined effect of 4 size var.
s <- rbind(an, size=b['TOTAL', ])
class(s) <- 'anova.rms'
plot(s)

## ----peffects,cache=TRUE,results='asis',cap='Partial effects (log hazard or log-log cumulative probability scale) of all predictors in reduced model, after multiple imputation',scap='Partial effects after multiple imputation',w=6.75,h=4.5,cache=TRUE----
ggplot(Predict(g), abbrev=TRUE, ylab=NULL)   # Figure (*\ref{fig:continuousY-peffects}*)

## ----cfmissmeth,cache=TRUE----------------------------------------------------
gc <- orm(gh ~ rcs(age,5) + re + rcs(leg,3) +
          rcs(waist,4) + tri + rcs(sub,4),
          family=loglog, data=w, x=TRUE, y=TRUE)
gb <- bootcov(gc, B=300)

## ----peffects2,cap='Partial effect for age from multiple imputation (center red line) and casewise deletion (center blue line) with symmetric Wald 0.95 confidence bands using casewise deletion (gray shaded area), basic bootstrap confidence bands using casewise deletion (blue lines), percentile bootstrap confidence bands using casewise deletion (dashed blue lines), and symmetric Wald confidence bands accounting for multiple imputation (red lines).',scap='Partial effect for age with bootstrap and Wald confidence bands',w=5,h=4,bot=1----
bootclb <- Predict(gb, age, boot.type='basic')
bootclp <- Predict(gb, age, boot.type='percentile')
multimp <- Predict(g,  age)
plot(Predict(gc, age), addpanel=function(...) {
  with(bootclb, {llines(age, lower, col='blue')
                 llines(age, upper, col='blue')})
  with(bootclp, {llines(age, lower, col='blue', lty=2)
                 llines(age, upper, col='blue', lty=2)})
  with(multimp, {llines(age, lower, col='red')
                 llines(age, upper, col='red')
                 llines(age, yhat, col='red')} ) },
     col.fill=gray(.9), adj.subtitle=FALSE)   # Figure (*\ref{fig:continuousY-peffects2}*)

## ----meanvs,cap='Predicted mean \\hba vs.\\ predicted median and 0.9 quantile along with their marginal distributions',scap='Predicted mean, median, and 0.9 quantile of \\hba',w=4.5,h=3.5----
M  <- Mean(g)
qu <- Quantile(g)
med <- function(lp) qu(.5, lp)
q90 <- function(lp) qu(.9, lp)
lp  <- predict(g)
lpr <- quantile(predict(g), c(.002, .998), na.rm=TRUE)
lps <- seq(lpr[1], lpr[2], length=200)
pmn <- M(lps)
pme <- med(lps)
p90 <- q90(lps)
plot(pmn, pme,   # Figure (*\ref{fig:continuousY-meanvs}*)
     xlab=expression(paste('Predicted Mean ',  HbA["1c"])),
     ylab='Median and 0.9 Quantile', type='l',
     xlim=c(4.75, 8.0), ylim=c(4.75, 8.0), bty='n')
box(col=gray(.8))
lines(pmn, p90, col='blue')
abline(a=0, b=1, col=gray(.8))
text(6.5, 5.5, 'Median')
text(5.5, 6.3, '0.9', col='blue')
nint <- 350
scat1d(M(lp),   nint=nint)
scat1d(med(lp), side=2, nint=nint)
scat1d(q90(lp), side=4, col='blue', nint=nint)

## ----nomogram,cap='Nomogram for predicting median, mean, and 0.9 quantile of glycohemoglobin, along with the estimated probability that \\hba $\\ge 6.5, 7$, or $7.5$, all from the log-log ordinal model',scap='Nomogram of log-log ordinal model for \\hba',w=6.75,h=5.75,ps=9----
g      <- Newlevels(g, list(re=abbreviate(levels(w$re))))
exprob <- ExProb(g)
nom <-
  nomogram(g, fun=list(Mean=M,
                'Median Glycohemoglobin' = med,
                '0.9 Quantile'           = q90,
                'Prob(HbA1c >= 6.5)'=
                     function(x) exprob(x, y=6.5),
                'Prob(HbA1c >= 7.0)'=
                     function(x) exprob(x, y=7),
                'Prob(HbA1c >= 7.5)'=
                     function(x) exprob(x, y=7.5)),
           fun.at=list(seq(5, 8, by=.5),
             c(5,5.25,5.5,5.75,6,6.25),
             c(5.5,6,6.5,7,8,10,12,14),
             c(.01,.05,.1,.2,.3,.4),
             c(.01,.05,.1,.2,.3,.4),
             c(.01,.05,.1,.2,.3,.4)))
plot(nom, lmgp=.28)   # Figure (*\ref{fig:continuousY-nomogram}*)


## load package deSolve for ode simulation
library(deSolve)

## types of noise:
## 1. process noise: complementary or essential resources in the main text model. core, tail, or general in the model in Appendix D
## 2. measurement noise
noisetypes=c('complementary','essential','core','tail','general','measurement')

## scaling factors: scale noise levels in the kernel
scaling.factors=data.frame(noise=c('complementary','essential','core','tail','general','measurement'),scaling=c(30,1,8,250,2,.4))

## number of species
S=200

## species niche/trait values
set.seed(0)
trait=sort(runif(S))
d=as.matrix(dist(trait))
d[d>max(d)/2]=max(d)-d[d>max(d)/2]

## kernel width
w=.1

## noise-free competition kernel
A0=exp(-(d/w)^4); A0=A0/mean(A0)*.2

## Function to generate the competition kernel.
## Inputs: species x-niche/trait values, type of noise, degree of noise, simulation number (run).
## Outputs: A = noisy kernel in the case of process noise, noise-free kernel in the case of measurement noise
## (cont) A0 = noise-free kernel in the case of process noise, noisy kernel in the case of measurement noise;
## (cont) d = distances on x-niche/trait axis (on a circular axis);
## (cont) prox = proxy trait values in the case of measurement noise; traity = y-niche/trait values;
## (cont) spear = Spearman's rho, correlation between kernel and distances on x-axis;
## (cont) pi = P(Atail > Amean) - P(Acore > Amean), quantifies core-tail structure in the kernel
Kernel=function(noiselevel,noisetype,traitvalues=trait,run=0){
	stopifnot(noisetype%in%noisetypes)

	## tie random number generator to run
	set.seed(run)

	## number of species
	S=length(traitvalues)

	## scaled noise level
	a0=noiselevel*with(scaling.factors,scaling[match(noisetype,noise)])

	## distances on x-niche/trait axis (axis is circular)
	d=as.matrix(dist(traitvalues)); d[d>max(d)/2]=max(d)-d[d>max(d)/2]

	## A0 = noise-free kernel in the case of process noise, noisy kernel in the case of measurement noise
	A0=exp(-(d/w)^4); A0=A0/mean(A0)*.2

	## threshold distance separating core from tail
	dcoretail=d[which.min(abs(A0-mean(A0)))]

	## traity = y-niche/trait values; will contribute to kernel in proportion to noise level
	traity=NULL

	## A = noisy kernel in the case of process noise, noise-free kernel in the case of measurement noise
	if(noisetype%in%c('complementary','essential')){ traity=runif(S); dy=as.matrix(dist(traity)); dy[dy>max(dy)/2]=max(dy)-dy[dy>max(dy)/2]}
	if(noisetype=='complementary'){ wyinverse=a0; A=exp(-sqrt((d/w)^2+(dy*wyinverse)^2)^4)}		## from 1 to 10
	if(noisetype=='essential'){ wy=a0; A=pmax(exp(-(d/w)^4),exp(-(dy/wy)^4))}				## from .01 to .15

	if(noisetype%in%c('core','tail','general')){
		sigma = if(noisetype=='core') a0*exp(-(d/.1)^4) else if(noisetype=='tail') a0*(exp(d^4)-1) else if(noisetype=='general') a0
		A=matrix(pmax(0,rnorm(S*S,mean=exp(-(d/w)^4),sd=sigma)),S,S)
		while(TRUE){ i=which(diag(A)==0); if(length(i)==0) break; diag(A)[i]=pmax(0,rnorm(length(i),mean=1,sd=a0))}
	}

	## prox = proxy trait values in the case of measurement noise
	prox=NULL
	if(noisetype=='measurement'){
		prox=rnorm(S,mean=traitvalues,sd=a0); d=as.matrix(dist(prox)); d[d>max(d)/2]=max(d)-d[d>max(d)/2]
		A=A0; A0=exp(-(d/w)^4); A0=A0/mean(A0)*.2
	}

	## normalize A
	A=A/mean(A)*.2

	## spear = Spearman's rho; pi = P(Atail > Amean) - P(Acore > Amean)
	spear=cor(as.numeric(d),as.numeric(A),method='spearman')											## -1 (perfect) to 0 (null)
	pi=sum(A[d>=dcoretail]>mean(A))/sum(d>=dcoretail)-(sum(A[d<=dcoretail]>mean(A))/sum(d<=dcoretail))	## -1 (perfect) to 0 (null)

	return(list(
		A=A,
		A0=A0,
		d=d,
		prox=prox,
		traity=traity,
		spear=spear,
		pi=pi
	))
}

Run=function(traits,compkernel,immig,maxtime=1e4,plot=1,logplot=1){
	## initial abundances
	x0=rep(1e-3,nrow(compkernel))+runif(nrow(compkernel),min=0,max=1e-3/100)

	## time series
	times=seq(0,maxtime,by=.1)

	## Lotka-Volterra dynamic equations
	LV=function(times,N,parms) list(pmax(N,0)*(1-as.numeric(parms$Kernel%*%pmax(N,0)))+parms$m)

	## Simulate model
	x=ode(y=x0,times=times,func=LV,parms=list(Kernel=compkernel,m=immig),method='lsoda'); n=x[nrow(x),-1]; n[n<1e-5]=0

	## Calculate richness at each time point
	s=apply(x[,-1],1,function(v) sum(v>1e-5))

	## Plot results
	if(plot) if(!logplot) plot(trait,n,t='h',las=1) else plot(trait[n>0],log(1+n[n>0]/min(n[n>0])),t='h',las=1)

	return(list(data=data.frame(trait=traits,abundance=n),richness=data.frame(time=x[,1],S=s)))
}


library(dplyr)

#' Computes precision-recall statistics
#'
#' @param df     A data.frame containing the fields value and hit
#' @param value  The numeric value associated with the score
#' @param hit    Whether (1/TRUE) or not (0/FALSE) the observation is a success
roc = function(df, value, hit) {
    if (any(is.na(df[[value]]) | is.na(df[[hit]])))
        stop("data.frame contains NAs, remove them first")

    mydf = data.frame(value = df[[value]], hit = df[[hit]], check.names=FALSE) %>%
        mutate(i = 1:nrow(.),
               value = value - min(value)) %>%
        mutate(value = value / max(value)) %>%
        arrange(-value) %>%
        mutate(TPR = cumsum(hit) / sum(hit),
               FPR = cumsum(1-hit) / sum(1-hit)) %>%
        arrange(i)

    df$FPR = mydf$FPR
    df$TPR = mydf$TPR
    df
}

#' Computes precision-recall AUC
#'
#' @param df         A data.frame containing the fields value and hit
#' @param value      The numeric value associated with the score
#' @param hit        Whether (1/TRUE) or not (0/FALSE) the observation is a success
#' @param symmetric  count wrong sign as right (default:FALSE)
#' @return           The area under the curve
roc_auc = function(value, hit, symmetric=FALSE) {
    pROC::auc(as.logical(hit), c(1:length(value))/length(value),
              direction = ifelse(symmetric, "auto", "<"))
}


# Data is the origin and destination arrival times for trips between two stops
# Get all O->D trips
source('/home/nate/scarbs_transit/import-data.r')

# density() params
bw = 1
n = 1000
# colors
col_exp = rgb(187,125,69,alpha=70,max=255) # blue
col_loc = rgb(100,90,166,alpha=74,max=255) # red
# segments to look at
segments = list(
	list(
		name = '198_vs_86_kennedy_lawrence',
		# from stop_code 6487 (lawrence) to stop_code 15278 (kennedy)
		# from stop_code 1037 (kennedy) to stop_code 6488 (lawrence)
		east_stops = c(6488,6487), # check
		west_stops = c(15278,1037), # check
		express_names = c('198_0_198','198_1_198'),
		xlim = c(10,30),
		ylim = c(0,.21)
	)#,
#	list(
#		name = '95_vs_95e_bayview_UTSC',
#		east_stops = c(7698,7699), # ellesmere at military trail
#		west_stops = c(9188,9069), # york mills at bayview
#		express_names = c('95_0_95E','95_1_95E'),
#		xlim = c(30,60),
#		ylim = c(0,.14)
#	)
)
# loop over each of the segments to be plotted
for( segment in segments ){
	# set variables for this iteration
	name = segment[['name']]
	east_stops = segment[['east_stops']]
	west_stops = segment[['west_stops']]
	express_names = segment[['express_names']]
	xlim = segment[['xlim']]
	ylim = segment[['ylim']]
	# print
	print(paste( 'working on', name ))
	# identify the direction of travel (RELATIVE TO THIS SEGMENT)
	od$dir <- factor(
		ifelse(
			od$o %in% west_stops & od$d %in% east_stops, # heading east
			'east',
			ifelse(
				od$o %in% east_stops & od$d %in% west_stops, # heading west
				'west',
				'unknown'
			)
		)
	)
	# distinguish express service (RELATIVE TO THIS SEGMENT)
	od$express <- factor( od$direction_id %in% express_names )
	# plot
#	pdf(
#		paste0('/home/nate/Dropbox/UTSC transit/figures/',name,'.pdf'),
#		width = (max(xlim)-min(xlim))*0.2,
#		height = 4
#	)
		par( mfrow=c(5,1), mar=c(0,0,0,0), family="serif" ) # margins are bottom left top right
		# four plots by direction and peak time
		for(time_of_day in c('morning','evening')){
			for(direction in c('west','east')){
				# make blank plot
				plot( 0, axes=F, type="b", xlab="", ylab="", xlim=xlim, ylim=ylim, main='' )
				# for both express and local, plot the density
				for(express in c(T,F)){
					# get data for each direction of travel
					d = od[od$express==express & od$dir==direction & od$ToD==time_of_day,]
					# calculate the density
					dens = density( d$travel_time, bw=bw, n=n )
					print( paste( time_of_day, direction, express, sqrt( 2*var(d$travel_time) ) ) )
					polygon( # plot the densities together
						x=dens$x, y=dens$y,
						col=( if(express) col_exp else col_loc ),
						lty=0
					)
					# plot the medians
#					abline(
#						v = c( median(w$travel_time), median(e$travel_time) ),
#						col = if(express) col_exp else col_loc,
#						lty=2
#					)
				}
			}
		}
		plot( 0, axes=F, type="b", xlab="", ylab="", xlim=xlim, ylim=ylim, main='' )
		ticks = seq(xlim[1],xlim[2],by=2)
		abline(v=ticks)
		text(x=ticks,y=rep(mean(ylim),length(ticks)),labels=ticks)
#	dev.off()
}
#	# stats output
#	w_exp = od[od$express==T & od$dir=='west' & od$ToD==time_of_day,'travel_time']
#	w_loc = od[od$express==F & od$dir=='west' & od$ToD==time_of_day,'travel_time']
#	e_exp = od[od$express==T & od$dir=='east' & od$ToD==time_of_day,'travel_time']
#	e_loc = od[od$express==F & od$dir=='east' & od$ToD==time_of_day,'travel_time']
#	print( paste(name, time_of_day, 'w / e express travel time gains') )
#	print(1 - median(w_exp) / median(w_loc) )
#	print(1 - median(e_exp) / median(e_loc) )


## 2. Date Representation ##

library(lubridate)
date1 <- "01011970" # should be January 1, 1970
date2 <- "2019-03-04" # should be March 4, 2019
date_standardized1 <- mdy(date1)
date_standardized2 <- ymd(date2)

## 3. Time Representation ##

library(lubridate)
datetime1 <- "01-01-1970-00-00-00" # should be January 1, 1970 at midnight
datetime2 <- "2019-03-14 1:59 AM" # should be March 14, 2019, 1:59 AM
datetime_standardized1 <- mdy_hms(datetime1)
datetime_standardized2 <- ymd_hm(datetime2)

## 5. Component Extraction ##

library(lubridate)
input_date <- "2020-11-13 13:13:13"
answer_month <- month(input_date)
answer_day_of_week <- wday(input_date, label = TRUE)

## 6. Time Span Calculations ##

library(lubridate)
now <- Sys.time() %>% as_datetime
days_since_founding <- now - ymd_hms("2015-03-01 00:00:00")

## 7. Durations and Periods ##

library(lubridate)

start <- ymd("2020/05/01")
duration_end <- start + duration(day = 5, hour = 12)
period_end <- start + period(month = 1, day = 1)

Data Analyst in R/Step 1 - Introduction to R/4. Specialized Data Processing in R Strings and Dates/2. Date and Time Manipulation in R Fundamentals.r


# TODO: Remove reactiveValues and use reactiveVal for unified naming
library(keras)
library(shiny)
library(ggrepel)
library(tidyverse)

# Load MNIST dataset, normalize and flatten 28x28 images using row-major layout (which is used by tensorflow).
# Also normalize the grayscale values into [0; 1] and one-hot-encode the labels.
mnist <- dataset_mnist()
MNIST <- list(x.train       = array_reshape(mnist$train$x, c(nrow(mnist$train$x), 784)) / 255,
              x.test        = array_reshape(mnist$test$x, c(nrow(mnist$test$x), 784)) / 255,
              y.train       = to_categorical(mnist$train$y, 10),
              y.test        = to_categorical(mnist$test$y, 10),
              y.train.digit = mnist$train$y, # keep the single-digit labels for convenience
              y.test.digit  = mnist$test$y)

# Return ggplot-heatmap from a row-major 1D vector.
#
# Kept generic enough to plot arbitrary 2D heatmaps, since ggplot does not have any heatmap geoms and 'image()' rotates
# the image for no healthy reason. Might be reused at some point.
plot_heatmap <- function(data, nrow = 1, ncol = length(data)) {

  X = rep(1:nrow, times  = ncol)
  Y = rep(ncol:1, each = nrow)
  heat.map <- ggplot()                                    +
    geom_raster(aes(x = X, y = Y, fill = data))           +
    coord_cartesian(xlim = c(1, nrow), ylim = c(1, nrow)) +
    theme_void()                                          +
    theme(legend.position="none")

  return(heat.map)
}

# Return ggplot of training history. Expects a wide-format tibble consisting of all metrics to be displayed.
#
# The x-axis displays the epoch (the integral index of each observation which need not be provided). The y-axis
# shows the numerical value of each metric. The metric type is mapped to the color aesthetic (one color per
# column in the input tibble).
plot_training_history <- function(data,             # wide-format tibble
                                  geom = geom_line) # any geom compatible with the x, y and color aesthetics
{
  if(nrow(data) == 0) {
    return(ggplot)
  }

  plot.data <- data %>%
    mutate(Epoch = row_number()) %>%
    gather(-Epoch, key = 'Metric', value = 'Value')

  history.plot <- ggplot(plot.data) +
    geom(aes(x = Epoch, y = Value, color = Metric))

  return(history.plot)
}

# Return indices of false predictions
#
# The model's predictions of 'x' are argmax'ed and compaired against y.
get_false_predictions <- function(model, x, y) {

  predicted.digits <- model %>% predict(x) %>% k_argmax %>% as.integer
  return(which(predicted.digits != y))
}

# Return untrained Multi-Layer Perceptron Keras model with a single hidden layer.
#
# The number of hidden neurons is parameterized.
initialize_model <- function(input.size = 784, hidden.units = 16, output.size = 10) {

  # Defining is a 2-part process: Firstly, the layers are specified. Secondly, the loss-function and the optimization
  # algorithm are chosed. The second step is referred to as 'compiling' the model in Keras lingo.
  model <- keras_model_sequential(name = "MNIST Classifier")                                                   %>%
    layer_dense(units = hidden.units, activation = 'relu', input_shape = c(input.size), name = "Hidden-Layer") %>%
    layer_dense(units = output.size, activation = 'softmax', name = "Output-Layer")                            %>%
    compile(loss = 'categorical_crossentropy', metrics = c('accuracy'), optimizer = optimizer_rmsprop())

  return(model)
}

# Returns ggplot barchart over estimates for each class 0 - 9
plot_digit_estimates <- function(estimates) {

  estimates <- as.vector(estimates)
  if(length(estimates) == 0) return(ggplot())

  bar.chart <-
    ggplot() +
      geom_col(aes(x = 0:(length(estimates)-1), y = estimates, fill=as.factor(0:(length(estimates)-1))), show.legend = F) +
      scale_x_continuous(breaks = 0:9) +
      labs(title = "Class Estimates") +
      theme(
        axis.title.y = element_blank(),
        axis.ticks.y = element_blank(),
        axis.title.x = element_blank(),
        plot.title = element_text(size=16, face="bold", hjust=0.5),
        axis.text.y = element_blank(),
        axis.text.x = element_text(face = "plain", size=12)
      )
  return(bar.chart)
}

### Define the app's user interface
ui <- fluidPage(title = "Live Neural Networks Demo", width="960px",

    tabsetPanel(type = "tabs",
                tabPanel("Explore"))
#   fluidRow(
#     column(4, offset = 2, align="center",
#       h2("Test Sets"),
#       sliderInput('test.index', label=NULL, min=1, max=10000, value=1000),
#       strong(textOutput(outputId = 'label.test')),
#       plotOutput(outputId = 'test.image.plot')
#     ),
#     column(4, align = "center",
#       h2("Training Set"),
#       sliderInput('train.index', label=NULL, min=1, max=60000, value=8400),
#       strong(textOutput(outputId = 'label.train')),
#       plotOutput(outputId = 'training.image.plot')
#     )
#   )
#   fluidRow(
#     column(4, align="center",
#       sliderInput("epoch.increment", label="Numer of Epochs to Train", value=16, min=1, max=64, step=1),
#       splitLayout(cellWidths=c("65%", "35%"),
#         actionButton("reset.button", label="Reset + Run", width="100%"),
#         actionButton("run.button", label="Run", width="100%")
#       ),
#       br(),
#       splitLayout(
#         h5("Hidden neurons: ", style="padding-bottom: -10px;"),
#         numericInput("hl.size", label=NULL, min=1, max=128, step=1, value=16)),
#       # TODO: Properly concatenate the static prefix and the dynamic counter value
#       h4(textOutput("epoch.counter")),
#       br(),
#       radioButtons("geom.plot.option", label=NULL, choices=list("Point", "Line"), inline=T),
#       checkboxInput("show.train.acc.option", label="Show training set history", value=T)
#     ),
#     column(8, align="center",
#       plotOutput("training.history.plot")
#     )
#   ),
#   fluidRow(
#     column(4, align="center",
#       actionButton('init.button', label="Load Test Set Predictions", width = "100%"),
#       br(), br(),
#       uiOutput('false.prediction.slider'),
#       br(), br(),
#       splitLayout(
#         strong(textOutput('label')),
#         em(textOutput('prediction'))
#       ),
#       checkboxInput("show.correct.option", "Show Correct Predictions", T),
#       br(),
#       plotOutput('image.pixmap')
#     ),
#     column(6, offset=1, align="center",
#       plotOutput('estimates.barchart')
#     )
#   )
)

### Define the app's reactive outputs, i.e. the 'server'
server <- function(input, output) {

  # define reactive parameters and their dependent variables
  TRAINING.HISTORY <- reactiveVal(tibble())
  MODEL <- reactiveVal(initialize_model())
  EPOCH.COUNTER <- reactive({

    return(nrow(TRAINING.HISTORY()))
  }) # mirrors the height of the training dataframe

  FALSE.PREDICTIONS <- reactive({
    # BUG: dependency on the model is not captured (this reactive environment is not executed when learning and
    # FALSE.PREDICTIoNS and FALSE.PRE). Use an explicit dependency on TRAINING.HISTORY as a workaround for now.
    TRAINING.HISTORY()

    return(get_false_predictions(MODEL(), MNIST$x.test, MNIST$y.test.digit) )
  })

  FALSE.PREDICTIONS.INDEX <- reactive({

    return(FALSE.PREDICTIONS()[input$prediction.slider])
  })

  # Pixmap of test image
  output$test.image.plot <- renderPlot({

   return(plot_heatmap(MNIST$x.test[input$test.index,], nrow = 28, ncol = 28))
  })

  # Pixmap of training image
  output$training.image.plot <- renderPlot({

    return(plot_heatmap(MNIST$x.train[input$train.index,], nrow = 28, ncol = 28))
  })

  # Label of test image
  output$label.test <- renderText({

    return(paste0("Label: ", MNIST$y.test.digit[[input$test.index]]))
  })

  # Label of training image
  output$label.train <- renderText({

    return(paste0("Label: ", MNIST$y.train[[input$train.index]]))
  })

  # render epoch counter
  output$epoch.counter <- renderText({

    return(paste0("Epochs trained: ", EPOCH.COUNTER()))
  })

  # render training history plot
  output$training.history.plot <- renderPlot({

    return(plot_training_history(TRAINING.HISTORY()))
  })

  # 'reset.button' callback: Reset the model.
  observeEvent(input$reset.button, {

    MODEL(initialize_model())
    TRAINING.HISTORY(tibble())
  })

  # 'run.button' callback: Perform training.
  observeEvent(input$run.button, {

    fit.result <- fit(MODEL(), MNIST$x.train, MNIST$y.train,
                      initial_epoch = EPOCH.COUNTER(),
                      epochs = EPOCH.COUNTER() + input$epoch.increment,
                      validation_split = 0.2,
                      batch_size = 12000)

    # append newly gathered values. The column names are deduced automatically
    delta <- fit.result$metrics %>% as_tibble

    TRAINING.HISTORY(bind_rows(TRAINING.HISTORY(), delta))
  })

  output$prediction <- renderText({

    if(length(FALSE.PREDICTIONS.INDEX()) == 0) return("") # catch uninitialized value

    estimates <- MODEL() %>% predict(MNIST$x.test[FALSE.PREDICTIONS.INDEX(), ] %>% matrix(nrow=1))
    predicted.digit <- estimates %>% k_argmax %>% as.integer
    return(paste0("Prediction: ", predicted.digit))
  })

  output$label <- renderText({

    if(length(FALSE.PREDICTIONS.INDEX()) == 0) return("") # catch uninitialized value

    return(paste0("Label: ", MNIST$y.test.digit[FALSE.PREDICTIONS.INDEX()]))
  })

  output$false.prediction.slider <- renderUI({

    sliderInput('prediction.slider', label="False Prediction", min=1, max=length(FALSE.PREDICTIONS()), value=1)
  })

  # render estimates' barchart
  output$estimates.barchart <- renderPlot({

    if(length(FALSE.PREDICTIONS.INDEX()) == 0) return("") # catch uninitialized value

    estimates <- MODEL() %>% predict(MNIST$x.test[FALSE.PREDICTIONS.INDEX(), ] %>% matrix(nrow=1))
    return(plot_digit_estimates(estimates))
  })

  output$image.pixmap <- renderPlot({

    if(length(FALSE.PREDICTIONS.INDEX()) == 0) return("") # catch uninitialized value

    return(plot_heatmap(MNIST$x.test[FALSE.PREDICTIONS.INDEX(),], nrow = 28, ncol = 28))
  })
}

# Run the app
shinyApp(ui = ui, server = server)


################################################################################
#                            Reproduce Summary Stats
#                          Gabilan Creek Turbidity TMDL
#                                   11/27/2019
#                         john.inman@waterboards.ca.gov
################################################################################

# Peter created some summary stats and graphics using uncurated data. Reproduce
# his summary stats table so he can regenerate his graphics with updated
# numbers

options(max.print=1000)
rm(list =ls())
today <- format(Sys.Date(), "%Y%m%d")

# Pull in curated CEDEN data
data_dir <- 'H:\\gabilan-turbidity-tmdl\\data\\'
data <- # downloaded from CEDEN on 5/16/2019
    read.csv(paste0(data_dir, 'ceden-turbidity.csv'))

% all data# {{{
date <- as.Date(data$SampleDate, format = "%m/%d/%Y")
month <- as.numeric(strftime(date, format = "%m"))
dry <- month > 4 & month < 10
datd <- data[dry, ]
datw <- data[!dry, ]

dats <- list(data, datd, datw)
names(dats) <- c("all", "dry", "wet")
sums <- lapply(1:length(dats), function(x) NA)
names(sums) <- names(dats)

for (i in 1:length(dats)) {
    dat <- dats[[i]]
    stacs <-
        dats[[i]][, match("StationCode", names(dat))]
    results <-
        dats[[i]][, match("Result", names(dat))]
    N <-
        tapply(stacs, stacs, length)
    StationCode <-
        names(N)
    turb_median <-
        tapply(results, stacs, median)
    turb_max <-
        tapply(results, stacs, max)
    turb_min <-
        tapply(results, stacs, min)
    turb_quan1 <-
        tapply(results, stacs, quantile, probs = 0.10)
    turb_quan25 <-
        tapply(results, stacs, quantile, probs = 0.25)
    turb_quan5 <-
        tapply(results, stacs, quantile, probs = 0.50)
    turb_quan75 <-
        tapply(results, stacs, quantile, probs = 0.75)
    turb_quan9 <-
        tapply(results, stacs, quantile, probs = 0.90)
    turb_mean <-
        tapply(results, stacs, mean)
    N.gte.25 <-
        sapply(1:length(StationCode), function(i) sum(ifelse(results[stacs == StationCode[i]] >= 25, 1, 0)))
    pct.gte.25 <-
        N.gte.25 / N * 100
    N.gte.40 <-
        sapply(1:length(StationCode), function(i) sum(ifelse(results[stacs == StationCode[i]] >= 40, 1, 0)))
    pct.gte.40 <-
        N.gte.40 / N * 100
    sums[[i]] <- data.frame(StationCode, N, turb_median, turb_max, turb_min, turb_quan1, turb_quan25, turb_quan5, turb_quan75, turb_quan9, turb_mean, N.gte.25, pct.gte.25, N.gte.40, pct.gte.40)
}

# write.csv(sums$all, paste0(data_dir, "summary-stats-all-", today, ".csv"))
# write.csv(sums$dry, paste0(data_dir, "summary-stats-dry-", today, ".csv"))
# write.csv(sums$dry, paste0(data_dir, "summary-stats-wet-", today, ".csv"))
# }}}
% cmp data# {{{
data <-
    data[data$ParentProject == "RWB3 Cooperative Monitoring Program", ]
data$StationCode <- factor(data$StationCode)

date <- as.Date(data$SampleDate, format = "%m/%d/%Y")
month <- as.numeric(strftime(date, format = "%m"))
dry <- month > 4 & month < 10
datd <- data[dry, ]
datw <- data[!dry, ]

dats <- list(data, datd, datw)
names(dats) <- c("all", "dry", "wet")
sums <- lapply(1:length(dats), function(x) NA)
names(sums) <- names(dats)

for (i in 1:length(dats)) {
    dat <- dats[[i]]
    stacs <-
        dats[[i]][, match("StationCode", names(dat))]
    results <-
        dats[[i]][, match("Result", names(dat))]
    N <-
        tapply(stacs, stacs, length)
    StationCode <-
        names(N)
    turb_median <-
        tapply(results, stacs, median)
    turb_max <-
        tapply(results, stacs, max)
    turb_min <-
        tapply(results, stacs, min)
    turb_quan1 <-
        tapply(results, stacs, quantile, probs = 0.10)
    turb_quan25 <-
        tapply(results, stacs, quantile, probs = 0.25)
    turb_quan5 <-
        tapply(results, stacs, quantile, probs = 0.50)
    turb_quan75 <-
        tapply(results, stacs, quantile, probs = 0.75)
    turb_quan9 <-
        tapply(results, stacs, quantile, probs = 0.90)
    turb_mean <-
        tapply(results, stacs, mean)
    N.gte.25 <-
        sapply(1:length(StationCode), function(i) sum(ifelse(results[stacs == StationCode[i]] >= 25, 1, 0)))
    pct.gte.25 <-
        N.gte.25 / N * 100
    N.gte.40 <-
        sapply(1:length(StationCode), function(i) sum(ifelse(results[stacs == StationCode[i]] >= 40, 1, 0)))
    pct.gte.40 <-
        N.gte.40 / N * 100
    sums[[i]] <- data.frame(StationCode, N, turb_median, turb_max, turb_min, turb_quan1, turb_quan25, turb_quan5, turb_quan75, turb_quan9, turb_mean, N.gte.25, pct.gte.25, N.gte.40, pct.gte.40)
}

write.csv(sums$all, paste0(data_dir, "summary-stats-all-cmp-", today, ".csv"))
write.csv(sums$dry, paste0(data_dir, "summary-stats-dry-cmp-", today, ".csv"))
write.csv(sums$wet, paste0(data_dir, "summary-stats-wet-cmp-", today, ".csv"))
# }}}


#' Function that optimizes sinusoid parameters to fit d18O data
#'
#' The second core function of the ShellChron growth model. Loops
#' through all data windows and uses the \code{growth_model} function
#' to create d18O series that match the input data. This step is
#' iterated and optimized (minimizing the Sum of Squared Residuals)
#' through the SCEUA algorithm (by Duan et al., 1992) which finds
#' the optimal input parameters to the growth rate and Sea Surface
#' Temperature (SST) sinusoids to simulate d18O data.
#' @param dat Matrix containing the input data
#' @param dynwindow Information on the position and length of modeling
#' windows
#' @param transfer_function Transfer function used to convert d18Oc to temperature
#' data.
#' @param d18Ow Either a single value (constant d18Ow) or a vector of length
#' equal to the period in SST data (365 days by default) containing information
#' about seasonality in d18Ow. Defaults to constant d18Ow of 0 permille VSMOW
#' (the modern mean ocean value)
#' @param T_per Period of SST sinusoid (in days; default = 365)
#' @param G_per Period of growth rate sinusoid (in days; default = 365)
#' @param t_int Time interval (in days; default = 1)
#' @param t_maxtemp Timing of the warmest day of the year (in julian day;
#' default = 182.5, or May 26th halfway through the year)
#' @param SCEUApar Parameters for SCEUA optimization (iniflg, ngs, maxn, kstop
#' pcento, peps). For details, refer to Duan et al. (1992) in references
#' @param sinfit Apply sinusoidal fitting to guess initial parameters for SCEUA
#' optimization? \code{TRUE/FALSE}
#' @param MC Number of Monte Carlo simulations to apply for error propagation
#' Default = 1000
#' @param plot Should results of modeling be plotted? \code{TRUE/FALSE}
#' @return A list containing the \code{resultarray} which contains the full
#' result of all simulations on each data window and the \code{parmat} listing
#' all optimized growth rate and SST parameters used to model d18O in each data
#' window
#' @seealso Duan, Qingyun, Soroosh Sorooshian, and Vijai Gupta. "Effective and
#' efficient global optimization for conceptual rainfall runoff models." Water
#' resources research 28.4 (1992): 1015-1031. https://doi.org/10.1029/91WR02985
#' @references package dependencies: ggplot2 3.2.1; rtop 0.5.14
#' Function dependencies: sinreg, d18O_model, growth_model
#'
#' \doi{10.1029/91WR02985}
#' @examples
#' # Create dummy input data column by column
#' dat <- as.data.frame(seq(1000, 40000, 1000))
#' colnames(dat) <- "D"
#' dat$d18Oc <- sin((2 * pi * (seq(1, 40, 1) - 8 + 7 / 4)) / 7)
#' dat$YEARMARKER <- c(0, rep(c(0, 0, 0, 0, 0, 0, 1), 5), 0, 0, 0, 0)
#' dat$D_err <- rep(100, 40)
#' dat$d18Oc_err <- rep(0.1, 40)
#' # Create dummy dynwindow data
#' dynwindow <- as.data.frame(seq(1, 29, 2))
#' colnames(dynwindow) <- "x"
#' dynwindow$y <- rep(12, 15)
#' # Run model function
#' \donttest{resultlist <- run_model(dat = dat,
#'     dynwindow = dynwindow,
#'     transfer_function = "KimONeil97",
#'     d18Ow = 0,
#'     T_per = 365,
#'     G_per = 365,
#'     t_int = 1,
#'     t_maxtemp = 182.5,
#'     SCEUApar = c(1, 25, 10000, 5, 0.01, 0.01),
#'     sinfit = TRUE,
#'     MC = 1000,
#'     plot = FALSE)}
#' @export
run_model <- function(dat, # Core function to run the entire model on the data (dat)
    dynwindow, # The window vetor resulting from reading in the data
    transfer_function = "KimONeil97",
    d18Ow = 0,
    T_per = 365, # Temperature sinusoid parameters
    G_per = 365, # Growth sinusoid parameters
    t_int = 1, # Default time interval = 1 day
    t_maxtemp = 182.5, # Default time (day) at which maximum temperature is reached is 182.5 (exactly halfway through the year, or 1st of June)
    SCEUApar = c(1, 25, 10000, 5, 0.01, 0.01), # Set parameters for SCEUA optimization (iniflg, ngs, maxn, kstop, pcento, peps)
    sinfit = TRUE, # Apply sinusoidal fitting to guess initial parameters for SCEUA optimization? (TRUE/FALSE)
    MC = 1000, # If errors = TRUE, give the number of iterations for Monte Carlo simulation used in error propagation (default = 1000, if MC = 0 no eror propagation is done)
    plot = FALSE # Should the progress of model fitting be plotted?
    ){

    d18Oc <- d18Oc_err <- Omod <- NULL # Predefine variables to circumvent global variable binding error

    # Prepare data arrays for storage of modeling results
    resultarray <- array( # Create array to contain all modeling results of overlapping windows
        rep(as.matrix(cbind(dat, matrix(NA, ncol = length(dynwindow$x), nrow = length(dat$D)))), 9), # Replicate matrix of dat + extra columns to contain all variables
        dim = c(length(dat$D), length(dynwindow$x) + length(dat[1,]), 9) # Six variables, being: Modeled d18O, residuals, Day of the Year, Growth between datapoints, Instantaneous growth rate at datapoint and Modeled temperature
    )

    parmat <- matrix(NA, nrow = 7, ncol = length(dynwindow$x)) # Matrix in which to store the modeling parameters
    colnames(parmat) <- dynwindow$x
    rownames(parmat) <- c("T_amp", "T_pha", "T_av", "G_amp", "G_pha", "G_av", "G_skw")

    # Prepare plot to show model progress

    if(plot == TRUE){
        dev.new()
        fitplot <- ggplot2::ggplot(dat, ggplot2::aes(D, d18Oc)) + # Create a plot showing the fit of each window on the original data, start with a plot of the original data
        ggplot2::geom_point() +
        ggplot2::geom_line() +
        ggplot2::geom_errorbar(ggplot2::aes(ymin = d18Oc - d18Oc_err, # Add error bars on model result (1 SD)
            ymax = d18Oc + d18Oc_err),
            width = dat$D_err) +
        ggplot2::geom_errorbarh(ggplot2::aes(xmin = D - D_err,
            xmax = D + D_err),
            height = 0.05) +
        ggplot2::ggtitle("Plot of d18Oc values vs. depth. Black = data, Red = model, Errorbars = 1 SD")
        plot(fitplot)
    }

    # Estimate growth rate variability and round up to nearest higher magnitude of 10 for conservative boundary
    GRavest <- max(diff(dat[dat$YEARMARKER == 1,1])) / 365 # Estimate maximum growth rate from yearmarkers
    GRavmax <- 10 ^ (ceiling(log(GRavest, 10))) # Round up to nearest higher magnitude of 10

    # Find tailored range of temperatures from data
    d18Oc_range <- range(dat$d18Oc) # Find d18Oc range in data
    if(transfer_function == "KimONeil97"){ # Find temperature range (to be superseded with inverse d18O_model function in later updates)
        T_range <- 18.03 * 1000 / (log((d18Oc_range - (0.97002 * rev(range(d18Ow)) - 29.98)) / 1000 + 1) * 1000 + 32.42) - 273.15 # Use Kim and O'Neil (1997) with conversion between VSMOW and VPDB by Brand et al. (2014)
    }else if(transfer_function == "GrossmanKu86"){
        T_range <-  20.6 - 4.34 * (d18Oc_range - rev(range(d18Ow)) - 0.2) # Use Grossmann and Ku (1986) modified by Dettmann et al. (1999)
    }else{
        print("ERROR: Supplied transfer function is not recognized")
    }
    T_max <- max(T_range)
    T_amp_max <- 2 * abs(diff(T_range))

    # Collate lower boundaries of parameters
    parl <- c(
        T_amp = 0, # Minimum T amplitude in degrees C
        T_pha = 0, # Minimum phase in days
        T_av = -4, # Minimum average T in degrees C
        G_amp = 0, # Minimum seasonal GR range in um/d
        G_pha = 0, # Minimum GR phase in days
        G_av = -1 * GRavmax, # Minimum average GR in um/d.
        G_skw = 0 # Minimum skew factor
    )

    # Collate upper boundaries of parameters
    paru <- c(
        T_amp = round(T_amp_max + 0.5, 0), # Maximum T amplitude in degrees C
        T_pha = 365, # Maximum phase in days
        T_av = round(T_max + 0.5, 0), # Maximum average T in degrees C
        G_amp = 2 * GRavmax, # Maximum seasonal GR range in um/d
        G_pha = 365, # Maximum GR phase in days
        G_av = GRavmax, # Maximum average GR in um/d (based on conservative boundaries of YEARMARKER indicators)
        G_skw = 100 # Maximum skew factor
    )

    # Set parameters for SCEUA optimization
    iniflg = SCEUApar[1] # Flag for initial parameter array (default = 1; included)
    ngs = SCEUApar[2] # Number of complexes (sub-populations, default = 25)
    maxn = SCEUApar[3] # Maximum number of function evaluations allowed during optimization (default = 10000)
    kstop = SCEUApar[4] # Maximum number of evolution loops before convergency (default = 5)
    pcento = SCEUApar[5] # Percentage change allowed in function value criterion before stop (default = 0.01)
    peps = SCEUApar[6] # Convergence level for parameter set (difference between parameters required for stop; default = 0.01)

    # Run the model on all windows

    for(i in 1:length(dynwindow$x)){ # Loop over shell record
        print(paste("Processing Datawindow:", i, "of", length(dynwindow$x))) # Keep track of progress

        # Isolate year of d18O data based on window data
        Dsam <- dat[dynwindow$x[i]:(dynwindow$x[i] + dynwindow$y[i] - 1), 1]
        Osam <- dat[dynwindow$x[i]:(dynwindow$x[i] + dynwindow$y[i] - 1), 2]
        if(MC > 0){
            D_err <- dat[dynwindow$x[i]:(dynwindow$x[i] + dynwindow$y[i] - 1), 4] # Optional: include error on D
            O_err <- dat[dynwindow$x[i]:(dynwindow$x[i] + dynwindow$y[i] - 1), 5] # Optional: include error on d18Oc
        }else{
            D_err <- rep(0, dynwindow$y)
            O_err <- rep(0, dynwindow$y)
            MC <- 0
        }

        if(sinfit){ # If sinusoidal fitting is enabled
            sinlist <- sinreg(Dsam, Osam) # Run sinusoidal regression to find initial parameter values
            # Estimate starting parameters from regression results
            O_av_start <- sinlist[[1]][1] # Export starting value for annual d18O average
            O_amp_start <- sinlist[[1]][2] # Export starting value for d18O amplitude
            O_pha_start <- sinlist[[1]][4] %% sinlist[[1]][3] # Estimate position (in depth of the first peak in d18O)
            O_per_start <- sinlist[[1]][3] # Export starting value for period in distance domain
        }else{
            O_av_start <- mean(Osam) # Estimate starting value for annual d18O average by mean of d18O in record
            O_amp_start <- diff(range(Osam)) / 2 # Estimate starting value for d18O amplitude by half the difference between minimum and maximum d18Oc
            O_per_start <- diff(range(Dsam)) # Estimate starting period as thickness of isolated year
            O_pha_start <- 0.25 * O_per_start # Set starting phase to one quarter of a cycle if it cannot be estimated from sinusoidal regression
        }

        if(transfer_function == "KimONeil97"){
            T_av_start <- 18.03 * 1000 / (1000 * log((O_av_start - (0.97002 * mean(d18Ow) - 29.98)) / 1000 + 1) + 32.42) - 273.15  # Estimate mean temperature. Use Kim and O'Neil (1997) with conversion between VSMOW and VPDB by Brand et al. (2014)
            T_amp_start <- 18.03 * 1000 / (1000 * log((O_av_start - O_amp_start - (0.97002 * mean(d18Ow) - 29.98)) / 1000 + 1) + 32.42) - 273.15 - T_av_start # Estimate temperature amplitude. Use Kim and O'Neil (1997) with conversion between VSMOW and VPDB by Brand et al. (2014)
        }else if(transfer_function == "GrossmanKu86"){
            T_av_start <- 20.6 - 4.34 * (O_av_start - mean(d18Ow) - 0.2) # Estimate mean temperature. Use Grossmann and Ku (1986) modified by Dettmann et al. (1999)
            T_amp_start <- 20.6 - 4.34 * (O_av_start - O_amp_start - mean(d18Ow) - 0.2) - T_av_start # Estimate mean temperature. Use Grossmann and Ku (1986) modified by Dettmann et al. (1999)
        }else{
            print("ERROR: Supplied transfer function is not recognized")
        }

        O_peak <- O_pha_start + Dsam[1] # Find position of d18O peak in distance domain
        T_pha_start <- ((O_pha_start - 0.5 * O_per_start) %% O_per_start) / O_per_start * T_per # Estimate position of first peak in temperature (low in d18O) relative to annual cycle (days)
        G_av_start <- O_per_start / G_per # Estimate average growth rate in distance/day

        years <- 3 # Set default number of years to 3

        # Collate starting parameters
        par0 <- c(
            T_amp = T_amp_start,
            T_pha = T_pha_start,
            T_av = T_av_start,

            G_amp = G_av_start / 2, # Start by estimating growth rate changes by half the average
            G_pha = T_pha_start, # Start by estimating that the peak in growth rate coincides with the peak in temperature
            G_av = G_av_start,
            G_skw = 50 # Start with a no skew
        )

        invisible(capture.output( # Suppress the details on converging SCEUA
            sceua_list <- rtop::sceua(growth_model,
                par0,
                T_per = T_per,
                G_per = G_per,
                years = years,
                t_int = t_int,
                transfer_function = transfer_function,
                d18Ow = d18Ow,
                Dsam = Dsam,
                Osam = Osam,
                t_maxtemp = t_maxtemp,
                parl,
                paru,
                maxn,
                kstop,
                pcento,
                ngs,
                iniflg = iniflg,
                peps = peps,
                implicit = function(pars){sum(pars[4]/2, pars[6]) < 1} # Make sure that the cumulative GR curve is not located below 0 (if G_av < - G_amp / 2)
                )
            ))

        par1 <- sceua_list[[1]] # Eport parameters of final model
        names(par1) <- names(par0)

        result <- growth_model(par1, T_per, G_per, years, t_int, transfer_function, d18Ow, Dsam, Osam, t_maxtemp, plot = FALSE, MC, D_err, O_err, return = "result") # Calculate the end result of the best fit

        if(plot == TRUE){
            fitplot <- fitplot + # Add the new model fit to the plot to track progress of the model
                ggplot2::geom_point(data = as.data.frame(result), ggplot2::aes(Dsam, Omod), colour = "red") +
                ggplot2::geom_line(data = as.data.frame(result), ggplot2::aes(Dsam, Omod), colour = "red")
            print(fitplot)
        }

        resultarray[, i + length(dat[1, ]), ] <- rbind(matrix(NA, nrow = i - 1, ncol = 9), result[, 3:11], matrix(NA, nrow = length(dat$D) - i - length(result[,1]) + 1, ncol = 9)) # Add results to result array
        parmat[, i] <- par1 # Add parameters to parameter array
    }

    # Provide names for all dimensions in the result array
    dimnames(resultarray) <- list(
        paste("sample", 1:length(resultarray[, 1, 3])),
        c(colnames(dat), paste("window", 1:length(dynwindow$x))),
        c("Modeled_d18O", "d18O_residuals", "Time_of_year", "Instantaneous_growth_rate", "Modeled temperature", "Modeled_d18O_SD", "Time_of_Year_SD", "Instantaneous_growth_rate_SD", "Modeled_temperature_SD")
    )

    colnames(parmat) <- paste("window", 1:length(parmat[1,]))
    return(list(resultarray, parmat))
}


my_data <- read.csv('tmp.csv')
kruskal.test(value ~ group, data=my_data)


#' LOO-CV, WAIC and Raw LPPD Calculations
#'
#' Implements LOO-CV, WAIC and Raw LPPD for the \code{\link{model_judgement}} function. Contains
#' the helper function "colVars" which calculates row-wise variances efficiently.
#'
#' @param stanfit A Stanfit object fitted on synthetic data.
#' @param current_model Name of the current model (Currently not in use.)
#' @param lik_name Name under which the log likelihoods have been saved in the models. Needs to be identical
#' across all Stanfit objects.
#' @param impute_inf A boolean which regulates if underflow values should be automatically imputed or not. If
#' \code{FALSE}, the models with such values will just be ignored. If \code{TRUE}, a report will be generated
#' on how many values were imputed and for which models.
#' @return A list with LOO-CV, WAIC and Raw LPPD calculations.
waic <- function(stanfit, current_model, lik_name, impute_inf){
    #http://kylehardman.com/BlogPosts/View/6 DIC code also from Gelman
    #Modified code of www.stat.columbia.edu/~gelman/research/unpublished/waic_stan.pdf
    #from gist.github.com/ihrke for underflow probs

    colVars <- function(a) {
        n <- dim(a)[[1]];
        c <- dim(a)[[2]];
        result <- (.colMeans(((a - matrix(.colMeans(a, n, c),
                                          nrow = n, ncol = c, byrow = TRUE)) ^ 2), n, c) * n / (n - 1))
        return(result)
    }

    log_lik <- rstan::extract(stanfit, lik_name)$log_lik

    if(impute_inf){
        lik_imp <- sum(is.infinite(log_lik))/length(log_lik)
        log_lik[is.infinite(log_lik)] <- mean(log_lik[!is.infinite(log_lik)])
    }
    dim(log_lik) <- if (length(dim(log_lik))==1) c(length(log_lik),1) else
        c(dim(log_lik)[1], prod(dim(log_lik)[2:length(dim(log_lik))]))
    S <- nrow(log_lik)
    n <- ncol(log_lik)
    #log pointwise
    lpd <- log(colMeans(exp(log_lik))) #only when posterior simulations in Stan are correctly made (and possible)

    #waic
    p_waic <- colVars(log_lik)
    elpd_waic <- lpd - p_waic
    waic <- -2*elpd_waic

    #loo
    loo_weights_raw <- 1/exp(log_lik-max(log_lik))

    if(impute_inf){
        loo_imp <- sum(is.infinite(loo_weights_raw))/length(loo_weights_raw)
        loo_weights_raw[is.infinite(loo_weights_raw)] <- mean(loo_weights_raw[!is.infinite(loo_weights_raw)])
    }

    loo_weights_normalized <- loo_weights_raw/matrix(colMeans(loo_weights_raw),nrow=S,ncol=n,byrow=TRUE)
    loo_weights_regularized <- pmin (loo_weights_normalized, sqrt(S))

    elpd_loo <- log(colMeans(exp(log_lik)*loo_weights_regularized)/colMeans(loo_weights_regularized))
    p_loo <- lpd - elpd_loo
    elpd_loo <- elpd_loo*-2
    pointwise <- cbind(waic,lpd,p_waic,elpd_waic,p_loo,elpd_loo)
    total <- colSums(pointwise)
    se <- sqrt(n*colVars(pointwise))
    ic <- list(waic=total["waic"], elpd_waic=total["elpd_waic"],
               p_waic=total["p_waic"], elpd_loo=total["elpd_loo"], p_loo=total["p_loo"],
               pointwise=pointwise, total=total, se=se)

    if(impute_inf){
        imps <- list('lik_imp' = lik_imp, 'loo_imp' = loo_imp)
        return(list('ic' = ic, 'imps' = imps))
    } else{
        return(list('ic' = ic))
    }
}


library(ggplot2)
library(reshape2)
library(plyr)
setwd("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/")
dt <- read.table("Results/grid_lstm_wins.csv", header=TRUE, sep=',')
dt_melted <- melt(dt, id.vars=c("nsamples","nfeatures", "nseqfeatures", "seqlen"), variable.name='models', value.name = "accuracy")
dt_melted$dynamic_ratio <- dt_melted$nseqfeatures/(dt_melted$nfeatures + dt_melted$nseqfeatures)
dt_melted$nsamples <- as.factor(dt_melted$nsamples)
dt_melted$nseqfeatures <- as.factor(dt_melted$nseqfeatures)
dt_melted$nfeatures <- as.factor(dt_melted$nfeatures)
dt_melted$seqlen <- as.factor(dt_melted$seqlen)

calc_confidence_interval <- function(data=dt_melted, feature_of_interest){
  command <- paste("dt_summary <- ddply(data, .(", feature_of_interest, ", models), summarize, mean_acc=round(mean(accuracy, na.rm = T),2), sd_acc=round(sd(accuracy, na.rm = T),2))", sep='')
  eval(parse(text=command))
  eval(parse(text=paste("dt_tot <- ddply(data, .(", feature_of_interest,", models), nrow)", sep='')))
  colnames(dt_tot)[3] <- "count"
  dt_summary <- merge(dt_summary, dt_tot, by=c(feature_of_interest, "models"), all.x=T)
  dt_summary$se <- dt_summary$sd_acc/sqrt(dt_summary$count)
  return(dt_summary)
}

dt_summary <- calc_confidence_interval(data=dt_melted, feature_of_interest="seqlen")
limits <- aes(ymax = mean_acc + 1.96*se, ymin=mean_acc - 1.96*se) #95% C.I.
p1 <- ggplot(dt_summary, aes(x=seqlen, y=mean_acc, fill=models)) + geom_bar(position='dodge', stat='identity', color="grey90") +
  theme_bw(base_size=32) + geom_errorbar(limits, position='dodge')

dt_summary <- calc_confidence_interval(data=dt_melted, feature_of_interest="seqlen")
limits <- aes(ymax = mean_acc + 1.96*se, ymin=mean_acc - 1.96*se) #95% C.I.
p2 <- ggplot(dt_summary, aes(x=models, y=mean_acc, fill=seqlen)) + geom_bar(position='dodge', stat='identity', color="grey90") +
  theme_bw(base_size=32) + geom_errorbar(limits, position='dodge') +
  ylab("mean accuracy") + theme(axis.text.x = element_text(angle = 40, hjust = 1)) + labs(fill="sequence \nlength")

dt_summary <- calc_confidence_interval(data=dt_melted, feature_of_interest="nsamples")
limits <- aes(ymax = mean_acc + 1.96*se, ymin=mean_acc - 1.96*se) #95% C.I.
p3 <- ggplot(dt_summary, aes(x=models, y=mean_acc, fill=nsamples)) + geom_bar(position='dodge', stat='identity', color="grey90") +
  theme_bw(base_size=32) + geom_errorbar(limits, position='dodge')

dt_summary <- calc_confidence_interval(data=dt_melted, feature_of_interest="nfeatures")
limits <- aes(ymax = mean_acc + 1.96*se, ymin=mean_acc - 1.96*se) #95% C.I.
p4 <- ggplot(dt_summary, aes(x=models, y=mean_acc, fill=nfeatures)) + geom_bar(position='dodge', stat='identity', color="grey90") +
  theme_bw(base_size=32) + geom_errorbar(limits, position='dodge')

dt_summary <- calc_confidence_interval(data=dt_melted, feature_of_interest="nseqfeatures")
limits <- aes(ymax = mean_acc + 1.96*se, ymin=mean_acc - 1.96*se) #95% C.I.
p5 <- ggplot(dt_summary, aes(x=models, y=mean_acc, fill=nseqfeatures)) + geom_bar(position='dodge', stat='identity', color="grey90") +
  theme_bw(base_size=32) + geom_errorbar(limits, position='dodge')

#dynamic ratio
p6 <- ggplot(dt_melted, aes(x=dynamic_ratio, y=accuracy))+
geom_point() + theme_bw(base_size=32) + facet_wrap(~models)
p6

png("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Results/mean_acc_vs_seqlen.png", width = 1600, height = 1000)
print(p2)
dev.off()

png("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Results/mean_acc_vs_nsamples.png", width = 1600, height = 1000)
print(p3)
dev.off()

png("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Results/mean_acc_vs_nfeatures.png", width = 1600, height = 1000)
print(p4)
dev.off()

png("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Results/mean_acc_vs_nseqfeatures.png", width = 1600, height = 1000)
print(p5)
dev.off()

setEPS()
postscript("/Users/annaleontjeva/Desktop/My_files/Generative-Models-in-Classification/Results/mean_acc_vs_seqlen.eps")
print(p2)
dev.off()

# general plot of accuracy vs. models
p7 <- ggplot(dt_melted, aes(x=models, y=accuracy)) + geom_boxplot() + theme_bw(base_size=24) + coord_flip() +
  geom_point(position = position_jitter(width = 0.2)) +
  geom_boxplot(outlier.colour = NA, fill = NA) + facet_wrap(~nsamples)
multiplot(p2,p3,p4,p5)
p1
p2
p3
p4
p5
p6

ggplot(dt_melted, aes(x=feat_ratio, y=accuracy, size=nsamples, color=nsamples)) +
  geom_point() + theme_bw(base_size=24) + geom_jitter(position = position_jitter()) + facet_wrap(~models)

ggplot(dt_melted, aes(x=feat_ratio)) + geom_histogram()

dt_sbs <- subset(dt_melted, nsamples==3000 & nfeatures==30 & nseqfeatures==1 & seqlen==50)

ggplot(dt_sbs, aes(x=models, y=accuracy)) + geom_bar(position="dodge", stat='identity')+theme_bw(base_size=24)


./tests.verify: test performed on 2007.09.05

#### Test: ./tests.verify running ./make_module_1.sh
['__doc__', '__file__', '__name__', 'gridloop1', 'gridloop2']
module ext_gridloop:
   gridloop1(a, xcoor, ycoor, pyfunc)
   a = gridloop2(xcoor, ycoor, pyfunc)
CPU time of ./make_module_1.sh: 1.5 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running ../../Grid2Deff.py verify1
x+2*y = [[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
x+2*y = 0.0
x+2*y = 2.0
x+2*y = 0.5
x+2*y = 2.5
x+2*y = 1.0
x+2*y = 3.0
f computed by external gridloop1 function and f1:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
x+2*y = 0.0
x+2*y = 2.0
x+2*y = 0.5
x+2*y = 2.5
x+2*y = 1.0
x+2*y = 3.0
f computed by external gridloop2 function and f1:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
f computed by external gridloop1 function and StringFunction:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
f computed by external gridloop2 function and StringFunction:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
f computed by external gridloop2 function and StringFunction.__call__:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
f computed by __call__ and StringFunction:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
array seen from Python:
value at (0,0)  	 = a[0,0] = 0
value at (0,1)  	 = a[0,1] = 2
value at (0.5,0)  	 = a[1,0] = 0.5
value at (0.5,1)  	 = a[1,1] = 2.5
value at (1,0)  	 = a[2,0] = 1
value at (1,1)  	 = a[2,1] = 3
CPU time of ../../Grid2Deff.py: 0.6 seconds on ubuntu i686, Linux

#### Test: ./tests.verify running ../../Grid2Deff.py exceptions1
<type 'exceptions.TypeError'> gridloop1() argument 1 must be numpy.ndarray, not tuple
<type 'exceptions.ValueError'> a array is 1-dimensional or not of type float
<type 'exceptions.TypeError'> func1 is not a callable function
<type 'exceptions.NameError'> global name 'Complex64' is not defined
<type 'exceptions.ValueError'> xcoor array is 2-dimensional, but expected to be 1-dimensional
CPU time of ../../Grid2Deff.py: 0.6 seconds on ubuntu i686, Linux