# # This script was written by nicolas m. roberts, primarily using the geologyGeometry library of functions, written by Joshua R. Davis.
# # if you incounter bugs in the code, please inform nick at nmroberts@wisc.edu

### PRELIMINARY WORK ####

# Set the working directory.
setwd("~/Desktop/20170620geologyGeometry")

# [!!!] FOR WINDOWS: Set the working directory.
# setwd("C:/users/[Insert user name]/Desktop/20170620geologyGeometry")

# Load the necessary R libraries.
source("library/all.R")

# Load some custom functions
source("JSG_statsFunctions.r")

# #[!!!] Uncomment only if you have compiled C on your system and have the C libraries loaded at the top of this script. Uncomment and run the following line only if you have compiled C. # [!!!] Markov chain Monte Carlo and Kamb contouring in equal volume plots require C compiler. Skip MCMC and equal volume Kamb lines if you do not wish to install C. Load the necessary library
# source("libraryC/all.R")

#==========================LOAD THE DATA========================================

# Load the foliation-lineation data
Follins <- geoDataFromFile("data/Follins_Ahs.csv")

# Check how many measurements there are
nrow(Follins)

#==========================PLOT THE DATA========================================

# Plot foliation-lineation locations in map view
plot(
    Follins$easting,
    Follins$northing,
    xlab = "Easting (meters)",
    ylab = "Northing (meters)"
)

# Plot the data in Equal area plot. Pole to foliation (red), Lineation (cyan)
lineEqualAreaPlotTwo(lapply(Follins$rotation, function(s)
    s[1, ]),
    lapply(Follins$rotation, function(s)
        s[2, ]))

# Plot Follins in Equal Area plots with Kamb contours (numbers are 2 sigma values)
# Poles to foliation (circles)
lineKambPlot(lapply(Follins$rotation, function(s)
    s[1, ]), c(2, 6, 10, 14, 18))
# Lineations (squares)
lineKambPlot(lapply(Follins$rotation, function(s)
    s[2, ]),
    c(2, 6, 10, 14, 18),
    shapes = c("s"))

