'

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)
}


oldCanopyShootNumber = canopyShootNumber
emergedLeaves = int(max(1, ceil(leafNumber - 1)))
shoots = fibonacci(emergedLeaves)
canopyShootNumber = min(shoots * sowingDensity, targetFertileShoot)
averageShootNumberPerPlant = canopyShootNumber / sowingDensity
if (canopyShootNumber != oldCanopyShootNumber):
    tilleringProfile.append(canopyShootNumber - oldCanopyShootNumber)
tillerNumber = len(tilleringProfile)
for i in range(len(leafTillerNumberArray),int(ceil(leafNumber))):
    leafTillerNumberArray.append(tillerNumber)


#'@title Return the transition points of the trend for the given time series
#'
#'@description Transition points are defined as indices at which the time series changes direction
#'
#'@usage  tp <- getTrendTransitionPoints(tsData)
#'
#'@param tsData A time series object.
#'
#'@return A vector of integers corresponding to indices of transition points in the time series
#'
#'@export

getTrendTransitionPoints <- function(tsData)
{
	tsObj.tr <- getTrend(tsData)
	tsObj.tp <- which(c(NA,NA,sign(diff(sign(diff(tsObj.tr))))) != 0)

	return (tsObj.tp)
}


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 install.packages("gdata")
 install.packages("evir")
 library(gdata)
 library(evir)

 StormDamageData <- read.xls("d:/publicdatamay2007.xls", sheet = 1)

 head(StormDamageData)

 tail(StormDamageData)

 dim(StormDamageData)

 ChangeFormat <- function(x){
                     x=as.character(x)
                     for(i in 1:10){x=sub(",","",as.character(x))}
                     return(as.numeric(x))}

 base <- StormDamageData[,1:4]

 base$Base.Economic.Damage <- Vectorize(ChangeFormat)(StormDamageData$Base.Economic.Damage)

 base$Normalized.PL05 <- Vectorize(ChangeFormat)(StormDamageData$Normalized.PL05)

 base$Normalized.CL05 <- Vectorize(ChangeFormat)(StormDamageData$Normalized.CL05)

 head(base)

 plot(base$Normalized.PL05/1e9,type="h",ylim=c(0,155), main = "207 Hurricanes, Normalized Costs: 1900 - 2005", xlab = "Index of Loss", ylab = "Normalized Costs", col = "red")

 TestBase <- table(base$Year)

 TestBase

 years <- as.numeric(names(TestBase))

 years

 frequency <- as.numeric(TestBase)

 frequency

 years0frequency <- (1900:2005)[which(!(1900:2005)%in%years)]

 years0frequency

 StormDamageData <- data.frame(years=c(years, years0frequency), frequency=c(frequency, rep(0,length(years0frequency))))

 head(StormDamageData)

 plot(years, frequency, type="h", main = "Frequency of Hurricanes: 1900 - 2005", xlab = "Time (Years)", ylab = "Annual Frequency", col = "red")

 mean(StormDamageData$frequency)

 LinearTrend <- glm(frequency~years, data = StormDamageData, family=poisson(link="identity"), start=lm(frequency~years, data = StormDamageData)$coefficients)

 LinearTrend

 ExpTrend <- glm(frequency~years, data=StormDamageData, family = poisson(link="log"))

 ExpTrend

 plot(years, frequency, type='h', ylim=c(0,6), main = "No. of Major Hurricanes Predicted for 2014", xlim=c(1900,2020))

 cpred1 <- predict(ExpTrend, newdata = data.frame(years=1890:2030), type="response")

 cpred1

 lines(1890:2030,cpred1,col="blue")

 cpred0 <- predict(LinearTrend, newdata=data.frame(years=1890:2030), type="response")

 cpred0

 lines(1890:2030, cpred0, col="red")

 abline(h = mean(StormDamageData$frequency), col="black")

 predictions <- cbind(constant = mean(StormDamageData$frequency), linear= cpred0[126], exponential=cpred1[126])

 predictions

 points(rep((1890:2030)[126],3), predictions, col=c("black","red","blue"), pch=19)

 hill(base$Normalized.PL05)

 threshold <- .5

 gpd.PL <- gpd(base$Normalized.PL05/1e9/20, threshold)$par.ests

 mean(base$Normalized.CL05/1e9/20 >.5)

 ExpectedValue <- function(yinf,ysup,xi,beta){
    as.numeric(integrate(function(x) (x-yinf) * dgpd(x,xi,mu=threshold,beta),
    lower=yinf,upper=ysup)$value +
    (1-pgpd(ysup,xi,mu=threshold,beta))*(ysup-yinf))
     }

 predictions[1]

 mean(base$Normalized.PL05/1e9/20.5)

 ExpectedValue(2,6,gpd.PL[1],gpd.PL[2])*1e3

 predictions[1] * mean(base$Normalized.PL05/1e9/20 >.5) * ExpectedValue(2, 6, gpd.PL[1], gpd.PL[2]) * 1e3

Chapter 13/Case Study 2 - Pricing Reinsurance Contracts.r


####
###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) ,]


val <- pnorm(250, 2.4 * 100, sqrt( 100 * (2.0 ^ 2) ))
write(round(val, 4), stdout())


############## 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")


#' solve
#'
#' Solve a system of equations or invert a float matrix.
#'
#' @param a,b
#' A float vector/matrix.
#' @param ...
#' Ignored.
#'
#' @return
#' A float matrix if inverting.  If solving a system, a float vector if given
#' one "right hand side", and a float matrix otherwise (just like R).
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' cp = crossprod(s)
#' solve(cp)
#'
#' y = fl(1:3)
#' solve(cp, y)
#'
#' @useDynLib float R_solve_spm R_solve_spmspm
#' @name solve
#' @rdname solve
NULL

solve_float32 = function(a, b, ...)
{
  if (missing(b))
    ret = .Call(R_solve_spm, DATA(a))
  else
  {
    if (is.integer(b))
      b = fl(b)

    if (is.float(b))
      ret = .Call(R_solve_spmspm, DATA(a), DATA(b))
    else if (is.numeric(b))
      return(solve(dbl(a), b))
  }

  float32(ret)
}

#' @rdname solve
#' @export
setMethod("solve", signature(a="float32", b="ANY"), solve_float32)


#' 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)
}


C09AAJ Example Program Results

Parameters read from file ::
        Wavelet : Haar  End mode : Zero          N = 8
Input data      X :
2.000   5.000   8.000   9.000   7.000   4.000   -1.000  1.000

Length of wavelet filter :      2
Number of Levels :      3
Number of coefficients in each level:
                1        1       2       4
Total number of wavelength coefficients : 8

