## Assignment 2 i.e Quiz 2 of R class##
## Quiz 1##
cube <- function(x, n) {
        x^3
}
cube(3)

# Since no use of n in the function enviroments, so it is evaluated i.e function
# does not depends on n, so there is no error at all.

## Quiz 2 ##

x<- 1:10
if(x >5) {
        x <- 0
}

# since the value of x is vector and it could evaluate for first value only
# Warning message:
#        In if (x > 5) { :
#                                the condition has length > 1 and only the first element will be used

#### Question 3 ####
f <- function(x) {
        g <- function(y) {
                y + z
        }
        z <- 4
        x + g(x)
}

z <- 10
f(3) # will call function g <- function(y) {y +z} in the function enviroment,
# z <- 4; 3 + g(3), now function g called in function enviroment i.e 3 + 4 = 7
# so, g (3) will return 7  and hence 3 + 7  = 10

#### Question 4 ####

x <- 5
y <- if (x < 3) {
        NA
} else {
        10
}

### Programming Assignement 2###

makeVector <- function(x = numeric()) {
        m <- NULL
        set <- function(y) {
                x <<- y
                m <<- NULL
        }
        get <- function() x
        setmean <- function(mean) m <<- mean
        getmean <- function() m
        list(set = set,
             get = get,
             setmean = setmean,
             getmean = getmean)
}

cachemean <- function(x, ...) {
        m <- x$getmean()
        if(!is.null(m)) {
                message("getting cached data")
                return(m)
        }
        data <- x$get()
        m <- mean(data, ...)
        x$setmean(m)
        m
}

makeCacheMatrix <- function(x = matrix()) {
        ## Initialise the matrix.
        inverseMatrix <- NULL
        # set the given matrix
        set <- function(matrix) {
                m <<- matrix
                inverseMatrix <<- NULL
        }

        # Get the given matrix
        get <- function()  {
                m
        }

        # find and set the inverse of the matrix
        setInverse <- function(solve) {
                inverseMatrix <<- solve
        }

        # Get the inverted matrix
        getInverse <- function() {
                inverseMatrix
        }

        # Return the list
        list(set = set,
             get = get,
             setInverse = setInverse,
             getInverse = getInverse
        )
}

cacheSolve <- function(x, ...) {
        ## Return a matrix that is the inverse of 'x'
        inverseMatrix <- x$getInverse()
        if(!is.null(inverseMatrix)) {
                message("getting cached inverse matrix")
                return(inverseMatrix)
        }

        originalMatrix <- x$get()
        inverseMatrix <- solve(originalMatrix, ...)
        x$setInverse(inverseMatrix)
        inverseMatrix
}

}


#' rsq_1.1 - generate r-squared for observations relative to 1:1 line
#'
#' @param observed   observed values of dependent variable.
#' @param predicted  predicted values of dependent variable.
#'
#' @return returns r-squared value for observed vs. predicted. Can be negative.
#' @export
#'
#' @examples
rsq_1.1 <- function(observed, predicted){
  if(sum(is.na(observed )) > 0){stop('Error: NAs in observed vector.' )}
  if(sum(is.na(predicted)) > 0){stop('Error: NAs in predicted vector.')}
  #calculate residual sums of squares relative to actual prediction (i.e. "1:1 line")
  SS.res <- sum((observed - predicted)^2)
  #calculate total sum of squares.
  SS.tot <- sum((observed - mean(observed))^2)
  #calculate rsq and return.
  rsq.1 <- 1 - SS.res/SS.tot
  return(rsq.1)
}


'

summaryw -> Return Heteroskedastic robust standard errors for "model".

clx -> Return clustered-standard errors for "fm".

wald.ci -> Return Wald Confidenceintervall for second "coef" of "reg"

anderson.rubin.ci -> Return "Anderson Rubin CI" for "ivmodel" with sig. niveau
                     "conflevel". Default is "conflevel=.95"

'

summaryw = function(model) {
    '
    Return Heteroskedastic robust standard errors for "model"
    '

    s = summary(model)
    X = model.matrix(model)
    u2 = residuals(model)^2
    XDX = 0

    ## Here one needs to calculate X'DX. But due to the fact that
    ## D is huge (NxN), it is better to do it with a cycle.
    for (i in 1:nrow(X)) {
        XDX = XDX + u2[i] * X[i,] %*% t(X[i,])
    }

    # inverse(X'X)
    XX1 = solve(t(X)%*%X)

    # Variance calculation (Bread x meat x Bread)
    varcovar = XX1 %*% XDX %*% XX1

    # degrees of freedom adjustment
    dfc = sqrt(nrow(X)) / sqrt(nrow(X) - ncol(X))

    # Standard errors of the coefficient estimates are the
    # square roots of the diagonal elements
    stdh = dfc*sqrt(diag(varcovar))

    t = model$coefficients / stdh
    p = 2 * pt(
        -abs(t),nrow(X)-ncol(X)
    )
    results = cbind(
        model$coefficients, stdh, t, p
    )
    dimnames(results) = dimnames(s$coefficients)
    list(results, dfc^2 * varcovar)
}

clx = function(fm, dfcw, cluster) {
    # Return clustered-standard errors for "fm".
    # 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
    list(coeftest(fm, vcovCL), vcovCL)
}

wald.ci = function (reg , alpha, cluster){
    # Return Wald Confidenceintervall for second "coef" of
    # "reg"
    df = summary(reg)$df[2]
    c = summary(reg)$df[1]
    h = clx(fm = reg, dfcw = 1, cluster = cluster)[[1]][c + 2] * qt(1 - alpha/2,df)
    est = reg$coef[2]
    paste(
        "$[", round(est - h,2),  ", " , round(est + h,2), "]$",
        sep=""
    )
}

anderson.rubin.ci = function(ivmodel, conflevel=.95){
    ## Return "Anderson Rubin CI" for "ivmodel" with sig. niveau
    ## "conflevel". Default is "conflevel=.95"

    y = ivmodel$y
    n = length(y)

    if( is.null(ivmodel$x)==TRUE ){
        print("Refit ivmodel with x=TRUE option in the ivreg function.")
        stop()
    }

    regressors = ivmodel$x$regressors
    instruments = ivmodel$x$instruments

    # Use notation in Davidson and MacKinnon, 2011
    # Figure out based on ivmodel fit from ivreg, the elements in Davidson and MacKinnon
    W = instruments;
    # Figure out which columns in regressors and instruments are the same
    regressors.same.vec = rep(0,ncol(regressors))
    instruments.columns.same = rep(0,ncol(regressors)-1)
    count = 1
    for (i in 1:ncol(regressors)) {
        tempmat = regressors[,i] - instruments
        tempsum = apply(abs(tempmat),2,sum)
        regressors.same.vec[i] = sum(tempsum==0) > 0

        if (sum(tempsum==0)>0) {
            instruments.columns.same[count] = i
            count = count + 1
        }
    }

    y2column = which(regressors.same.vec==0)
    y2 = regressors[,y2column]
    Z = regressors[,-y2column]
    W2 = instruments[,-instruments.columns.same]

    l = ncol(W)

    if ( is.null(ncol(Z)) ){
        Z = matrix(Z)
        k = ncol(Z)
    } else {
        k = ncol(Z)
    }

    q = qf( conflevel, l-k, n-l )
    cval = q * (l-k) / (n-l)
    y1 = matrix(y, ncol=1)

    y2hat.given.W = fitted( lm(y2 ~ W - 1) )
    y2hat.given.Z = fitted( lm(y2 ~ Z) )
    y1hat.given.W = fitted( lm(y1 ~ W-1) )
    y1hat.given.Z = fitted( lm(y1 ~ Z) )

    coef.beta0sq = cval * sum(y2^2) - (cval+1) * sum(y2 * y2hat.given.W) + sum(y2 * y2hat.given.Z)

    a = sum( y1 * y2hat.given.Z)
    coef.beta0 = -2 * cval * sum(y1*y2) + 2 * (cval+1) * sum(y1 * y2hat.given.W) - 2 * a

    coef.constant = cval * sum(y1^2) - (cval + 1) * sum(y1 * y1hat.given.W) + sum(y1 * y1hat.given.Z)

    D = coef.beta0^2 - 4 * coef.constant * coef.beta0sq

    if(coef.beta0sq==0){
        if (coef.beta0>0) {
            ci=c(
                "[",
                round(-coef.constant / coef.beta0, 2),
                ",Infinity)"
            )
        }
        if (coef.beta0<0) {
            ci=c(
                "(-Infinity,",
                round(-coef.constant / coef.beta0, 2),
                "]"
            )
         }
        if (coef.beta0==0) {

                if (coef.constant>=0) {
                                     ci="\\text{Whole Real Line}"
                }
                if (coef.constant<0) {
                                    ci="\\text{Empty Set}"
                }
         }
    }

    if (coef.beta0sq!=0) {
        if (D<0) {
            if (coef.beta0sq>0) {
                ci="\\text{Whole Real Line}"
            }
            if (coef.beta0sq<0) {
                ci="\\text{Empty Set}"
            }
        }
        if (D>0) {
            # Roots of quadratic equation
            # Roots of quadratic equation
            root1 = ( -coef.beta0 + sqrt(D) ) / (2 * coef.beta0sq)
            root2=( -coef.beta0 - sqrt(D) ) / (2 * coef.beta0sq)
            upper.root = round( max(root1,root2), 2)
            lower.root = round( min(root1,root2), 2)

            if (coef.beta0sq<0) {
                ci = paste(
                    "[",
                    lower.root,",",
                    upper.root,"]",
                    sep=""
                )
            }
            if (coef.beta0sq>0) {
                ci = c(
                    paste(
                        "($-\\infty$,",
                        "$",
                        lower.root,
                        "$]U",
                        sep=""
                    ),
                    paste(
                        "[$",
                        upper.root,
                        "$",
                        ",$\\infty$)",
                        sep=""
                    )
                )
            }
        }
        if (D==0) {
            ci="\\text{Whole Real Line}"
        }
    }
    return(confidence.interval = ci)
}


####
###UMR_Trib Data. Si Woodstoich Working Group
#5.19.19

##====================================
#What's diff from before?
##Now using TP and TN instead of the inorganic constituents
#and put Si in numerator of ratios, like Paul did

library(plyr)
library(dplyr)

setwd("~/Woodstoich/RawData_5.14.19")

#importing data
Data<-read.table(file="UMR_Tribs_jcc_5.14.19.csv", header=TRUE, sep=',')
names(Data)

#Helper variables from Paul
N.mw=14.0067
P.mw=30.973762
C.mw=12.0107
Si.mw=28.0855

#Adding new colums with data in moles so to calc molar ratios
Data$uMSi<-(Data$SI/Si.mw*1000)
Data$uMNOX<-(Data$NOX/N.mw*1000)
Data$uMNHX<-(Data$NHX/N.mw*1000)
Data$uMSRP<-(Data$SRP/P.mw*1000)
Data$uMDIN<-(Data$uMNOX+Data$uMNHX)
Data$Si_DIN<-(Data$uMSi/Data$uMDIN)
Data$Si_SRP<-(Data$uMSi/Data$uMSRP)

Data$uMTP<-(Data$TP/P.mw*1000)
Data$uMTN<-(Data$TN/N.mw*1000)
Data$Si_TP<-(Data$uMSi/Data$uMTP)
Data$Si_TN<-(Data$uMSi/Data$uMTN)

range(Data$uMSi, na.rm=T)

#subsetting to remove negatives
Data<-subset(Data, uMSi>0 & uMNOX>0 & uMSRP>0 & uMNHX>0 & uMTP>0 & uMTN>0)

#Fixing dates and adding year as a column
Data$DATE2=as.Date(Data$DATE, c("%m/%d/%Y"))
Data$YEAR=as.numeric(format(Data$DATE2,c("%Y")))

#making each site name into a unique number
unique(Data$LOCATCD)
Data$SiteNum<-as.numeric(as.factor(Data$LOCATCD))
head(Data$SiteNum)
unique(Data$SiteNum)

#Calc min and max dates for each site
SiteDates<-ddply(Data, c("LOCATCD"), summarise, min.date=min(YEAR), max.date=max(YEAR))
SiteDates$YrsData<-with(SiteDates, as.numeric(max.date-min.date))
LongTermSites<-subset(SiteDates, SiteDates$YrsData>20)

#Now merge these sites with >20 yrs data with larger dataset
Data3<-merge(LongTermSites, Data, by=c("LOCATCD"))
head(Data3)

#calc avg vaues by year at each site
AvgByYr<-aggregate(cbind(Data3$uMSi, Data3$uMNHX, Data3$uMSRP, Data3$uMNOX, Data3$uMDIN,
                          Data3$Si_TN, Data3$Si_TP, Data3$uMTP, Data3$uMTN) ~ Data3$LOCATCD + Data3$YEAR, FUN=mean)