# Plot the Follins in an Equal Volume plot (after Davis and Titus, 2017)
oriEqualVolumePlot(
    Follins$rotation,
    group = oriLineInPlaneGroup,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = "black" ,
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Ahsahka_EqualVol1.png", "Ahsahka_EqualVol2.png")

# [!!!] Uncomment only if you have compiled C on your system and have the C libraries loaded at the top of this script.
# Skip if you have not compiled C. Plot 6-sigma Kamb contours for the data in an equal volume plot (after Davis and Titus, 2017)
# oricKambPlot(
#     Follins$rotation,
#     group = oriLineInPlaneGroup,
#     multiple = 6,
#     backgroundColor = "white",
#     curveColor = "black",
#     boundaryAlpha = 0.1,
#     colors = "black",
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none"
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("Ahsahka_Kamb_equalVol1.png", "Ahsahka_Kamb_EqualVol2.png")

#==========================IDENTIFY GEOGRAPHIC TRENDS========================================

# 1) Visually inspect the possibility of geographic trends in the data

# Plot foliation-lineation locations in map view, colored in gray-scale by northing. This shading will be used in the following plots.
plot(
    Follins$easting,
    Follins$northing,
    col = shades(Follins$northing),
    pch = 19
)

# Plot foliation-lineation orientations in an equal volume plot (after Davis and Titus, 2017)
oriEqualVolumePlot(
    Follins$rotation,
    group = oriLineInPlaneGroup,
    simplePoints = FALSE,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = shades(Follins$northing),
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Ahsahka_shadesNorthing_equalVol1.png",
                      "Ahsahka_shadesNorthing_EqualVol2.png")

# Plot foliation-lineation orientations colored by northing. Poles to foliation (circles), Lineation (squares)
lineEqualAreaPlot(
    c(
        lapply(Follins$rotation, function(s)
            s[1, ]),
        lapply(Follins$rotation, function(s)
            s[2, ])
    ),
    col = shades(Follins$northing),
    shapes = c(replicate(length(Follins$rotation), "c"), replicate(length(Follins$rotation), "s"))
)

#————————————————————————————————————————————————————————————

# 2) Run geodesic regressions to quantify any extant trends.

# Create a temporary version of the foliation lineation data and establish a geographic criteria that encompasses all the data.
FollinsAll <- Follins
AhsAllCrit <-
    FollinsAll$easting > 550000 & Follins$northing > 5140000
FollinsAll$domain <- replicate(nrow(FollinsAll), 1)
Follins$domain[AhsAllCrit] <- 1

# 2A) Perform a geodesic regression with respect to azimuths every 10 degrees on all data, using the geographic criteria defined above. Each regression asks the question: "does orientation change linearly with respect to an azimuth towards x degrees"
regressions <- regressionSweep(FollinsAll, 10, (AhsAllCrit), 0)

# Create a data frame that contains the summary information for the regressions
regressionsSum <- data.frame(regressions[[19]])

# Name the columns of the data frame
names(regressionsSum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# View the summary table for the output.
regressionsSum

# Plot the R^2 value as a function of Azimuth
plot(
    as.vector(regressionsSum$Azimuth),
    as.vector(regressionsSum$R_squared),
    xlab = "Azimuth",
    ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# 3) Run kernal regression to quantify any extant trends.

# Recategorize the symmetric copies of the data.
mu <- oriFrechetMean(Follins$rotation, group=oriLineInPlaneGroup)
Follins$rotation <- oriNearestRepresentatives(Follins$rotation, mu, group=oriLineInPlaneGroup)

# Define the bandwith for a kernal regression. If desired, uncomment the next line (it may take ~20 minutes to run). Otherwise, use the pre-calculated value, "bandwidth".
# bandwidth <- rotBandwidthForKernelRegression(Follins$northing,Follins$rotation)
bandwidth <- 0.02314421

# Perform a kernel regression with respect to northing. The kernel function is analogous to finding a best fit curve in 2D.
kernelReg <- lapply(
    seq(
        from = min(Follins$northing),
        to = max(Follins$northing),
        by = 100
    ),
    rotKernelRegression,
    Follins$northing,
    Follins$rotation,
    bandwidth,
    numSteps = 1000
)

# Filter the regression results to only keep those that give an error of 0 and minimum eigen value > 0
sapply(kernelReg, function(regr)
    regr$error)
sapply(kernelReg, function(regr) {
    regr$minEigenvalue > 0
})

# Plot the regression curve in an equal volume plot.
kernelRegCurve <- lapply(kernelReg, function(regr)
    regr$r)
oriEqualVolumePlot(
    kernelRegCurve,
    group=oriLineInPlaneGroup,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = "black",
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    simplePoints = TRUE
)

# Compute the R^2 for the kernel regression.
KernRsquared <-
    rotRsquaredForKernelRegression(Follins$northing, Follins$rotation, bandwidth, numSteps =
                                       1000)

# View the R^2 value
KernRsquared

# Do a permutation test for significance. This takes a significant amount of time (>>1 hr)
rSquareds <-
    rotKernelRegressionPermutations(Follins$northing, Follins$rotation, bandwidth, numPerms =
                                        1000)
length(rSquareds)
p <- sum(rSquareds > KernRsquared$rSquared)
p

#==========================DEFINE GEOGRAPHIC DOMAINS========================================

# Define geographic criteria, based on sampling area, with the proposed shear zone boundary into account.
domain1Crit <- Follins$easting < 560000 & Follins$northing < 5158000
domain2Crit <- (Follins$easting >= 560000 & Follins$northing < 5163000) | Follins$easting >= 565000
domain3Crit <- !(domain1Crit | domain2Crit)

# # Create a new column in the dataframe in which to store the domain information
Follins$domain <- replicate(nrow(Follins), 1)

# Classify the foliation-only dataset by domain
Follins$domain[domain1Crit] <- 1
Follins$domain[domain2Crit] <- 2
Follins$domain[domain3Crit] <- 3

# Plot the locations of the foliation-lineation data in map view, each domain a different color. Domain 1 (Red), Domain 2 (Green), Domain 3 (Blue)
plot(
    x = Follins$easting,
    y = Follins$northing,
    xlab = "Easting (meters)",
    ylab = "Northing (meters)",
    col = hues(Follins$domain),
    pch = 19
)

#==========================IDENTIFY GEOGRAPHIC TRENDS WITHIN DOMAINS========================================

# 1) Make sure each domain is roughly unimodal
#DOMAIN 1, n = 23.
oriEqualVolumePlot(
    Follins$rotation[domain1Crit],
    oriLineInPlaneGroup,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = "black",
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)

#[!!!] Uncomment only if you have compiled C on your system and have the C libraries loaded at the top of this script.
# oricKambPlot(
#     Follins$rotation[domain1Crit],
#     oriLineInPlaneGroup,
#     backgroundColor = "white",
#     curveColor = "black",
#     boundaryAlpha = 0.1,
#     colors = "black",
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none"
# )

#DOMAIN 2, n = 14.
oriEqualVolumePlot(
    Follins$rotation[domain2Crit],
    oriLineInPlaneGroup,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = "black",
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)

#[!!!] Uncomment only if you have compiled C on your system and have the C libraries loaded at the top of this script.
# oricKambPlot(
#     Follins$rotation[domain2Crit],
#     oriLineInPlaneGroup,
#     backgroundColor = "white",
#     curveColor = "black",
#     boundaryAlpha = 0.1,
#     colors = "black",
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none"
# )

#DOMAIN 3, n = 32.
oriEqualVolumePlot(
    Follins$rotation[domain2Crit],
    oriLineInPlaneGroup,
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.1,
    colors = "black",
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)
oriEqualVolumePlot(Follins$rotation[domain2Crit],
                   oriLineInPlaneGroup,
                   col = hues(Follins$easting[domain2Crit]))

#[!!!] Uncomment only if you have compiled C on your system and have the C libraries loaded at the top of this script.
# oricKambPlot(
#     Follins$rotation[domain2Crit],
#     oriLineInPlaneGroup,
#     backgroundColor = "white",
#     curveColor = "black",
#     boundaryAlpha = 0.1,
#     colors = "black",
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none"
# )

# Plot all the foliation data in an equal volume plot (after Davis and Titus, 2017), colored by domain. Domain 1 (red), Domain 2 (green), Domain 3 (blue)
oriEqualVolumePlot(
    Follins$rotation,
    oriLineInPlaneGroup,
    col = hues(Follins$domain),
    backgroundColor = "white",
    curveColor = "black",
    boundaryAlpha = 0.2,
    axesColors = c("black", "black", "black"),
    fogStyle = "none"
)

#————————————————————————————————————————————————————————————

# 2) Look for geographic patterns in plots.
#DOMAIN 1, n = 23. maybe a very faint rainbow--more like clumping of the dark blues together.
oriEqualVolumePlot(Follins$rotation[domain1Crit],
                   oriLineInPlaneGroup,
                   col = shades(Follins$northing[domain1Crit]))

#DOMAIN 2, n = 14. Part of the problem with small sample sizes--you can't really know whether the datapoints are independent...
oriEqualVolumePlot(Follins$rotation[domain2Crit],
                   oriLineInPlaneGroup,
                   col = shades(Follins$northing[domain2Crit]))

#DOMAIN 3, n = 32. No rainbow.
oriEqualVolumePlot(Follins$rotation[domain2Crit],
                   oriLineInPlaneGroup,
                   col = shades(Follins$easting[domain2Crit]))

#————————————————————————————————————————————————————————————

# 3) From visual inspection of the above plots, Domain 1 and Domain 3 potentially have geographic dependency. Perform regressions on these two domains.

#DOMAIN 1, n = 23. Perform a series of Geodesic Regressions for every 10° azimuth, with p-values not calculated.
regressionsD1 <- regressionSweep(Follins, 10, domain1Crit, 0)

# Create a dataframe with the summary information for the regressions
regressionsD1Sum <- data.frame(regressionsD1[[19]])

# Name the columns of the data frame
names(regressionsD1Sum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# View the summary table for the output.
regressionsD1Sum

# Plot the R^2 value as a function of Azimuth
plot(
    as.vector(regressionsD1Sum$Azimuth),
    as.vector(regressionsD1Sum$R_squared),
    xlab = "Azimuth",
    ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# Define the Azimuth with the highest R-squared value. (In this case, 130)
azimuthD1 <-
    Follins$easting[domain1Crit] * sin(130 * degree) + Follins$northing[domain1Crit] *
    cos(130 * degree)

# DOMAIN 1, n = 23. Define the bandwith for a kernal regression. If desired, uncomment the next line (it may take ~20 minutes to run). Otherwise, use the pre-calculated value, "bandwidthD1".
# bandwidthD1 <- rotBandwidthForKernelRegression(azimuthD1,Follins$rotation[domain1Crit])
bandwidthD1 <- 0.02202349

#Run the kernel regression
kernelRegD1 <- lapply(
    seq(
        from = min(azimuthD1),
        to = max(azimuthD1),
        by = 100
    ),
    rotKernelRegression,
    azimuthD1,
    Follins$rotation[domain1Crit],
    bandwidthD1,
    numSteps = 1000
)
sapply(kernelRegD1, function(regr)
    regr$error)
sapply(kernelRegD1, function(regr) {
    regr$minEigenvalue > 0
})

# Plot the regression curve
kernelRegCurveD1 <- lapply(kernelRegD1, function(regr)
    regr$r)
oriEqualVolumePlot(Follins$rotation[domain1Crit],
                   curves = list(kernelRegCurveD1),
                   simplePoints = TRUE, oriLineInPlaneGroup)

# Compute the R^2.
KernRsquaredD1 <-
    rotRsquaredForKernelRegression(azimuthD1, Follins$rotation[domain1Crit], bandwidthD1, numSteps =
                                       1000)
KernRsquaredD1

# Do a permutation test for significance.
rSquaredsD1 <-
    rotKernelRegressionPermutations(azimuthD1, Follins$rotation[domain1Crit], bandwidthD1, numPerms =
                                        1000)
length(rSquareds)
pD1 <- sum(rSquareds > KernRsquared$rSquared)

#the p-value for this regression.
pD1

#————————————————————————————————————————————————————————————

#Now do the same thing for Domain 3

#DOMAIN 3, n = 32. A series of Geodesic Regressions for every 10° azimuth, with p-values not calculated.
regressionsD3 <- regressionSweep(Follins, 10, domain3Crit, 0)

# Create a dataframe with the summary information for the regressions
regressionsD3Sum <- data.frame(regressionsD3[[19]])

# Name the columns of the data frame
names(regressionsD3Sum) = c("Azimuth", "Error", "Min_Eigen", "R_squared", "Pvalue")

# View the summary table for the output.
regressionsD3Sum

# Plot the R^2 value as a function of Azimuth
plot(
    as.vector(regressionsD3Sum$Azimuth),
    as.vector(regressionsD3Sum$R_squared),
    xlab = "Azimuth",
    ylab = "R-squared"
)

#————————————————————————————————————————————————————————————

# Define the Azimuth with the highest R-squared value. (In this case, 60)
azimuthD3 <-
    Follins$easting[domain3Crit] * sin(60 * degree) + Follins$northing[domain3Crit] *
    cos(60 * degree)

#DOMAIN 3, n = 32. Define the bandwith for a kernal regression. If desired, uncomment the next line (it may take ~20 minutes to run). Otherwise, use the pre-calculated value, "bandwidthD3".
# bandwidthD3 <-
#     rotBandwidthForKernelRegression(Follins$northing[domain3Crit], Follins$rotation[domain3Crit])
bandwidthD3 <- 0.1331092

#Run the kernel regression
kernelRegD3 <- lapply(
    seq(
        from = min(azimuthD3),
        to = max(azimuthD3),
        by = 100
    ),
    rotKernelRegression,
    azimuthD3,
    Follins$rotation[domain3Crit],
    bandwidthD3,
    numSteps = 1000
)
sapply(kernelRegD3, function(regr)
    regr$error)
sapply(kernelRegD3, function(regr) {
    regr$minEigenvalue > 0
})

# Plot the regression curve
kernelRegCurveD3 <- lapply(kernelRegD3, function(regr)
    regr$r)
oriEqualVolumePlot(Follins$rotation[domain3Crit],
                   curves = list(kernelRegCurveD3),
                   simplePoints = TRUE,
                   oriLineInPlaneGroup)

# Compute the R^2.
KernRsquaredD3 <-
    rotRsquaredForKernelRegression(azimuthD3, Follins$rotation[domain3Crit], bandwidthD3, numSteps = 1000)
KernRsquaredD3

# Do a permutation test for significance.
rSquaredsD3 <-
    rotKernelRegressionPermutations(Follins$northing[domain3Crit], Follins$rotation[domain3Crit], bandwidthD3, numPerms = 1000)
length(rSquareds)
pD3 <- sum(rSquareds > KernRsquaredD3$rSquared)

#the p-value for this regression.
pD3

##==========================STATISTICAL DESCRIPTORS========================================

# 1) Domain 1, n = 23

# Frechet mean (minimizes the Frechet variance).
FrechetMeanDom1 <-
    oriFrechetMean(Follins$rotation[domain1Crit], oriLineInPlaneGroup)
geoStrikeDipRakeDegFromRotation(FrechetMeanDom1)
FrechetVarDom1 <-
    oriVariance(Follins$rotation[domain1Crit], FrechetMeanDom1, oriLineInPlaneGroup)

# Plot the FrechetMean in an Equal Angle plot
FrechetCurvesDom1 <-
    lapply(Follins$rotation[domain1Crit], function(r)
        rotGeodesicPoints(FrechetMeanDom1, r, 10))
oriEqualAnglePlot(points = Follins$rotation[domain1Crit], curves = FrechetCurvesDom1, group = oriLineInPlaneGroup)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanDom1)

# Print the Frechet variance.
FrechetVarDom1

#————————————————————————————————————————————————————————————

# 2) Domain 2, n = 14
#Frechet mean minimizes the Frechet variance.
FrechetMeanDom2 <-
    oriFrechetMean(Follins$rotation[domain2Crit], oriLineInPlaneGroup)
geoStrikeDipRakeDegFromRotation(FrechetMeanDom2)
FrechetVarDom2 <-
    oriVariance(Follins$rotation[domain2Crit], FrechetMeanDom2, oriLineInPlaneGroup)

# Plot the FrechetMean in an Equal Angle plot
FrechetCurvesDom2 <-
    lapply(Follins$rotation[domain2Crit], function(r)
        rotGeodesicPoints(FrechetMeanDom2, r, 10))
oriEqualAnglePlot(points = Follins$rotation[domain2Crit], curves = FrechetCurvesDom2, oriLineInPlaneGroup)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanDom2)

# Print the Frechet variance
FrechetVarDom2

#————————————————————————————————————————————————————————————

# 3) Domain 3, n = 32
#Frechet mean minimizes the Frechet variance.
FrechetMeanDom3 <-
    oriFrechetMean(Follins$rotation[domain3Crit], oriLineInPlaneGroup)
geoStrikeDipRakeDegFromRotation(FrechetMeanDom3)
FrechetVarDom3 <-
    oriVariance(Follins$rotation[domain3Crit], FrechetMeanDom3, oriLineInPlaneGroup)

# Plot the FrechetMean in an Equal Angle plot
FrechetCurvesDom3 <-
    lapply(Follins$rotation[domain3Crit], function(r)
        rotGeodesicPoints(FrechetMeanDom3, r, 10))
oriEqualAnglePlot(points = Follins$rotation[domain3Crit], curves = FrechetCurvesDom3, oriLineInPlaneGroup)

# Print the Strike, Dip, Rake of the Frechet mean.
geoStrikeDipRakeDegFromRotation(FrechetMeanDom3)

# Print the Frechet variance.
FrechetVarDom3

#————————————————————————————————————————————————————————————

# 4) Dispersion of the data

#The standard way to get at dispersion is to compute the maximum matrix fisher likelihood. The matrix fisher distribution comprises a kind of "mean" and a positive definite symmetric matrix, which characterises the anisotropic dispersion.

# Redefine the rotations to be within one of the symmetric copies
mu <- oriFrechetMean(Follins$rotation, group = oriLineInPlaneGroup)
Follins$rotation <-
    oriNearestRepresentatives(Follins$rotation, mu, oriLineInPlaneGroup)

# Northern Domain, n = 16. Fisher maximum likelihood
mleDom1 <- rotFisherMLE(Follins$rotation[domain1Crit])
mleDom1
eigen(mleDom1$kHat, symmetric = TRUE, only.value = TRUE)$values

#Central Domain, n = 34. Fisher maximum likelihood
mleDom2 <- rotFisherMLE(Follins$rotation[domain2Crit])
mleDom2
eigen(mleDom2$kHat, symmetric = TRUE, only.value = TRUE)$values

#Southern Domain, n = 79. Fisher maximum likelihood
mleDom3 <- rotFisherMLE(Follins$rotation[domain3Crit])
mleDom3
eigen(mleDom3$kHat, symmetric = TRUE, only.value = TRUE)$values

#==========================INFERENCE========================================

# Here, we can perform some statistical techniques to use information about the samples (each domain) to compute a probability cloud of the mean of the population(s) from which those samples were taken.
# From numerical work in Davis and Titus (2017), MCMC will work the best for small sample sizes that have the matrix fisher anisotropy (eigenvalues) of (large, large, small). All four domains have this anisotropy, and have too few data points to use the (computationally quicker) bootstrapping method.

#We'll do both and compare.

# Compute the bootstrap cloud of means
Follins_domain1Boots <-
    oriBootstrapInference(Follins$rotation[domain1Crit], 10000, oriLineInPlaneGroup)
Follins_domain2Boots <-
    oriBootstrapInference(Follins$rotation[domain2Crit], 10000, oriLineInPlaneGroup)
Follins_domain3Boots <-
    oriBootstrapInference(Follins$rotation[domain3Crit], 10000, oriLineInPlaneGroup)

# [!!!] Requires C libraries to run.
# [!!!] Compute the Markov chain Monte Carlo cloud of means
# [!!!]Uncomment lines if you have compiled C on your computer and have loaded the C libraries at the top of this script.

# Follins_domain1MCMC <-
#     oricWrappedTrivariateNormalMCMCInference(Follins$rotation[domain1Crit],
#                                              group = oriLineInPlaneGroup,
#                                              numCollection = 100)
# Follins_domain2MCMC <-
#     oricWrappedTrivariateNormalMCMCInference(Follins$rotation[domain2Crit],
#                                              group = oriLineInPlaneGroup,
#                                              numCollection = 100)
# Follins_domain3MCMC <-
#     oricWrappedTrivariateNormalMCMCInference(Follins$rotation[domain3Crit],
#                                              group = oriLineInPlaneGroup,
#                                              numCollection = 100)

#————————————————————————————————————————————————————————————

# 1) Northern v. Central domains

# A) Using MCMC

# [!!!] Requires C libraries to run.
# Construct the 95% confidence ellipsoids from small triangles
# tris1_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain1MCMC$mBar,
#         Follins_domain1MCMC$leftCovarInv,
#         Follins_domain1MCMC$q095,
#         numNonAdapt = 4
#     )
# tris2_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain2MCMC$mBar,
#         Follins_domain2MCMC$leftCovarInv,
#         Follins_domain2MCMC$q095,
#         numNonAdapt = 4
#     )
#
# # Plot the MCMC comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#     points = c(Follins_domain1MCMC$ms, Follins_domain2MCMC$ms),
#     boundaryAlpha = .1,
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none",
#     background = "white",
#     triangles = c(tris1_MCMC, tris2_MCMC),
#     simplePoints = TRUE,
#     colors = c(replicate(length(
#         Follins_domain1MCMC$ms
#     ), "black"), replicate(
#         length(Follins_domain2MCMC$ms), "orange"
#     )),
#     group = oriTrivialGroup
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_Ahs_d1d2_1.png", "MCMC_WestMt_d1d2_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#     lapply(Follins_domain1MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain1MCMC$ms, function(s)
#         s[2, ])
# ),
# c(
#     lapply(Follins_domain2MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain2MCMC$ms, function(s)
#         s[2, ])
# ))

#....................................................................

# B) Using bootstrapping

# Construct the 95% confidence ellipsoids from small triangles
tris1_Boot <-
    rotEllipsoidTriangles(
        Follins_domain1Boots$center,
        Follins_domain1Boots$leftCovarInv,
        Follins_domain1Boots$q095,
        numNonAdapt = 4
    )
tris2_Boot <-
    rotEllipsoidTriangles(
        Follins_domain2Boots$center,
        Follins_domain2Boots$leftCovarInv,
        Follins_domain2Boots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
rotEqualAnglePlot(
    points = c(
        Follins_domain1Boots$bootstraps,
        Follins_domain2Boots$bootstraps
    ),
    triangles = c(tris1_Boot, tris2_Boot),
    boundaryAlpha = .1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_domain1Boots$bootstraps), "black"
    ), replicate(
        length(Follins_domain2Boots$bootstraps), "orange"
    ))
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_Ahs_d1d2_1.png", "Boots_Ahs_d1d2_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
    lapply(Follins_domain1Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain1Boots$bootstraps, function(s)
        s[2, ])
),
c(
    lapply(Follins_domain2Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain2Boots$bootstraps, function(s)
        s[2, ])
))