Wavelet coefficients C:
12.374 4.596 -5.000 5.500 -2.121 -0.707 2.121 -1.414

Reconstruction  Y :
2.000 5.000 8.000 9.000 7.000 4.000 -1.000 1.000


########################
###MEDIATION IN R#######
####USING LAVAAN########
########################

# STEP 1: LOAD LIBRARIES
# To run the line of code you are on:
# press CTRL + Enter (Windows)
# press COMMAND + Enter (Mac)
# Or, highlight CTRL/CMD + Enter
install.packages("lavaan") #only needs to be done once
install.packages("psych") #only needs to be done once
library(lavaan)
library(psych)

# STEP 2: LOAD DATA
# I took the data from Table 3.1 in Mackinnon (2008, p. 56)

thirst_dat <- read.csv("thirst_dat.csv")

# Print first and last five observations

thirst_dat %>%
  headTail()

#room_temp = IV
#thirst = MEDIATOR
#consume = DV

# STEP 3: VISUALIZATION
# It's always a good idea to look at your data.

thirst_dat %>%
  select(room_temp, thirst, consume) %>% #telling r what columns we want to see
  pairs.panels()

# You can optionally remove the below "#" to run "help"
# "help" will tell you more about the function
# help("pairs.panels")

# STEP 4: CREATING OUR MEDIATION MODEL
# We will first run mediation with lavaan
# Below we write a model to test indirect effect using sem()
# from lavaan (LAtent VAriable ANalysis)

# Quick Guide to lavaan syntax/symbols
# `~` = Regress onto
# Within the regression models, I label coefficients with the astrix.
# `:=` = Define a new parameter.
## Note when you define new parameter with :=, you can use the astrix to multiply values

mod1 <- '# a path IV -> Mediator
         thirst ~ a * room_temp

         # b path  Mediator -> DV
         consume ~ b * thirst

         # c prime path  IV -> DV
         consume ~ cp * room_temp

         # indirect and total effects
         ab := a * b
         total := cp + ab'

# Next, set random seed so results can be reproduced
set.seed(1234)

# STEP 5: RUNNING SEM
# Fit model
# You must specify bootstrapping in the sem() function
# Normally I run 10000, but it takes time.
# To be time efficient, we will only run 1000 today
fsem1 <- sem(mod1, data = thirst_dat, se = "bootstrap", bootstrap = 1000)

# STEP 6: SUMMARIZE MODEL
# standardized = TRUE adds standardized estimate to the model output.
summary(fsem1, standardized = TRUE)

# Print all model parameters
parameterestimates(fsem1, boot.ci.type = "bca.simple", standardized = TRUE)
help("parameterestimates")
# STEP 7: INTERPRET
#Every 1 degree increase in room temperature was associated with an a = 0.339 (S.E. = 0.099) increase
#in thirstiness units.

#Adjusting for room temperature, every 1-unit increase in thirstiness was
#associated with drinking b = 0.451 (S.E. = 0.152) more deciliters of water.

#Increases in room temperature were associated with increases in water
#drinking indirectly through increases in thirstiness.
#Specifically, for every a = 0.339 unit increase in the association between room
#temperature and thirstiness, there was an ab = 0.153 (S.E. = 0.064) increase in deciliters of
#water people drank. (INDIRECT EFFECT)
#Importantly, a bias-corrected bootstrapped confidence interval with 1,000
#samples was above zero, 95% CI [0.06, 0.32].

#Last, there was no sufficient evidence that room
#temperature was associated with how many deciliters of water
#people drank independent of its association with
#thirstiness, c' = 0.208 (S.E. = 0.126).

#########################
####PSYCH PACKAGE#######
#########################

## Test same model using psych package
# The syntax for mediation in psych doesn't have as steep a learning curve as lavaan
# but lavaan (and SEM in general) has more flexibility in specifying more involved models.
thirst_dat %>%
  mediate(y = "consume", x = "room_temp", m = "thirst", n.iter = 1000) %>%
  print(short = FALSE)

### Sources
#MacKinnon, D. P. (2008). Introduction to statistical mediation analysis. New York, NY: Lawrence Erlbaum Associates.

#Revelle, W. (2017) How to use the psych package for mediation/moderation/regression analysis.

#Rosseel, Y. (2012). Lavaan: An R package for structural equation modeling and more. Version (BETA). Journal of statistical software, 48(2), 1-36.

#Rucker, D. D., Preacher, K. J., Tormala, Z. L., & Petty, R. E. (2011). Mediation analysis in social psychology: Current practices and new recommendations. Social and Personality Psychology Compass, 5(6), 359-371.

#http://www.stat.cmu.edu/~hseltman/PIER/SemAndLavaan.pdf

#https://nmmichalak.github.io/nicholas_michalak/blog_entries/2018/nrg01/nrg01.html


x <- c(31, 4, 15, 92, 65)
# if we were to run the function rank(x) it will return [1] 3 1 2 5 4


# Instalação dos Pacotes

install.packages('readxl');
install.packages('data.table');
install.packages('dplyr');
install.packages('tidyr');
install.packages('lubridate');
install.packages('arulesCBA');
install.packages('ggplot2');
install.packages('reshape');
install.packages('rpivotTable');

library(readxl);
library(data.table);
library(dplyr);
library(tidyr);
library(lubridate);
library(arulesCBA);
library(ggplot2);
library(reshape);
library(rpivotTable);

A02 <- read_excel('./A02.xlsx');

# Exercicio 3
boxplot(A02$Quantity);

media_quantidade <- mean(A02$Quantity);
dp_quantidade <- sd(A02$Quantity);

## Dividido pelo numero de Regios(13)

erro_quantidade <- qnorm(0.975) * dp_quantidade/13;
li_quantidade <- media_quantidade - erro_quantidade;
ls_quantidade <- media_quantidade + erro_quantidade;
out_max_quantidade <- media_quantidade + 3 * dp_quantidade;
out_min_quantidade <- media_quantidade - 3 * dp_quantidade;

## Normalização

A02N <- A02 %>% filter(Quantity < out_max_quantidade & Quantity > out_min_quantidade) %>% select(Quantity, `Order Date`, Region, State);

boxplot(A02N$Quantity);

media_quantidade <- mean(A02N$Quantity);
dp_quantidade <- sd(A02N$Quantity);
erro_quantidade <- qnorm(0.975) * dp_quantidade/13;
li_quantidade <- media_quantidade - erro_quantidade;
ls_quantidade <- media_quantidade + erro_quantidade;

# Exercicio 4

A02Q <- A02N %>% group_by(State, Region) %>% summarise(media=mean(Quantity), qtd=n());