names(AvgByYr)
colnames(AvgByYr) <- c("LOCATCD", "Year", "AvguMSi", "AvgNH4", "AvgSRP", "AvgNOX",
                        "AvgDIN", "AvgSi_TNRatio", "AvgSi_TPRatio", "AvgTP", "AvgTN")
Data4<-AvgByYr[order(AvgByYr$LOCATCD),]
range(Data4$AvgSi_TNRatio)

##==============================================
##plotting avg annual values over time for each site with >20yrs data
##exported the results of simple linear regression
##=============================================

library(broom)
#glace in the broom package give R2 (and apparently pvalues). tidy gives p values and slopes

#making new datafram of site IDs
LocatID<-data.frame(unique(Data4$LOCATCD))

#Average Si:TN molar ratios over time. y axis range: 0.124 to 6.38
#these plots have y axis that includes all values but hard to see trends so zooming in on next plot
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgSiTN_Plot.jpeg"), width=7, height=5, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.8,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"],
       xlim=c(1990, 2020), ylim=c(0,6.5), main=paste("Site", i), ylab="Si:TN",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,2,4,6), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

df2<-cbind(LocatID, df)
write.csv(df2, file="R2_Si_TNRatiosvsTime_5.15.19_wNames.csv", row.names=TRUE, na = "NA")

#these margins work for exporting graphs to file folders but use above graphics if want to display the plots in panel in R Studio
#Si:TN plots more zoomed in
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgSiTN_Plot_zoomed_in.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2,2,1.2))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"],
       xlim=c(1990, 2020), ylim=c(0,3), main=paste("Site", i), ylab="Si:TN",
       mgp=c(1.1,.2,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main=0.8, cex.lab=0.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,1,2,3), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgSi_TNRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

range(Data4$AvgSi_TPRatio) #3 to 285
#these margins work for exporting graphs to file folders but use above graphics if want to display the plots in panel in R Studio
#Si:TP plots
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgSiTP_Plot.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,0.9))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"],
       xlim=c(1990, 2020), ylim=c(0,290), main=paste("Site", i), ylab="Si:TP",
       mgp=c(1.7,.1,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main=0.8, cex.lab=0.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,100, 200,300), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

##Same as above except y axis is zoomed in
#more Si_TP plots
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgSiTP_Plot_ZoomedIn.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,0.9))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"],
       xlim=c(1990, 2020), ylim=c(0,150), main=paste("Site", i), ylab="Si:TP",
       mgp=c(1.7,.1,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main=0.8, cex.lab=0.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,50, 100, 150), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgSi_TPRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

df2<-cbind(LocatID, df)
write.csv(df2, file="R2_Si_TPRatiosvsTime_wNames.csv", row.names=TRUE, na = "NA")

#Average DSi values over time
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgDSivsTime.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.3,2,0.9))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvguMSi"],
       xlim=c(1990, 2020), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM",
       mgp=c(1.6,1.1,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main=0.8, cex.lab=0.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.3, cex.axis=.8, mgp=c(0,0.3,0), font.axis=1)
  axis(side=2, at = c(0,50,100,150,200, 250), tcl=-.3, cex.axis=.8, mgp=c(0,0.3,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvguMSi"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvguMSi"]~ Data4[Data4$LOCATCD==i, "Year"]))))
  }
dev.off()

df2<-cbind(LocatID, df)
write.csv(df2, file="R2_DSivsTime_wNames.csv", row.names=TRUE, na = "NA")

#Average TP values over time
range(Data4$AvgTP) #1.7 to 44
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgTP_Plot.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgTP"],
       xlim=c(1990, 2020), ylim=range(Data4$AvgTP), main=paste("Site", i), ylab="TP uM",
       mgp=c(1.6,.2,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main =0.8, cex.lab=.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,20,40), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgTP"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgTP"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

LocatID<-data.frame(unique(Data4$LOCATCD))
df2<-cbind(LocatID, df)
write.csv(df2, file="R2_TPvsTime_5.19.19c.csv", row.names=TRUE, na = "NA")

#zooming in
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgTP_Plot_ZoomedIn.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgTP"],
       xlim=c(1990, 2020), ylim=c(0,15), main=paste("Site", i), ylab="TP uM",
       mgp=c(1.3,.2,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main =0.8, cex.lab=.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,5, 10, 15), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgTP"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgTP"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

#Average TN values over time
range(Data4$AvgTN) #134 to 1153
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgTN_Plot.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,1))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgTN"],
       xlim=c(1990, 2020), ylim=range(Data4$AvgTN), main=paste("Site", i), ylab="TN uM",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main =0.8, cex.lab=.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,250, 500, 750, 1000), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgTN"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgTN"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

df2<-cbind(LocatID, df)
write.csv(df2, file="R2_TNvsTime_wNames.csv", row.names=TRUE, na = "NA")

#Average TN values over time - zoomed in
range(Data4$AvgTN) #134 to 1153
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgTN_Plot_zoomedIn.jpeg"), width=7, height=4, units="in", res=200)
par(mfrow=c(4,7), mar=c(2,2.5,2,1))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgTN"],
       xlim=c(1990, 2020), ylim=c(0,700), main=paste("Site", i), ylab="TN uM",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n", cex.main =0.8, cex.lab=.8)
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,300, 600), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgTN"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgTN"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

##==============================================
##playing with Chl data 5.16.19
##==============================================
Data5<-subset(Data3, CHLcal>0 & VSS>0)

#calculating average annual values with smaller dataset that excludes negatives for VSS and Chl a (n=~6000 now)
#this still includes all sites with >20 yrs data
AvgByYr_withChlVSS<-aggregate(cbind(Data5$uMSi, Data5$uMNHX, Data5$uMSRP, Data5$uMNOX, Data5$uMDIN,
                                    Data5$DINSi, Data5$PSi, Data5$VSS, Data5$CHLcal) ~ Data5$LOCATCD + Data5$YEAR, FUN=mean)
names(AvgByYr_withChlVSS)
colnames(AvgByYr_withChlVSS) <- c("LOCATCD", "Year", "AvguMSi", "AvgNH4", "AvgSRP", "AvgNOX",
                                  "AvgDIN", "AvgDIN_SiRatio", "AvgP_SiRatio", "AvgVSS", "AvgChl")
Data6<-AvgByYr_withChlVSS[order(AvgByYr_withChlVSS$LOCATCD),]

###===================================
# looping Chl a vs. consitutents at each site
##====================================
range(Data6$AvgChl, na.rm=T)
range(Data6$AvguMSi)
names(Data6)
range(Data5$VSS, na.rm=T)

#Average Chl a vs. DSi at each site
df=NULL
plot.path=paste0(getwd(),"/img/")
jpeg(filename=paste0(plot.path, "AvgDSivsChl_5.16.19b.jpeg"), width=7, height=7, units="in", res=200)

par(mfrow=c(4,7), mar=c(2.9,2.8,2,1.7))
for(i in unique(Data6$LOCATCD)){
  plot(Data6[Data6$LOCATCD==i, "AvgChl"], Data6[Data6$LOCATCD==i, "AvguMSi"],
       xlim=c(0, 35), ylim=c(0,300), main=paste("Site", i), ylab="DSi uM",
       mgp=c(1.6,.1,0), las=1, xlab="Chl a", xaxt="n", yaxt="n", cex.main=.9)
  axis(side=1, at = c(0, 10, 20, 30), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,100, 200, 300), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data6[Data6$LOCATCD==i, "AvguMSi"]~ Data6[Data6$LOCATCD==i, "AvgChl"]))
  df=rbind(df,data.frame(glance(lm(Data6[Data6$LOCATCD==i, "AvguMSi"]~ Data6[Data6$LOCATCD==i, "AvgChl"]))))
}
dev.off()