#————————————————————————————————————————————————————————————

# 2) Northern vs. Southern domains

# A) Using MCMC

# [!!!] Requires C libraries to run.
# Construct the 95% confidence ellipsoids from small triangles
# tris1_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain1MCMC$mBar,
#         Follins_domain1MCMC$leftCovarInv,
#         Follins_domain1MCMC$q095,
#         numNonAdapt = 5
#     )
# tris3_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain3MCMC$mBar,
#         Follins_domain3MCMC$leftCovarInv,
#         Follins_domain3MCMC$q095,
#         numNonAdapt = 5
#     )
#
# # Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#     points = c(Follins_domain1MCMC$ms, Follins_domain3MCMC$ms),
#     triangles = c(tris1_MCMC, tris3_MCMC),
#     boundaryAlpha = 0.1,
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none",
#     background = "white",
#     simplePoints = TRUE,
#     colors = c(replicate(length(
#         Follins_domain1MCMC$ms
#     ), "black"), replicate(length(
#         Follins_domain3MCMC$ms
#     ), "blue")),
#     group = oriTrivialGroup
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_Ahs_d1d3_1.png", "MCMC_Ahsd1d3_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#     lapply(Follins_domain1MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain1MCMC$ms, function(s)
#         s[2, ])
# ),
# c(
#     lapply(Follins_domain3MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain3MCMC$ms, function(s)
#         s[2, ])
# ))

#....................................................................

# B) Using bootstrapping
# Construct the 95% confidence ellipsoids from small triangles
tris1_Boot <-
    rotEllipsoidTriangles(
        Follins_domain1Boots$center,
        Follins_domain1Boots$leftCovarInv,
        Follins_domain1Boots$q095,
        numNonAdapt = 4
    )
tris3_Boot <-
    rotEllipsoidTriangles(
        Follins_domain3Boots$center,
        Follins_domain3Boots$leftCovarInv,
        Follins_domain3Boots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids.
rotEqualAnglePlot(
    points = c(
        Follins_domain1Boots$bootstraps,
        Follins_domain3Boots$bootstraps
    ),
    triangles = c(tris1_Boot, tris3_Boot),
    boundaryAlpha = .1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_domain1Boots$bootstraps), "black"
    ),
    replicate(
        length(Follins_domain3Boots$bootstraps), "blue"
    ))
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_Ahs_d1d3_1.png", "Boots_Ahs_d1d3_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
    lapply(Follins_domain1Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain1Boots$bootstraps, function(s)
        s[2, ])
),
c(
    lapply(Follins_domain3Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain3Boots$bootstraps, function(s)
        s[2, ])
))

#————————————————————————————————————————————————————————————

# 3) Central vs. Southern domains

# A) Using MCMC

# [!!!] Requires C libraries to run.
# Construct the 95% confidence ellipsoids from small triangles
# tris2_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain2MCMC$mBar,
#         Follins_domain2MCMC$leftCovarInv,
#         Follins_domain2MCMC$q095,
#         numNonAdapt = 4
#     )
# tris3_MCMC <-
#     rotEllipsoidTriangles(
#         Follins_domain3MCMC$mBar,
#         Follins_domain3MCMC$leftCovarInv,
#         Follins_domain3MCMC$q095,
#         numNonAdapt = 4
#     )
#
# # Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
# oriEqualAnglePlot(
#     points = c(Follins_domain2MCMC$ms, Follins_domain3MCMC$ms),
#     triangles = c(tris2_MCMC, tris3_MCMC),
#     boundaryAlpha = 0.1,
#     axesColors = c("black", "black", "black"),
#     fogStyle = "none",
#     background = "white",
#     simplePoints = TRUE,
#     colors = c(replicate(
#         length(Follins_domain2MCMC$ms), "orange"
#     ), replicate(length(
#         Follins_domain3MCMC$ms
#     ), "blue")),
#     group = oriTrivialGroup
# )
#
# # If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
# afterMaximizingWindow("MCMC_Ahs_d2d3_1.png", "MCMC_Ahs_d2d3_2.png")
#
# # Plot the MCMC comparison in an Equal Area plot
# lineEqualAreaPlotTwo(c(
#     lapply(Follins_domain2MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain2MCMC$ms, function(s)
#         s[2, ])
# ),
# c(
#     lapply(Follins_domain3MCMC$ms, function(s)
#         s[1, ]),
#     lapply(Follins_domain3MCMC$ms, function(s)
#         s[2, ])
# ))

#....................................................................

# B) Using bootstrapping

# Construct the 95% confidence ellipsoids from small triangles
tris2_Boot <-
    rotEllipsoidTriangles(
        Follins_domain2Boots$center,
        Follins_domain2Boots$leftCovarInv,
        Follins_domain2Boots$q095,
        numNonAdapt = 4
    )
tris3_Boot <-
    rotEllipsoidTriangles(
        Follins_domain3Boots$center,
        Follins_domain3Boots$leftCovarInv,
        Follins_domain3Boots$q095,
        numNonAdapt = 4
    )

# Plot the bootstrap comparison in an equal Volume plot, with 95% confidence ellipsoids
oriEqualAnglePlot(
    points = c(
        Follins_domain2Boots$bootstraps,
        Follins_domain3Boots$bootstraps
    ),
    triangles = c(tris2_Boot, tris3_Boot),
    boundaryAlpha = 0.1,
    axesColors = c("black", "black", "black"),
    fogStyle = "none",
    background = "white",
    simplePoints = TRUE,
    colors = c(replicate(
        length(Follins_domain1Boots$bootstraps), "orange"
    ), replicate(
        length(Follins_domain3Boots$bootstraps), "blue"
    )),
    group = oriTrivialGroup
)

# If you wish to save this figure, maximize the plot window on your screen before running this line. It will save to your working directory folder.
afterMaximizingWindow("Boots_Ahs_d2d3_1.png", "Boots_Ahs_d2d3_2.png")

# Plot the bootstrap comparison in an Equal Area plot
lineEqualAreaPlotTwo(c(
    lapply(Follins_domain2Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain2Boots$bootstraps, function(s)
        s[2, ])
),
c(
    lapply(Follins_domain3Boots$bootstraps, function(s)
        s[1, ]),
    lapply(Follins_domain3Boots$bootstraps, function(s)
        s[2, ])
))


pdf_file<-"pdf/lorenzcurves_lc_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=8)

par(mfcol=c(1,2),mai=c(0.25,0.25,0.25,0.25),omi=c(1.25,0.5,1.25,0.5),pin=c(4.5,4.5),cex=1.3,family="Lato Light",las=1,family="Lato Light")
library(Hmisc)
library(ineq)

# Read data and prepare chart

myData<-spss.get("myData/AEQU+.por",use.value.labels=T)
x2008<-subset(myData$EQINCOM1,myData$EQINCOM1 > 0 & myData$V2 == "STUDIEN-NR. 4600")
Lc.Eplus2008<-Lc(x2008)
x1988<-subset(myData$EQINCOM1,myData$EQINCOM1 > 0 & myData$V2 == "STUDIEN-NR. 1670")
Lc.Eplus1988<-Lc(x1988)
x<-Lc.Eplus1988$p
y<-Lc.Eplus1988$L

# Create chart

source("scripts/inc_plot_lorenz.r")
x<-Lc.Eplus2008$p
y<-Lc.Eplus2008$L
source("scripts/inc_plot_lorenz.r")

# Titling

mtext("Lorenz Curve of Income Distribution in 1988 and 2008",3,line=1.5,adj=0,cex=1.85,family="Lato Black",outer=T)
mtext("German General Social Survey",3,line=-0.5,adj=0,cex=1.85,font=3,outer=T)
mtext("Source: GESIS ZA 4600, ZA 1670",1,line=2,adj=1,cex=1.05,font=3,outer=T)
dev.off()


### Selecionando variáveis de um dataframe pelo nome

# select variables v1, v2, v3
myvars <- c("v1", "v2", "v3")
newdata <- mydata[myvars]

### Selecionando variáveis de um dataframe por índice e intervalo.

# another method
myvars <- paste("v", 1:3, sep="")
newdata <- mydata[myvars]

# select 1st and 5th thru 10th variables
newdata <- mydata[c(1,5:10)]

### Removendo variáveis de um dataframe usando vetor de booleans

# exclude variable v2 in v1, v2, v3
newdata <- mydata[c(TRUE, FALSE, TRUE)]

### Removendo variáveis de um dataframe indicando o índice da coluna

# exclude 3rd and 5th variable
newdata <- mydata[c(-3,-5)]

### Removendo variáveis de um dataframe atribuindo NULL à coluna (apaga a coluna)

# delete variables v3 and v5
mydata$v3 <- mydata$v5 <- NULL

### Selecionando observações de um dataframe segundo as linhas do dataset

# first 5 observations
newdata <- mydata[1:5,]

### Selecionando observações de um dataframe segundo o valor dos campos

# based on variable values
newdata <- mydata[ which(mydata$gender=='F' & mydata$age > 65),]

### Selecionando observações de um dataframe usando subset

# using subset function
newdata <- subset(mydata, age >= 20 | age < 10,
select=c(ID, Weight) )

# using subset function (part 2)
newdata <- subset(mydata, sex=='m' & age > 25,
select=weight:income)

### Ordenando um dataframe

# sort by mpg and cyl
newdata <- mtcars[order(mtcars$mpg, mtcars$cyl),]

#sort by mpg (ascending) and cyl (descending)
newdata <- mtcars[order(mtcars$mpg, -mtcars$cyl),]

### Adicionando colunas um dataframe. É feito juntando-se dois dataframes por meio de uma ou mais variáveis em comum (semelhante à um inner join)
# <novo.frame> <- merge(<frameA>, <frameB>, by="VAR" )

### Adicionando linhas à um dataframe. Junta-se dois dataframes verticalmente desde que possuam as mesmas variáveis
# <novo.frame> <- rbind(<frameA>, <frameB>)

# merge two data frames by ID and Country
total <- merge(data frameA,data frameB,by=c("ID","Country"))

### Agregando dados um dataframe e retorna sumário estatístico da agregação

# <resultado> <- aggregate(<dataframe>, by=list(<VARS>), fun=<função> )

# aggregate data frame mtcars by cyl and vs, returning means for numeric variables
attach(mtcars)
aggdata <-aggregate(mtcars, by=list(cyl,vs), FUN=mean, na.rm=TRUE)
print(aggdata)
detach(mtcars)


source("./utils.r")
comm.set.seed(1234, diff=TRUE)

x = ranshaq(rnorm, m.local, n, local=TRUE)

if (storage == "float")
{
  suppressMessages(library(float, quietly=TRUE))
  x = shaq(fl(DATA(x)))
}

princomp = function(x)
{
  d = eigen(cov(x), only.values=TRUE)$values
  comm.print(c(d[1], d[length(d)]))
}

time = comm.timer(princomp(x))
comm.print(time)

finalize()


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script is called by the file .... which reproduces the modelling results
# shown in Supplementary Fig. 5 of the article.
#
# This file plots the model results.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# increased exponentially during the simulation to account for increases in
# propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
# Five scenarios were simulated assuming different increases in the rate of
# introduction (constant, linear or exponential increase, related to import
# volumes or the number of founded botanic gardens).
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

x11(width=12,height=6)
layout(matrix(c(1:15),nr=3))
op <- par(oma=c(0,4,1,1),mar=c(3,2,0.5,0.5),las=1,cex=0.9,mgp=c(2.5,0.35,0),tck=-0.02,xaxs="i",yaxs="i")

### constant propagule pressure ############################################################
## load data
all_main <- read.table("SimInvAcc_VarMain_allmain_const.csv",sep=";",header=T)
axis1 <- read.table("SimInvAcc_VarMain_axis1_const.csv",sep=";",header=T)
timeaxis <- read.table("SimInvAcc_VarMain_timeaxis_const.csv",sep=";",header=T)
m <- read.table("SimInvAcc_VarMain_PropPress_const.csv",sep=";",header=T)
isl_agg <- read.table("SimInvAcc_VarMain_island_const.csv",sep=";",header=T)
realtime <- read.table("SimInvAcc_VarMain_realtime_const.csv",sep=";",header=T)