cor(A02Q[, 3:4]);
pairs(A02Q[, 3:4]);

boxplot(media ~ Region, data= A02Q, xlab = 'Regiao', ylab = 'Media');
reg = lm(media ~ Region, data = A02Q);
summary(reg);
anova(reg);

State = factor(A02Q$State);
faixa_media = discretize(A02Q$media, method="cluster", breaks=5);
table(State, faixa_media);
chisq.test(table(State, faixa_media));

Region = factor(A02Q$Region);
faixa_media = discretize(A02Q$media, method="cluster", breaks=5);
table(Region, faixa_media);
chisq.test(table(Region, faixa_media));

A02N <- A02N %>% mutate(ano=year(`Order Date`));
A02N <- A02N %>% mutate(mes=month(`Order Date`));

# Exercicio 5

A02Reg <- A02N %>% group_by(ano, mes) %>% summarise(total = sum(Quantity));
setDT(A02Reg);
class(A02Reg);
A02Reg[,ano3 := ano - 2011];
A02Reg[,periodo := (ano3 * 12) + mes];

plot(total ~ periodo, data = A02Reg);

regressao <- lm(total ~ periodo, data = A02Reg);

A <- summary(regressao)$coefficients[1,1];
B <- summary(regressao)$coefficients[2,1];

A02Reg[,previsao := A + (periodo * B)];
plot(previsao ~ periodo, data=A02Reg);
lines(previsao ~ periodo, data=A02Reg);

# Exercicio 6
A02C <- A02N %>% group_by(Region) %>% summarise(media = mean(Quantity), qtde = n());
clusters <- hclust(dist(A02C[,2,3]));
clusterCut <- cutree(clusters, 3);
ggplot(A02C, aes(media, qtde, color = A02C$Region)) + geom_point(alpha = 0.4, size = 5.5) + geom_point(col = clustersCut);
plot(clusters, labels = A02C$Region);
table(A02C$Region, clustersCut);

# Exercicio 7

paisano <- cast(A02N, Region ~ ano);
clusters <- hclust(dist(paisano[, 2:4]));
clusterCut <- cutree(clusters, 3);
table(paisano$Region, clusterCut);

ggplot(paisano, aes(2011, 2012, color = paisano$Region)) + geom_point(alpha = 0.4, size = 5.5) + geom_point(col = clusterCut);
plot(clusters, labels=paisano$Region);
rpivotTable(A02N)


#' 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
  }
}


library(ggplot2)
library(gridExtra)

load("sc1-multi-time.RData")

# extract if2 data

if2names <- c("if2.R0","if2.r","if2.sigma","if2.eta","if2.berr","if2.Iinit")
if2data <- estmat[,if2names]
colnames(if2data) <- c("R0","r","sigma","eta","berr","Iinit")
if2times <- estmat[,7]

# extract hmc data

hmcnames <- c("hmc.R0","hmc.r","hmc.sigma","hmc.eta","hmc.berr","hmc.Iinit")
hmcdata <- estmat[,hmcnames]
colnames(hmcdata) <- c("R0","r","sigma","eta","berr","Iinit")
hmctimes <- estmat[,14]

# average times

avif2time <- mean(if2times)
avhmctime <- mean(hmctimes)

avif2time
avhmctime

# sort results

if2sorted <- apply(if2data, 2, sort)
hmcsorted <- apply(hmcdata, 2, sort)

## take centre 95%

nTrials <- dim(estmat)[1]

cinds <- (0.025*nTrials+1):(0.975*nTrials)
if295 <- if2sorted[cinds,]
hmc95 <- hmcsorted[cinds,]

if2plotdata <- data.frame(if295)
hmcplotdata <- data.frame(hmc95)

linecolour <- "grey50"
lineweight <- 0.5

## if2 density plots

R0kernel <- qplot(if2plotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$R0)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

rkernel <- qplot(if2plotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$r)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(if2plotdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$sigma)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(if2plotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$Iinit)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(if2plotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$eta)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(if2plotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$berr)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)

## hmc density plots

R0kernel <- qplot(hmcplotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$R0)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

rkernel <- qplot(hmcplotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$r)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(hmcplotdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$sigma)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(hmcplotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$Iinit)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(hmcplotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$eta)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(hmcplotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$berr)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)

## combined plots