write.csv(df, file="R2_DIN_SiRatiosvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

##=======================================================
##below is me f-ing around...
##=======================================================

#couldn't figure this out - to define the path inside the loop:
mypath<-file.path(~"Woodstoich","RawData_5.14.19", "img")
jpeg(file=mypath)

#if use below, i have to change site num to locatcd bc got rid of misc numbers:

#testing out the loop here - works! just going into wrong folder and these are each plot individually, not multi-panel:
#so putting in diff folder:
setwd("~/Woodstoich/RawData_5.14.19/img")
for(i in unique(Data4$SiteNumber)){
  jpeg(paste("plot_", i, ".jpeg", sep=""))
  plot(Data4[Data4$SiteNumber==i, "Year"], Data4[Data4$SiteNumber==i, "AvguMSi"],
       xlim=range(Data4$Year), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM", xlab="")
  dev.off()
}

#couldn't figure out matrix so using mfrow instead
layout(matrix(1:3, ncol=3))
layout(matrix(1:28,7,4,byrow=F))

#Test code for saving plot to folder
jpeg(file = "~/Woodstoich/RawData_5.14.19/img/plot2.jpeg")
plot(Data4$Year, Data4$AvgP_SiRatio)
dev.off()

#lets add trend line to plot
#practice plot not in loop:
plot(Data4$Year, Data4$AvguMSi, ylim=c(5,250), xlim=c(1990,2020), ylab="DSi uM", xlab="", las=1)
title("DSi uM concentrations over time, LOCATCD==WPO2.6M ", line=2, cex.main=.8)
abline(lm(Data4$AvguMSi ~ Data4$Year))
fit1<-lm(Data4$AvguMSi ~ Data4$Year)
fit2<-lm(Data4$AvguMSi ~ Data4$Year)

#this loop works - just need to save the files to a folder
for(i in unique(Data4$SiteNumber)){
  plot(Data4[Data4$SiteNumber==i, "Year"], Data4[Data4$SiteNumber==i, "AvguMSi"],
       xlim=range(Data4$Year), ylim=range(Data4$AvguMSi), main=paste("Site", i), ylab="DSi uM", xlab="")
  }
dev.off()

#this works but ignore
plot(Data4$Year[which(Data4$SiteNumber==1)], Data4$AvguMSi [which(Data4$SiteNumber==1)], ylim=c(5,250), xlim=c(1990,2020), ylab="DSi uM", xlab="", las=1)
title("DSi uM concentrations over time, Site ", line=2, cex.main=.8)

#Average DIN:DSi molar ratios over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.8,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"],
       xlim=c(1990, 2020), ylim=c(0,16), main=paste("Site", i), ylab="DIN:DSi",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,5,10,15), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgDIN_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

write.csv(df, file="R2_DIN_SiRatiosvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

##Switched ratios around - not using these any longer
#Average DIP:Si molar ratios over time
df=NULL
par(mfrow=c(4,7), mar=c(2,2.8,2,1.3))
for(i in unique(Data4$LOCATCD)){
  plot(Data4[Data4$LOCATCD==i, "Year"], Data4[Data4$LOCATCD==i, "AvgP_SiRatio"],
       xlim=c(1990, 2020), ylim=c(0,.1), main=paste("Site", i), ylab="SRP:DSi",
       mgp=c(1.8,.2,0), las=1, xlab="", xaxt="n", yaxt="n")
  axis(side=1, at = c(1990, 2000, 2010, 2020), tcl=-.4, cex.axis=.8, mgp=c(0,.3,0), font.axis=1)
  axis(side=2, at = c(0,0.05, 0.1), tcl=-.3, cex.axis=.8, mgp=c(0, .5,0), font.axis=1, las=1)
  abline(lm(Data4[Data4$LOCATCD==i, "AvgP_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))
  df=rbind(df,data.frame(glance(lm(Data4[Data4$LOCATCD==i, "AvgP_SiRatio"]~ Data4[Data4$LOCATCD==i, "Year"]))))
}
dev.off()

write.csv(df, file="R2_P_SiRatiosvsTime_5.15.19.csv", row.names=TRUE, na = "NA")

##not using but kept for maybe later
#calc avg vaues by year at each site
AvgByYr<-aggregate(Data$uMSi~ Data$SiteNum + Data$YEAR, FUN=mean)
colnames(AvgByYr) <- c("SiteNumber", "Year", "AvguMSi")
Data3<-AvgByYr[order(AvgByYr$SiteNumber),]

#these are 'or' not 'and' statements
Data5<-subset(Data,subset=uMSi>0 | uMNOX>0 | uMNHX>0 | uMSRP>0)
Data9<-Data[ !is.na(Data$uMSi | Data$uMNOX| Data$uMSRP | Data$NHX) & (Data$uMSi>0 | Data$uMNOX>0 |Data$uMNHX>0 | Data$uMSRP>0) ,]

#Does same thing as above but uses the 'which', which some pple don't like
Data8<-Data[ which(Data$uMSi>0 | Data$uMNOX>0 |Data$uMNHX>0 | Data$uMSRP>0) ,]


############## CELL CYCLE DISTRIBUTION ESTIMATION FROM DAPI INTENSITIES ################
#
#   licensed under the MIT License:
#
#   Copyright (c) 2016 Andreas Stengl, David Hoerl, Heinrich Leonhardt and Jonas Helma
#
#   Permission is hereby granted, free of charge, to any person obtaining a copy of this
#   software and associated documentation files (the "Software"), to deal in the Software
#   without restriction, including without limitation the rights to use, copy, modify, merge,
#   publish, distribute, sublicense, and/or sell copies of the Software, and to permit
#   persons to whom the Software is furnished to do so, subject to the following conditions:
#
#   The above copyright notice and this permission notice shall be
#   included in all copies or substantial portions of the Software.
#
#   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
#   TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULARPURPOSE AND NONINFRINGEMENT. IN NO EVENT
#   SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLEFOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
#   IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
#   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
########################################################################################

library(GenSA)

################################## Function Defs ###############################

# sum of three Gaussian functions
threegauss = function(x, params) {
  res = (params[3]*exp(-1/2*(x-params[1])^2/params[2]^2) +
           params[6]*exp(-1/2*(x-params[4])^2/params[5]^2) +
           params[9]*exp(-1/2*(x-params[7])^2/params[8]^2))
  res
}

# single Gaussian
agauss = function(x, params) {
  res = (params[3]*exp(-1/2*(x-params[1])^2/params[2]^2))
  res
}

# plateau with Gaussian fade-out
gaussline = function(x, params){
  res = c()
  for(xi in x){
    if (xi < params[1]){
      y = (params[3]*exp(-1/2*(xi-params[1])^2/params[4]^2))
    }
    else if (xi > params[2]) {
      y=  (params[3]*exp(-1/2*(xi-params[2])^2/params[4]^2))
    }
    else{
      y =( params[3])
    }
    res = c(res, y)
  }
  res
}

# sum of two Gaussian peaks plus a constant plateau with Gaussian fade-out
twogaussplusbroadendgauss = function(x, params) {
  res = (params[3]*exp(-1/2*(x-params[1])^2/params[2]^2) +
           params[6]*exp(-1/2*(x-params[4])^2/params[5]^2) +
           gaussline(x, params[7:10]))
  res
}

# guess plataeu height as minimum of vals between indices x1 and x2
guessplateau = function(vals, x1,x2) {
  pg = vals[x1-1 + which.min(vals[c(x1):c(x2)])]
  dif = vals[x2] - pg

  # x2 is the minimum, take a slightly lower value as the guess
  if(dif <= 0){
    pg = vals[x2]*0.99999999
  }
  pg
}

# integrate peak area of G1, S, G2 and sum of them
integratepeaks = function(xs, params){
  G1 = integrate(function(x) {agauss(x, params[1:3])}, lower=min(xs), upper=max(xs))
  G2 = integrate(function(x) {agauss(x, params[4:6])}, lower=min(xs), upper=max(xs))
  S = integrate(function(x) {gaussline(x, params[7:10])}, lower=min(xs), upper=,max(xs))
  Pop = G1$value+S$value+G2$value
  res = c(G1$value,S$value,G2$value,Pop)
  res
}

################ Fitting script #########################

# for saving the results of multiple runs
# do not re-initialize every time
curveareas = data.frame()

########### START ##################

## 1) the integrated DAPI intensities per cell should be assigned to DAPIIntensities

DAPIIntensities = c()

## in our case:
# platerow = 3
# platecolumn = 3
# DAPIIntensities = subset(SKBR3,Row %in% platerow & Column == platecolumn)$IDapiAbs

## 2) get xs and ys
# xs = histogram bin mids
# ys = density curve
h = hist(DAPIIntensities, breaks = 100, probability = T)
xs = h$mids
ys = h$density

# 3) Guess parameters
# Guesses for peak positions
xG1 = xs[which.max(smooth(ys))]
xp1g = which.max(ys)
pgxg = xp1g - 1 + which.min(ys[xp1g:(which.max(ys)*2.5)])
xp2g = pgxg - 1 + which.max(ys[pgxg:100])
xG2 = xs[xp2g]

# Guesses for peak and plateau heights
peak1guess = ys[which.max(smooth(ys))]
plateauguess <- guessplateau(ys,xp1g,xp2g)
peak2guess = ys[xp2g]

# Guess for all 10 params
guess = c(xG1, xG1/6, (peak1guess-plateauguess),
          xG2, xG1/6, (peak2guess-plateauguess),
          xG1, xG2, plateauguess, xG1/6)

# lower and upper bounds
guessupper = guess + guess*c(0.5, 0.9, 0.05,
                             0.1, 0.5, 0.5,
                             0.25, 0.15, 0.1, 0.9)
guesslower = guess - guess*c(0.5, 0.1, 0.3,
                             0.05, 0.5, 0.1,
                             0.5, 0.05, 0.9, 0.1)

## 4) do optimization
res = GenSA(NULL,function(guess) {sum((ys-twogaussplusbroadendgauss(xs, guess))^2)},
             upper = guessupper, lower = guesslower )

## 5) plot histogram + fitted curves

plot(xs, ys, type = "h")
  lines(xs, agauss(xs, res$par[1:3]), col="red")
  lines(xs, agauss(xs, res$par[4:6]), col="green")
  lines(xs, gaussline(xs, res$par[7:10]), col="blue")
  lines(xs, twogaussplusbroadendgauss(xs, res$par), col="cyan")

  # plot guesses
  abline(v = xG1, col='red')
  abline(v = xG2,col ='green')
  abline(h = peak1guess, col='red')
  abline(h = plateauguess, col='blue')
  abline(h = peak2guess, col='green')

## 6) append resulting areas under curves to accumulated results

### name for the condition of the histogram
# e.g.

condition = '16nM Trastuzumab'

curveareas = rbind.data.frame(curveareas, c(condition, as.numeric(integratepeaks(xs, res$par))), stringsAsFactors = FALSE)
colnames(curveareas) = c('condition', 'G1', 'S', 'G2', 'total')

################ Accumulated results plot/saving ###################

# normalize to area=1
normIntegrals = apply(curveareas[,2:5], 2, function(x){as.numeric(as.character(x))}) /
  as.numeric(as.character(curveareas[,5]))
# plot stacked bars
barplot(t(normIntegrals[,1:3]), names.arg = curveareas$condition)

# save cell cycle fractions
write.table(normIntegrals, "Z:/normIntegrals.txt", sep="\t")


#' f_newton
#'
#' The newton algorithm to minimize the criteria
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#'
#' @param init initialization for $\beta$
#' @param alpha threshold $\alpha$, within $(0, 0.5)$.
#' @param bet   shrinkage rate $\bet$, within $(0, 1)$.
#' @param v_smooth  vector of smoothing parameters
#' @param maxit maximum number of iterations
#' @param thresh    stopping critria threshhold
#' @param trace indicator whether to plot trace
#'
#' @import MASS
#'
#' @return the estimated $\beta$
#'
f_newton <- function(v_y, v_x, v_k0, v_m, init,
                        alpha = 0.2, bet = 0.1, v_smooth = rep(1, 3),
                        maxit = 1e4, thresh = 1e-3, trace = NULL) {

#-------------------------------------------------------
##### set up #####
#-------------------------------------------------------
    function_call <- match.call()
    x_ord <- order(v_x)
    v_x <- v_x[x_ord]
    v_y <- v_y[x_ord]
    iter <- 0L
    #Define dimensions
    k1 <- v_k0[1]; k2 <- v_k0[2]; m1 <- v_m[1]; m2 <- v_m[2]
    #Require
    m_n1 <- f_n1(v_x, k1, m1)
    m_g1 <- f_g1(k2, m2)
    m_g2 <- f_g2(k2, m2)
    m_sigmatau <- f_sigmatau(k2 + m2)
    m_sigma <- f_sigma(k1 + m1, k2 + m2)
    m_s <- f_mats(k1 + m1, k2 + m2, v_smooth)
    n_m2 <- rep(0, k2 + m2); n_m2[k2 + m2] <- 1

    #Precalculate
    m_h1 <- f_h1(m_n1, m_g1, m_g2, m_sigmatau, n_m2)

    #Initialization
    if (is.null(init)) {
        init <- f_init(v_y, v_x, m_sigma, m_n1, v_k0, v_m, m_s)
    }
    til_beta <- init
    v_beta <- og_beta(til_beta, k1 + m1, k2 + m2)

    #Calculate H2
    v_taustar <- f_tausearch(v_y, m_n1, til_beta, m_sigma, k2, m2)
    m_ntau <- f_ntau(v_taustar, k2, m2)
    m_h2 <- f_h2(m_n1, m_ntau, m_g1, m_sigmatau)

    #Loss
    s_loss <- f_loss(v_beta, til_beta, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)
    ##trace
    if (!is.null(trace)) {
        plot(v_x, v_y,
            type = "p", pch = 16, cex = 0.8, col = "grey",
            xlim = grDevices::extendrange(v_x, f = .5),
            ylim = grDevices::extendrange(v_y, f = .5),
            xlab = "", ylab = "",
            sub = paste("Iter:", iter, ", Error=", round(Inf, 3))
        )
        for (i in seq_along(trace)) {
            v_med <- f_qscop(trace[i], m_n1, til_beta, m_sigma, k2, m2)
            lines(v_x, v_med, col = i + 1)
        }
    }

    #Repeat
    while (maxit > iter) {
        iter <- iter + 1

        #Calculate gradient
        v_deriv <- f_lossderiv(til_beta, v_k0 + v_m, m_sigma, m_h1, m_h2)
        v_grad <- f_grad(v_beta, v_deriv, m_s)
        #Calculate Hessian
        m_hess <- f_hess(v_deriv, v_k0 + v_m, m_s)

        ##Loss
        t <- 1
        #Line search
        step_size <-  c(MASS::ginv(m_hess) %*% v_grad)
        grad_size <- alpha * crossprod(v_grad, step_size)
        repeat{
            new_beta <- v_beta - t * step_size
            new_tilbeta <- tilde_beta(new_beta, k1 + m1, k2 + m2)
            new_loss <- f_loss(new_beta, new_tilbeta, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)
            t <- bet * t
            if (new_loss <= (s_loss -  t * grad_size)) {
                break
            }
        }

        #Update v_beta
        v_beta <- new_beta
        til_beta <- new_tilbeta

        #Update H2 (most time consuming)
#ptm <- proc.time()# Start the clock!
        v_taustar <- f_tausearch(v_y, m_n1, til_beta, m_sigma, k2, m2)
#print(proc.time() - ptm)# Stop the clock
        m_ntau <- f_ntau(v_taustar, k2, m2)
        m_h2 <- f_h2(m_n1, m_ntau, m_g1, m_sigmatau)

        ##trace
        if (!is.null(trace)) {
            plot(v_x, v_y,
                type = "p", pch = 16, cex = 0.8, col = "grey",
                xlim = grDevices::extendrange(v_x, f = .5),
                ylim = grDevices::extendrange(v_y, f = .5),
                xlab = "", ylab = "",
                sub = paste("Iter:", iter, "Error=", round(s_loss, 3))
            )
            for (i in seq_along(trace)) {
                v_med <- f_qscop(trace[i], m_n1, til_beta, m_sigma, k2, m2)
                lines(v_x, v_med, col = i + 1)
            }
        }
        #Check stop criterion
        converge <- (abs(new_loss - s_loss) <= thresh * s_loss)
        s_loss <- new_loss
        if (converge) break

    }

#-------------------------------------------------------
##### Output #####
#-------------------------------------------------------
    out <- list(
        beta = v_beta,
        til_beta = til_beta,
        converge = converge,
        iter = iter,
        loss = s_loss,
        tau = v_taustar,
        x = v_x,
        y = v_y,
        n1 = m_n1,
        m_sigma = m_sigma,
        mat_s = m_s,
        call = function_call)

    return(out)
}


#' Rank difference test
#'
#' Performs Kornbrot's rank difference test. It's a modified Wilcoxon signed-rank
#' test which produces consistent and meaningful results for ordinal or monotonically
#' transformed data.
#'
#' For ordinal scale data, the Wilcoxon signed-rank test results in subtraction
#' of those ordinal scale values. However, this subtraction is not meaningful on
#' the ordinal scale. In addition, any monotone transformation of the data will
#' result in different signed ranks, thus different p-values. However, ranking
#' the original data allows for meaningful addition and subtraction of ranks and
#' preserves ranks over monotonic transformation. Kornbrot described the rank
#' difference test for this reason.
#'
#' Kornbrot recommends that the rank difference procedure be used in preference
#' to the Wilcoxon signed-rank test in all paired comparison designs where the data
#' are not both of interval scale type and of known distribution type. The rank
#' difference test preserves good power compared to Wilcoxon's signed-rank test,
#' is more powerful than the sign test, and has the benefit of being a true
#' distribution-free test.
#'
#' The procedure for Wilcoxon's signed-rank test is as follows:
#'
#' 1. Calculate differences for each paired observation.
#' 2. Remove differences equal to zero.
#' 3. Order the absolute differences from smallest to largest.
#' 4. Assign ranks \eqn{1, \dots, n} with average rank for ties.
#' 5. Calculate W+ = sum of the ranks for positive differences. The sum of W+ and
#'    W- is \eqn{n(n+1)/2}, so either can be calculated from the other.
#' 6. Choose the smaller of W+ and W- as the test statistic W.
#' 7. Since the test statistic is the smaller of W+ and W-, the critical region
#'    is the left tail of the distribution. W is distributed approximately normal
#'    with mean \eqn{mu = (n(n+1))/4} and variance
#'    \eqn{sigma^2 = (Tn(n+1)(2n+1))/24}, where T is a correction for ties and
#'    \eqn{T = 1-(sum(t^3-t)/(N^3-N))}, summed over all ties, where t is the
#'    length of a tie. The continuity corrected mean \eqn{mu = ((n(n+1))/4)+0.5}.
#'
#' The procedure for Kornbrot's rank difference test is as follows:
#'
#' 1. Combine all 2n observations.
#' 2. Assign ranks \eqn{1, \dots, 2n} with average rank for ties.
#' 3. Perform the Wilcoxon signed-rank test using the paired ranks.
#'
#' The test statistic for the rank difference test (D) is not exactly equal to the
#' test statistic (W) of the naive rank-transformed Wilcoxon signed-rank test
#' (the latter being implemented in `rdt()`). Using W should result in a
#' conservative estimate for D, and they approach in distribution as the sample
#' size increases. \insertCite{kornbrot1990;textual}{rankdifferencetest}
#' discusses methods for calculating D when n<7 and 8<n<=20.
#'
#' `zero.method = "Pratt"` uses the method by Pratt (1959), which first
#' rank-transforms the absolute differences (including zeros) and then removes
#' the ranks corresponding to zero-differences. `zero.method = "Wilcoxon"` uses
#' the method by Wilcoxon (1950), which first removes the zero-differences and
#' then rank-transforms the remaining absolute differences.
#'
#' @param data A data.frame
#' @param formula  A formula of either form:
#'        \describe{
#'          \item{y ~ x | block}{
#'            For use when `data` is in long format. `y` is the numeric outcome,
#'            `x` is the binary grouping factor, and `block` is the
#'            observation-level grouping factor. `x` and `block` must be factors.
#'          }
#'          \item{y ~ x}{
#'            For use when `data` is in wide format. `y` is the first measurement
#'            and `x` is the second measurement on the same observation.
#'          }
#'        }
#'        The differences in ranks are calculated as `y - x` or, when `x` is a
#'        factor, the first factor level minus the second.
#' @param zero.method A string for the method used to handle differences equal to
#'        zero: `"Pratt"` (default) or `"Wilcoxon"`.
#' @param distribution A string for the method used to calculate the conditional
#'        null distribution of the test statistic: Asymptotic distribution
#'        `"asymptotic"` (default), Monte Carlo resampling `"approximate"`,
#'        or the exact distribution `"exact"`.
#' @param alternative A string for the alternative hypothesis: `"two.sided"`
#'        (default), `"greater"`, or `"less"`.
#' @param return A string for the return object: `"data.frame"` (default) or
#'        `"coin"`.
#' @param ... Further arguments passed to \code{coin::\link[coin]{wilcoxsign_test}}.
#'
#' @references
#' \insertRef{kornbrot1990}{rankdifferencetest}
#'
#' \insertRef{pratt1959}{rankdifferencetest}
#'
#' \insertRef{wilcoxon1950}{rankdifferencetest}
#'
#' @return
#' If `return = "data.frame"`, a data.frame with columns `p.value`, `z.statistic`,
#' `formula`, `alternative`, and `method`.
#'
#' If `return = "coin"`, an object inheriting from class
#' \code{"\linkS4class{IndependenceTest}"}.
#'
#' @importFrom coin wilcoxsign_test pvalue
#' @importFrom stats as.formula
#'
#' @export
#'
#' @examples
#' #----------------------------------------------------------------------------
#' # rdt() example
#' #----------------------------------------------------------------------------
#' library(rankdifferencetest)
#'
#' # Use example data from Kornbrot (1990)
#' data <- kornbrot_table1
#'
#' # Create long-format data for demonstration purposes
#' data_long <- reshape(
#'   data = kornbrot_table1,
#'   direction = "long",
#'   varying = c("placebo", "drug"),
#'   v.names = c("time"),
#'   idvar = "subject",
#'   times = c("placebo", "drug"),
#'   timevar = "treatment",
#'   new.row.names = seq_len(prod(length(c("placebo", "drug")), nrow(kornbrot_table1)))
#' )
#' # Subject and treatment must be factors. The ordering of the treatment factor
#' # will determine the difference (placebo - drug).
#' data_long$subject <- factor(data_long$subject)
#' data_long$treatment <- factor(data_long$treatment, levels = c("placebo", "drug"))
#'
#' # Recreate analysis and results from section 7.1 in Kornbrot (1990)
#' ## The p-value shown in Kornbrot (1990) was continuity corrected. rdt() does
#' ## not apply a continuity correction, so the p-value here will be slightly
#' ## lower. It does match the uncorrected p-value shown in footnote on page 246.
#' rdt(
#'   data = data,
#'   formula = placebo ~ drug,
#'   alternative = "two.sided",
#'   distribution = "asymptotic"
#' )$p.value/2
#' rdt(
#'   data = data_long,
#'   formula = time ~ treatment | subject,
#'   alternative = "two.sided",
#'   distribution = "asymptotic"
#' )$p.value/2
#'
#' # The same outcome is seen after transforming time to rate.
#' ## The rate transformation inverts the rank ordering.
#' data$placebo_rate <- 60 / data$placebo
#' data$drug_rate <- 60 / data$drug
#' data_long$rate <- 60 / data_long$time
#'
#' rdt(
#'   data = data,
#'   formula = placebo_rate ~ drug_rate,
#'   alternative = "two.sided",
#'   distribution = "asymptotic"
#' )$p.value/2
#' rdt(
#'   data = data_long,
#'   formula = rate ~ treatment | subject,
#'   alternative = "two.sided",
#'   distribution = "asymptotic"
#' )$p.value/2
#'
#' # In contrast to the rank difference test, the Wilcoxon signed-rank test
#' # produces differing results. See table 1 and table 2 in Kornbrot (1990).
#' wilcox.test(
#'   x = data$placebo,
#'   y = data$drug,
#'   paired = TRUE,
#'   exact = TRUE,
#'   alternative = "two.sided"
#' )$p.value/2
#' wilcox.test(
#'   x = data$placebo_rate,
#'   y = data$drug_rate,
#'   paired = TRUE,
#'   exact = TRUE,
#'   alternative = "two.sided"
#' )$p.value/2
#'
rdt <- function(
  data,
  formula,
  zero.method = c("Pratt", "Wilcoxon"),
  distribution = c("asymptotic", "approximate", "exact"),
  alternative = c("two.sided", "greater", "less"),
  return = c("data.frame", "coin"),
  ...
) {
  #-----------------------------------------------------------------------------
  # Check arguments
  #-----------------------------------------------------------------------------
  if(!is.data.frame(data)) {
    stop("Check the 'data' argument in rdt(). The object must be a data.frame.")
  }
  if(!inherits(formula, "formula")) {
    stop("Check the 'formula' argument in rdt(). The object must be a formula.")
  }
  formula_vars <- all.vars(formula)
  missing_vars <- formula_vars[!formula_vars %in% names(data)]
  if(length(missing_vars) > 0) {
    stop(paste0(
      "Check the formula argument in rdt(). Variables not found in the data: ",
      paste0(shQuote(missing_vars), collapse = ", ")
    ))
  }
  if(!length(formula_vars) %in% 2:3) {
    stop("Check the formula argument in rdt(). It must be of form y ~ x or y ~ x | block.")
  }
  zero.method <- match.arg(zero.method)
  distribution <- match.arg(distribution)
  alternative <- match.arg(alternative)
  return <- match.arg(return)

  #-----------------------------------------------------------------------------
  # Perform test
  #-----------------------------------------------------------------------------
  ## Step 1: Generate model data
  md <- model2data(formula = formula, data = data)

  ## Step 2: Rank order data and prepare for coin::wilcoxsign_test()
  if(is.null(md$block)) {
    # Intermediate argument check: if no block, must only have two variables.
    if(!all(lengths(md) == c(1, 1, 0))) {
      stop("Check the formula used in rdt(). It must correspond with a pairwise comparison as y ~ x.")
    }
    # Note: Kornbrot orders opposite direction: rank(-xtfrm(data)).
    ranks <- rank(c(md$y[[1]], md$x[[1]]), na.last = "keep")
    coin_data <- data.frame(
      y = ranks[seq_along(md$y[[1]])],
      x = ranks[seq_along(md$x[[1]]) + length(md$y[[1]])]
    )
    coin_formula <- as.formula("y ~ x")
  } else {
    # Intermediate argument check: must be a balanced pairwise comparison.
    if(length(unique(md$x[[1]])) != 2) {
      stop(paste0(
        "Check the data and/or formula used in rdt(). The variable ",
        shQuote(names(md$x)),
        " must be a balanced 2 level factor."
      ))
    }
    coin_data <- data.frame(
      y = rank(md$y[[1]], na.last = "keep"),
      x = as.factor(md$x[[1]]),
      block = as.factor(md$block[[1]])
    )
    coin_formula <- as.formula("y ~ x | block")
  }

  ## Step 3: Run Wilcoxon signed-rank test
  coin <- wilcoxsign_test(
    formula = coin_formula,
    data = coin_data,
    zero.method = zero.method,
    distribution = distribution,
    alternative = alternative,
    ...
  )

  #-----------------------------------------------------------------------------
  # Prepare results
  #-----------------------------------------------------------------------------
  diff <- if(is.null(md$block)) {
    paste0(names(md$y), " - ", names(md$x))
  } else {
    paste0(levels(coin_data$x)[1], " - ", levels(coin_data$x)[2])
  }

  alternative <- paste0(
    "True location shift of ranks (",
    diff,
    ") is ",
    ifelse(
      test = identical(coin@statistic@alternative, "two.sided"),
      yes = "not equal to ",
      no = paste0(coin@statistic@alternative, " than ")
    ),
    coin@nullvalue
  )

  method <- paste(
    "Kornbrot's Rank Difference Test using the",
    paste0(
      toupper(substring(distribution, 1,1)),
      substring(distribution, 2)
    ),
    coin@method,
    sep = " "
  )

  df <- data.frame(
    p.value = as.numeric(pvalue(coin)),
    z.statistic = coin@statistic@teststatistic,
    formula = deparse(formula),
    alternative = alternative,
    method = method
  )

  #-----------------------------------------------------------------------------
  # Return
  #-----------------------------------------------------------------------------
  if(identical(x = return, y = "data.frame")) {
    df
  } else {
    coin
  }
}


powerset <- function(set){
	ps <- list()
	ps[[1]] <- numeric()						#Start with the empty set.
	for(element in set){						#For each element in the set, take all subsets
		temp <- vector(mode="list",length=length(ps))		#currently in "ps" and create new subsets (in "temp")
		for(subset in 1:length(ps)){				#by adding "element" to each of them.
			temp[[subset]] = c(ps[[subset]],element)
		}
		ps <- c(ps,temp)						#Add the additional subsets ("temp") to "ps".
	}
	ps
}

powerset(1:4)


#' GLS confidence intervals
#'
#' Computes confidence intervals for a GLS regression. When the variance covariance matrix is based on a phylogeny, this computes the confidence intervals for a phylogenetic regression (PGLS).
#' @param Y Dependent variable.
#' @param X Independent variable.
#' @param Sigma Matrix describing the covariance among data points. For the phylogenetic regression, this is based on a phylogeny (vcv(tree)).
#' @return GLS results.
#' @return Confidence intervals of the estimates ('CI').
#' @return Confidence intervals of unobserved values of Y ('CI.plot').
#' @references Smaers & Rohlf (2016) Testing species' deviations from allometric preductions using the phylogenetic regression. Evolution. 70 (5): 1145-1149.
#' @examples see https://smaerslab.com/software/
#' @export
gls.ci<-function(Y,X,Sigma){
      n<-length(X)
#Standardize sigma to reduce rounding errors
      tr<-sum(diag(Sigma))
      Sigma<-n*Sigma/tr
#Input
      invSigma<-solve(Sigma)
#pgls mean and variance
      X1<-rep(1,n)
      q<-2          # adjust if multivariate!!
      C1<-solve(t(X1)%*%invSigma%*%X1)
      Y_PGLSmean<-c(C1%*%t(X1)%*%invSigma%*%Y)
      Y_PGLSdeviations = Y - Y_PGLSmean
      Y_PGLSvariance = (t(Y_PGLSdeviations)%*%invSigma%*%Y_PGLSdeviations)/(n-1)
      SE_Y_mean = sqrt(Y_PGLSvariance/n)
#Regression
      XX<-cbind(rep(1,n),X)
      C<-solve(t(XX)%*%invSigma%*%XX)
      w<-C%*%t(XX)%*%invSigma
      B<-w%*%Y
      Yhat<-XX%*%B
      Yresid=Y-Yhat
      Y_MSEresid<-c((t(Yresid)%*%invSigma%*%Yresid)/(n-q))
      a<-B[1]
      b<-B[2]
#SE of statistics
      SEa<-sqrt(diag(C)*Y_MSEresid)[1]
      SEb<-sqrt(diag(C)*Y_MSEresid)[2]
#Save model
      intercept<-cbind(a,SEa)
      slope<-cbind(b,SEb)
      model<-rbind(intercept,slope)
      colnames(model)<-c("Estimate","Std.Error")
      rownames(model)<-c("intercept","slope")
#confint
      SEYhat<-sqrt(diag(XX%*%C%*%t(XX))%*%((t(Yresid)%*%invSigma%*%Yresid)/(n-q)))
      CI<-cbind(X,Yhat,SEYhat)
            Lower2.5<-Yhat-qt(0.975,n)*SEYhat
            Lower5<-Yhat-qt(0.95,n)*SEYhat
            Upper5<-Yhat+qt(0.95,n)*SEYhat
            Upper2.5<-Yhat+qt(0.975,n)*SEYhat
      CI<-cbind(CI,Lower2.5)
      CI<-cbind(CI,Lower5)
      CI<-cbind(CI,Upper5)
      CI<-cbind(CI,Upper2.5)
      CI<-CI[order(CI[,1]),]
      colnames(CI)<-c("X","Yhat","SEYhat","Lower2.5","Lower5","Upper5","Upper2.5")
      CI<-as.data.frame(CI)
#confint extrapolated
      Xi<-seq(c(min(X)-abs(max(X))),to=c(abs(max(X))*5),length.out=100)
      Z<-c(Xi)
      ZZ<-cbind(rep(1,length(Z)),Z)
      SEYhat.Xi<-sqrt(diag(ZZ%*%C%*%t(ZZ))%*%((t(Yresid)%*%invSigma%*%Yresid)/(n-q)))
      Yhat.Xi<-a+b*Xi
            Lower2.5.Yhat.Xi<-Yhat.Xi-qt(0.975,n)*SEYhat.Xi
            Lower5.Yhat.Xi<-Yhat.Xi-qt(0.95,n)*SEYhat.Xi
            Upper5.Yhat.Xi<-Yhat.Xi+qt(0.95,n)*SEYhat.Xi
            Upper2.5.Yhat.Xi<-Yhat.Xi+qt(0.975,n)*SEYhat.Xi
      CI.plot<-cbind(Xi,Yhat.Xi,SEYhat.Xi,Lower2.5.Yhat.Xi,Lower5.Yhat.Xi,Upper5.Yhat.Xi,Upper2.5.Yhat.Xi)
      colnames(CI.plot)<-c("X","Yhat","SEYhat","Lower2.5","Lower5","Upper5","Upper2.5")
      CI.plot<-as.data.frame(CI.plot)
results<-list(model,CI,CI.plot)
names(results)<-c("model","CI","CI.plot")
return(results)
}


# Random Walk for Brownian Motion
# S_0 = 0
# For all n >= 1, S_n = Epsilons_1 + ... Epsilons_n
# ie S_n = S_(n-1) + Epsilons_n
# 23-04-2015
# Killian Martin--Horgassan

randomWalk = function(n, Epsilons) {

	# The vector of the Epsilon_i, they are uniformly distributed on {-1,+1}
	vect <- Epsilons

	output <- rep(0,n+1)

	for (i in 2:(n+1)) {
		output[i] <- output[i-1]+vect[i-1]
	}

	return(output)
}


## Function to do Wright-Fisher simulation with selection and a finite sample size
# using set Ne, s, and initial allele frequency
# Sample each generation

# f1: the initial allele frequency uniform prior
# s: the selection coefficient uniform prior
# cnt: the size of the samples (in # chromosomes)
# gen: the number of generations
# ne: Ne value
# h: dominance effect

wfs_ts <- function(f1=0, s=0, cnt=50, gen=20, ne=100, h=0.5){
	p <- rep(NA, gen)
	fsamp <- p

	p[1] <- f1 # current allele frequency
	fsamp[1] <- rbinom(1,cnt,p[1])/cnt # first sample allele frequency
	waa <- 1+s # relative fitness of genotype AA
	wab <- 1+s*h
	wbb <- 1
	for(i in 2:gen){
		x <- (waa*p[i-1]^2 + wab*p[i-1]*(1-p[i-1]))/(waa*p[i-1]^2 + wab*2*p[i-1]*(1-p[i-1]) + wbb*(1-p[i-1])^2) # probability of sampling allele A, given selection
		p[i] <- rbinom(1,ne,x)/ne
		fsamp[i] <- rbinom(1,cnt,p[i])/cnt # first sample allele frequency
#		print(paste(x,p))
	}

	# return values
	out <- list(gen=1:gen, p=p, fsamp=fsamp)
	return(out)
}


do_summary_simple_mean <- function (x, target_var){

	# calculates simple (i.e., not stratified) mean statistics
	# Nuno Prista, SLU Aqua, Sweden
	# Developed @ KustMonitoring Review 2019

	#x is a dataframe or data.table with
		# # target values in target_var variable

	# 2019-05-06: added clow_mean and chigh_mean (confidence intervals)

# ==========================
# Non-stratified (Nst) results
# ==========================

	values<-x[[target_var]]
	# simple mean
		Nst_mean<-mean(values)
	# simple_var_mean
		Nst_var_mean<-var(values)/length(values)
	# simple se of the mean
		Nst_se_mean<-sd(values)/sqrt(length(values))
	# simple cv/rse of the mean
			Nst_rse_mean<-round(Nst_se_mean/Nst_mean*100,1)

	list(pop_res = data.frame(type = "simple", variable = target_var,  n_tot = length(values), n_strata = NA, mean = Nst_mean, var_mean = Nst_var_mean, se_mean = Nst_se_mean, rse_mean = Nst_rse_mean, clow_mean=Nst_mean-2*Nst_se_mean, chigh_mean=Nst_mean+2*Nst_se_mean), stratum_res = NULL, type="stratified")

}


## estimate effect sizes from association tests of features
## se standard errors of the coefficients
## mat input data matrix (features x samples)
ivwfe.stats <- function(estimate, se, mat=NULL, rho=NULL) {
    ## http://onlinelibrary.wiley.com/doi/10.1002/sim.6835/full
    ## calculate rho
    if (is.null(rho)) {
        stopifnot(!is.null(mat))
        rho <- ivwfe.rho(mat)
    }
    ## remove missing values
    na <- is.na(estimate) | is.na(se)
    if (sum(na) > 0) {
        if (sum(na) == length(estimate))
            return(c(B=NA, S=NA))

        estimate <- estimate[!na]
        se <- se[!na]
        rho <- rho[!na,!na,drop=F]
    }
    ## calculate statistics
    ivwfe.stats0 <- function(estimate, se, rho) {
        tryCatch({
            omega <- (se%*%t(se))*rho
            omega.inv <- solve(omega)
            one <- matrix(1,nrow=nrow(omega.inv), ncol=1)
            S2 <- 1/(t(one) %*% omega.inv %*% one)
            c(B=S2 * (t(one) %*% omega.inv) %*% estimate,
              S=sqrt(S2))
        }, error=function(e) {
            c(B=NA,S=NA)
        })
    }
    return(ivwfe.stats0(estimate, se, rho))
}

ivwfe.getz <- function(estimate, se, mat=NULL, rho=NULL) {
    stats <- ivwfe.stats(estimate, se, mat, rho)
    as.vector(stats["B"]/stats["S"])
}

ivwfe.rho <- function(mat) {
    mat <- t(mat)
    ## correlation matrix + nudge (to ensure invertible)
    rho <- cor(mat, use="p") + diag(x=0.05,ncol(mat),ncol(mat))
}

ivwfe.ma <- function(estimates, se) {
    weights <- 1/se^2
    se <- sqrt(1/rowSums(weights, na.rm=T))
    estimates <- rowSums(estimates * weights, na.rm=T)/rowSums(weights, na.rm=T)
    z <- estimates/se
    p <- 2*pnorm(-abs(z), lower.tail=T)
    data.frame(estimate=estimates,
               se=se,
               z=z,
               p.value=p)
}


#' Estimating the inverse first-order reliability method (IFORM) environmental contours
#'
#' @description
#' This function estimates the Invserse FORM (IFORM) environmental contours, as proposed in Winterstein et al. (1993)
#' for a given sample data set or a fitted joint distribution of class \code{ht} or \code{wln}.
#'
#' @param object either a fitted joint distribution of class \code{wln} or \code{ht}, or an existing sample data
#' set containing \code{hs} and \code{tp} as columns. See details.
#'
#' @param output_rp the required return periods (in years) for the estimated contours.
#'
#' @param npy the (optional) number of data points per year. This argument is only needed if the input
#' \code{object} is a sample data set.
#'
#' @param n_point the number of points to output around each contour. The default value is 100.
#'
#' @param alpha0 the omission factor for the IFORM contours. The default value is 0, meaning no
#' inflation to the estimated contours.
#'
#' @details
#' The IFORM contour is constructed based on the first-order reliability method (FORM) and
#' it searches a hypersphere of constant radius to find the maximum response.
#'
#' The function can be applied to an existing sample set, which can be generated by function \code{\link{sample_jdistr}}
#' or otherwise by importing a CSV file using function \code{\link[data.table]{fread}}. The input sample data
#' object must contain \code{hs} and \code{tp} as columns. The user must also specify the number of points per year
#' \code{npy} and a valid \code{output_rp}, i.e. the maximum \code{output_rp} must be shorter than the total
#' duration of the data set.
#'
#' Alternatively this function can be applied to a fitted joint distribution object
#' generated by function \code{\link{fit_ht}} or \code{\link{fit_wln}}.  When applied to a \code{ht} object,
#' the estimated contour is a blending between the two conditional models \eqn{Hs|Tp>tp} and \eqn{Tp|Hs>hs} above
#' high thresholds \eqn{tp} and \eqn{hs}, as specified in Heffernan and Tawn (2004).
#'
#' @return A set of estimated IFORM contours with the specified return periods in the format
#' of a \code{data.table} with \code{rp}, \code{hs}, and \code{tp} as columns.
#'
#' @examples
#' # Estimating IFORM contours based on a fitted model
#' data(ww3_pk)
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 50, dep_thresh_count = 500)
#' ec_ht = estimate_iform(object = ht, output_rp = c(10,100,1000,10000))
#' plot_ec(ec = ec_ht, raw_data = ww3_pk)
#'
#' # Estimating IFORM contours based on a sample data set
#' data(ww3_ts)
#' ec_data = estimate_iform(object = ww3_ts, output_rp = c(.5, 1, 2), npy = ww3_ts[, .N/10])
#' plot_ec(ec = ec_data, raw_data = ww3_ts)
#'
#' @references
#' Winterstein, S. R., Ude, T. C., Cornell, C. A., Bjerager, P., Haver, S., 1993. Environmental parameters
#' for extreme variable: Inverse Form with omission factors. In: Proc. 6th Int. Conf. on
#' Structural Safety and Reliability, Innsbruck, Austria.
#'
#' Heffernan, Janet & A. Tawn, Jonathan. (2004). A Conditional Approach for Multivariate Extreme Values.
#' Journal of the Royal Statistical Society Series B. 66. 497-546. 10.1111/j.1467-9868.2004.02050.x.
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}, \code{\link{sample_jdistr}}, \code{\link{plot_ec}}
#'
#' @export
estimate_iform = function(
  object, output_rp, npy = NULL, n_point=100, alpha0=0){

  if("wln" %in% class(object)){

    res = .estimate_iform_from_wln(wln = object, output_rp = output_rp, n_point = n_point, alpha0 = alpha0)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("ht" %in% class(object)){

    res = .estimate_iform_from_ht(ht = object, output_rp = output_rp, n_point = n_point, alpha0 = alpha0)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("data.table" %in% class(object)){

    if(is.null(npy)){
      stop("Argument npy must be provided for estimating contours from sample data.")
    }else{
      invalid_rp = output_rp[output_rp>object[, .N/npy]]
      if(length(invalid_rp)==length(output_rp)){
        stop("All output_rp values are invalid as they require extrapolation. Consider fitting a joint distribution first.")
      }else if(length(invalid_rp)>=1 & length(invalid_rp)<length(output_rp)){
        warning("Certain output_rp values are ignored as they requires extrapolation. Consider fitting a joint distribution first.")
      }
      output_rp = setdiff(output_rp, invalid_rp)
    }

    res = .estimate_iform_from_sample_data(
      sample_data = object, sample_data_npy = npy,
      output_rp = output_rp, n_point = n_point, alpha0 = alpha0)

  }else{

    stop("The input object must be of class ht, wln or data.table.")
  }

  return(res)
}

# Sub functions -----------------------------------------------------------

.estimate_iform_from_sample_data = function(sample_data, sample_data_npy, output_rp, n_point, alpha0){

  # Calculate beta and inflate
  prob = 1 - 1/(sample_data_npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]
  calc[, hs:=quantile(sample_data$hs, p1, names = F)]

  for(i in 1:calc[, .N]){
    cond_distr_bw = calc[rp==calc[i]$rp, bw.SJ(hs)]
    td_data = sample_data[abs(hs-calc$hs[i])<=cond_distr_bw/2]
    if(td_data[,.N]<.knn){
      td_data = sample_data[sort.list(abs(hs-calc$hs[i]))[1:.knn]]
    }
    calc[i, tp:=quantile(td_data$tp, p2, names = F)]
  }

  # Return
  res = calc[, .(rp, hs, tp)]
  return(res)
}

.estimate_iform_from_wln = function(wln, output_rp, n_point, alpha0){

  # Calculate beta and inflate
  prob = 1 - 1/(wln$npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]
  calc[, hs:=qweibull(p1, shape=wln$hs$par["shape"], scale=wln$hs$par["scale"])+wln$hs$par["loc"]]
  calc[, m:=wln$tp$par[1] + wln$tp$par[2] * (hs ^ wln$tp$par[3])]
  # calc[, s:=wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs)]
  calc[, s:=pmax(.limit_zero, wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs))]
  calc[, tp:=qlnorm(p2, m, s)]

  # Return
  res = calc[, .(rp, hs, tp)]
  return(res)
}

.estimate_iform_from_ht = function(ht, output_rp, n_point, alpha0){

  p_thresh = ht$margin$p_margin_thresh
  n_exceed = length(ht$margin$hs$emp)*(1-p_thresh)

  # Calculate beta and inflate
  prob = 1 - 1/(ht$npy*output_rp)
  beta = qnorm(prob)
  beta_star = beta / (sqrt(1-(alpha0^2)))

  # Define points
  angle = seq(0, 2*pi, length.out = n_point+1)
  calc = data.table(rp = rep(output_rp, each=n_point+1), angle = angle)
  calc[, u1:=rep(beta_star, each=n_point+1)*cos(angle)]
  calc[, u2:=rep(beta_star, each=n_point+1)*sin(angle)]
  calc[, p1:=pnorm(u1)]
  calc[, p2:=pnorm(u2)]

  # Estimate hs based on hs model
  calc_hs = calc[p1>ht$dep$p_dep_thresh]
  calc_hs[, hs:=.convert_unif_to_origin(
    unif = p1, p_thresh = p_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]

  # Estimate tp based on tp|hs HT model for large hs
  calc_hs[, lap1:=.convert_unif_to_lap(p1)]
  calc_hs[, resid_q:=quantile(ht$dep$hs$resid, p2)]
  calc_hs[,lap2:=ht$dep$hs$par[1]*lap1+resid_q*lap1^ht$dep$hs$par[2]]
  calc_hs[, p_tp:=.convert_lap_to_unif(lap2)]
  calc_hs[, tp:=.convert_unif_to_origin(
    unif = p_tp, p_thresh = p_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  # Estimate tp based on tp model
  calc_tp = calc[p2>ht$dep$p_dep_thresh]
  calc_tp[, tp:=.convert_unif_to_origin(
    unif = p2, p_thresh = p_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  # Estimate hs based on hs|tp HT model for large tp
  calc_tp[, lap2:=.convert_unif_to_lap(p2)]
  calc_tp[, resid_q:=quantile(ht$dep$tp$resid, p1)]
  calc_tp[,lap1:=ht$dep$tp$par[1]*lap2+resid_q*lap2^ht$dep$tp$par[2]]
  calc_tp[, p_hs:=.convert_lap_to_unif(lap1)]
  calc_tp[, hs:=.convert_unif_to_origin(
    unif = p_hs, p_thresh = p_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]

  # Return
  res = merge(
    x = calc_hs[, .(rp, angle, hs, tp)], y = calc_tp[, .(rp, angle, hs, tp)],
    by=c("rp", "angle"), all=T)
  res[is.na(hs.x), hs:=hs.y]
  res[is.na(tp.x), tp:=tp.y]
  res[is.na(hs.y), hs:=hs.x]
  res[is.na(tp.y), tp:=tp.x]
  res[!is.na(hs.x+hs.y), hs:=hs.x*cos(angle)^2+hs.y*sin(angle)^2]
  res[!is.na(hs.x+hs.y), tp:=tp.x*cos(angle)^2+tp.y*sin(angle)^2]
  setkey(res, rp, angle)
  return(res[, .(rp, hs, tp)])
}


#' @name MGB2
#' @rdname  MGB2
#' @aliases dMGB2  pMGB2  hMGB2
#' @title Bivarite MGB2 copula
#' @description Density, distribution function, and h-functions for the bivariate MGB2 copula proposed in Yang et al.,(2011).
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param pars1,pars2,pars3 copula parameters, denoted by \eqn{p_1, p_2, q}.
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#' @references Xipei Yang, Edward W Frees, and Zhengjun Zhang. A generalized beta copula with applications in
#' modeling multivariate long-tailed data. Insurance: Mathematics and Economics, 49(2):265-284, 2011.
#' @details
#' The MGB2 copula with parameters (p1, p2, q) has joint density
#' 		\deqn{c(u_1,u_2;p_1,p_2,q)=\frac{\Gamma(q)\Gamma(\sum_{i=1}^2 p_i + q)}{\prod_{i=1}^2\Gamma(p_i+q)}\frac{\prod_{i=1}^2 (1 + x(u_i;p_i,q))^{p_i+q}}{(1 + \sum_{i=1}^{2}x(u_i;p_i,q))^{\sum_{i=1}^{2}p_i+q}},}
#' for \eqn{p_1, p_2>0, q>0}.
#' (Here Gamma(a) is the function implemented by R's \code{\link[base]{gamma}} and defined in its help.
#'
#'
#' The joint cdf of the MGB2 copula is
#'
#' \deqn{C(u_1,u_2;p_1,p_2,q)=\int_{0}^{+\infty}\prod_{i=1}^{2}G_p(\frac{I_{p_i,q}^{-1}(u_i)}{(1-I_{p_i,q}^{-1}(u_i))\theta})\times \frac{\theta^{-(q+1)}e^{-1/\theta}}{\Gamma(q)}d\theta, }
#' where \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}}.
#'
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,p_1,p_2,q) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,p_1,p_2,q) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{p_1,p_2,q}.
#'
#'
#' @return
#' \code{dcMGB2.bivar} gives the density
#'
#' \code{pcMGB2.bivar} gives the distribution function
#'
#' \code{hcMGB2.bivar} gives the h-functions (hfunc1, hfunc2).
NULL

#' @rdname  MGB2
#' @export
#' @examples
#' dcMGB2.bivar(u1 = c(0.2, 0.5), u2 = c(0.9, 0.2), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)
dcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  dim <- 2
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))

  if (u1 == 0 | u2 == 0) {
    dc <- 0
  } else {
    dc <- gamma(q)^(dim - 1) * gamma(p1 + p2 + q) / (gamma(p1 + q) * gamma(p2 + q)) * (1 + x1)^(p1 + q) * (1 + x2)^(p2 + q) / (1 + x1 + x2)^(p1 + p2 + q)
  }
  dc
}
dcMGB2.bivar <- Vectorize(dcMGB2.bivar)

#' @rdname MGB2
#' @export
#' @examples
#' pcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)
pcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))
  fin <- function(theta) { # rely on a
    m1 <- x1 / theta
    m2 <- x2 / theta
    z1 <- pgamma(m1, shape = p1, scale = 1) * pgamma(m2, shape = p2, scale = 1)
    out <- z1 * theta^(-(q + 1)) * exp(-1 / theta) / gamma(q)
    out
  }
  if (u1 == 0 | u2 == 0) {
    z <- 0
  } else {
    z <- as.numeric(pracma::integral(fun = fin, xmin = 0, xmax = Inf, method = "Clenshaw"))
    # z <- as.numeric(integrate(f = fin, lower = 0, upper = Inf, rel.tol = 1e-4)$value)
  }
  return(z) # rely on k
}
pcMGB2.bivar <- Vectorize(pcMGB2.bivar)

#' @rdname MGB2
#' @export
#' @examples
#' hcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)$hfunc1
#' hcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)$hfunc2
hcMGB2.bivar <- function(u1, u2, pars1, pars2, pars3) {
  p1 <- pars1
  p2 <- pars2
  q <- pars3

  x1 <- qbeta(u1, shape1 = p1, shape2 = q) / (1 - qbeta(u1, shape1 = p1, shape2 = q))
  x2 <- qbeta(u2, shape1 = p2, shape2 = q) / (1 - qbeta(u2, shape1 = p2, shape2 = q))

  index1 <- u1 == 1 & u2 != 1
  index2 <- u1 != 1 & u2 == 1
  index3 <- u1 == 1 & u2 == 1
  z1 <- x2 / (x1 + x2 + 1)
  z2 <- x1 / (x2 + x1 + 1)
  z1[index1] <- 0
  z2[index1] <- 1
  z1[index2] <- 1
  z2[index2] <- 0
  z1[index3] <- 1
  z2[index3] <- 1
  hfunc1 <- pbeta(z1, shape1 = p2, shape2 = p1 + q)
  hfunc2 <- pbeta(z2, shape1 = p1, shape2 = p2 + q)
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}


# Chapter 8 Lab: Decision Trees

# Fitting Classification Trees

library(tree)
library(ISLR)
attach(Carseats)
High=ifelse(Sales<=8,"No","Yes")
Carseats=data.frame(Carseats,High)
tree.carseats=tree(High~.-Sales,Carseats)
summary(tree.carseats)
plot(tree.carseats)
text(tree.carseats,pretty=0)
tree.carseats
set.seed(2)
train=sample(1:nrow(Carseats), 200)
Carseats.test=Carseats[-train,]
High.test=High[-train]
tree.carseats=tree(High~.-Sales,Carseats,subset=train)
tree.pred=predict(tree.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(86+57)/200
set.seed(3)
cv.carseats=cv.tree(tree.carseats,FUN=prune.misclass)
names(cv.carseats)
cv.carseats
par(mfrow=c(1,2))
plot(cv.carseats$size,cv.carseats$dev,type="b")
plot(cv.carseats$k,cv.carseats$dev,type="b")
prune.carseats=prune.misclass(tree.carseats,best=9)
plot(prune.carseats)
text(prune.carseats,pretty=0)
tree.pred=predict(prune.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(94+60)/200
prune.carseats=prune.misclass(tree.carseats,best=15)
plot(prune.carseats)
text(prune.carseats,pretty=0)
tree.pred=predict(prune.carseats,Carseats.test,type="class")
table(tree.pred,High.test)
(86+62)/200

# Fitting Regression Trees

library(MASS)
set.seed(1)
train = sample(1:nrow(Boston), nrow(Boston)/2)
tree.boston=tree(medv~.,Boston,subset=train)
summary(tree.boston)
plot(tree.boston)
text(tree.boston,pretty=0)
cv.boston=cv.tree(tree.boston)
plot(cv.boston$size,cv.boston$dev,type='b')
prune.boston=prune.tree(tree.boston,best=5)
plot(prune.boston)
text(prune.boston,pretty=0)
yhat=predict(tree.boston,newdata=Boston[-train,])
boston.test=Boston[-train,"medv"]
plot(yhat,boston.test)
abline(0,1)
mean((yhat-boston.test)^2)

# Bagging and Random Forests

library(randomForest)
set.seed(1)
bag.boston=randomForest(medv~.,data=Boston,subset=train,mtry=13,importance=TRUE)
bag.boston
yhat.bag = predict(bag.boston,newdata=Boston[-train,])
plot(yhat.bag, boston.test)
abline(0,1)
mean((yhat.bag-boston.test)^2)
bag.boston=randomForest(medv~.,data=Boston,subset=train,mtry=13,ntree=25)
yhat.bag = predict(bag.boston,newdata=Boston[-train,])
mean((yhat.bag-boston.test)^2)
set.seed(1)
rf.boston=randomForest(medv~.,data=Boston,subset=train,mtry=6,importance=TRUE)
yhat.rf = predict(rf.boston,newdata=Boston[-train,])
mean((yhat.rf-boston.test)^2)
importance(rf.boston)
varImpPlot(rf.boston)

# Boosting

library(gbm)
set.seed(1)
boost.boston=gbm(medv~.,data=Boston[train,],distribution="gaussian",n.trees=5000,interaction.depth=4)
summary(boost.boston)
par(mfrow=c(1,2))
plot(boost.boston,i="rm")
plot(boost.boston,i="lstat")
yhat.boost=predict(boost.boston,newdata=Boston[-train,],n.trees=5000)
mean((yhat.boost-boston.test)^2)
boost.boston=gbm(medv~.,data=Boston[train,],distribution="gaussian",n.trees=5000,interaction.depth=4,shrinkage=0.2,verbose=F)
yhat.boost=predict(boost.boston,newdata=Boston[-train,],n.trees=5000)
mean((yhat.boost-boston.test)^2)


library(gridExtra)
library(tidyverse)
library(deSolve)
library(ggplot2)
library(plotly)
library(shinythemes)
library(shinyjs)
#library(covdata)

## Configuration
theme_set(theme_minimal(base_size = 12))

## CONSTANTS

# Population size
N <- 1394000

# Rate at which person stays in the infectious compartment (disease specific and tracing specific)
gamma <- 0.14

# Initial number of infected people
n_init <- 1

x_max = 365
max_time <- 365
# # Grid where to evaluate
# max_time <- 365 # 150
# times <- seq(0, max_time, by = 0.1)

# R0 for the beta and gamma values
# R0 <- beta*N/gamma

# calculate beta
# Infectious contact rate - beta = R0/N*gamma and when R0  ~2.25 then  2.25/N*gamma
# beta <- 4.5e-07

# Function to compute the derivative of the ODE system
# -----------------------------------------------------------
#  t - time
#  y - current state vector of the ODE at time t
#  parms - Parameter vector used by the ODE system (beta, gamma)

diffsdp<-function(sdp)
{
  # Compute the square of integer `n`
  dif <- as.numeric(as.Date(sdp) - as.Date("2020-03-03"))
  return(dif)
}

sir <- function(t, y, parms,
                social_dist_period,
                reduction) {

  beta0 <- parms[1]
  gamma <- parms[2]

  #print(social_dist_period)

  if (t <= social_dist_period[1]) {
    beta_t = beta0;
    #cat('1. This is loop number',t)
  }
  else if (t >=social_dist_period[1] && t <= social_dist_period[2]) {
    beta_t =  beta0 * reduction[1];
    #cat('2. This is loop number',t)
  }
  else if (t >=social_dist_period[2] && t <= social_dist_period[3]) {
    beta_t =  beta0 * reduction[2];
    #cat('3. This is loop number',t)
  }
  else if (t >=social_dist_period[3] && t <= social_dist_period[4]) {
    beta_t =  beta0 * reduction[3];
    #cat('3. This is loop number',t)
  }
  else {
    beta_t =  beta0 * reduction[4];
    #cat('4. This is loop number',t)
  }

  # Reduce contact rate
  #beta_t <- if_else(t <= social_dist_period[1],
  #                  beta0,
  #                  if_else(t <= social_dist_period[2],
  #                          beta0 * reduction[1],
  #                          beta0 * reduction[2]
  #                  )
  #)

  S <- y[1]
  I <- y[2]
  R <- y[3]
  return(list(c(S = -beta_t * S * I,
                I =  beta_t * S * I - gamma * I,
                R =  gamma * I)))
}

## we assume that some globals exist...
solve_ode <- function(sdp, red, typ, beta, max_time) {

  # Grid where to evaluate
  times <- reactive({ seq(0, max_time, by = 0.1) })

  ode_solution <- lsoda(y = c(N - n_init, n_init, 0),
                        times = times(),
                        func  = sir,
                        parms = c(beta, gamma),
                        social_dist_period = sdp,
                        reduction = red) %>%
    as.data.frame() %>%
    setNames(c("t", "S", "I", "R")) %>%
    mutate(beta = beta,
           gama = gamma,
           R0 = N * beta / gamma,
           s  = S,
           i  = I,
           type = typ)

  daily <- ode_solution %>%
    filter(t %in% seq(0, max_time, by = 1)) %>%
    mutate(C = if_else(row_number() == 1, 0, lag(S, k = 1) - S),
           c = C)

  daily
}

# add results with intervention and plot
run <- function(sdp, red, r0, max_time) {
  #print(sdp)
  #print("sdp")
  #print(sdp2)
  #print("sdp2")
  print(red)
  shinyjs::logjs(red)
  #print("red")

  beta <- r0 / N * gamma

  ode_solution_daily <- solve_ode(
    sdp = c(0, max_time,max_time,max_time),  # social_dist_period
    red = c(1, 1, 1, 1),         # reduction
    typ = "If there was no Lockdown",
    beta = beta,
    max_time
  )

  # solve with interventions
  ode_solution2_daily <- solve_ode(
    sdp = sdp,
    red = red,
    typ = "with Lockdown",
    beta = beta,
    max_time
  )

  # solve with interventions
  #ode_solution3_daily <- solve_ode(
  #  sdp = sdp2,
  #  red = c(0.66, 0.8),
  #  typ = "with Lockdown2",
  #  beta = beta,
  #  max_time
  #)

  # Combine the two solutions into one dataset
  ode_df <- rbind(ode_solution_daily, ode_solution2_daily)

}

plot_lockdown <- function(ode_df, sdp) {
  #print("Plot Result")
  #print(sdp)
  #print(ode_df)
  #write.csv(x=ode_df, file="ode_df")
  max_time = 365
  # The final size in the two cases:
  final_sizes <- ode_df %>%
    group_by(type) %>%
    filter(row_number() == n()) %>%
    mutate("Proportion Infected" = scales::percent(1 - s, accuracy = 1)) %>%
    select("Proportion Infected", interventions = type) %>%
    arrange(desc(interventions))

  # Plot
  y_axis_fixed = FALSE
  if (y_axis_fixed) {
    y_max <- 0.09
  } else {
    y_max <- max(ode_df$c, na.rm = TRUE) * 1.05
  }
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01
  col_sdp <- "deeppink4"

  x_labs <- sort(c(0, 150, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ode_df$date <- as.Date(ode_df$t+start)

  pp <-ggplotly(
    ggplot(ode_df,
           aes(x = t,
               y = 0,
               xend = t,
               yend = c,
               color = type,
               name = date)) +
      geom_segment(alpha = 0.7) +
      geom_line(aes(x = t, y = c)) +
      labs(
        x = "Days from first known case",
        y = "Forecasts for Infected Daily",
        subtitle = "Daily new cases",
        caption  = "SIQ: Separate, Isolate and Quarantine period") +
      scale_x_continuous(labels = x_labs,
                         breaks = x_labs) +
      scale_y_continuous(limits = c(0, y_max), labels = scales::comma) +
      #scale_color_brewer(name = "Key",
      #                   type = "qual",
      #                   palette = 6,
      #                   guide = guide_legend(reverse = TRUE)) +
      # sdp
      #geom_hline(yintercept = 10900, color = "deeppink4") +
      geom_vline(xintercept = sdp, lty = 2, color = "gray30") +
      geom_text(aes(x = 10 + sdp[1] + (sdp[2] - sdp[1])/2,
                    y = y_text,
                    label = "With No Lockdown"),
                vjust = 0,
                color = col_sdp) +
      geom_text(aes(x = sdp[2] + 100,
                    y = y_text,
                    label = "With Lockdowns"),
                vjust = 0,
                color = "springgreen3") +
      geom_segment(aes(
        x = sdp[1],
        y = y_arrow,
        xend = sdp[2] * 0.99, # shorten
        yend = y_arrow
      ),
      size = 0.3,
      color = col_sdp,
      arrow = arrow(length = unit(2, "mm"))) +
      geom_segment(aes(
        x = sdp[2]*1.01, # shorten
        y = y_arrow,
        xend = max_time,
        yend = y_arrow
      ),
      size = 0.3,
      color = col_sdp,
      arrow = arrow(length = unit(2, "mm")))  +
      # Add final size as table
      annotation_custom(tableGrob(final_sizes,
                                  rows = NULL,
                                  theme = ttheme_minimal(
                                    core    = list(fg_params = list(hjust = 0, x = 0.1)),
                                    rowhead = list(fg_params = list(hjust = 0, x = 0))
                                  )),
                        xmin = max_time * 0.4,
                        xmax = max_time,
                        ymin = y_max * 0.8,
                        ymax = y_max * 0.8
      )
  )
  ggplotly(pp, tooltip="c")
}

plot_predict <- function(ode_df, sdp) {
  print(sdp)
  max_time = 365

  x_labs <- sort(c(0, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03")
  ode_df$date <- as.Date(ode_df$t+start)
  #filtered <- subset(ode_df, type == "with SIQ")
  result <- filter(ode_df, type == "with Lockdown")
  result$Dead <-result$C * 0.005
  total_deaths = sum(result$Dead)
  total_cases = sum(result$C)
  total_detected_cases = sum(result$C) * 0.2
  y_max <- max(result$c, na.rm = TRUE) * 1.05
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01
  col_sdp <- "deeppink4"

  result = head(result, 365)
  names(result)[names(result) == "C"] <- "daily_infections"
  result$CumulativeCases <-cumsum(result$daily_infections)
  #print(result)

  pp1 <-ggplotly(
    ggplot(result, aes(date, daily_infections)) +
      geom_bar(stat="identity", na.rm = TRUE, fill = "darkturquoise") +
      labs(
        x = "Date",
        y = "Infected Daily") + #ggtitle("Predicted Daily Infections with Lockdown Interventions") +
        #title = "Predicted Daily Infections with Lockdown Interventions") +
      geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30",linetype="dotted") +
      scale_x_date(date_breaks = "1 month", date_minor_breaks = "1 week",
                   date_labels = "%B") + theme(axis.text.x = element_text(angle = 60, hjust = 1)) +
      theme(axis.text=element_text(size=8),
            axis.title=element_text(size=8)) +
      annotate(geom="text",x=start + 45,
               y=y_max, label="Full Lockdown",fontface="bold", color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[2] + 4,
               y=y_max,label="Ph 1",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[3] + 4,
               y=y_max,label="Ph 2",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[4] + 4,
               y=y_max,label="Ph 3",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + 300,
               y=y_max, label=sprintf("Total Cases = %s",toString(ceiling(total_cases))),fontface="bold",color = "red") +
    annotate(geom="text",x=ends + 300,
             y=y_max * .9, label=sprintf("Total Detected Cases = %s",toString(ceiling(total_detected_cases))),fontface="bold",color = "red") +
    annotate(geom="text",x=ends + 300,
             y=y_max * .8, label=sprintf("Total Dead = %s",toString(ceiling(total_deaths))),fontface="bold",color = "red")
      + scale_y_continuous(labels = scales::comma)

  )
  ggplotly(pp1, tooltip="daily_infections")
}

make_summary_table <- function(ode_df, sdp) {

  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03") + sdp[1]
  ode_df$date <- as.Date(ode_df$t+start)
  prediction <- filter(ode_df, type == "with Lockdown")

  prediction$Dead <-prediction$C * 0.005
  prediction$Detected_Cases <-prediction$C * 0.1

  summary <- prediction %>%mutate(Year_Month = format(date, "%Y-%m")) %>%
    group_by(Year_Month) %>%
    summarise(total_predicted_cases = ceiling(sum(C)), total_detected_cases = ceiling(sum(Detected_Cases)), total_predicted_deaths = ceiling(sum(Dead)))

  summary <- summary[order(summary$Year_Month),]

  return(summary)

}

plot_real <- function(ode_df, sdp) {
  guy  <- read.csv(file = 'Trinidad.csv')
  guy$date <- as.Date(guy$date)
  pp3 <-ggplotly(
    ggplot(guy, aes(x=date)) +
      geom_line(aes(y = cu_cases, color = "Cumulative Cases")) +
      geom_line(aes(y = cu_deaths, color = "Cumulative Deaths")) +
      geom_point(aes(y = cases, color = "Cases", alpha=1/3), shape=1) +
      geom_point(aes(y = deaths, color = "Deaths",alpha=1/3), shape = 4) +
      scale_colour_manual("",
                          breaks = c("Cumulative Cases", "Cumulative Deaths", "Cases","Deaths"),
                          values = c("turquoise3", "red", "turquoise3","red")) #+
    #scale_y_continuous(labels = scales::comma) + geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30") +
    #annotate(geom="text",x=start + 50,
    #         y=top,label="Lockdown starts",fontface="bold", color = "deeppink4") +
    #annotate(geom="text",x=ends + sdp[1] + 30,
    #         y=top,label="Phase 1",fontface="bold",color = "deeppink4") +
    #annotate(geom="text",x=ends + sdp[2] + 30,
    #         y=top,label="Phase 2",fontface="bold",color = "deeppink4")
  )

  ggplotly(pp3)
}

plot_cum <- function(ode_df, sdp) {

  max_time = 365

  x_labs <- sort(c(0, 200, 300, 365, sdp))
  start = as.Date("2020-03-03")
  ends = as.Date("2020-03-03") + sdp[1]
  ode_df$date <- as.Date(ode_df$t+start)
  #filtered <- subset(ode_df, type == "with SIQ")
  result <- filter(ode_df, type == "with Lockdown")
  y_max <- max(result$c, na.rm = TRUE) * 1.05
  y_arrow <- y_max * 0.975
  y_text  <- y_arrow + y_max * 0.01

  col_sdp <- "deeppink4"

  result = head(result, 365)
  names(result)[names(result) == "C"] <- "daily_infections"
  result$CumulativeCases <-cumsum(result$daily_infections)
  result$Dead <-result$daily_infections * 0.005
  result$CumulativeSus <-result$S - result$Dead
  result$CumulativeDead <-cumsum(result$Dead)
  result$CumulativeRec <- result$S - result$CumulativeCases
  top = head(result$CumulativeSus, n=1) * 1.1
  #top = result["CumulativeCases"].iloc[-1]
  #print(result)

  pp3 <-ggplotly(
    ggplot(result, aes(x=date)) +
      geom_line(aes(y = CumulativeCases, color = "Cases")) +
      geom_line(aes(y = CumulativeDead, color = "Dead")) +
      geom_line(aes(y = CumulativeSus, color = "Susceptible")) +
      geom_line(aes(y = R, color = "Recovered")) +
      scale_colour_manual("",
                          breaks = c("Cases", "Dead", "Susceptible","Recovered"),
                          values = c("steelblue", "darkred", "goldenrod", "green")) +
      #scale_color_discrete(name = "Descriptions", labels = c("CumulativeCases", "CumulativeDead", "CumulativeSus", "R")) +
      scale_y_continuous(labels = scales::comma) + geom_vline(xintercept=as.numeric(ode_df$date[sdp]), colour="gray30") +
      annotate(geom="text",x=start + 40,
               y=top,label="Lockdown",fontface="bold", color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[2] - 26,
               y=top,label="Ph 1",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[3] - 26,
               y=top,label="Ph 2",fontface="bold",color = "deeppink4") +
      annotate(geom="text",x=ends + sdp[4] - 26,
               y=top,label="Ph 3",fontface="bold",color = "deeppink4")
  )

  ggplotly(pp3, tooltip="CumulativeCases")
}

ui <- fluidPage(theme = shinytheme("flatly"),
  titlePanel("What Happens When T&T Re-Opens? An Interactive Covid-19 SIR Policy Simulator"),
  h4("Charts update in real-time, please allow ~5 seconds for charts to load"),
  hr(),
  sidebarLayout(
    sidebarPanel(
      h3("Phase 1 of Lockdown Removal"),
      br(),
      dateInput("end",
                "Set start date:",
                value = "2020-06-08",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, salons, offices & gyms)", value = FALSE),
      checkboxInput("gat", label = "Mass Gatherings of 25+ allowed", value = FALSE),
      checkboxInput("sch", label = "Schools re-opened", value = FALSE),
      sliderInput("sda",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 60,
                  step  = 1),
      hr(),
      h3("Phase 2 of Lockdown Removal"),
      br(),
      dateInput("end2",
                "Set start date:",
                value = "2020-06-22",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo2", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non2", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus2", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res2", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, offices, salons & gyms)", value = TRUE),
      checkboxInput("gat2", label = "Mass Gatherings of 25+ allowed", value = TRUE),
      checkboxInput("sch2", label = "Schools re-opened", value = TRUE),
      sliderInput("sda2",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 50,
                  step  = 1),
      hr(),
      h3("Phase 3 of Lockdown Removal"),
      br(),
      dateInput("end3",
                "Set start date:",
                value = "2020-08-17",
                format = "dd/mm/yyyy"),
      br(),
      h4("Select Policy Choices"),
      checkboxInput("foo3", label = "Food Establistments and related stores re-opened", value = TRUE),
      checkboxInput("non3", label = "Manufacturing & Public Section re-started", value = TRUE),
      checkboxInput("bus3", label = "Medium to low risk businesses and malls re-opened", value = TRUE),
      checkboxInput("res3", label = "Medium to high risk businesses re-openes (resturants, bars, cinemas, offices, salons & gyms)", value = FALSE),
      checkboxInput("gat3", label = "Mass Gatherings of 25+ allowed", value = FALSE),
      checkboxInput("sch3", label = "Schools re-opened", value = FALSE),
      sliderInput("sda3",
                  "Control Social Distance/Mask Wearing/Hand Washing Adherance (100% is everyone follows)",
                  min   = 1,
                  max   = 100,
                  value = 70,
                  step  = 1),
      #radioButtons("sda", label = h4("Control Social Distance Adherance (Mask Wearing etc)"),
      #             choices = list("0 to 30% People wear masks in public" = 7,
      #                            "30% to 70% People wear masks in public" = 13,
      #                            "70% to 100% People wear masks in public" = 16),
      #             selected = 13),
      #radioButtons("sdo", label = h4("Social Distancing Obeyed"),
      #             choices = list("0 to 30% People object 6ft spacing" = 7,
      #                            "30% to 70% People object 6ft spacing" = 13,
      #                            "70% to 100% People object 6ft spacing" = 15),
      #             selected = 13),
      #radioButtons("hwh", label = h4("Hand Washing and Basic Hygenine"),
      #             choices = list("0 to 30% People follow" = 7,
      #                            "30% to 70% People follow" = 13,
      #                           "70% to 100% People follow" = 15),
      #             selected = 13),
      br(),
      hr(),
      tags$div("Developed by Rajev Ratan"),
      tags$div("Version 2.1, 16-May-2020"),
      tags$a(href="https://caribbeandatafam.com/","Caribbean Data Fam"),

      br(),
      width = 3,
    ),

    mainPanel(

      # Output: Tabset w/ plot, summary, and table ----
      tabsetPanel(type = "tabs",
                  tabPanel("Forecasted Cases", plotlyOutput("chart1",  height = "auto", width = "auto"),
                           DT::dataTableOutput('table', width = "55%", height = "auto")),
                  tabPanel("Forecasted Cumulative Data", plotlyOutput("chart3",  height = "auto",width = "auto")),
                  tabPanel("Actual Data", plotlyOutput("chart2",  height = "auto",width = "100%")),
                  tabPanel("What if there were no Lockdowns?", plotlyOutput("chart4",  height = "auto",width = "auto"))
                  #tabPanel("Table", tableOutput("table"))
      ),

      #br(),
      #br(),
      #hr(),
      div(HTML("Parameters Used:")),
      div(HTML("R0 of 2.25")),
      div(HTML("Gamma = 0.2, beta <- 4.5e-07 ")),
      div(HTML("beta <- 4.5e-07 ")),
      div(HTML("Population = 1,394,000")),
      div(HTML("Initial Infect People = 2")),
      div(HTML("Day 0 is 3rd March 202")),
      br(),
      width = 9
    )

  )
)

server <- function(input, output) {

  res <- reactive({

    run(sdp = c(c(30, diffsdp(input$end)), diffsdp(input$end2),  diffsdp(input$end3)),
        #sdp2 = c(c(diffsdp(input$end)),c(diffsdp(input$end2))),
        #red = c(0.4, (100-(input$red_two)/1.5)/100),
        #test =  input$mask,
        red = c(0.3, (((100 - ((-13*as.integer(input$sch)) + (-13*as.integer(input$res)) + (-13*as.integer(input$gat)) +
                                 (-10*as.integer(input$bus))+ (-10*as.integer(input$foo)) +
                                 (-10*as.integer(input$non))  ))/100)- 0.7) * (1-(as.integer(input$sda)/300)),
                (((100 - ((-13*as.integer(input$sch2)) + (-13*as.integer(input$res2)) + (-13*as.integer(input$gat2)) +
                            (-10*as.integer(input$bus2))+ (-10*as.integer(input$foo2)) +
                            (-10*as.integer(input$non2))  ))/100)- 0.7) * (1-(as.integer(input$sda2)/300)),
                (((100 - ((-13*as.integer(input$sch3)) + (-13*as.integer(input$res3)) + (-13*as.integer(input$gat3)) +
                            (-10*as.integer(input$bus3))+ (-10*as.integer(input$foo3)) +
                            (-10*as.integer(input$non3))  ))/100)- 0.7) * (1-(as.integer(input$sda3)/300))),

        #(((100 - ((-5*as.integer(input$sch2)) + (-5*as.integer(input$res2)) + (-5*as.integer(input$gat2)) +
        #           (-5*as.integer(input$bus2))+ (-5*as.integer(input$foo2))+ (-5*as.integer(input$non2)) + (-1*(10-(as.integer(input$sda2)/10) )) ))/100)- 0.4)),
        #red2 = c(0(((100 - ((-5*as.integer(input$sch)) + (-5*as.integer(input$res)) + (-4*as.integer(input$gat)) +
        #                      (-3*as.integer(input$bus))+ (-3*as.integer(input$foo))+ (-3*as.integer(input$non)) + (-1*(7-(as.integer(input$sda)/10) )) ))/100)- 0.4),
        #         (((100 - ((-5*as.integer(input$sch2)) + (-5*as.integer(input$res2)) + (-4*as.integer(input$gat2)) +
        #                     (-3*as.integer(input$bus2))+ (-3*as.integer(input$foo2))+ (-3*as.integer(input$non2)) + (-1*(7-(as.integer(input$sda2)/10) )) ))/100)- 0.4)),
        r0  = 2.25,
        max_time = 365)
    #start  = input$start,
    #
    #)
  })

  output$table <- DT::renderDataTable(make_summary_table(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2),diffsdp(input$end3))) ), options=list(scrollX=T))

  output$chart1 <- renderPlotly({
    plot_predict(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart2 <- renderPlotly({
    plot_real(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart3 <- renderPlotly({
    plot_cum(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

  output$chart4 <- renderPlotly({
    plot_lockdown(res(), c(c(30,diffsdp(input$end),diffsdp(input$end2)), diffsdp(input$end3)) )
  })

}

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


# empirical likelihood for the mean
meanlike <- function(x){
 n<- length(x)

f1<- function(lambda,x){
     x/(n-lambda*x)
    }

 sx<- sort(x)
 nt<- 40
 nlam<-40
 th<- seq(1.01*sx[1],(sx[n-1]+.99*(sx[n]-sx[n-1])),len=nt)
 theta<- NULL
 loglik<- NULL
 for (i in 1:nt){
   a<- x-th[i]
   lam <- seq(n/min(a),n/max(a),len=nlam)
   lam <- lam[c(-1,-nlam)]
   glam <-outer(lam,a,'f1')
   glam<- c(glam %*% rep(1,n))
   lam0<- approx(glam,lam,xout=0)$y
   if (is.na(lam0)==F) {   # lam0 exists
      w <- 1/(n-lam0*a)
      if (min(w)>0 & max(w)<1){  # proper distribution
        ll<- sum(log(w))
        theta<- c(theta,th[i])
        loglik <- c(loglik,ll)
      }
   } # endif
 }# endfor

 loglik<- loglik - max(loglik)
 out <- list(theta= theta, loglik=loglik)
 return(out)
} # end function


#Example  :  2   Chapter :  2.3   pageno : 58
#Purpose of Elimination matrices
I<-matrix(c(1,0,0,0,1,0,0,0,1),ncol=3)
E31<-matrix(c(1,0,-4,0,1,0,0,0,1),ncol=3)
b<-matrix(c(1,3,9),ncol=1)
Ib<-I%*%b
print(Ib)
Eb<-E31%*%b
print(Eb)