# plot panels a-b
run_tot <- dim(all_main)[2]
matplot(axis1,all_main,type="p",log="yx",pch=1,cex=0.7,col=rainbow(run_tot,start=0,end=4/6),lty=1,ylab="",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,4,1))
axis(2,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("a",side=3,adj=-0.23,line=0.5,font=2)
mtext("Constant",side=3,font=2,line=0.3)
mtext("Species",side=2,line=2,cex=0.9,las=0)
mtext("Mainland",side=2,las=0,cex=1,font=2,line=4)

plot(timeaxis[,1],m[,1],xlim=c(0,max(timeaxis)),ylim=c(0,1),xlab="",ylab="",type="l")
mtext("Simulation time",side=1,line=1.4)
mtext("b",side=3,adj=-0.23,line=0.5,font=2)
mtext("Probability",side=2,line=2,cex=0.9,las=0)
mtext("Translocation",side=2,las=0,cex=1,font=2,line=4)

matplot(realtime,isl_agg,type="l",xlim=c(0,max(timeaxis)),ylim=c(0,max(isl_agg)),col=rainbow(run_tot,start=0,end=4/6),lty=1,xlab="",ylab="")
mtext("Simulation time",side=1,line=1.4)
mtext("c",side=3,adj=-0.23,line=0.5,font=2)
mtext("First record rate",side=2,line=2,cex=0.9,las=0)
mtext("Island",side=2,las=0,cex=1,font=2,line=4)

### linear increase in propagule pressure ###########################################################
# load data
all_main <- read.table("SimInvAcc_VarMain_allmain_lininc.csv",sep=";",header=T)
axis1 <- read.table("SimInvAcc_VarMain_axis1_lininc.csv",sep=";",header=T)
timeaxis <- read.table("SimInvAcc_VarMain_timeaxis_lininc.csv",sep=";",header=T)
m <- read.table("SimInvAcc_VarMain_PropPress_lininc.csv",sep=";",header=T)
isl_agg <- read.table("SimInvAcc_VarMain_island_lininc.csv",sep=";",header=T)
realtime <- read.table("SimInvAcc_VarMain_realtime_lininc.csv",sep=";",header=T)

# plot panels d-f
run_tot <- dim(all_main)[2]
matplot(axis1,all_main,type="p",log="yx",pch=1,cex=0.7,col=rainbow(run_tot,start=0,end=4/6),lty=1,ylab="",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,4,1))
axis(2,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("d",side=3,adj=-0.16,line=0.5,font=2)
mtext("Linear increase",side=3,font=2,line=0.3)

plot(timeaxis[,1],m[,1],xlim=c(0,max(timeaxis)),ylim=c(0,1),xlab="",ylab="",type="l")
mtext("Simulation time",side=1,line=1.4)
mtext("e",side=3,adj=-0.16,line=0.5,font=2)

matplot(realtime,isl_agg,type="l",xlim=c(0,max(timeaxis)),ylim=c(0,max(isl_agg)),col=rainbow(run_tot,start=0,end=4/6),lty=1,xlab="",ylab="")
mtext("Simulation time",side=1,line=1.4)
mtext("f",side=3,adj=-0.16,line=0.5,font=2)

## exponential increase in propagule pressure ##############################################################
# load data
all_main <- read.table("SimInvAcc_VarMain_allmain_exp.csv",sep=";",header=T)
axis1 <- read.table("SimInvAcc_VarMain_axis1_exp.csv",sep=";",header=T)
timeaxis <- read.table("SimInvAcc_VarMain_timeaxis_exp.csv",sep=";",header=T)
m <- read.table("SimInvAcc_VarMain_PropPress_exp.csv",sep=";",header=T)
isl_agg <- read.table("SimInvAcc_VarMain_island_exp.csv",sep=";",header=T)
realtime <- read.table("SimInvAcc_VarMain_realtime_exp.csv",sep=";",header=T)

# plot panels g-i
run_tot <- dim(all_main)[2]
matplot(axis1,all_main,type="p",log="yx",pch=1,cex=0.7,col=rainbow(run_tot,start=0,end=4/6),lty=1,ylab="",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,4,1))
axis(2,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("g",side=3,adj=-0.16,line=0.5,font=2)
mtext("Exponential increase",side=3,font=2,line=0.3)

plot(timeaxis[,1],m[,1],xlim=c(0,max(timeaxis)),ylim=c(0,1),xlab="",ylab="",type="l")
mtext("Simulation time",side=1,line=1.4)
mtext("h",side=3,adj=-0.16,line=0.5,font=2)

matplot(realtime,isl_agg,type="l",xlim=c(0,max(timeaxis)),ylim=c(0,max(isl_agg)),col=rainbow(run_tot,start=0,end=4/6),lty=1,xlab="",ylab="")
mtext("Simulation time",side=1,line=1.4)
mtext("i",side=3,adj=-0.16,line=0.5,font=2)

### increase in propagule pressure related to trade ####################################################
# load data
all_main <- read.table("SimInvAcc_VarMain_allmain_trade.csv",sep=";",header=T)
axis1 <- read.table("SimInvAcc_VarMain_axis1_trade.csv",sep=";",header=T)
timeaxis <- read.table("SimInvAcc_VarMain_timeaxis_trade.csv",sep=";",header=T)
m <- read.table("SimInvAcc_VarMain_PropPress_trade.csv",sep=";",header=T)
isl_agg <- read.table("SimInvAcc_VarMain_island_trade.csv",sep=";",header=T)
realtime <- read.table("SimInvAcc_VarMain_realtime_trade.csv",sep=";",header=T)

# plot panels j-l
run_tot <- dim(all_main)[2]
matplot(axis1,all_main,type="p",log="yx",pch=1,cex=0.7,col=rainbow(run_tot,start=0,end=4/6),lty=1,ylab="Species",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,4,1))
axis(2,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("j",side=3,adj=-0.23,line=0.5,font=2)
mtext("Trade",side=3,font=2,line=0.3)

plot(timeaxis[,1],m[,1],xlim=c(1800,2010),ylim=c(0,0.8),xlab="",ylab="",type="l")
mtext("Simulation time",side=1,line=1.4)
mtext("k",side=3,adj=-0.23,line=0.5,font=2)

matplot(realtime,isl_agg,type="l",ylim=c(0,max(isl_agg)),col=rainbow(run_tot,start=0,end=4/6),xlim=c(1800,2000),lty=1,xlab="",ylab="Accumulation rate")
mtext("Simulation time",side=1,line=1.4)
mtext("l",side=3,adj=-0.23,line=0.5,font=2)

### increase in propagule pressure related to the number of botanic gardens ########################################
# load data
all_main <- read.table("SimInvAcc_VarMain_allmain_botgar.csv",sep=";",header=T)
axis1 <- read.table("SimInvAcc_VarMain_axis1_botgar.csv",sep=";",header=T)
timeaxis <- read.table("SimInvAcc_VarMain_timeaxis_botgar.csv",sep=";",header=T)
m <- read.table("SimInvAcc_VarMain_PropPress_botgar.csv",sep=";",header=T)
isl_agg <- read.table("SimInvAcc_VarMain_island_botgar.csv",sep=";",header=T)
realtime <- read.table("SimInvAcc_VarMain_realtime_botgar.csv",sep=";",header=T)

# plot panels m-o
run_tot <- dim(all_main)[2]
matplot(axis1,all_main,type="p",log="yx",pch=1,cex=0.7,col=rainbow(run_tot,start=0,end=4/6),lty=1,ylab="",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,4,1))
axis(2,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("m",side=3,adj=-0.2,line=0.5,font=2)
mtext("Botanic gardens",side=3,font=2,line=0.3)

plot(timeaxis[,1],m[,1],xlim=c(1800,2010),ylim=c(0,0.25),xlab="",ylab="",type="l")
mtext("Simulation time",side=1,line=1.4)
mtext("n",side=3,adj=-0.2,line=0.5,font=2)

matplot(realtime,isl_agg,type="l",ylim=c(0,max(isl_agg)),col=rainbow(run_tot,start=0,end=4/6),xlim=c(1800,2000),lty=1,xlab="",ylab="")
mtext("Simulation time",side=1,line=1.4,cex=0.9)
mtext("o",side=3,adj=-0.2,line=0.5,font=2)

par(op)

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_Plot.r


library(gdalUtils)
library(raster)
## For reprojecting and resampling a raster
# An example of using gdalwarp

# read in one of the UW rasters for reference information
UW_FCID <- raster("../../../CBI_Unshared_Work/CARBCAT Development/Data/UW Modeled Biomass Resource/Treatment Tiffs/Remove100Percent.tif")

# get desired crs projection
UW_crs <- as.character(crs(UW_FCID))

# get desired extent
UW_ext <- bbox(extent(UW_FCID))

# get desired pixel cell size
tr <- c(30, 30)

# Reproject the FCCS raster using nearest neighbor (should preserve values).

gdalwarp(srcfile = "climate_adair.tif", # source raster
        dstfile = "climate.tif", # destination (what the new raster will be called and where to save it)
         tr = tr, # output resolution
         r = "near", # resampling method (this is nearest neighbor which preserves values
                    # 'bilinear' would produce a mean value)
         t_srs = UW_crs, # target spatial reference system
         te = c(UW_ext), # target extent
         overwrite=TRUE) #

## note, I have definitely used this to upsample rasters to a higher resolution. I took
## a 4km x 4km raster of CA up to 30m x 30m and it was a difference of 125kb to 4.5 gb


#  Paste into R
setwd("~/Desktop/sip/data/")
data3.df<-read.csv("happy.csv")
reg <- lm(Y~X.1+X.2+X.3+X.4+X.5,data=data3.df)
plot(reg$fitted,reg$resid,type="n",main="Happy Birthday")
points(reg$fitted,reg$resid,pch=16)
#  :-)


births <- read.table('birth.txt',header=T)

# There is a durbin-watson test function in both the car and lmtest
#   libraries.
# I don't have any experience with either, so I can't make a
#   recommendation.

# regression with ar(1) errors.  Requires the nlme library.

library(nlme)

birth.ar <- gls(netherlands~year,data=birth,corr=corAR1(0,~1))

# gls() is the generalized least squares estimation function
# corAR1() specifies an ar(1) correlation.
#  The first value  is the initial value for the ar(1) correlation.
#    This is iteratively updated, so in a well-behaved problem,
#    the choice doesn't matter.
# The second specifies the time variable and optionally groups
#    of independent obs.  If obs are in time order ~1 suffices.

# gls() does not provide the Kenward-Rogers adjustments, so the
#  results will be somewhat different from SAS

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/births3.r


#summarises annual climate maps (produced by agricultureMap_future.r or agricultureMap.r)
#mean, median, max, min, sd, q5, q95 of DEF, PET Temp, pptn, Di by RCP and Year

rm(list = ls())
library(raster)

#function to clip raster to specified states (specified in states_ls list)
clipStates <- function(inRaster, statemap, states_ls)
{
  #substitute values so that only specified states have data
  #first create the data frame
  mdf <- data.frame()
  for(m in seq_along(states_ls)) {
    if(m == 1) {
      mdf <- data.frame(a=states_ls[m], b=1)
    }  else  {
      mdf <- rbind(mdf, c(states_ls[m], 1))
    }
  }
  #now subs in the statemap
  statemap <- subs(x=statemap, y=mdf, by=1, which=2, subsWithNA=T)

  #trim so that statemap is extent of masked data
  smaskmap <- trim(statemap)

  #crop pl stack to extent of crop map
  inRaster <- crop(inRaster, smaskmap)

  #mask to extent of desired states
  inRaster <- mask(inRaster, smaskmap)

  return(inRaster)

}

#directory in which to read the data
inputDir <- "Data/FutureClimate/agriCapital/"
outputFn <- "ClimateSummaryData_51.csv"

#specify states to plot (for all states provide empty list)
#states <- c()  #all states
states <- c(51) #MT

#raster of stateIDs
statemap <- raster(paste0(inputDir,"sim10_BRstates_latlon_5km.asc"))

#list of variables to summarise
Variables <- c("DEF", "PET", "Temperature", "Precipitation", "DrynessIndex")

#create output dataframe
df <- data.frame(
  Year=integer(),
  RCP=integer(),
  Variable=character(),
  mean=double(),
  median=double(),
  sd=double(),
  min=double(),
  max=double(),
  q05=double(),
  q95=double()
  )

#loop over rcps
for(rcp in c(45,85)){
  #loop over years
  for(year in 2015:2017){

    print(paste0("rcp ", rcp, ", year ", year))

    #loop over variables
    for(var in Variables){

      #read raster
      ras <- raster(paste0(inputDir,"Annual",var,"_rcp",rcp,"_",year,".asc"))

      #mask if specific states are desired
      if(!is.null(states)){
        ras <- clipStates(ras, statemap, states) }

      #calc summary stats
      meanStat <- round(cellStats(ras, stat='mean', na.rm=T, asSample=F), 3)
      medianStat <- round(quantile(ras, probs=c(0.50), na.rm=T, names=F), 3)
      sdStat <- round(cellStats(ras, stat='sd', na.rm=T, asSample=F),4)
      minStat <- round(cellStats(ras, stat='min', na.rm=T, asSample=F), 3)
      maxStat <- round(cellStats(ras, stat='max', na.rm=T, asSample=F), 3)
      q.05 <- round(quantile(ras, probs=c(0.05), na.rm=T, names=F), 3)
      q.95 <- round(quantile(ras, probs=c(0.95), na.rm=T, names=F), 3)

      #bind to datafram
      yr <- data.frame(Year=year, RCP=rcp, Variable=var, mean=meanStat, median=medianStat, sd=sdStat, min=minStat, max=maxStat, q05=q.05, q95=q.95)
      df <- rbind(df, yr)

    }
  }
}

#write data to file (overwrites if exists)
write.csv(df, paste0(inputDir,outputFn), row.names=F, quote=F)


s = sample(1:150,120)

train = iris[s,]
test = iris[-s,]

model = randomForest(Species~Sepal.Length+Sepal.Width+Petal.Length+Petal.Width,data =train)
print(model)
plot(model)
pred = predict(model,test)
print(pred)
print(table(pred))
#p1 = addmargins(table(pred,iris$Species))
#print(p1)


#Jenny Smith

#march 30, 2017
#Purpose: Create a list of survival analyses and Given survival package Survfit() object, plot the survival curves and calculate the P values for differences in survival.

SurvObjects <- function(df, colNames, group, rho=0, time=NULL,ref=NULL){
  #df is the dataframe with clinical data.
  #colnames is a character vector (length 2) with the colnames of the time and event, in that order.
  #group is the column name as character vector of the explanatory variable to test
  #time is optional if you need to convert days to years for example.
  #rho is 1 or 0 or inbetween. 0=logrank test and 1=gehan-wilcoxon test

  require(survival)
  require(survMisc)

  #optional time unit conversion
  if (is.null(time)){
    time <- (df[[colNames[1]]])
  }else if (time == "DtoY"){
    time <- (df[,colNames[1]]/365)
  }else if (time == "MtoY"){
    time <- (df[,colNames[1]]/12)
  }

  #Kaplan Meier Estimates
  KM <- Surv(time = time, event = df[[colNames[2]]])

  if (group == 1){
    #model fit
    survFit <- survfit(KM ~ 1)
    return(survFit)

  }else{

    if (!is.null(ref)){
      df[,group] <- relevel(as.factor(df[,group]), ref=ref)
    }

    #model fit
    survFit <- survfit(KM ~ df[,group], data=df)

    #cox proportional Hazards
    cph.test <- coxph(KM ~ df[,group])

    #test proportional hazards assumption
    cph.zph <- cox.zph(cph.test, transform = "km")
    rhoPval <- as.data.frame(cph.zph$table)$p #test the PH assumption

    if (length(rhoPval) > 1){
      rhoPval <- rhoPval[length(rhoPval)]
    }

    # survMisc compare stat tests for two curves
    tne <- ten(eval(survFit$call$formula), data=df)
    capture.output(comp(tne)) -> allTests

    if (rhoPval >= 0.05 ){
      attr(tne, "lrt")[1,] -> pVal #log-rank test
      test <- "log.rank"
    }else if (rhoPval < 0.05){
      attr(tne, "lrt")[2, ] -> pVal #Gehan-Breslow-Wilcoxon
      test <- "Gehan.Breslow.Wilcoxon"
    }

    list <- list(survFit, pVal, cph.test, cph.zph, KM)
    names(list) <- c("survFit", test, "CoxPH", "PH_Test","KaplanMeirerEst")
    return(list)
  }
}

#Survival plot without gridlines.
SurvivalPlot <- function(fit, LegendTitle, timeUnit,include.censored=TRUE, colors,pval=NULL,max.year=NULL){
  #fit the output of the survFit() function.
  #legend title is a character vector which will be the plot legend title.
  #timeUnit is a character vector for the follow-up time in days, years, months etc.
  #colors is a character vector the same length as the number of groups.
  #max.year is the time (singe numeric) in years to end the plot at.
  #pval is string (charcter or numeric) of the p-value

  require(survival)
  library(ggplot2)
  library(GGally)

  if(is.null(pval)){
    pval <- ""
  }else{
    pval <- paste0("p = ",pval)
  }

  if(!is.null(max.year)){
    # if(max(fit$time) < max.year){
    pos.x <- max.year
    # }
  }else{
    pos.x <- max(fit$time)
  }

  if(is.null(fit$strata)){
    lm <- 1 #left margin (lm)
    rm <- 4  #right margin(rm)
    num.cols <- 1
    num.rows <- 1

    #main survival plot
    p <- ggsurv(fit, surv.col = colors,
                cens.col=colors, CI=FALSE,
                lty.est = 1, size.est = 1.0,
                cens.size = 2.0,order.legend=FALSE)

  }else{

    m <- max(nchar(gsub("^.+\\=(.+)", "\\1", names(fit$strata)))) #maximum number of characters
    d <- length(fit$strata) #how many groups
    lm <- case_when(m <= 2 ~ 0.90,
                    m <= 5 ~ 1.25,
                    m > 5 & m <= 9 ~ 1.7,
                    m > 9 & m < 13 ~ 2.6,
                    m >= 13 & m < 17 ~ 3.4,
                    m >= 17 & m < 21 ~ 5.0,
                    m >= 21 & m < 23 ~ 6.0,
                    m >= 23 & m < 25 ~ 6.5,
                    m >= 25 ~ 7.5)#left margin (lm)
    # print(c("km.plot", lm))
    rm <- case_when(d <= 4 ~ 1.5, d > 4 ~ 2.0) #right margin(rm)
    num.cols <- 2
    num.rows <- 2

    if(d > 4 & d < 7){
      num.rows <- 3
    }else if(d > 7 & d <= 18){
      num.cols <- 3
      num.rows <- 6
    }else if(d > 18){
      num.cols <- 5
      num.rows <- 5
    }

    if(num.cols*num.rows < d){
      num.rows <- 10
    }

    #main survival plot
    p <- ggsurv(fit, plot.cens=include.censored,
                surv.col = colors, CI=FALSE,
                lty.est = 1, size.est = 1.0,
                cens.size = 2.0,order.legend=FALSE)
  }

  #customize the plot
  p <- p +
    labs(y= "Fraction Surviving", x = paste(timeUnit, "Follow-up")) +
    scale_y_continuous(limits = c(0,1),
                       breaks = seq(0,1,0.2),
                       minor_breaks = NULL) +
    scale_x_continuous(limits = c(0,pos.x),
                       breaks = seq(0,pos.x, 2)) +

    theme(plot.title = element_text(hjust = 0.5, size=10),
          panel.background = element_rect(fill="white"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_rect(colour = "black", fill= NA, size=1.0),

          axis.text = element_text(colour = "black"),
          axis.text.y = element_text(size = 12),
          axis.text.x = element_text(size=12),
          axis.title = element_text(size = 12),
          legend.position = "top",
          legend.direction  = "horizontal",
          legend.margin = margin(0,0,0,0, unit = "pt"),
          legend.text = element_text(size=10),
          legend.title = element_text(size=10),
          legend.key=element_blank()) +

    theme(plot.margin = margin(0, rm,.5,lm,unit="cm")) +
    annotate(geom="text", x=1, y=0.05, label=pval, size=5) +
    guides(color=guide_legend(ncol=num.cols, nrow=num.rows))

  if (length(colors) > 1){
    p$scales$scales[[1]]$name <- LegendTitle
    p$scales$scales[[2]]$name <- LegendTitle
  }

  return(p)
}

#risk table dataframe
risk.table <- function(survFit.obj, f.levels=NULL,
                       times=NULL,col="black",
                       ret.data=FALSE, max.year=NULL){
  #survFit.obj is the results  survfit()
  #f.levels is an optional character vector to relevel the order of the groups, if desired. else levels is alphabetical
  #times would be a seperate numeric vector, with years/x-axis breaks points, if desired.

  if(!is.null(max.year)){
    # if (max(survFit.obj$time) < max.year){
      times <- seq(0,max.year, by= 2)
      xlims <- max.year
    # }
  }else{
    times <- seq(0,max(survFit.obj$time), by= 2)
    xlims <- max(survFit.obj$time)
  }

  #Summary dataframe with the selected time points to get % OS/ EFS for plot x-axis
  summ <- summary(survFit.obj, times=times, extend=TRUE)

  if(is.null(f.levels)){
    f.levels <- unique(as.character(summ$strata)) %>%
      gsub("^.+\\=(.+)", "\\1", .)
  }

  #Create a new dataframe to hold the time,KM estimate and strata for plotting
  risk.df <- bind_cols(list(time=summ$time,
                            surv=summ$surv,
                            n.risk=summ$n.risk,
                            Group=as.character(summ$strata))) %>%
    set_colnames(c("time","surv","N.Risk","Group")) %>%
    mutate(Group=gsub("^.+\\=(.+)", "\\1", Group),
           Group=factor(Group, levels = f.levels))

  if(ret.data){
    return(risk.df)
  }

  #variable for deciding length of margins. longer group names would need more space.
  m <- max(nchar(levels(risk.df$Group))) # print(c("length:", m))
  d <- length(levels(risk.df$Group))
  lm <- case_when(m <= 5 ~ 1.75,
                  m > 5 & m <= 9 ~ 1.00,
                  m > 9 & m <= 10 ~ 1.00,
                  m > 10 & m < 13 ~ 1.10,
                  m >= 13 ~ 1.20)

  rm <- case_when(d <= 5 ~ 1.5,
                  m > 5 ~ 2.0)

  #gglot the risk table (risk.df)
  tbl <- ggplot(risk.df, aes(x = time, y = Group, label=N.Risk)) +
    geom_text(size = 5)  +
    theme_bw()  +
    scale_x_continuous("Number at risk",
                       limits = c(0,xlims),
                       breaks = times) +
    xlab(NULL) +
    ylab(NULL) +
    theme(panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_blank(),
          legend.position="none",
          axis.line = element_line(size=0.7, color="black"),
          axis.title.x = element_text(size=12),
          axis.ticks.x = element_blank(),
          axis.title.y = element_blank(),
          axis.text.x = element_blank(),
          axis.text.y = element_text(face="bold",
                                     size=12,
                                     color= col[levels(risk.df$Group)],
                                     hjust=1)) +
    #of note: this margin is still not perfect..... the size of window in Rstudio is different than what actually shows up on the tiff...
    theme(plot.margin = margin(-1.5, rm, 0.1, lm, unit="cm"))

  return(tbl)
}

##The function below added 10/2/17
KM.plots <- function(df, group_vars=NULL, type="OS",
                     covariate,
                     cohort,cc=NULL,
                     riskTable=TRUE,
                     f.levels=NULL,
                     max.year=NULL,
                     custom_cols=NULL,
                     include.censored=TRUE){
  library(dplyr)
  library(tibble)
  library(survival)
  library(magrittr)
  library(tidyr)
  suppressPackageStartupMessages(require(gridExtra))

  #df is the cleaned CDE with patient IDs as rownames.
  #group_vars is a character vector of a column name to group_by() in dplyr.
  #type is "OS" for OS/EFS or "EOI" for end of induction time points
  #covariate is a character string for the column in CDE to be the explanatory variable
  #cohort is for "0531" or "1031" (different colnames)

  #Define KM estimates for survival analysis
  if (cohort == "0531" & type=="OS"){
    os.est <- "Surv(Overall.Survival.Time.in.Days/365.25, OS.ID)"
    efs.est <- "Surv(Event.Free.Survival.Time.in.Days/365.25, Event.ID)"
  }else if (cohort == "1031" & type=="OS"){
    os.est <- "Surv(OS.time..days./365.25, OS.ID)"
    efs.est <- "Surv(EFS.time..days./365.25, Event.ID)"
  }else if (cohort == "TCGA" & type=="OS"){
    os.est <- "Surv(OS.months..3.31.12/12, clinData1.vital_status)"
    efs.est <- "Surv(EFS.months....3.31.12/12, first.event)"
  }else if (cohort=="BEAT_AML" & type=="OS"){
    os.est <- "Surv(OverallSurvival_VIZOME/365.25, OS.ID)"
    #No EFS data available
  }else if (type=="EOI"){
    if(is.null(custom_cols)){message("Need custom columnames for time and event for EOI analyses.
                                     Custom calls must a list of 2 names os.est and efs.est containing vector of
                                     time column in days and event.type indicator column as 0,1 in that order.");
      return(custom_cols)}
    os.est <- paste0("Surv(",custom_cols[["os.est"]][1],"/365.25",", ",custom_cols[["os.est"]][2], ")")
    efs.est <- paste0("Surv(",custom_cols[["efs.est"]][1],"/365.25",", ",custom_cols[["efs.est"]][2], ")")
  }

  #function for colors
  colorcodes <- function(df,covariate){
    strata <- unlist(unique(df[,covariate])) #Unique groups (strata)
    strata <- strata[order(strata)] #ensure the alphabetical order
    len <- length(strata)

    if ( ! is.null(cc)){
      return(cc)

    }else{
      colors <- c("dodgerblue4", "brown3", "darkgoldenrod3",
                  "deepskyblue1",
                  "azure4", "darkmagenta",
                  "turquoise4", "green4",
                  "deeppink", "navajowhite2","chartreuse2","lightcoral",
                  "mediumorchid", "saddlebrown", "#466791","#60bf37","#953ada",
                  "#4fbe6c","#ce49d3","#a7b43d","#5a51dc",
                  "#d49f36","#552095","#507f2d","#db37aa",
                  "#84b67c","#a06fda","#df462a","#5b83db",
                  "#c76c2d","#4f49a3","#82702d","#dd6bbb",
                  "#334c22","#d83979","#55baad","#dc4555",
                  "#62aad3","#8c3025","#417d61","#862977",
                  "#bba672","#403367","#da8a6d","#a79cd4",
                  "#71482c","#c689d0","#6b2940","#d593a7","#895c8b","#bd5975")
      cc <- NULL
      for ( i in 1:len){
        c <- colors[i]
        cc <- c(cc,c)
      }
      names(cc) <- strata
      return(cc)
    }
  }

  #Formula for KM curves
  OS.form <- as.formula(paste(os.est,' ~ ',covariate))

  #perform survival analysis for all factor levels
  grouped.df <-  df %>%
      group_by(!!! rlang::syms(group_vars)) %>%
      do(OS.cox=coxph(OS.form, data = .),
         OS.fit=survfit(OS.form, data=.),
         OS.diff=survdiff(OS.form, data=.), #survdiff for log-rank p-value
         OS=SurvivalPlot(survfit(OS.form, data=.), #survival plots
                         LegendTitle = covariate,
                         timeUnit = "Years",
                         max.year = max.year,
                         include.censored=include.censored,
                         colors =  colorcodes(.,covariate = covariate)))

    if(exists("efs.est")){
      #Formula for EFS KM curves
      EFS.form <- as.formula(paste(efs.est,' ~ ', covariate))

      grouped.df.efs <-  df %>%
        group_by(!!! rlang::syms(group_vars)) %>%
        do( EFS.cox=coxph(EFS.form, data = .),
            EFS.fit=survfit(EFS.form, data=.),
            EFS.diff=survdiff(EFS.form, data=.), #survdiff for log-rank p-value
            EFS=SurvivalPlot(survfit(EFS.form, data=.),
                             LegendTitle= covariate,
                             timeUnit= "Years",
                             max.year = max.year,
                             include.censored=include.censored,
                             colors= colorcodes(., covariate = covariate)))

      grouped.df <- bind_cols(grouped.df, grouped.df.efs)
    }

    #Denote the grouping variable in the results dataframe
    if(is.null(group_vars)){
      grouped.df <- add_column(grouped.df, Group="AML",.before = 1)
    }else{
      col.idx <- which(colnames(grouped.df)=="OS.cox")-1
      grouped.df <- unite(grouped.df,
                          "Group",1:all_of(col.idx), remove = FALSE, sep=" in ")
    }

  #function to calculate a p-value
  pvalue <- function(survdiff.res){
    p <- pchisq(survdiff.res$chisq, df=length(survdiff.res$n) - 1, lower=FALSE)
    p <- ifelse(p < 0.001, "p < 0.001", paste0("p = ", round(p, digits = 3)))
    return(p)
  }

  #Function to extract N of cohort.
  groupSize <- function(survdiff.res){paste0("N = ", sum(survdiff.res$n))}

  #Update the survial plots with an informative title and p values, and group N
  types <- c("Relapse", "Failure", "OS", "EFS")
  plots <- which(colnames(grouped.df) %in% types)

  #for each row (nrow > 1, when grouping variable given)
  for ( i in 1:nrow(grouped.df)){

    #for each OS/EFS column
    for (plot.idx in plots){
      fit.idx <- plot.idx-2
      fit <- grouped.df[[fit.idx]][[i]]
      summ <- summary(fit)
      median.surv <- summ$table[,"median"]
      x_pos <- ifelse(min(median.surv,na.rm=T) < 1, max(summ$time,na.rm = T), 1)
      y_pos <- ifelse(min(median.surv, na.rm=T) < 1, 0.95, 0.05)

      idx.logrank <- plot.idx-1
      N <- groupSize(grouped.df[[idx.logrank]][[i]])
      pval <- pvalue(grouped.df[[idx.logrank]][[i]]) %>%
        paste(.,N, sep="\n")

      #Add Main Title that is the column name (eg Relapse,OS, EFS, etc) and grouping factors
      grouped.df[[plot.idx]][[i]]$labels$title <- paste(names(grouped.df[plot.idx]),
                                                        grouped.df[["Group"]][i],
                                                        sep = ": ")

      #Add P value and the N
      grouped.df[[plot.idx]][[i]] <- grouped.df[[plot.idx]][[i]] +
        annotate(geom="text", x=x_pos, y=y_pos, label=pval, size=5) +
        theme(plot.title = element_text(face="bold"))

      #Add a risk table (Number of patients at risk at each time )
      if(riskTable){

        risk.tab <- risk.table(survFit.obj = fit,
                               ret.data = TRUE)
        risk.tab.p <- risk.table(survFit.obj = fit,
                                 col = cc,
                                 f.levels = f.levels,
                                 max.year=max.year)

        # Create a blank plot for place-holding
        blank.pic <- ggplot(risk.tab, aes(time, surv)) +
          geom_blank() +
          theme_bw() +
          theme(axis.text.x = element_blank(),
                axis.text.y = element_blank(),
                axis.title.x = element_blank(),
                axis.title.y = element_blank(),
                axis.ticks = element_blank(),
                panel.grid = element_blank(),
                panel.border = element_blank())

      # grid.arrange(grouped.df[[plot.idx]][[i]], blank.pic, risk.tab.p, clip = FALSE, nrow = 3,
      #                    ncol = 1, heights = unit(c(2, .1, .25), c("null", "null", "null")))

       grouped.df[[plot.idx]][[i]] <-  arrangeGrob(grouped.df[[plot.idx]][[i]],
                                                   blank.pic, risk.tab.p,
                                                   clip = FALSE,
                                                   nrow = 3, ncol = 1,
                                                   heights = unit(c(2, .2, .4),
                                                                  c("null", "null", "null")))

      }
    }
  }

  return(grouped.df)
}

#Function to save the outputs from KM.plots()
saveMultiPlots <- function(KM.plots.res,w=8,h=5){
  #This is for the relapse results from KM.plots()

  N <- nrow(KM.plots.res)

  covar <- function(i){
    names(KM.plots.res[grep("diff",colnames(KM.plots.res))][[i,1]]$n) %>%
      str_split_fixed(.,pattern="=",n=2) %>% .[,1] %>% unique()
  }

  name <- function(i){paste(KM.plots.res[[1]][i],covar(i),col,"KMplot.tiff", sep="_")}
  cols <- grep("diff",colnames(KM.plots.res), value = TRUE, invert = TRUE)[-1]

  for (col in cols){
    lapply(1:N, function(x) ggsave(filename = name(x),
                                   plot = KM.plots.res[[col]][[x]],
                                   device = "tiff",
                                   width = w,
                                   height = 5,
                                   dpi=600))

  }
}

#Added from LSC17  Analysis  on July 12, 2017.
weibull.HR <- function(weibull.mod){
  #weibull.mod is the output of survreg(, dist="wiebull")
  # multivar is a numeric vector idicating the indices of multi varaite analysis to be returned.
  if (is.null(multivar)){
    idx <- 2 #univariate analysis
  }else{
    idx <- 2:length(weibull.mod$coefficients)
  }
  HR <- round(exp(weibull.mod$coefficients*-1*1/weibull.mod$scale)[idx], digits = 3)
}

#Added from LSC17  Analysis  on July 12, 2017.
parametricSumaryTable <- function(survreg.res){
  summ <- summary(survreg.res)
  table <- as.data.frame(summ$table)

  # coef <- summ$coefficients[which(! grepl("Int", names(summ$coefficients)))]
  idx <- which( ! grepl("Int|Log", names(survreg.res$coefficients)))

  UCI_HR2 <- round(exp((survreg.res$coefficients[idx] - 1.96*table$`Std. Error`[idx])*-1*1/survreg.res$scale),
                   digits = 3)
  LCI_HR2 <- round(exp((survreg.res$coefficients[idx]  + 1.96*table$`Std. Error`[idx])*-1*1/survreg.res$scale),
                   digits=3)

  HR <- round(exp(survreg.res$coefficients[idx]*-1*1/survreg.res$scale), digits = 3)
  CI <- paste(LCI_HR2, UCI_HR2, sep="-")
  pVal <- round(table$p[idx], digits=3)

  stats <- data.frame(HR, CI,pVal)
  colnames(stats) <- c("Hazard Ratio", "95% Confidence Interval", "P-value")
  return(stats)
}

#Added from LSC17 Multivariate Analysis  on June 24th, 2017.
coxSummaryTable <- function(coxph.res,Colname="Group"){
  c.mod <- coxph.res
  c.summ <- summary(coxph.res)
  c.table <- as.data.frame(c.summ$coefficients) %>% cbind(.,as.data.frame(c.summ$conf.int))
  # c.table
  c.HR <- round(c.table$`exp(coef)`, digits=3)
  c.CI <- paste(round(c.table$`lower .95`,digits=3),round(c.table$`upper .95`, digits = 3), sep="-")
  c.pVal <- round(c.table$`Pr(>|z|)`, digits=3)

  comp <- gsub("^.+(Yes|No|Unknown|High|Low)", "\\1",names(c.mod$coefficients))
  c.stats <- data.frame(names(c.mod$coefficients) ,comp, c.HR, c.CI, c.pVal)
  colnames(c.stats) <- c("Variable", Colname,"Hazard Ratio", "95% Confidence Interval", "P-value")
  # rownames(c.stats) <- names(c.mod$coefficients)

  return(c.stats)
}

#functions to calculate the p-value for differnces in KM curves from survdiff() function
#Tests if there is a difference between two or more survival curves using the G-rho family of tests, or for a single curve against a known alternative.
calc_KMcurve_pvalues <- function(survdiff, digits=3){
  p <-  pchisq(survdiff$chisq, length(survdiff$n)-1,
              lower.tail = FALSE) %>%
    round(.,  digits = digits)

  return(p)
}

#create a table with OS/EFS percent at specified time point
#uses the summary() function on the survfit() object
#can optionally input p-values manually from survdiff() function
outcome_table <- function(fit, time=5, pvalues=NULL){

  summ <- summary(fit, times=time)
  type <- ifelse(any(grepl("OS", summ$call)),"OS","EFS")
  summ <- summ[!grepl("table|std.chaz|call", names(summ))]
  summ <- summ[sapply(summ,length)==length(summ$strata)]

  surv_col <- paste("Percent", type)
  n <- length(summ$strata)

  tab <- tibble(as.data.frame(summ)) %>%
    mutate_at(vars(surv,lower,upper,std.err), ~round(.*100, digits = 2)) %>%
    mutate(Group=str_split_fixed(strata, pattern = "=", n=2)[,2])

  if(!is.null(pvalues) & length(pvalues) < n){
    pval_ref <- NA #ref is the first position in the strata
    pvalues=c(pval_ref, pvalues) #must be in same order as strata in the survift()!
    tab <- tab %>%
      add_column(pvalue=pvalues)

    tab <- tab %>%
      select(Group,
             "Number Patients per Group"=n,
             "Time (years)"=time,
             !!surv_col := surv,
             "Lower 95% CI"=lower,
             "Upper 95% CI"=upper,
             "Standard Error"=std.err,
             "p-value"=pvalue)
  } else{

    tab <- tab %>%
      select(Group,
             "Number Patients per Group"=n,
             "Time (years)"=time,
             !!surv_col := surv,
             "Lower 95% CI"=lower,
             "Upper 95% CI"=upper,
             "Standard Error"=std.err)

  }

  return(tab)
}

# introduction This entire function was written by Lindsay Keegan based off
# a tutorial by Edwin Thoen posted here:
# http://www.r-statistics.com/2013/07/creating-good-looking-survival-curves-the-ggsurv-function/
# and slightly adapted by Avery McIntosh, 2015.
#See TCGA AML 05May2017.Rmd for example usage.
#S is the fit object
#NEEDS TO BE TESTED AGAIN

ggsurv.m <- function(s, CI = 'def', plot.cens = T, surv.col = 'gg.def',
                     cens.col = 'red', lty.est = 1, lty.ci = 2,
                     cens.shape = " ", back.white = F, xlab = 'Time (days)',
                     ylab = 'Retention Probability', main = '') {

  strata <- length(s$strata)
  n <- s$strata

  #update JS to deal with the super imposed curves to seq by 4 for 24 and split with comma
  groups <- factor(unlist(lapply(strsplit(names(s$strata),split = "=|,"),
                                 function(x) paste(x[2], x[4], sep="."))))

  gr.name <-  unlist(strsplit(names(s$strata), '='))[1] #LSC17
  gr.df <- vector('list', strata)
  ind <- vector('list', strata)
  n.ind <- c(0,n); n.ind <- cumsum(n.ind)

  for(i in 1:strata) ind[[i]] <- (n.ind[i]+1):n.ind[i+1]

  for(i in 1:strata){
    gr.df[[i]] <- data.frame(
      time = c(0, s$time[ ind[[i]] ]),
      surv = c(1, s$surv[ ind[[i]] ]),
      up = c(1, s$upper[ ind[[i]] ]),
      low = c(1, s$lower[ ind[[i]] ]),
      cens = c(0, s$n.censor[ ind[[i]] ]),
      group = rep(groups[i], n[i] + 1))
  }

  dat <- do.call(rbind, gr.df)
  dat.cens <- subset(dat, cens != 0)

  pl <- ggplot(dat, aes(x = time, y = surv, group = group)) +
    xlab(xlab) + ylab(ylab) + ggtitle(main) +
    geom_step(aes(col = group),lty=1, size=1.15) +
    geom_point(data = dat.cens, aes(x=time, y=surv, color=group), shape=3, size=4) +
    labs(y= "Fraction Surviving", x = paste("Follow-up in", "Years")) +
    theme(plot.title = element_text(hjust = 0.5, size=18),
          panel.background = element_rect(fill="white"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          axis.text.y = element_text(size = 16),
          axis.text.x = element_text(size=16),
          axis.title = element_text(size = 16),
          panel.border = element_rect(colour = "dark grey", fill= NA, size=1.0),
          legend.text = element_text(size=14),
          legend.title = element_text(size=14)) +
    scale_y_continuous(limits = c(0,1), breaks = seq(0,1,0.2), minor_breaks = NULL) +
    scale_x_continuous(limits = c(0,max(dat$time)), breaks = seq(0,max(dat$time), 2))

  # list <- list(n, groups, gr.name)
  # names(list) <- c("n", "groups", "gr.name")
  return(p1)

}

# KM.plots <- function(df, groupBy, type="OS", covariate,cohort,cc=NULL,
#                      riskTable=TRUE,f.levels=NULL, max.year=NULL){
#   library(dplyr)
#   library(survival)
#   library(magrittr)
#   suppressPackageStartupMessages(require(gridExtra))
#
#   #df is the cleaned CDE with patient IDs as rownames. stringsAsFactors=FALSE
#   #type is for relapse due to having strate with 0 members...
#   #covariate is a character string for the column in CDE to be the explanatory variable
#
#   #Formula for survival analysis
#   if (cohort == "0531"){
#     os.est <- "Surv(Overall.Survival.Time.in.Days/365.25, OS.ID)"
#     efs.est <- "Surv(Event.Free.Survival.Time.in.Days/365.25, Event.ID)"
#
#     OS.form <- as.formula(paste(os.est,' ~ ',covariate))
#     EFS.form <- as.formula(paste(efs.est,' ~ ', covariate))
#   }else if (cohort == "1031"){
#     os.est <- "Surv(OS.time..days./365.25, OS.ID)"
#     efs.est <- "Surv(EFS.time..days./365.25, Event.ID)"
#
#     #updated on 6/15/18 to reflect the new CDEs for 1031.
#     OS.form <- as.formula(paste(os.est, ' ~ ', covariate))
#     EFS.form <- as.formula(paste(efs.est, ' ~ ', covariate))
#   }
#
#   #function for colors
#   colorcodes <- function(df){
#     strata <- unlist(unique(df[,covariate])) #Unique groups (strata)
#     strata <- strata[order(strata)] #ensure the alphabetical order
#     len <- length(strata)
#
#     if ( ! is.null(cc)){
#       return(cc)
#
#     }else{
#       colors <- c("dodgerblue4", "firebrick1", "green4",  "darkorange",
#                   "turquoise3","azure4", "chartreuse1", "darkmagenta",
#                   "deeppink", "darkslategray1", "navajowhite2",
#                   "brown3", "darkgoldenrod3", "deepskyblue1", "lightcoral",
#                   "mediumorchid", "saddlebrown")
#       cc <- NULL
#       for ( i in 1:len){
#         c <- colors[i]
#         cc <- c(cc,c)
#       }
#       names(cc) <- strata
#       return(cc)
#     }
#   }
#
#   #perform survival analysis for all factor levels
#   if (type=="OS"){
#     grouped.df <-  df %>%
#       group_by_(groupBy) %>%
#       do(OS.fit=survfit(OS.form, data=.),
#          OS.diff=survdiff(OS.form, data=.), #survdiff for log-rank p-value
#          OS=SurvivalPlot(survfit(OS.form, data=.), #survival plots
#                          LegendTitle = "",
#                          timeUnit = "Years",
#                          max.year = max.year,
#                          colors =  colorcodes(.)),
#
#          EFS.fit=survfit(EFS.form, data=.),
#          EFS.diff=survdiff(EFS.form, data=.),
#          EFS=SurvivalPlot(survfit(EFS.form, data=.),
#                           LegendTitle="",
#                           timeUnit= "Years",
#                           max.year = max.year,
#                           colors= colorcodes(.)))
#   }
#
#   #function to calculate a p-value
#   pvalue <- function(survdiff.res){
#     p <- pchisq(survdiff.res$chisq, df=length(survdiff.res$n) - 1, lower=FALSE)
#     p <- ifelse(p < 0.001, "p < 0.001", paste0("p = ", round(p, digits = 3)))
#     return(p)
#   }
#
#   #Function to extract N of cohort.
#   groupSize <- function(survdiff.res){paste0("N = ", sum(survdiff.res$n))}
#
#   #Update the survial plots with an informative title and p values, and group N
#   types <- c("Relapse", "Failure", "OS", "EFS")
#   plots <- which(colnames(grouped.df) %in% types)
#
#   #for each row (nrow > 1, when grouping variable given)
#   for ( i in 1:nrow(grouped.df)){
#
#     #for each OS/EFS column
#     for (plot.idx in plots){
#       idx.logrank <- plot.idx-1
#       N <- groupSize(grouped.df[[idx.logrank]][[i]])
#       pval <- pvalue(grouped.df[[idx.logrank]][[i]]) %>%
#         paste(., N, sep="\n")
#
#       #Add more informative Legend Title
#       legendTitle <- as.character(grouped.df[i,1]) %>%
#         unique(c(groupBy, .)) %>%
#         paste(., ": ", covariate, sep="")
#
#       for (j in 1:2){
#         grouped.df[[plot.idx]][[i]]$scales$scales[[j]]$name <-  legendTitle
#       }
#
#       #Add Main Title that is the column name (eg Relapse,OS, EFS, etc)
#       grouped.df[[plot.idx]][[i]]$labels$title <- names(grouped.df[plot.idx])
#
#       #Add P value and the N
#       grouped.df[[plot.idx]][[i]] <- grouped.df[[plot.idx]][[i]] +
#         annotate(geom="text", x=1, y=0.05, label=pval, size=5)
#
#       if(riskTable){
#
#         fit.idx <- plot.idx-2
#         fit <- grouped.df[[fit.idx]][[i]]
#         risk.tab <- risk.table(survFit.obj = fit, ret.data = TRUE)
#         risk.tab.p <- risk.table(survFit.obj = fit,col = cc, f.levels = f.levels, max.year=max.year)
#
#         # Create a blank plot for place-holding
#         blank.pic <- ggplot(risk.tab, aes(time, surv)) +
#           geom_blank() +
#           theme_bw() +
#           theme(axis.text.x = element_blank(),
#                 axis.text.y = element_blank(),
#                 axis.title.x = element_blank(),
#                 axis.title.y = element_blank(),
#                 axis.ticks = element_blank(),
#                 panel.grid = element_blank(),
#                 panel.border = element_blank())
#
#
#         # grid.arrange(grouped.df[[plot.idx]][[i]], blank.pic, risk.tab.p, clip = FALSE, nrow = 3,
#         #                    ncol = 1, heights = unit(c(2, .1, .25), c("null", "null", "null")))
#
#         grouped.df[[plot.idx]][[i]] <-  arrangeGrob(grouped.df[[plot.idx]][[i]], blank.pic, risk.tab.p,
#                                                     clip = FALSE, nrow = 3, ncol = 1,
#                                                     heights = unit(c(2, .2, .4),c("null", "null", "null")))
#
#       }
#     }
#   }
#
#   return(grouped.df)
# }

# saveKM <- function(KM.plots.res,dir){
#
#   N <- nrow(KM.plots.res)
#   group <- colnames(KM.plots.res)[1]
#
#   OS <- KM.plots.res$OS
#   EFS <- KM.plots.res$EFS
#
#   saveplot <- function(gg,N){
#     type <- substitute(gg)
#
#     lapply(1:N, function(i)
#       ggsave(filename = paste("TARGET_AML",group,
#                               unlist(KM.plots.res[i,1]),
#                               type,"plot.png", sep="_"),
#              plot = gg[[i]], device = "png", height = 7, width = 12,dpi = 600 ))
#   }
#
#   saveplot(OS,N=N)
#   saveplot(EFS,N=N)
# }

# SurvObjects <- function(df, colNames, group, rho=0, time=NULL){
#   #df is the dataframe with clinical data.
#   #colnames is a character vector (length 2) with the colnames of the time and event, in that order.
#   #group is the column name as character vector of the explanatory variable to test
#   #time is optional if you need to convert days to years for example.
#   #rho is 1 or 0 or inbetween. 0=logrank test and 1=gehan-wilcoxon test
#
#   require(survival)
#   require(survMisc)
#
#   #optional time unit conversion
#   if (is.null(time)){
#     time <- (df[, colNames[1]])
#   }else if (time == "DtoY"){
#     time <- (df[,colNames[1]]/365)
#   }else if (time == "MtoY"){
#     time <- (df[,colNames[1]]/12)
#   }
#
#   #Kaplan Meier Estimates
#   KM <- Surv(time = time, event = df[,colNames[2]])
#
#   if (group == 1){
#     #model fit
#     survFit <- survfit(KM ~ 1)
#     return(survFit)
#
#   }else{
#     #model fit
#     survFit <- survfit(KM ~ df[,group],data=df)
#
#     #cox proportional Hazards
#     cph.test <- coxph(KM ~ df[,group])
#
#     #test proportional hazards assumption
#     cph.zph <- cox.zph(cph.test, transform = "km")
#     rhoPval <- as.data.frame(cph.zph$table)$p #test the PH assumption
#
#     if (length(rhoPval) > 1){
#       rhoPval <- rhoPval[length(rhoPval)]
#     }
#
#     # survMisc compare stat tests for two curves
#     tne <- ten(eval(survFit$call$formula), data=df)
#     capture.output(comp(tne)) -> allTests
#
#     if (rhoPval >= 0.05 ){
#       attr(tne, "lrt")[1,] -> pVal #log-rank test
#       test <- "log.rank"
#     }else if (rhoPval < 0.05){
#       attr(tne, "lrt")[2, ] -> pVal #Gehan-Breslow-Wilcoxon
#       test <- "Gehan.Breslow.Wilcoxon"
#     }
#
#     list <- list(survFit, pVal, cph.test, cph.zph, KM)
#     names(list) <- c("survFit", test, "CoxPH", "PH_Test","KaplanMeirerEst")
#     return(list)
#   }
# }


# This code assumes you've downloaded and unzipped the file
#   exdata-data-NEI_data.zip in your working directory.  If you haven't it's
#   easy enough to write the code to check using file.exists etc

## This first line will likely take a few seconds. Be patient!
NEI <- readRDS("summarySCC_PM25.rds")
SCC <- readRDS("Source_Classification_Code.rds")

# Plot 4
# Subsetting...
Combustion <- grepl("comb",
                    SCC$SCC.Level.One,
                    ignore.case = TRUE)

Coal <- grepl("coal",
              SCC$SCC.Level.Four,
              ignore.case = TRUE)

Coal.Comb <- (Coal & Combustion)

ccSCC <- SCC[Coal.Comb,]$SCC
ccNEI <- NEI[NEI$SCC %in% ccSCC,]

library(ggplot2)

png(filename = "plot4.png",
    width = 640,
    height = 480)

ggplot(ccNEI,aes(factor(year), Emissions/10^3)) +
  geom_bar(stat = "identity", fill = "grey") +
  theme_bw() +
  guides(fill = FALSE) +
  labs(x = "Year", y = expression("Total PM"[2.5]*" Emission (Thousand Tons)")) +
  labs(title = expression("Plot 4: PM"[2.5]*" Coal-Combustion Related Source Emissions Across US from 1999-2008"))

dev.off()


#' matmult
#'
#' Matrix multiplication.
#'
#' @param x,y
#' fmlmat matrices.
#'
#' @return
#' A matrix of the same type as the inputs.
#'
#' @name matmult
#' @rdname matmult
NULL

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="fmlmat", y="fmlmat"),
  function(x, y)
  {
    ret = linalg_matmult(x=DATA(x), y=DATA(y))
    wrapfml(ret)
  }
)

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="fmlmat", y="matrix"),
  function(x, y)
  {
    y_fml = ytox(x, y)
    ret = linalg_matmult(x=DATA(x), y=DATA(y))
    wrapfml(ret)
  }
)

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="matrix", y="fmlmat"),
  function(x, y)
  {
    x_fml = ytox(y, x)
    ret = linalg_matmult(x=DATA(x), y=DATA(y))
    wrapfml(ret)
  }
)