R0kernel <- qplot(hmcplotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_density(aes(x = if2plotdata$R0), linetype = "dashed") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

rkernel <- qplot(hmcplotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_density(aes(x = if2plotdata$r), linetype = "dashed") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(hmcplotdata$sigma, geom = "density", xlab = expression(sigma)), ylab = "") +
    geom_density(aes(x = if2plotdata$sigma), linetype = "dashed") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(hmcplotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_density(aes(x = if2plotdata$Iinit), linetype = "dashed") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(hmcplotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_density(aes(x = if2plotdata$eta), linetype = "dashed") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(hmcplotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_density(aes(x = if2plotdata$berr), linetype = "dashed") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)


#' Produce a stars object with zero value on a fixed resolution
#'
#' @param data spatial feature of the relevant locations
#' @param resolution cell size
#' @param values values to populate the stars values with, default to 0
#'
#' @export
stars_ref <- function(data, resolution, values = 0L) {

  stars::st_as_stars(sf::st_bbox(data), dx = resolution, dy = resolution, values = values)
}

#' Creates identifiers for (x,y) coordinates.
#' Used to work with crs 3035
#'
#' @param x matrix of coordinates (first column = x, second = y). Or a vector of x coordinates.
#' @param y default to NULL (if x is a matrix). Or a vector of y coordinates.
#' @param resolution default to 200. Size of raster cells which are identified.
#'
#' @export
coord2idINS <- function(x, y = NULL, resolution = 200) {

  if (!is.null(y)) x <- cbind(x, y)
  resolution <- round(resolution)

  res <- apply(x, MARGIN = 1:2, FUN = function(z) formatC(floor(z / resolution) * resolution, format = "d"))
  res <- paste0("r", resolution, "N", res[, 2], "E", res[, 1])

  nas <- apply(x, MARGIN = 1, FUN = anyNA)
  res[nas] <- NA

  res
}

#' Retrieves (x, y) coordinates from idINS.
#' Used to work with crs 3035
#'
#' @param ids character vector of idINS
#' @param stop_if_res_not_cst default to TRUE. Refuse to convert id with different resolutions
#'
#' @export
idINS2coord <- function(ids, stop_if_res_not_cst = TRUE) {

  ids <- strsplit(as.character(ids), "[rNE]")
  resolution <- lapply(ids, FUN = function(liste) liste[2]) |> unlist() |> as.numeric()
  if (stop_if_res_not_cst) stopifnot(length(unique(resolution)) == 1L)

  x <- lapply(ids, FUN = function(liste) liste[4]) |> unlist() |> as.numeric()
  y <- lapply(ids, FUN = function(liste) liste[3]) |> unlist() |> as.numeric()

  res <- matrix(c(x + resolution/2, y + resolution/2), ncol = 2)
  colnames(res) <- c("x", "y")

  res
}

#' Transform a data.table with idINS to a star object.
#' Assumes crs 3035
#'
#' @param data a data.table with an idINS column
#' @param idINS name of the idINS column. Default to idINS.
#'
#' @import data.table
#'
#' @export
dt2stars <- function(data, idINS = "idINS")
{
  if(!is.data.table(data)) setDT(data)
  xy <- idINS2coord(data[[idINS]]) |> as.data.table()

  data <- cbind(data[, .SD, .SDcol = !idINS], xy)

  #sf::st_as_sf(data, coords = c("x", "y"), crs = st_crs(3035))
  data <- stars::st_as_stars(data, dims = c("x", "y"))
  st_crs(data) <- sf::st_crs(3035)

  data
}


require(rms)
set.seed(1)
age <- rnorm(500, 50, 10)
sex <- sample(c('female', 'male'), 500, TRUE)
y   <- sample(0:4, 500, TRUE)
d   <- expand.grid(age=50, sex=c('female', 'male'))

w <- impactPO(y ~ age + sex, nonpo = ~ sex, newdata=d)
w
# Note that PO model is a better model than multinomial (lower AIC)
# since multinomial model's improvement in fit is low in comparison
# with number of additional parameters estimated.  The same is true
# in comparison to the partial PO model.

# Reverse levels of y so stacked bars have higher y located higher
revo <- function(z) {
  z <- as.factor(z)
  factor(z, levels=rev(levels(as.factor(z))))
}

ggplot(w$estimates, aes(x=method, y=Probability, fill=revo(y))) +
  facet_wrap(~ sex) + geom_col() +
  xlab('') + guides(fill=guide_legend(title=''))

d <- expand.grid(sex=c('female', 'male'), age=c(40, 60))
w <- impactPO(y ~ age + sex, nonpo = ~ sex, newdata=d)
w
ggplot(w$estimates, aes(x=method, y=Probability, fill=revo(y))) +
  facet_grid(age ~ sex) + geom_col() +
  xlab('') + guides(fill=guide_legend(title=''))


cat("Type matrix functions; ")
# Virus type: probabilities
typecount <- function(tpdata){
  matrix(c(sort(unique(tpdata)),as.vector(table(tpdata))),nrow=2,byrow=TRUE)
}

normalize <- function(pvec){
  if (sum(pvec)==0) {return(pvec)}
  return(pvec/sum(pvec))
}

# Virus type
rndtype <- function(typepvec){ # generate random type
  sum(rmultinom(1,1,typepvec)*types)
}

mctype <- function(tpdata,tpvec){ # substitute missing type with random type
  tmp <- c()
  for (k in 1:length(tpdata)){
    if (is.na(tpdata[k])){
      tmp[k] <- rndtype(tpvec)
    } else {
      tmp[k] <- tpdata[k]
    }
  }
  return(tmp)
}

mctype1 <- function(oldtp,tpdata,tpvec){ # substitute 1 missing by random type
  tmp <- oldtp
  untyped <- which(is.na(tpdata))
  tmp[untyped[sample(1:length(untyped),1)]] <- rndtype(tpvec)
  return(tmp)
}

mctypemat <- function(mctp){
  typemat <- matrix(NA,ncol=length(mctp),nrow=length(mctp))
  for (i in 1:length(mctp)){
    for (j in 1:length(mctp)){
      typemat[i,j] <- ifelse((mctp[i]==1 & mctp[j]==1),1,0)
    }
  }
  return(typemat)
}


library(MASS)

p_h <- 0.97
h <- 6/(10^5)
p_hc <- 0.0009

hc <- 1 - h
pc_hc <- 1 - p_hc

p <- p_hc*hc + p_h*h
print(fractions(p))

h_p <- (p_h*h)/p
print(fractions(h_p))

# Parte 3

m_h <- 0.962
m_hc <- 0.527

f_h <- 1 - m_h
f_hc <- 1 - m_hc

p.m_h <- p_h*m_h
p.f_h <- p_h*f_h

h_p.m <- (p_h*m_h*h)/(p_h*m_h*h + p_hc*m_hc*hc)
h_p.f <- (p_h*f_h*h)/(p_h*f_h*h + p_hc*f_hc*hc)

print(fractions(h_p.m))
print(fractions(h_p.f))


0x2d7==727            # TRUE
identical(0x2d7, 727) # TRUE
is.numeric(727)       # TRUE
is.integer(727)       # FALSE
is.integer(727L)      # TRUE
is.numeric(0x2d7)     # TRUE
is.integer(0x2d7)     # FALSE
is.integer(0x2d7L)    # TRUE


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)


# Ismail Sunni
rm(list = ls())  # Clear data

# Load library
library(splancs)
library(spatstat)
library(geojsonio)

# Set working directory
setwd("/home/ismailsunni/dev/r/eq-project")

# Data loading
path <- "eq-filtered.geojson"
eqsp <- geojson_read(path, what='sp')  # Read GeoJSON as SpatialPointsDataFrame
tail(eqsp)  # Show the content of the data
# eq <- as.ppp.SpatialPointsDataFrame(eq)  # Convert to ppp
eq <- as(eqsp, "ppp")  # Convert to ppp

# Boundary
bd <- readRDS("gadm36_IDN_0_sp.rds")

# Plot data and boundary
plot(bd, , main='Earthquake in Indonesia July 2014 - February 2019')  # Ploting boundary
plot(unmark(eq), add=TRUE, cex=2, col="red", pch=21)  # Ploting without marks

# Show the data
summary(eq)  # Show summary of the data
any(duplicated(eq))  # Check if there is a duplication
plot(unmark(eq), main='Earthquake in Indonesia')  # Ploting without marks
plot(eq, which.marks = 'depth', main='Earthquake in Indonesia (depth)', bg="red")  # Plot with depth
plot(bd, add=TRUE)
plot(eq, which.marks = 'magnitude', main='Earthquake in Indonesia (magnitude)')  # Plot with magnitude
plot(bd, add=TRUE)
plot(eq, which.marks = 'year', main='Earthquake in Indonesia (year)')  # Plot with year
plot(bd, add=TRUE)

# Density
plot(density(eq))
plot(bd, add=TRUE)

# Contour
contour(density(eq))
plot(bd, add=TRUE)

# Perspective
persp(density(eq), theta = 30, phi = 30)

# Showing per year
eq2015 = subset(eq, year==2015)
eq2016 = subset(eq, year==2016)
eq2017 = subset(eq, year==2017)
eq2018 = subset(eq, year==2018)

par(mfrow=c(2,2))
title <- 'Earthquake in Indonesia '
plot(unmark(eq2015), main=paste(title, '(2015)', eq2015$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2016), main=paste(title, '(2016)', eq2016$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2017), main=paste(title, '(2017)', eq2017$n, 'events'), bg="red", pch=21, cex=4) # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2018), main=paste(title, '(2018)', eq2018$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)

# Big earthquake
eqbig = subset(eq, magnitude>=6)
plot(unmark(eqbig), bg="red", pch=21, cex=4)
plot(bd, add=TRUE)

eq2015 = subset(eqbig, year==2015)
eq2016 = subset(eqbig, year==2016)
eq2017 = subset(eqbig, year==2017)
eq2018 = subset(eqbig, year==2018)

# Showing big earthquake per year
par(mfrow=c(2,2))
title <- 'Big Earthquake in Indonesia '
plot(unmark(eq2015), main=paste(title, '(2015)', eq2015$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2016), main=paste(title, '(2016)', eq2016$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2017), main=paste(title, '(2017)', eq2017$n, 'events'), bg="red", pch=21, cex=4) # Ploting without marks
plot(bd, add=TRUE)
plot(unmark(eq2018), main=paste(title, '(2018)', eq2018$n, 'events'), bg="red", pch=21, cex=4)  # Ploting without marks
plot(bd, add=TRUE)

# Showing big earthquake per year with magnitude
par(mfrow=c(2,2))
title <- 'Earthquake in Indonesia (magnitude)'
plot(eq2015, which.marks = 'magnitude', main=paste(title, '(2015)')  # Plot with magnitude
plot(eq2016, which.marks = 'magnitude', main=paste(title, '(2016)')  # Plot with magnitude
plot(eq2017, which.marks = 'magnitude', main=paste(title, '(2017)')  # Plot with magnitude
plot(eq2018, which.marks = 'magnitude', main=paste(title, '(2018)')  # Plot with magnitude

# Quadrat count
Q <- quadratcount(eq, nx=4, ny=3)
Q
plot(Q, cex=5)
plot(bd, , main='Earthquake in Indonesia July 2014 - February 2019', add=TRUE)  # Ploting boundary
plot(unmark(eq), add=TRUE, cex=2, col="red", pch=21)  # Ploting without marks

# Intensity
plot(intensity(Q, image=TRUE), main=NULL, las=1)  # Plot density raster
plot(unmark(eq), pch=20, cex=0.6, col=rgb(0,0,0,.5), add=TRUE)  # Add points

# Quadrat test CSR
M=quadrat.test(eq, nx=4, ny=3)
M
plot(bd, , main='Earthquake in Indonesia July 2014 - February 2019', add=TRUE)  # Ploting boundary
plot(unmark(eq), add=TRUE, cex=2, col="red", pch=21)  # Ploting without marks
plot(M, add=TRUE, cex=5)

# Distance test
G <- Gest(eq)
plot(G)

# Kest
K <- Kest(eq)
K
plot(K)

E <- envelope (eq, Kest, nsim=39)
E
plot(E)

# Kinhom
Ki <- Kinhom(eq)
Ki
plot(Ki)

Ei <- envelope (eq, Kinhom, nsim=39)
plot(Ei)

# Area Interaction
x = ppm(unmark(eq), ~1, AreaInter(r=1))


scenario <- 1

source(paste("data_regression_NIG_scenario_", scenario, ".r", sep = ""))
summary(lm(y_0 ~ -1 + X_0))

library(npowerPrioR)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling from the "prior"

prior <- stan_model("stan/simple_linear_regression_NIG_prior.stan")

lm.data <- list(
  N0 = N_0,
  P = P,
  X0 = X_0,
  y0 = y_0,
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  a_0 = NULL
)
#########
J <- 20
maxA <- 1
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10, stan.list = lm.data, pars = c("beta", "sigma_sq"))
)
## Exporting
write.csv(adaptive.ca0.estimates$result, row.names = FALSE,
          file = paste("../data/constant_data/RegressionNIG_logCA0_adaptive_J=", J,"_scenario_", scenario, ".csv",  sep = ""))

save(adaptive.ca0.estimates,
     file = paste("../data/constant_data/RegressionNIG_priorParameterEstimates_adaptive_J=", J,"_scenario_", scenario, ".RData",  sep = ""))


#' 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)
}


# 4. faza: Napredna analiza podatkov

source("lib/libraries.r")

#####################################LINEARNA REGRESIJA#######################################################

data.za.analizo <- zemljisca.in.zivina %>% filter(regija %in% c("lj", "nm", "mb", "ms", "kp", "kr"))

g <- ggplot(data.za.analizo, aes(x=skupno.stevilo.zemljisc, y=skupno.stevilo.zivine)) + geom_point() +
  labs(title = "Relacija med številom živine in površino kmetijskih zemljišč") + xlab("Površina zemljišč") + ylab("Število živine") +
  theme(plot.title = element_text(hjust=0.5, size=15),
        axis.line = element_line(colour = "purple",
                                 size = 1, linetype = "solid"))

lin <- lm(data=data.za.analizo, skupno.stevilo.zivine ~ skupno.stevilo.zemljisc)
lin
napovedi <- predict(lin, data.frame(skupno.stevilo.zemljisc=seq(0, 250000, 5000)))

g + geom_line(data = data.frame(skupno.stevilo.zemljisc=seq(0, 250000, 5000), napovedi = napovedi),
              aes(x = skupno.stevilo.zemljisc, y = napovedi), col = "violet")

kv <- lm(data=data.za.analizo, skupno.stevilo.zivine ~ I(skupno.stevilo.zemljisc^2))
kv
g + geom_smooth(method="lm", formula = y ~ x + I(x^2), color="violet")

z <- lowess(data.za.analizo$skupno.stevilo.zemljisc, data.za.analizo$skupno.stevilo.zivine)
g + geom_line(data=as.data.frame(z), aes(x=x, y=y), color="violet")

mls <- loess(data=data.za.analizo, skupno.stevilo.zivine ~ skupno.stevilo.zemljisc)
g + geom_smooth(method="loess", color = "violet")

sapply(list(lin, kv, mls, z), function(x) mean((x$residuals^2)))

#Ugotovim kateri model ima najmanjšo napako in tega potem izberem.
which.min(sapply(list(lin, kv, mls), function(x) mean((x$residuals^2))))

analiziran.graf <- g + geom_smooth(method="loess", formula = y ~ x, color = "violet")

#######################################RAZVRŠČANJE V SKUPINE ######################################################
## Z METODO VODITELJEV

set.seed(123)

data.za.razvrscanje <- merge(x = zemljisca.in.zivina, y = imena.regij.nazaj, by = "regija", all.x = TRUE) %>%
  dplyr::select(regija = oznaka, leto, skupno.stevilo.zemljisc, skupno.stevilo.zivine, zivina.na.ha) %>%
  filter(regija != "SLOVENIJA", leto == 2007) %>% dplyr::select(-leto)

data.za.razvrscanje.norm <- data.za.razvrscanje %>% dplyr::select(-regija) %>% scale()
rownames(data.za.razvrscanje.norm) <- data.za.razvrscanje$regija

skupine <- kmeans(data.za.razvrscanje.norm, 5, nstart=1000)
skupine$tot.withinss

skupine.zemljevid <- data.frame(regija = data.za.razvrscanje$regija,
                                Skupina = factor(skupine$cluster))

tmap_mode("plot")

clustering.zemljevid <- tm_shape(merge(zemljevid.regije, skupine.zemljevid, by.x = "NAME_1", by.y = "regija")) + tm_polygons("Skupina", popup.vars = c("Skupina " = "Skupina"), title="Skupina") +
  tm_layout(
    "Razvrstitev regij v skupine glede na št. zemljišč \n in živine v 2007 ",
    legend.title.size=1,
    legend.text.size = 0.8,
    legend.position = c("right","bottom"),
    legend.bg.color = "white",
    legend.bg.alpha = 1)


# 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)
}


#' Seasonal data.frames optimisation function
#'
#' This function allows to optimise the time series seasonal data, based on the stationarity tests' results.
#' It is an extention of test.df() function.
#'
#' @param datax A data.frame of seasonal data to be studied of length equal to explicative variable vector. The first column is advised to be year and the second to be "M" for monthly data, or "T" for trimestrial data.
#' @param season An indicator of seasonality type to be used as present in the data.frame.
#'
#' @return A data.frame with test results by variable.
#'
#' @keywords optimise.df test.df
#' @export
#' @examples
#' optimise.df = function(datax, season)
#'
#' @import tidyverse
#' @import tseries
#'
optimise.df = function(datax, season) {
    # Aux
    df =
        data.frame(matrix(NA, nrow = 3, ncol = ncol(datax)))
    # Identity
    colnames(df) = colnames(datax)
    rownames(df) = c("p-ADF", "p-KPSS.L", "p-KPSS.T")
    # Tests
    df[1,] = datax %>%
        lapply(function(x) tseries::adf.test(na.omit(x))$p.val) %>%
        unlist()
    df[2,] = datax %>%
        lapply(function(x) tseries::kpss.test(na.omit(x), null = "Level")$p.val) %>%
        unlist()
    df[3,] = datax %>%
        lapply(function(x) tseries::kpss.test(na.omit(x), null = "Trend")$p.val) %>%
        unlist()
    # Seasonality test
    if (season == "M") {
        m = datax %>%
            group_by(M) %>%
            summarise_all(function(x) mean(na.omit(x)))
        v = datax %>%
            group_by(M) %>%
            summarise_all(function(x) var(na.omit(x)))
        GM = datax %>%
            select(-M) %>%
            summarise_all(function(x) mean(na.omit(x)))
        GM = GM[rep(1, nrow(m)),]
        tm = round((m[,2:ncol(m)]-GM)/v[,2:ncol(v)], 4)
        tm = cbind(tm, M = m$M)
    } else if (season == "T") {
        m = datax %>%
            group_by(T) %>%
            summarise_all(function(x) mean(na.omit(x)))
        v = datax %>%
            group_by(T) %>%
            summarise_all(function(x) var(na.omit(x)))
        GM = datax %>%
            select(-T) %>%
            summarise_all(function(x) mean(na.omit(x)))
        GM = GM[rep(1, nrow(m)),]
        tm = round((m[,2:ncol(m)]-GM)/v[,2:ncol(v)], 4)
        tm = cbind(tm, T = m$T)
    } else {
        return(df)
        warning("No seasonal component to analyse")
    }
    df = dplyr::union(df, tm)
    # Transform
    tr = datax %>%
        mutate(t = 1:nrow(datax)) %>%
        na.omit()
    for (i in 3:ncol(df)) {
        if (df[2,i] < 0.1) {
            tr[,i] = tr[,i] - lm(tr[,i] ~ tr$t)$fit
            colnames(tr)[i] = paste0("d_", colnames(tr)[i])
        } else if (df[3,i] < 0.1) {
            tr[,i] = tr[,i] - mean(tr[,i])
            colnames(tr)[i] = paste0("L_", colnames(tr)[i])
        } else if (df[1,i] > 0.1) {
            tr[,i] = tr[,i] - lag(tr[,i])
            colnames(tr)[i] = paste0("T_", colnames(tr)[i])
        }
    }
    # Results
    res = list(test = df, data = tr)
    return(res)
}


devtools::load_all()

# examples for tau_star.r
k1 <- 4
ktau <- 4
m1 <- 4
mtau <- 4
y <- rnorm(200)
n1 <- f_n1(1:200, k1, m1)
beta <- rnorm(prod(ktau + mtau, k1 + m1))
til_beta <- tilde_beta(beta, k1 + m1)
m_sigma <- f_sigma(ktau + mtau, k1 + m1)
f_qscop(seq(0, 1, 0.1), n1, til_beta, m_sigma, ktau, mtau)
f_qscop(0, n1, til_beta, m_sigma, ktau, mtau) < f_qscop(1, n1, til_beta, m_sigma, ktau, mtau)

tilde_beta(beta, k1 + m1)

f_qscop(.5, t(n1[1, ]), til_beta, m_sigma, ktau, mtau)

f_qzeros(0.5, 2:3, y, n1, til_beta, m_sigma, ktau, mtau)

v_taus <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
sapply(1:200, function(x) {
        f_qscop(v_taus[x], t(n1[x, ]), til_beta, m_sigma, ktau, mtau)
}) - y

# examples for derivative.r
v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))

m_g1 <- f_g1(ktau, mtau)
m_g2 <- f_g2(ktau, mtau)
m_sigmatau <- f_sigmatau(ktau + mtau)

m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau)
m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)

v_lossderiv <- f_lossderiv(til_beta, c(ktau + mtau, k1 + m1), m_sigma, m_h1, m_h2)

f_grad(beta, v_lossderiv, m_s)
m_hess <- f_hess(v_lossderiv, c(ktau + mtau, k1 + m1), m_s)
MASS::ginv(m_hess)
## validate the integration
v_taus <- seq(0, 1, 0.001)
cbind(colMeans(diag(v_taus) %*% spline_basis(v_taus, ktau, mtau, c(1, 0))))

tcrossprod(m_g1, m_sigmatau) %*% (n_m2 - tcrossprod(m_g2, m_sigmatau) %*% n_m2)

# examples for criteria.r
## f_loss
f_loss(til_beta, v_taustar, y, m_sigma, m_h1, m_h2)
s_criteria <- f_criteria(beta, til_beta, v_taustar, y, m_sigma, m_h1, m_h2, m_s)

# examples for descent.r
devtools::load_all()
set.seed(202104)
k1 <- 11
ktau <- 2
m1 <- 4
mtau <- 3
n <- 400
v_dim <- c(ktau + mtau, k1 + m1)
v_x <- runif(n)
v_y <- log(v_x)
sigma <- 0.4 * (0.5 + v_x)
v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)
v_taus <- seq(0.05, 0.95, 0.15)
til_beta <- NULL