model_snowdry <- function (Sdry_t1 = 0.0,
         Snowaccu = 0.0,
         Mrf = 0.0,
         M = 0.0){
    #'- Name: SnowDry -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: water in solid state in the snow cover Calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: water in solid state in the snow cover
    #'- inputs:
    #'            * name: Sdry_t1
    #'                          ** description : water in solid state in the snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Snowaccu
    #'                          ** description : snowfall accumulation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: Mrf
    #'                          ** description : liquid water in the snow cover in the process of refreezing
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: M
    #'                          ** description : snow in the process of melting
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'- outputs:
    #'            * name: Sdry
    #'                          ** description : water in solid state in the snow cover
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    Sdry <- 0.0
    if (M <= Sdry_t1)
    {
        tmp_sdry <- Snowaccu + Mrf - M + Sdry_t1
        if (tmp_sdry < 0.0)
        {
            Sdry <- 0.001
        }
        else
        {
            Sdry <- tmp_sdry
        }
    }
    return (list('Sdry' = Sdry))
}


library(feather)
library(tidyverse)
library(data.table)
library(partykit)

airq <- airquality
airq <- subset(airquality, !is.na(Ozone))
airct <- ctree(Ozone ~ ., data = airq,
               control = ctree_control(maxsurrogate = 3))