# v_beta <- rnorm(prod(v_dim))
# til_beta <- tilde_beta(v_beta, v_dim[2])
# init <- cq.reg(v_x, v_y, c("tesmi1", "ps"), "bfgs", c(5, 15))
# til_beta <- sum(init$coefficients[-1])
dev.new()
fit <- f_descent(v_y, v_x, c(ktau, k1), c(mtau, m1), til_beta,
        alpha = 0.1, bet = 0.1, v_smooth = c(1e-2, 1e-15, 1e-15),
        maxit = 100, eps = 1e-3, trace = seq(0.05, 0.95, 0.15)
)

# examples for bb-gd.r
fit <- f_bbgd(v_y, v_x, c(k1, k2), c(m1, m2), til_beta,
        v_smooth = c(10, 10, 10),
        maxit = 1, eps = 1e-4, trace = seq(0.05, 0.95, 0.15)
)

## f_newton
fit <- f_newton(v_y, v_x, c(k1, k2), c(m1, m2), NULL,
        alpha = 0.1, bet = 0.1, v_smooth = c(10, 10, 2),
        maxit = 100, thresh = 1e-3, trace = seq(0.05, 0.95, 0.15)
)

v_y <- sin(2 * pi * v_x)
v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)
fit <- f_descent(v_y, v_x, c(k1, k2), c(m1, m2), NULL,
        alpha = 0.2, bet = 0.1, v_smooth = c(10, 10, 2),
        maxit = 5, thresh = 1e-3, trace = v_taus
)

ptm <- proc.time() # Start the clock!
fit <- f_descent(v_y, v_x, c(k1, k2), c(m1, m2), NULL,
        alpha = 0.2, bet = 0.1, v_smooth = c(10, 10, 2),
        maxit = 100, thresh = 1e-3, trace = NULL
)
print(proc.time() - ptm) # Stop the clock

# examples for initial.r
devtools::load_all()
set.seed(202104)
k1 <- 4
k2 <- 4
m1 <- 4
m2 <- 4
n <- 400
v_x <- runif(n)
v_y <- log(v_x)
sigma <- 0.4 * (0.5 + v_x)
v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)
n1 <- f_n1(v_x, k1, m1)
m_sigma <- f_sigma(k1 + m1, k2 + m2)
m_s <- f_mats(k1 + m1, k2 + m2, rep(10, 3))
til_beta <- f_init(v_y, v_x, m_sigma, n1, c(k1, k2), c(m1, m2), m_s)

og_beta(til_beta, k1 + m1)

f_qscop(seq(0.05, 0.95, 0.15), n1, til_beta, m_sigma, k2, m2)

# examples for visualization.r
cq_prediction(0.1, fit, newdata = runif(10))
cq_plot(c(0.05, 0.25, 0.5, 0.75, 0.95), fit)

# examples for smoothQR.r
devtools::load_all()
set.seed(202104)
k1 <- 11
ktau <- 6
m1 <- 4
mtau <- 4
n <- 400
v_x <- runif(n)
v_y <- log(v_x)
sigma <- 0.4 * (0.5 + v_x)
v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)

# setup
v_dim <- c(ktau + mtau, k1 + m1)
n1 <- f_n1(v_x, k1, m1)
beta <- rnorm(prod(v_dim[1], v_dim[2]))
m_sigmatau <- f_sigmatau(v_dim[1])
m_g1 <- f_g1(ktau, mtau)
m_g2 <- f_g2(ktau, mtau)
# h1
m_h1 <- f_smoothh1(n1, m_g1, m_g2, m_sigmatau)
m_h0 <- m_h1$h0
m_h1 <- m_h1$h1

# htau #try sparse matrix
s_ntau <- 100
v_taus <- seq(0, 1, length.out = s_ntau)
m_ndesign <- kronecker(f_ntau(v_taus, ktau, mtau), n1)
m_sigma <- f_sigma(ktau + mtau, k1 + m1)
til_beta <- tilde_beta(beta, k1 + m1)
h <- max((((log(n) + 1) / n)^0.4), 0.05)

ptm <- proc.time() # Start the clock!

v_res <- f_smoothres(m_ndesign, v_y, m_sigma, til_beta, h)

print(proc.time() - ptm) # Stop the clock
# Using the Gaussian kernel
v_pres <- pnorm(v_res)
m_htau <- f_smoothhtau(m_ndesign, v_pres, s_ntau)
# deriv
loss_deriv <- f_smoothderiv(til_beta, v_dim, m_sigma, m_htau, m_h1)
# grad
m_s <- f_mats(v_dim[1], v_dim[2], rep(1, 3))
f_smoothgrad(beta, loss_deriv / n, m_s)
# loss
v_h0sig <- c(crossprod(m_h0, m_sigma))
f_smoothloss(v_res, v_pres, v_h0sig, til_beta, s_ntau, h)
f_smoothcrit(v_res, v_pres, v_h0sig, til_beta, beta, s_ntau, h, m_s)

# smoothdescent
devtools::load_all()
set.seed(202104)
k1 <- 11
ktau <- 2
m1 <- 4
mtau <- 3
n <- 400
v_x <- runif(n)
v_y <- log(v_x)
sigma <- 0.4 * (0.5 + v_x)
v_y <- v_y + rnorm(n, mean = rep(0, n), sd = sigma)

fit <- f_smoothbbgd(v_y, v_x, c(ktau, k1), c(mtau, m1),
        init = NULL,
        v_smooth = c(0.01, 0.01, 0.01),
        h = max((((log(length(v_y)) + 1) / length(v_y))^0.4), 0.05),
        s_ntau = 50,
        maxit = 50, eps = 1e-5, eta = 1e-8,
        trace = seq(0.05, 0.95, 0.15)
)