airct

df = read_feather('/Users/wbeard/repos/crash/data/interim/soc_msg.fth') %>% as.data.frame()
df = read_feather('/Users/wbeard/repos/crash/data/interim/soc_msg.fth') %>% as.data.frame()
ct <- ctree(missing ~ ., data = df, control=ctree_control(maxdepth=4))
pl(ct)
ct
plot(ct)

pl <- function(ct) {
  pdf(file = "/Users/wbeard/repos/crash/reports/figures/soc_cr_ctree.pdf",
      width = 18, # The width of the plot in inches
      # height = 4
      )
  plot(ct)
  dev.off()
}

df <- df[, !c("btime", "date", "build_id", )]

head(df)
typeof(df)
sapply(df,class)
df


%r

library(SparkR)

df <- sql("SELECT * FROM `v_forecast` WHERE `days_forward` = 1")

xt <- xtabs(~forecast_weather_group+actual_weather_group, data=collect(df))

print(xt)

chisq.test(xt)


library(randomForest)
library(dplyr)
library(plyr)
library(rgp)
#library(e1071)

x = dataset2_ucc_satgraf %>% select(Program, Path, Time.s._mean, Math, Trigonometric, Logarithmic, Calculations, Conditionals, Logical, Preprocessor, Assignment, Pointer, L1.Loops, L2.Loops, L3.Loops, Total.CC1., Total.CC2., Total.CC3., Average.CC1., Risk, vars, ol_coms,mincom,meancom,maxcom,sdcom,mininter,maxinter,meaninter,sdinter,minintra,maxintra,meanintra,sdintra,edgeratio,maxedgeratio,minedgeratio,meanedgeratio,sdedgeratio,unique_edges,ol_q,maxvar,meanvar,total_edges,weight,max_community,num_max_community,num_top_10_community,num_top_20_community,max_inter,num_max_inter,num_top_10_inter,num_top_20_inter,max_total,num_max_total,num_top_10_total,num_top_20_total,num_max_total_inter,num_max_total_community,num_max_inter_community,num_max_total_inter_community,num_top_10_total_inter,num_top_10_total_community,num_top_10_inter_community,num_top_10_total_inter_community,num_top_20_total_inter,num_top_20_total_community,num_top_20_inter_community,num_top_20_total_inter_community,total_clauses,var_unique_clauses,max_clause,mean_clause,max_reused,min_reused,mean_reused, Trans)
x = dplyr::rename(x, Time.s.=Time.s._mean)