dev.new()

fit <- f_smoothdescent(v_y, v_x, c(ktau, k1), c(mtau, m1),
        init = NULL,
        alpha = 0.1, bet = 0.8,
        v_smooth = c(1e-3, rep(1e-2, 2)),
        h = max((((log(length(v_y)) + 1) / length(v_y))^0.4), 0.05),
        s_ntau = 100,
        maxit = 10, eps = 1e-5, eta = 1e-3,
        trace = seq(0.05, 0.95, 0.15)
)

dev.new()

ptm <- proc.time() # Start the clock!

regfit <- cq.reg(v_x, v_y,
        c("tedmi", "cr"),
        "bfgs", c(10, 15),
        span = 0.05, sp = c(2.593664e-7, 5.28e-10)
)

print(proc.time() - ptm) # Stop the clock

# qs.r
devtools::load_all()
set.seed(202106)
n <- 400
x <- sort(runif(n))
y <- obs_f(x, gmean = "log", xsig = "linear", derr = "norm")

regfit <- cq.reg(x, y,
        c("tedmi", "cr"),
        "bfgs", c(10, 15),
        span = 0.05, sp = c(2.593664e-7, 5.28e-10)
)
cq_regplot(regfit)

# quantile sheet
dev.new()
system.time(scam_fit <- qs_scam(x, y,
        maxit = 10, ntaus = 10,
        arg_bs = c("tesmi1", "cr"),
        opt = "nlm.fd", dims = c(5, 15), ords = NA,
        analysis = F, trace = T, tol = 1e-3
))
qs_loss(x, y, scam_fit)
cq_regplot(fit)

dev.new()
v_time <- system.time(gam_fit <- qs_gam(x, y,
        maxit = 50, ntaus = 10,
        dims = c(5, 15), ords = NA,
        analysis = F, trace = T, sp = c(0, 0), tol = 1e-3
))

## count crossings
ptm <- proc.time() # Start the clock!

ntest <- 1e3
lengthout <- 1e3
test_x <- seq(0, 1, length.out = ntest)
taus <- seq(0, 1, length.out = lengthout)
tau <- taus[cut(seq_len(ntest * lengthout), breaks = lengthout, labels = FALSE)]
dat <- data.frame(tau = tau, x1 = rep(test_x, lengthout))
v_pred <- predict(scam_fit, dat)
m_pred <- matrix(c(v_pred), nrow = lengthout, byrow = T)
# cq_regplot(gam_fit)
# for (i in seq_along(taus)) {
#         lines(test_x, m_pred[i, ])
# }
sum(apply(diff(m_pred) < 0, 1, fun <- function(x) {
        if (any(x)) {
                1
        } else {
                0
        }
}))

print(proc.time() - ptm) # Stop the clock

any(diff(m_pred) < 0)

# expectile sheet
dev.new()
es_fit <- es_scam(x, y,
        maxit = 10, ntaus = 10,
        arg_bs = c("tedmi", "ps"),
        opt = "efs", dims = c(5, 15), ords = NA,
        analysis = F, trace = T, sp = c(10, 1e-5)
)

dev.new()
es_fit <- es_gam(x, y,
        maxit = 50, ntaus = 30,
        dims = c(5, 15), ords = NA,
        analysis = F, trace = T, sp = NULL, tol = 1e-5
)

# examples in cross_valid
devtools::load_all()
set.seed(202106)
n <- 400
x <- sort(runif(n))
y <- obs_f(x, gmean = "log", xsig = "linear", derr = "norm")

v_spx <- 10^(-8:0)
v_taus <- 10^(-1)
system.time(cv_qs <- cv_qsscam(x, y, 5,
        v_spx, v_taus,
        maxit = 10, ntaus = 10,
        arg_bs = c("tesmi1", "cr"),
        opt = "nlm.fd", dims = c(5, 15), tol = 1e-2
))

scam_fit <- qs_scam(x, y,
        maxit = 10, ntaus = 10,
        arg_bs = c("tesmi1", "cr"),
        opt = "nlm.fd", dims = c(5, 15), ords = NA,
        analysis = F, trace = T, sp = c(.1, 1), tol = 1e-2
)


###########################################################################
########Chapter 5 - Introduction to Neural Networks - using R##############
##########R program to build, train and test neural networks###############
###########################################################################
library("neuralnet")
library("ISLR")

data = Auto
View(data)

plot(data$weight, data$mpg, pch=data$origin,cex=2)
par(mfrow=c(2,2))
plot(data$cylinders, data$mpg, pch=data$origin,cex=1)
plot(data$displacement, data$mpg, pch=data$origin,cex=1)
plot(data$horsepower, data$mpg, pch=data$origin,cex=1)
plot(data$acceleration, data$mpg, pch=data$origin,cex=1)

mean_data <- apply(data[1:6], 2, mean)
sd_data <- apply(data[1:6], 2, sd)

data_scaled <- as.data.frame(scale(data[,1:6],center = mean_data, scale = sd_data))
head(data_scaled, n=20)

index = sample(1:nrow(data),round(0.70*nrow(data)))
train_data <- as.data.frame(data_scaled[index,])
test_data <- as.data.frame(data_scaled[-index,])

n = names(data_scaled)
f = as.formula(paste("mpg ~", paste(n[!n %in% "mpg"], collapse = " + ")))

net = neuralnet(f,data=train_data,hidden=3,linear.output=TRUE)
plot(net)

predict_net_test <- compute(net,test_data[,2:6])
MSE.net <- sum((test_data$mpg - predict_net_test$net.result)^2)/nrow(test_data)

Lm_Mod <- lm(mpg~., data=train_data)
summary(Lm_Mod)
predict_lm <- predict(Lm_Mod,test_data)
MSE.lm <- sum((predict_lm - test_data$mpg)^2)/nrow(test_data)

par(mfrow=c(1,2))
plot(test_data$mpg,predict_net_test$net.result,col='black',main='Real vs predicted for neural network',pch=18,cex=4)
abline(0,1,lwd=5)
plot(test_data$mpg,predict_lm,col='black',main='Real vs predicted for linear regression',pch=18,cex=4)
abline(0,1,lwd=5)
###########################################################################


murders <- mutate(murders, rate = total/population*100000)

population_in_millions <- murders$population/10^6
total_gun_murders <- murders$total

plot(population_in_millions, total_gun_murders)

log10_pop <- log10(murders$population)
log10_murders <- log10(total_gun_murders)

plot(log10_pop, log10_murders)

hist(murders$rate)

boxplot(rate~region, data = murders)