x2 = simple_hash_func_ucc_satgraf %>% select(Program,Path,Time.s.,Math,Trigonometric,Logarithmic,Calculations,Conditionals,Logical,Preprocessor,Assignment,Pointer,L1.Loops,L2.Loops,L3.Loops,Total.CC1.,Total.CC2.,Total.CC3.,Average.CC1.,Risk,vars,ol_coms,mincom,meancom,maxcom,sdcom,mininter,maxinter,meaninter,sdinter,minintra,maxintra,meanintra,sdintra,edgeratio,maxedgeratio,minedgeratio,meanedgeratio,sdedgeratio,unique_edges,ol_q,maxvar,meanvar,total_edges,weight,max_community,num_max_community,num_top_10_community,num_top_20_community,max_inter,num_max_inter,num_top_10_inter,num_top_20_inter,max_total,num_max_total,num_top_10_total,num_top_20_total,num_max_total_inter,num_max_total_community,num_max_inter_community,num_max_total_inter_community,num_top_10_total_inter,num_top_10_total_community,num_top_10_inter_community,num_top_10_total_inter_community,num_top_20_total_inter,num_top_20_total_community,num_top_20_inter_community,num_top_20_total_inter_community,total_clauses,var_unique_clauses,max_clause,mean_clause,max_reused,min_reused,mean_reused, Trans)

alg_name = "randomForest" ## change this line to use another algorithm
outlier = 0.00
alg = get(alg_name)
folds = 10

model1 = vector("list", folds)
model2 = vector("list", folds)
model3 = vector("list", folds)
model4 = vector("list", folds)

## remove 0 time
x = x %>% filter(Time.s. > 0)
x2 = x2 %>% filter(Time.s. > 0)

## Filter outliers
no_outliers_x = quantile(x$Time.s., probs = c(outlier, 1-outlier))
no_outliers_x2 = quantile(x2$Time.s., probs = c(outlier, 1-outlier))
x = x %>% filter(x$Time.s. >= no_outliers_x[1] & x$Time.s. <= no_outliers_x[2])
x2 = x2 %>% filter(x2$Time.s. >= no_outliers_x2[1] & x2$Time.s. <= no_outliers_x2[2])

pbar <- create_progress_bar('text')
pbar$init(folds*4)

## Training phase
for (fold in seq(0, folds-1)) {
  x$odd = as.integer(rownames(x)) %% folds == fold
  x2$odd = as.integer(rownames(x2)) %% folds == fold
  train = rbind(x[x$odd != TRUE,], x2[x2$odd != TRUE,])

  model1[[fold+1]]<-alg(formula=Time.s.~Calculations*Conditionals*Logical*Assignment*L1.Loops*L2.Loops*L3.Loops*Total.CC1.*Total.CC2.*Total.CC3.*Average.CC1.,
                     data=train)
  pbar$step()
  model2[[fold+1]]<-alg(formula=Time.s.~total_edges * weight * ol_q * edgeratio * ol_coms * vars * meancom * maxcom * mean_reused * meanintra * maxinter,
                        data=train)
  pbar$step()
  ## Old mix of metrics sat and UCC
  ## model3[[fold+1]]<-alg(formula=Time.s.~total_edges * weight * ol_q * edgeratio * ol_coms * vars * meancom * maxcom * meanintra * maxinter * Logical * Calculations * Assignment * L1.Loops,
  ##                      data=train)

  ## New person: mean_clause, meanvar, sdedgeratio, meanintra, mean_reused, meancom, unique_edges, vars, sdinter, max_community, ol_coms, maxedgeratio, maxinter, max_total, Trans
  model3[[fold+1]]<-alg(formula=Time.s.~mean_clause * meanvar * sdedgeratio * meanintra * mean_reused * meancom * unique_edges * vars * sdinter * max_community * ol_coms * maxedgeratio * maxinter * max_total,
                      data=train)
  pbar$step()
  ## New RF-RFE: max_clause, num_max_inter, weight, sdinter, meaninter, sdintra, ol_coms, L1.Loops, Risk, sdcom, meancom, sdedgeratio, meanintra, edgeratio, ol_q
  model4[[fold+1]]<-alg(formula=Time.s.~max_clause * num_max_inter * weight * sdinter * meaninter * sdintra * ol_coms * L1.Loops * Risk * sdcom * meancom * sdedgeratio * meanintra * edgeratio,
                        data=train)
  pbar$step()
}

assign(paste0(alg_name, "Model1_", outlier), model1)
assign(paste0(alg_name, "Model2_", outlier), model2)
assign(paste0(alg_name, "Model3_", outlier), model3)
assign(paste0(alg_name, "Model4_", outlier), model3)

v = vector("list", folds)
## Testing phase
for (fold in seq(0, folds-1)) {
  x$odd = as.integer(rownames(x)) %% folds == fold
  x2$odd = as.integer(rownames(x2)) %% folds == fold
  test = rbind(x[x$odd == TRUE,], x2[x2$odd == TRUE,])

  test$pred_ucc=predict(model1[[fold+1]], test)

  test$pred_satgraf=predict(model2[[fold+1]], test)

  test$pred_pearson=predict(model3[[fold+1]], test)

  test$pred_rfe=predict(model4[[fold+1]], test)

  v[[fold+1]] = test[,c("Path", "Time.s.", "pred_ucc", "pred_satgraf", "pred_pearson", "pref_rfe")]
}

w = bind_rows(v)
w = tbl_df(w)
w = arrange(w, Path)
assign(paste0("pred_results_for_",alg_name, outlier), w)

plot(y = w$Time.s., x = seq_along(w$Path), type="l", col="1")
lines(seq_along(w$Path), w$pred_rfe, col="yellow")
lines(seq_along(w$Path), w$pred_pearson, col="green")
lines(seq_along(w$Path), w$pred_satgraf, col="blue")
lines(seq_along(w$Path), w$pred_ucc, col="red")

assign(paste0("rmse_",alg_name, outlier, "_ucc"), rmse(w$Time.s., w$pred_ucc))
assign(paste0("rmse_",alg_name, outlier, "_satgraf"), rmse(w$Time.s., w$pred_satgraf))
assign(paste0("rmse_",alg_name, outlier, "_pearson"), rmse(w$Time.s., w$pred_pearson))
assign(paste0("rmse_",alg_name, outlier, "_rfe"), rmse(w$Time.s., w$pred_rfe))

assign(paste0("rsquared_",alg_name, outlier, "_ucc"), rsquared(w$Time.s., w$pred_ucc))
assign(paste0("rsquared_",alg_name, outlier, "_satgraf"), rsquared(w$Time.s., w$pred_satgraf))
assign(paste0("rsquared_",alg_name, outlier, "_pearson"), rsquared(w$Time.s., w$pred_pearson))
assign(paste0("rsquared_",alg_name, outlier, "_rfe"), rsquared(w$Time.s., w$pred_rfe))