## Final step: wall-to-wall map
# Choose two models: one with lowest RMSE, one with lowest MAE/highest accuracy
library(ranger)
library(raster)
library(future)
plan("multiprocess")
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r")
source("pixel-based/utils/RFTrain.r")
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
Data.df[is.na(Data.df)] = -9999
#Data.sp = Data.df
Data.df = st_set_geometry(Data.df, NULL)
Data.df = AddZeroValueColumns(Data.df)
Data.df = TidyData(Data.df, drop.cols=NULL)
#Data.sp = Data.sp[rownames(Data.df),]

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val[is.na(Data.val)] = -9999
Val.sp = Data.val
Data.val = st_set_geometry(Data.val, NULL)
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050
Val.sp = Val.sp[rownames(Data.val),]

# Prediction data
Data.pred = LoadPredictionAndCovariates()
Data.pred[is.na(Data.pred)] = -9999

Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

## First, 1-step RF model (lowest RMSE)
FlatPredictionTask = future({RFTrain("../data/pixel-based/predictions/", "randomforest-onestep-walltowall.csv", InflationAdjustment = 0, ValidationSet = as.data.frame(Data.pred))})
resolved(FlatPredictionTask)
FlatPredictions = value(FlatPredictionTask)
head(FlatPredictions)
SpatialPredictions = st_set_geometry(FlatPredictions, Data.pred[["geometry"]])
plot(SpatialPredictions["tree"])
plot(SpatialPredictions["water"])
plot(SpatialPredictions["shrub"])
st_write(SpatialPredictions, "../data/pixel-based/predictions/randomforest-onestep-walltowall.gpkg")

OneStepRaster = SfToRaster(SpatialPredictions) # Note: first layer is id, can be ignored
writeRaster(OneStepRaster, "../data/pixel-based/predictions/randomforest-onestep-walltowall.tif", datatype="INT1U", options=c("COMPRESS=DEFLATE"), overwrite=TRUE)
TIFFtoBMP = function(tifffile, layers=c(5,2,8), prefix="ctw", nas=3)
{
    # BMPs at native resolution (because raster doesn't support PNGs)
    # Set 1: Red: crops, green: trees, blue: water
    # Set 2: Red: bare,  green: grass, blue: shrub
    # Set 3: Red: urban
    InputRaster = brick(tifffile)
    OutputFile = strtrim(tifffile, nchar(tifffile)-4)
    Set = InputRaster[[layers]]
    Set = Set / 100 * 255
    Set[[nas]][is.na(Set[[nas]])] = 255 # Set specified bands to 255
    Set[is.na(Set)] = 0 # Set the rest to 0
    writeRaster(Set, paste0(OutputFile, "-", prefix, ".bmp"), datatype="INT1U", overwrite=TRUE)
}
TIFFtoBMP("../data/pixel-based/predictions/randomforest-onestep-walltowall.tif")
TIFFtoBMP("../data/pixel-based/predictions/randomforest-onestep-walltowall.tif", c(7,4,3), "bgs")
TIFFtoBMP("../data/pixel-based/predictions/randomforest-onestep-walltowall.tif", c(6,6,6), "urban")
TIFFtoBMP("../data/pixel-based/predictions/randomforest-onestep-walltowall.tif", c(3,2,4), "stg")
plotRGB(OneStepRaster, "shrub", "tree", "grassland", stretch="lin")

## Second, 3-step median forest (lowest MAE)
Med3PredictionTask = future({RFTrain3("../data/pixel-based/predictions/", "randomforest-threestep-median-walltowall.csv", PredictType="quantiles", ValidationSet = as.data.frame(Data.pred))})
resolved(Med3PredictionTask)
Med3Prediction = value(Med3PredictionTask)
Med3Prediction = st_set_geometry(Med3Prediction, Data.pred[["geometry"]])
st_write(Med3Prediction, "../data/pixel-based/predictions/randomforest-median-threestep-walltowall.gpkg")

Med3Raster = SfToRaster(Med3Prediction)
writeRaster(Med3Raster, "../data/pixel-based/predictions/randomforest-median-threestep-walltowall.tif", datatype="INT1U", options=c("COMPRESS=DEFLATE"), overwrite=TRUE)
Med3Hardened = which.max(Med3Raster[[-1]])
writeRaster(Med3Hardened, "../data/pixel-based/predictions/randomforest-median-threestep-walltowall-hardened.tif", datatype="INT1U", options=c("COMPRESS=DEFLATE"), overwrite=TRUE)
plotRGB(Med3Raster, "shrub", "tree", "grassland", stretch="lin")

TIFFtoBMP("../data/pixel-based/predictions/randomforest-median-threestep-walltowall.tif")
TIFFtoBMP("../data/pixel-based/predictions/randomforest-median-threestep-walltowall.tif", c(3,2,4), "stg")

TIFFtoBMP("../data/pixel-based/predictions/randomforest-median-threestep-walltowall.tif", c(3,2,4), "stg")

# Produce individual images for each class
for (layeridx in 2:nlayers(OneStepRaster))
{
    Class = GetCommonClassNames()[layeridx-1]
    TIFFtoBMP("../data/pixel-based/predictions/randomforest-onestep-walltowall.tif",
              c(layeridx,layeridx,layeridx), Class)
}
for (layeridx in 2:nlayers(OneStepRaster))
{
    Class = GetCommonClassNames()[layeridx-1]
    TIFFtoBMP("../data/pixel-based/predictions/randomforest-median-threestep-walltowall.tif",
              c(layeridx,layeridx,layeridx), Class)
}

# Can convert to PNGs
#BMPs = list.files("../data/pixel-based/predictions/", pattern=glob2rx("*.bmp"), full.names=TRUE)
#library(gdalUtils)
#lapply(BMPs, function(BMP) {gdal_translate(BMP, paste0(strtrim(BMP, nchar(BMP)-4), ".png"), options=c("ZLEVEL=9", "NBITS=1"))})
# Actually they are even larger, so never mind

## Model comparison plots

## Comparison between non-RF models
InterceptModel = Truth
InterceptModel[] = 1/length(Classes)
ggplotBox(list(Intercept = InterceptModel,
        Cubist10C = read.csv("../data/pixel-based/predictions/cubist-committees10.csv")/100,
        LassoLambdaMin = read.csv("../data/pixel-based/predictions/lasso-min-9999.csv", row.names=1)/100,
        FNCScaled = read.csv("../data/pixel-based/predictions/fnc-na0-scaled.csv"),
        SVMMean = read.csv("../data/pixel-based/predictions/svm-scale.csv")/100,
        SVMMedian = read.csv("../data/pixel-based/predictions/svm-median-maxgamma25.csv")/100,
        NNet3Layers = read.csv("../data/pixel-based/predictions/nn-3layers-softmax-adam-0na-nodropout.csv", row.names=1)/100
    ),
    Truth/100, main="Other model comparison", outlier.shape=NA)

# Load all the model data we cached

# Intercept
InterceptModel = Truth[,Classes]
InterceptModel[] = 1/length(Classes)*100

LM = read.csv("../data/pixel-based/predictions/lm-all-na0.csv")
PLSR = read.csv("../data/pixel-based/predictions/plsr-55c.csv") # With 55 components instead of all 67; optimal is to use all
Lasso = read.csv("../data/pixel-based/predictions/lasso-lambda0000401.csv") # With a slightly higher lambda than 0
Logistic = read.csv("../data/pixel-based/predictions/logistic-na0.csv")
FNC = read.csv("../data/pixel-based/predictions/fnc-na0.csv")
NN = read.csv("../data/pixel-based/predictions/nn-3layers-softmax-nadam-9999na-nodropout.csv", row.names="X")
Cubist = BinaryRelevance(NULL, NULL, NULL, NULL, filename="../data/pixel-based/predictions/cubist-committees10.csv")/100
SVM = BinaryRelevance(NULL, NULL, NULL, NULL, filename="../data/pixel-based/predictions/svm-median.csv")
SVM[SVM < 0] = 0
SVM = ScalePredictions(SVM, FALSE)
MRF = read.csv("../data/pixel-based/predictions/multivarrf-all-fixed.csv")
RFSingle = RFTrain("../data/pixel-based/predictions/", "randomforest-onestep-allcovars-validation.csv", InflationAdjustment = 0)[,Classes]
RFThreeStepMedian = RFTrain3("../data/pixel-based/predictions/", "randomforest-threestep-median.csv", PredictType="quantiles")[,Classes]

devEMF::emf("../output/2020-05-08-model-comparison-bar.emf", width=1272/100, height=634/100)
ggplotBox(list(Intercept = InterceptModel, FNC=FNC, LinearLassoPLSR=LM, Logistic=Logistic,
               MultivariateRF = MRF,  RFSingle = RFSingle, NN=NN, SVM=SVM, Cubist=Cubist, RF3SMedian=RFThreeStepMedian),
          Truth[,Classes], main="Model comparison", outlier.shape=NA)
dev.off()

devEMF::emf("../output/2020-05-08-model-comparison-line.emf", width=1272/100, height=634/100)
ggplotBoxLines(list(Intercept = InterceptModel, FNC=FNC, LinearLassoPLSR=LM, Logistic=Logistic,
                    MultivariateRF = MRF,  RFSingle = RFSingle, NN=NN, SVM=SVM, Cubist=Cubist, RF3SMedian=RFThreeStepMedian),
               Truth[,Classes], main="Model comparison")
dev.off()

# Reduced to best per group

ggplotBox(list(Intercept = InterceptModel, GLM=LM, RF = RFSingle, SVM=SVM),
          Truth[,Classes], main="Model comparison", outlier.shape=NA)

# Barplots
RMSEPlot = ggplotBar(list(`Equal proportions` = InterceptModel, GLM=LM, SVM=SVM, Cubist=Cubist*100, `RF 1-step mean` = RFSingle, `RF 3-step median` = RFThreeStepMedian)) + theme(legend.position="none", axis.title.x = element_blank())
MAEPlot = ggplotBar(list(`Equal proportions` = InterceptModel, GLM=LM, SVM=SVM, Cubist=Cubist*100, `RF 1-step mean` = RFSingle, `RF 3-step median` = RFThreeStepMedian), "MAE") + theme(legend.position="bottom")
pdf("../output/2020-06-03-model-comparison-bar.pdf", width=1272/175, height=634/175)
gridExtra::grid.arrange(RMSEPlot, MAEPlot, heights=c(40, 60))
dev.off()

# Relative measures
RRMSEPlot = ggplotBar(list(`Equal proportions` = InterceptModel, GLM=LM, SVM=SVM, Cubist=Cubist*100, `RF 1-step mean` = RFSingle, `RF 3-step median` = RFThreeStepMedian), ylab="RRMSE", digits=1, relative=TRUE, textsize=1.9, textvjust=-0.3) + theme(legend.position="none", axis.title.x = element_blank())
RMAEPlot = ggplotBar(list(`Equal proportions` = InterceptModel, GLM=LM, SVM=SVM, Cubist=Cubist*100, `RF 1-step mean` = RFSingle, `RF 3-step median` = RFThreeStepMedian), "MAE", "RMAE", digits=1, relative=TRUE, textsize=1.9, textvjust=-0.3) + theme(legend.position="bottom")
pdf("../output/2020-11-02-model-comparison-bar.pdf", width=1272/175, height=634/175)
gridExtra::grid.arrange(RRMSEPlot, RMAEPlot, heights=c(40, 60))
dev.off()

# Drill-down into Random Forest
RFTwoStep = ScalePredictions(RFTrain("../data/pixel-based/predictions/", "randomforest-twostep-truncated-validation.csv", InflationAdjustment = 1, TruncateZeroes = TRUE))
RFThreeStep = RFTrain3("../data/pixel-based/predictions/", "randomforest-threestep-validation.csv")
RFSingleMedian = ScalePredictions(RFTrain("../data/pixel-based/predictions/", "randomforest-onestep-median-validation.csv", InflationAdjustment = 0, PredictType="quantiles"))
RFTwoStepMedian = ScalePredictions(RFTrain("../data/pixel-based/predictions/", "randomforest-twostep-truncated-median.csv", InflationAdjustment = 1, TruncateZeroes = TRUE, PredictType="quantiles"))
RSLocationCovars = unlist(GetAllPixelCovars(TRUE)[c("spectral", "harmonic", "location")])
RFOnlyRSLocation = RFTrain("../data/pixel-based/predictions/", "randomforest-onestep-rscovars-validation.csv", InflationAdjustment = 0, covars=RSLocationCovars)
RFOnlyRSStrict = RFTrain("../data/pixel-based/predictions/", "randomforest-onestep-rscovars-nolocation-validation.csv", InflationAdjustment = 0, covars=unlist(GetAllPixelCovars(TRUE)[c("spectral", "harmonic")]))
SL3 = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, filename="../data/pixel-based/predictions/sl3-rf-cubist-rf.csv")

ggplotBox(list(
    Intercept = InterceptModel,
    RFOnlyRSStrict = RFOnlyRSStrict,
    RFOnlyRSLocation = RFOnlyRSLocation,
    RFSingle = RFSingle,
    RFTwoStep = RFTwoStep,
    RFThreeStep = RFThreeStep,
    RFSingleMedian = RFSingleMedian,
    RFTwoStepMedian = RFTwoStepMedian,
    RFThreeStepMedian = RFThreeStepMedian
), Truth[,Classes], main="Random forest model comparison", outlier.shape=NA)

RMSEPlot = ggplotBar(list(
    `Equal proportions` = InterceptModel,
    `1-step mean` = RFSingle,
    `2-step mean` = RFTwoStep,
    `3-step mean` = RFThreeStep,
    `1-step median` = RFSingleMedian,
    `3-step median` = RFThreeStepMedian
    )) + theme(legend.position="none", axis.title.x = element_blank())
MAEPlot = ggplotBar(list(
    `Equal proportions` = InterceptModel,
    `1-step mean` = RFSingle,
    `2-step mean` = RFTwoStep,
    `3-step mean` = RFThreeStep,
    `1-step median` = RFSingleMedian,
    `3-step median` = RFThreeStepMedian
    ), "MAE") + theme(legend.position="bottom")
pdf("../output/2020-06-04-rf-comparison-bar.pdf", width=1272/175, height=634/175)
gridExtra::grid.arrange(RMSEPlot, MAEPlot, heights=c(40, 60))
dev.off()

# Relative

RRMSEPlot = ggplotBar(list(
    `Equal proportions` = InterceptModel,
    `1-step mean` = RFSingle,
    `2-step mean` = RFTwoStep,
    `3-step mean` = RFThreeStep,
    `1-step median` = RFSingleMedian,
    `3-step median` = RFThreeStepMedian
), ylab="RRMSE", digits=1, relative=TRUE, textsize=1.9, textvjust=-0.3) + theme(legend.position="none", axis.title.x = element_blank())
RMAEPlot = ggplotBar(list(
    `Equal proportions` = InterceptModel,
    `1-step mean` = RFSingle,
    `2-step mean` = RFTwoStep,
    `3-step mean` = RFThreeStep,
    `1-step median` = RFSingleMedian,
    `3-step median` = RFThreeStepMedian
), "MAE", "RMAE", digits=1, relative=TRUE, textsize=1.9, textvjust=-0.3) + theme(legend.position="bottom")
pdf("../output/2020-11-02-rf-comparison-bar.pdf", width=1272/175, height=634/175)
gridExtra::grid.arrange(RRMSEPlot, RMAEPlot, heights=c(40, 60))
dev.off()

AccuracyStatisticsPlots(RFOnlyRSStrict[,Classes], Truth[,Classes]) # 18.4 RMSE, 10.3 MAE
hydroGOF::NSE(unlist(RFOnlyRSStrict[,Classes]), unlist(Truth[,Classes])) # 0.62
SCM(RFOnlyRSStrict[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 0.64±0.04, kappa 0.54±0.05

## OLS R2
PredList = list(FNC*100, LM, Logistic, NN, SVM, Cubist*100, RFSingle,
    RFOnlyRSLocation, RFTwoStep, RFThreeStep,
    RFSingleMedian, RFTwoStepMedian, RFThreeStepMedian, SL3)
OLSStats = t(sapply(PredList, function(Pred){
    OLS = summary(lm(unlist(Truth)~unlist(Pred)))
    OLSStat = t(c(OLS$r.squared, OLS$coefficients[,1]))
}))
rownames(OLSStats) = c("FNC", "LM", "Logistic", "NN", "SVM", "Cubist", "RFSingle",
                       "RFOnlyRSLocation", "RFTwoStep", "RFThreeStep",
                       "RFSingleMedian", "RFTwoStepMedian", "RFThreeStepMedian", "SL3")
colnames(OLSStats) = c("R.sq", "intercept", "slope")
round(OLSStats[,c(1,3,2)], 2)

## Plot 1:1 plots
png("../output/2020-06-21-rf1st-1to1-box-overall.png", width=70.2414*15, height=26.7229*15, res=300)
PlotBox(RFSingle, Truth, binpredicted = TRUE, transposeaxes = TRUE)
dev.off()
for (Class in Classes)
{
    png(paste0("../output/2020-06-21-rf1st-1to1-box-", Class, ".png"), width=70.2414*15, height=26.7229*15, res=300)
    print(PlotBox(RFSingle[,Class], Truth[,Class], binpredicted = TRUE, transposeaxes = TRUE))
    dev.off()
}

png("../output/2020-10-12-rf3st-1to1-box-overall.png", width=70.2414*20, height=26.7229*20, res=300)
PlotBox(RFThreeStepMedian, Truth, binpredicted = TRUE, transposeaxes = TRUE)
dev.off()
for (Class in Classes)
{
    png(paste0("../output/2020-10-12-rf3st-1to1-box-", Class, ".png"), width=70.2414*20, height=26.7229*20, res=300)
    print(PlotBox(RFThreeStepMedian[,Class], Truth[,Class], binpredicted = TRUE, transposeaxes = TRUE))
    dev.off()
}

# APU plot
pdf("../output/2021-03-22-apu-rf3step.pdf", width=10, height=5)
#devEMF::emf("../output/2021-01-13-apu-rf3step.emf", width=10, height=5)
APUPlot(RFThreeStepMedian, Truth)
dev.off()
pdf("../output/2021-03-22-apu-rf1step.pdf", width=10, height=5)
#devEMF::emf("../output/2021-01-13-apu-rf1step.emf", width=10, height=5)
APUPlot(RFSingle, Truth)
dev.off()

# Comparison with Montesano 2009
hydroGOF::NSE(RFThreeStepMedian, Truth) # NSE of trees at 0.72
cor(RFThreeStepMedian[,"tree"], Truth[,"tree"])^2 # 0.74
summary(lm(RFThreeStepMedian[,"tree"]~Truth[,"tree"])) # Significant coeffs, 5.8 intercept and 0.87 slope
summary(lm(Truth[,"tree"]~RFThreeStepMedian[,"tree"])) # Same this way, 3.17 and 0.85
RMSE(RFThreeStepMedian[,"tree"], Truth[,"tree"]) # 21.1

# Comparison with Li 2018
MyClass="water"
PlotHex(Cubist[,MyClass]*100, Truth[, MyClass], "Cubist")
hydroGOF::NSE(Cubist[,MyClass]*100, Truth[, MyClass]) # 0.723
cor(Cubist[,MyClass]*100, Truth[, MyClass])^2         # 0.726
AccuracyStats(Cubist[,MyClass]*100, Truth[, MyClass]) # 11.51 RMSE, 2.57 MAE
PlotHex(RFSingle[,MyClass], Truth[, MyClass], "RF")
hydroGOF::NSE(RFSingle[,MyClass], Truth[, MyClass])   # 0.716
cor(RFSingle[,MyClass], Truth[, MyClass])^2           # 0.728
AccuracyStats(RFSingle[,MyClass], Truth[, MyClass])   # 11.65 RMSE, 3.48 MAE

# Comparison with Walton 2008
MyClass="urban_built_up"
PlotHex(Cubist[,MyClass]*100, Truth[, MyClass], "Cubist")
hydroGOF::NSE(Cubist[,MyClass]*100, Truth[, MyClass]) # 0.398
cor(Cubist[,MyClass]*100, Truth[, MyClass])^2         # 0.452
AccuracyStats(Cubist[,MyClass]*100, Truth[, MyClass]) # 9.70 RMSE, 2.43 MAE
PlotHex(RFSingle[,MyClass], Truth[, MyClass], "RF")
hydroGOF::NSE(RFSingle[,MyClass], Truth[, MyClass])   # 0.385
cor(RFSingle[,MyClass], Truth[, MyClass])^2           # 0.510
AccuracyStats(RFSingle[,MyClass], Truth[, MyClass])   # 9.80 RMSE, 3.01 MAE
PlotHex(SVM[,MyClass], Truth[, MyClass], "SVM")
hydroGOF::NSE(SVM[,MyClass], Truth[, MyClass])        # 0.087
cor(SVM[,MyClass], Truth[, MyClass])^2                # 0.134
AccuracyStats(SVM[,MyClass], Truth[, MyClass])        # 11.94 RMSE, 2.86 MAE

# Comparison with GSW
round(AccuracyStatTable(RFSingle, Truth),2)
round(AccuracyStatTable(RFSingle, Truth, TRUE),2)
round(AccuracyStatTable(RFThreeStepMedian, Truth),2)
round(AccuracyStatTable(RFThreeStepMedian, Truth, TRUE),2)
round(NSE(RFSingle, Truth), 2)
round(cor(RFSingle$water, Truth$water)^2, 2)
round(cor(RFSingle$tree, Truth$tree)^2, 2)
round(cor(RFSingle$urban_built_up, Truth$urban_built_up)^2, 2)
round(NSE(RFThreeStepMedian, Truth), 2)
round(cor(RFThreeStepMedian$water, Truth$water)^2, 2)
round(cor(RFThreeStepMedian$tree, Truth$tree)^2, 2)
round(cor(RFThreeStepMedian$urban_built_up, Truth$urban_built_up)^2, 2)


source('vectormap.r')
source('distal_progression_csv_filename_list.r')
source('plot_histogram_matrix_3d.r')

source('helper_functions.r')

#main#
#if you want to use a different progression of more points, put the new filenames here
require(parallel)
# by default it's just looking in the current folder.
main <- function(filename_list, folder_path = "", binwidth=0.02, log_the_values=FALSE){
	#specify the filenames of the data for analysis
  list_of_point_matrices<- get_list_of_point_matrices(filename_list, folder_path)
	message("All point sets from CSV are in active Memory.")
	list_of_histogram_sublists <- lapply(list_of_point_matrices, histogram_all_columns, binwidth)

	# split the sublists and reorder into histograms by muscle
	# tasks_iterator = 1:length(finger_alpha_progression_filenames)
	# get the number of muscles and construct an iterator
	muscle_iterator = 1:get_length_of_sublist(list_of_point_matrices)
	message("All samples have been broken into histogram bins")
	list_of_histogram_progressions <- lapply(muscle_iterator,
		function(x) {
				get_nth_element_of_sublists(list_of_histogram_sublists,x)
		}
	)
	#for each muscle, make an image
	list_of_histogram_matrices <- lapply(list_of_histogram_progressions, get_matrix_of_counts)
	list_of_histogram_matrices_density <- lapply(list_of_histogram_matrices, density_normalization)
	pdf(paste0("histogram_heatmap_time_", get_unix_time_string_now(), ".pdf"), height = 9, width = 8)
	par(mfrow=c(7,1))
	par(mar=c(0.2,0.2,0.2,0.2))
	lapply(list_of_histogram_matrices_density, plot_force_progression_map, log_the_values)
	dev.off()
	message('plotting over')
	return(list_of_histogram_matrices)
}

filenames_to_visualize <- sorted_distal_progression_csv_filename_list()
list_of_histogram_matrices<- main(filenames_to_visualize, folder_path = 'n_1000_alphalen_1000/', binwidth=0.05, log_the_values=FALSE)
plot_histogram_matrices(list_of_histogram_matrices)

rgl.clear()
plot_3d_histogram_lineup(list_of_histogram_matrices, y_scale=50, time_spacing=100, activation_spacing = 1000, interplot_spacing=21000)
bg3d('white')

#if you want to get a PCA variance_explained plot for a couple of the plots. Loadings will be printed to the console.

# dev.off()
# plot.new()
# par(mfrow=c(1,3))
# pca_muscle_solution_space('finger2.881155463796023E-71474701464678.csv', '~/Documents/GitHub/bcohn12/space/output/')
# pca_muscle_solution_space('finger23.0492437103681881475092289825.csv', '~/Documents/GitHub/bcohn12/space/output/')
# pca_muscle_solution_space('finger28.8115546350790771475101516287.csv', '~/Documents/GitHub/bcohn12/space/output/')
# pca_muscle_solution_space('finger25.9078901456739781475102067373.csv', '~/Documents/GitHub/bcohn12/space/output/')
# main(long_list[seq(0,1000, length.out=20)], folder_path = '~/Documents/GitHub/bcohn12/space/output/')


###############################################################
## Section 4: ggplot gtables
###############################################################

###############################################################
## Lecture 14: Getting a ggplot gtable
###############################################################

# Draw a single panel graph

# Get the corresponding gtable

# Initial exploration of the gtable

# At some stage move to multipanel ggplot2

# Load packages
library(stringr)
library(gtable)
library(ggplot2)
library(grid)

# Draw graph
set.seed(64534)
p1 <- ggplot(data.frame(x = rnorm(100), y = rnorm(100),
                       f1 = rep(c("A", "B"), 50),
                       f2 = rep(c("C", "D"), each = 50)),
            aes(x, y)) +
      geom_point() +
      theme_grey(base_size = 18)

# To get the ggplot gtable, use the ggplot2 function, ggplotGrob()
g1 <- ggplotGrob(p1)

# I do indeed have a grob and a gtable
is.grob(g1)
is.gtable(g1)

# Draw the grob
grid.newpage()
grid.draw(g1)

# To see the layout, use gtable_show_layout()
gtable_show_layout(g1)

# What can be learned?
#  The layout has ten rows and seven columns.
#  The cell in the middle is the plot panel.
#  The other rows and columns contain axis material, or are margins, or they are empty.
#  Note the margins: They are 9 points wide
# It is impossible to read the heights and widths in the layout diagram
# Beginning at the top and moving down through the rows, there is:
#     a margin
#     four rows of zero height
#     the plot panel
#     two rows for axis material: tick marks and tick mark labels in row 7; axis label in row 8
#     another row of zero height
#     bottom margin

# Beginning at the left and moving right through the columns, there is:
#     a margin
#     two columns for axis material: axis label; and tick marks and tick mark labels
#     the plot panel
#     two columns of zero width
#     right margin

# Same plot but with a title

p2 <- p1 + ggtitle("A Scatterplot")

# To get the ggplot gtable, use the ggplot2 function, ggplotGrob()
g2 <- ggplotGrob(p2)
gtable_show_layout(g2)

# Note: the second row has expanded to accommodate the title

# Easier to read heights and widths by inspecting the values of these components of the gtable
g1$heights
# Heights (and widths) are more complex measures than the measures used in gtable I created
# Heights of rows:
# Again, starting at the top:
#   Top margin of 5.5 points
#   Four rows each 0 cm row for the title:
#   The plot panel:
#         the null unit means that the panel takes up whatever space is left over after all the axis material and margin are in place
#   The axis material:
#         there is space for the tick marks (2.75 points),
#         space for the tick mark label - grobheight unit allows for different font sizes
#   The axis label:
#         1 grobheight
#   One row: 0 cm
#   Bottom margin of 5.5 points

g1$widths
# Widths of columns:
# Left margin
# Axis label
# Tick marks and tick mark labels
# Plot panel
# Two Columns of zero width
# Right margin

# The layout data frame of the gtable
g1$layout

## More complex ggplot gtables
# Draw a plot with a legend
p3 <- p1 + aes(colour = f1)
p3

g3 <- ggplotGrob(p3)

gtable_show_layout(g3)
g3$layout

a = g3$widths
for(i in seq_along(g3$widths)) {
cat(paste0("[", i, "] ", str_wrap(g3$widths[i], 30, indent = 0, exdent = 5), "\n"))
}

# Add facetting - facet_grid
p4 <- p1 + facet_grid(. ~ f1)
p4

g4 <- ggplotGrob(p4)

gtable_show_layout(g4)
g4$layout
g4$heights

# Add facetting - facet_wrap
p5 <- p1 +  facet_wrap(~ f1)
p5

g5 <- ggplotGrob(p5)

gtable_show_layout(g5)
g5$layout
g5$heights

# facetting (facet_grid) and a legend
p6 <- p1 + aes(colour = f2) + facet_grid(. ~ f1)
p6

g6 <- ggplotGrob(p6)

g6$layout
g6$widths
gtable_show_layout(g6)

# Add two-way facetting - facet_grid
p7 <- p1 + facet_grid(f1 ~ f2)
p7

g7 <- ggplotGrob(p7)

g7$layout
g7$widths
gtable_show_layout(g7)

## grid functions to explore the gtable
# grid.ls()

p3
grid.ls(grid.force())

grid.ls(grid.force())

grid.newpage()
grid.draw(g1)
grid.ls()

grid.ls(g3)

grid.ls(grid.force(g1))

grid.ls(grid.force(g1))

nestedListing()

# current.vpTree()

x = current.vpTree()
x

x = gsub("viewport\\[GRID\\.VP.+]), ", "", x)

formatVPTree(x)

grid.ls(grid.force(), viewports=TRUE, grob = FALSE)

grid.ls(grid.force(gt2), view = T, grob = F, print = pathListing)

grid.ls(grid.force(gt2), view = T, grob = T, print = grobPathListing)

grid.ls(grid.force(gt2), view = T, grob = F, print = nestedListing)

grid.ls(grid.force(g1), view = F, grob = T, print = grobPathListing)

grid.ls(grid.force(gt), view = F, grob = T, print = nestedListing)

grid.ls(grid.force(gt), view = F, grob = T)

sink("temp.txt")
str(g1)
sink()

test2 <- readLines("temp.txt", n = 10)

str(g1)

###############################################################
## Lecture 15: First edit - Turn off clipping
###############################################################

# ggplot plot panels have clipping turned on.
# That is, any graphic objects placed outside the panel will not appear.

# Scenario 1
# Dot plot (developed by Cleveland - superior alternative to bar chart)
# Should begin at zero:   expand = c(0,0) takes care of that.
# But this means that part of the dot for zero counts / proportions / percentages
# will be cut off.
# In the chart, School C has a zero count
# and only half the dot appears.
library(ggplot2)
library(gtable)
library(grid)

data <- data.frame(School = c("A", "B", "C", "D", "E"),
                  Prop = c(0.27, 0.36, 0, 0.15, 0.29))
data$School <- factor(data$School, levels = rev(data$School))

p1 <- ggplot(data , aes(Prop, School)) +
     geom_segment(aes(xend = 0, yend = School), linetype = 3, size = .5) +
     geom_point(size = 3) +
     scale_x_continuous("Proportion of Students", limits = c(0, 1.1*max(data$Prop)), expand = c(0,0)) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = "black"))

p1

# Get the ggplot grob and check the layout data frame.
# Note: Clip is on for the panel
g1 <- ggplotGrob(p1)
g1$layout

# Turn clip off
# and check the layout data frame.
# Note: clip is off for the panel
g1$layout$clip[g1$layout$name == "panel"] = "off"
g1$layout

# Draw the graph
grid.newpage()
grid.draw(g1)

# What follows is a series of examples,
# each of which positions a plot element outside the plot panel,
# and thus each need the panel clipping turned off.
# The first uses hjust to position text outside the plot panel.
# The others use annotation_custom to position grobs outside the plot panel.
# So there is little by way of new material being presented here.
# But the examples review material on creating grobs (using grid)
# or extracting grobs from other ggplot2 plots.
#

## Scenario 2
# Some people like to add the counts to the chart, but want to keep the panel clear of text.
# That is the counts are place to the right.

### Ver 1: Place text grobs at "Inf", that is, on the edge of the panel,
# then move them a little further to the right using "hjust".
# But they will be outside the panel, and therefore, not visible because clipping is turned on.
# Turn clipping off, and the text should be visible.
# Also, widen the right margin so that the text will fit.

p2 <- p1 +
      geom_text(aes(label = Prop, x = Inf, y = School), hjust = -.5, size = 3) +
      theme(plot.margin = unit(c(1, 3, .5, .5), "lines"))

g2 <- ggplotGrob(p2)

g2$layout$clip[g2$layout$name == "panel"] = "off"
grid.newpage()
grid.draw(g2)

# hjust values of 0, .5, or 1 work well; even with strings of differing lengths.
# but hjust values less then zero or greater than one will not align strings of differing lengths.
# hjust leaves space that is a multiple of the number of characters in the string.
ggplot(data.frame(x = 1, y = 1:3, text = c("B", "BBBB", "BBBBBB")),
       aes(x=x,y=y,label = text)) +
   geom_point() +
   geom_text(hjust = -2)

# So for that reason, I would not use the hjust method for publication quality graphs.

### Ver 2
# Draw a separate plot containing just the text,
# Then extract the plot panel (Lecture 12)
# Then add the plot panel to the original dot plot using annotation_custom.

# dot plot
# The original plot but with some space to the right for the annotation
p2 = p1 + theme(plot.margin = unit(c(1, 3.5, .5, .5), "lines"))

# The chart containing the text
p3 = ggplot(data, aes(x = 1, y = School, label = Prop)) +
     geom_text(size = 3) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = NA))

p3

# Get the ggplot grob
g3 = ggplotGrob(p3)
g3$layout

# How to extract? Lecture 13
# Two ways: Filter or select the panel grob from the list of grobs

# Ver 2a - filter
g4 = gtable_filter(g3, "panel")
# But sometimes a little care is needed.
# g4 itself is a plot panel. It will have clipping turned on.
# Best to turn this clipping off.
g4$layout
g4$layout$clip[g4$layout$name == "panel"] = "off"

grid.newpage()
grid.draw(g4)
g4 = editGrob(grid.force(g4), "text", grep=TRUE, hjust = 1)

# A variation of Ver 2a
# Select the panel from the layout.
# But again, g5 is a plot panel. Best to turn off the clipping

# Ver 2b
g5 = g3[6, 4]
# OR
pos = g3$layout[g3$layout$name == "panel", c("t", "l")]
g5 = g3[pos[[1]], pos[[2]]]
g5$layout$clip[g5$layout$name == "panel"] = "off"

# Extract the pure grid grob.
# Pure grid grob - clipping is already turned off.
# Sometimes, I think it is preferable to extract the pure grid grob.
# Recall: the order of the grobs in the list of grobs is the same as the order in the layout dataframe.

# Ver 2c
g6 = g3$grobs[[grep("panel", g3$layout$name)]]
g6 = editGrob(g6, "text", grep=TRUE, hjust = 1)
grid.newpage()
grid.draw(g6)

# Complete the plot
# I add the grob contain the text (g4, g5 or g6) to the original dot plot using annotation_custom.
# Recall: annotation_custom positions grobs using data coordinates.
# But unlike other grobs, the plot panel does not expand if I use coordinates outside the initial plot panel.
# That is, I give annotation_custom an x-coordinate that is just a little larger than the maximum x-coordinate.
# The y-coordinates are easy. I want the new grob to span the full height of the data plot panel;
# that is, "-Inf" to "Inf".

p7 = p2 +
     annotation_custom(grob = g4,
                xmin = 1.15*max(data$Prop), xmax = 1.15*max(data$Prop),
                ymin = -Inf, ymax = Inf)

# The annotation is of an annotation of the dot plot's panel,
# but it is positioned outside the dot plot's panel.
# Therefore, I need to turn off the clipping.
# Get the ggplot grob for the completed chart, and turn off clipping.
g7 <- ggplotGrob(p7)
g7$layout$clip[g7$layout$name == "panel"] = "off"

# Draw the chart
grid.newpage()
grid.draw(g7)

# The alignment is better. The numbers are centre justified.
# I've left an additional line of code in the supplementary material
# that will allow different alignment.
# It involved borrowing a bit deeper into the grob.
# I deal with this in later lectures, but I leave the code here for those in a rush.

# A point to note: I'm forcing the annotation into a space of zero width.
# Thus the grob will spill outside the space available.
# And therefore, it is important to turn off clipping if using g4 (or g5) -
# the grobs that are themselves plot panels.
# I didn't have to turn off clipping.
# But then I would have had to select xmin and xmax values that would have allowed the grob to fit.
# It was easier, I think, to turn off the clipping.
# Arguably, easier still is to extract a pure grid grob from the grob list - g6.

## Ver 3
# Create the grobs on the run.
# Another option is to position each string in its own annotation_custom.
# That is, each string is its own textGrob.
# Now it will be easy to justify the numbers.
# I use the "just" slot in the textGrob function.
# There are five numbers;
# thus five grobs to be created;
# and five anotation_custom statements.
# Here, I use a loop.
# Each time through the loop, the y-coordinate is obtained from the data dataframe,
# and the x-coordinate is just a little larger than the maximum x-coordinate.

p2 <- p1 + theme(plot.margin = unit(c(2, 5, 3, 1), "lines"))

for (i in 1:length(data$Prop))  {
p2 <- p2 + annotation_custom(
      grob = textGrob(label = data$Prop[i], just = "right", gp = gpar(cex = .75)),
      ymin = data$School[i],         # Vertical position of the textGrob
      ymax = data$School[i],
      xmin = 1.17*max(data$Prop),    # Note: The grobs are positioned outside the plot area
      xmax = 1.17*max(data$Prop))
   }

# And another annotation_custom to position the label "P".
p2 <- p2 +  annotation_custom(
             grob = textGrob(label = "P", just = "right", vjust = 2),
             xmin = 1.16*max(data$Prop),
             xmax = 1.16*max(data$Prop),
             ymin = Inf,
             ymax = Inf)

# The annotations are not yet visible
p2

# Get the ggplot grob, turn off clipping on the plot panel
g2 <- ggplotGrob(p2)
g2$layout$clip[g2$layout$name == "panel"] = "off"

# draw the chart
grid.newpage()
grid.draw(g2)

###################
####### add grob to new column created using gtable_add_column
####### add grob with viewport

# Like ver 2, in that a second plot is drawn to contain just the text,
# and then extract the plot panel.
# But unlike ver 2, the panel is added to the original dot plot
# using gtable functions: gtable_add_col(), gtable_add_grob

# dot plot
# The original plot but with some space to the right for the annotation
p2 = p1 + theme(plot.margin = unit(c(1, 3.5, .5, .5), "lines"))

# The chart containing the text
p3 = ggplot(data, aes(x = 1, y = School, label = Prop)) +
     geom_text(size = 3) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = NA))

p3

# Get the ggplot grob
g3 = ggplotGrob(p3)
g3$layout

### First ggplot edit
# Example 3
# Scenario
# I want to add an annotation on the horizontal axis,
# indicating the location of a "Critical" proportion.
# The annotation contains a dotted line across the plot,
# a tick mark at the critical value;
# text indicating the critical value (0.33); and
# text indicating that the value is critical ("Critical").

# I construct the grob (Lesson ??).
# I first construct the four grobs separately,
# then combine the four grobs in a gTree structure.
# I will use annotation_custom to position the grob,
# but I will let annotation span the full height of the plot panel;
# that is, in the annotation_custom, ymax and ymin are "Inf" and "-Inf" respectively.
# I position the individual grobs when I create them using the default npc units:
# the two text grobs ("0.33", and "Critical") just below the bottom boundary,
# the tick mark spans the bottom boundary,
# and the line spans the plot panel.
# I don't worry about the x-coordinates when constructing the grobs;
# the x-coordinates will be taken care of with the placement of the annotation_custom.

gtext1 = textGrob("0.33", y = -.055, gp = gpar(col = "red"))
gtext2 = textGrob("Critical", y = -.09, gp = gpar(col = "red"))
gtick = linesGrob(y = c(-.01, .01),  gp = gpar(col = "red", lwd = 3))
gsegment = linesGrob(y = c(0, 1), gp = gpar(col = "red", lty = 3, lwd = 1))

ggrob = gTree("ggrob", children = gList(gtext1, gtext2, gsegment, gtick))

# Position the grob using annotation_custom.
# The x-coordinate can now be set (in data coordinates).
# Note the y-coordinates (-Inf, and Inf).
p3 = p2 + annotation_custom(ggrob, xmin=0.33, xmax=0.33, ymin=-Inf, ymax=Inf)

# Once again, elements are outside the plot panel:
# the dot for school C;
# the original annotations to the right of the plot; and,
# part of the new annotation.

g3 = ggplotGrob(p3)
g3$layout$clip[g3$layout$name=="panel"] <- "off"
grid.draw(g3)

# In this way, the placement of the grob in the horizontal direction is in terms of data coordinates,
# but the positioning in the vertical direction is in terms of relative (npc) coordinates.

# It's like we're able to mix unit systems.
# What's the advantage of doing it this way?
# I could have used data coordinates to fix the y-coordinates of the grob,
# But if the range of y-values changes (a school is added, or a school is dropped),
# the grob would no longer be nicely positioned.
# Doing the positioning in relative coordinates
# means that it doesn't matter if schools are added or dropped -
# the vertical positioning of the grob will exactly as it appears here.

# Complex grobs can be constructed,
# and with careful selection of x and y coordinates,
# and being careful about where the coordinates are set (in the grob construction or in the annotation_custom),
# A lot can be achieved with annotation_custom.

# But a note of caution - in a multi-panel plot (facet_grid or facet_wrap),
# the annotation will be drawn in every panel.
# If you don't want that effect, a different approach is required.
# Coming up in a later lesson.

###############################################################
## Lecture 15: Adding grobs to rows and columns of the gtable
###############################################################

# In Lecture 14, grobs were added using annotation_custom() function.
# This meant that the grob was added to the plot panel
# By selecting coordinates beyond the bounds of the plot panel,
# the grobs could nevertheless be positioned outside the panel.
# Thus, the first gtable edit - turn off clipping of the plot panel.

# In this lecture - the grobs are positioned using gtable functions,
# sometimes adding rows and columns to receive the grobs.

# Example 1
# Colour the border
# A contrived example: A want the border to be coloured red.
# Draw graph
set.seed(64534)
p1 <- ggplot(data.frame(x = rnorm(100), y = rnorm(100),
                       f1 = rep(c("A","B"), 50),
                       f2 = rep(c("C", "D"), each = 50)),
            aes(x,y)) + geom_point()
p1

# To get the ggplot gtable, use the ggplot2 function, ggplotGrob()
g1 <- ggplotGrob(p1)

gtable_show_layout(g1)
g1$layout

# Construct the grob - a red rectangle
rectR = rectGrob(gp = gpar(col = "red", fill = "red"))

# Add the rectabgle grob to the plot using
# Recall: gtable_add_grob from Lecture ??
# Four borders, four statements.
# What differs in the four statments are the t, l, b, and r parameters.
g1 = gtable_add_grob(g1, rectR, t=1, l=1, b=1, r=5)
g1 = gtable_add_grob(g1, rectR, t=1, l=5, b=6, r=5)
g1 = gtable_add_grob(g1, rectR, t=6, l=1, b=6, r=5)
g1 = gtable_add_grob(g1, rectR, t=1, l=1, b=6, r=1)

grid.newpage()
grid.draw(g1)

# Example 2
## Inspired by http://stackoverflow.com/questions/28652284/how-to-change-color-of-facet-borders-when-using-facet-grid/28669873#28669873
# In a facetted plot, colour gaps between panels

# Get the plot
p <- ggplot(mtcars, aes(mpg, wt)) + geom_point() +
     facet_grid(am ~ cyl)

## Get the plot grob
gt <- ggplotGrob(p)

# I could get the columns and rows from the layout
gtable_show_layout(gt)

# Vertical gaps are in columns 5 and 7
# and span rows 3 to 6.
# Horizontal gap is in row 5
# and spans columns 4 to 9

# Create an orange rectangle
rectG = rectGrob(gp = gpar(col = NA, fill = "orange"))

# Position the rectangle grob into the rows and columns.
# I could position the rectangles, one at a time, into the relevant columns and rows

gt = gtable_add_grob(gt, rectG, t = 3, l = 5, b = 6)
gt = gtable_add_grob(gt, rectG, t = 3, l = 7, b = 6)
gt = gtable_add_grob(gt, rectG, t = 5, l = 4, r = 9)

grid.newpage()
grid.draw(gt)

# If there were lots of panels, this could get tedious.
# I could be a bit more efficient.
# I'll use a loop.

gt <- ggplotGrob(p)

## Add orange rectangles into the vertical gaps
for(i in c(5, 7))
   gt <- gtable_add_grob(gt,
         list(rectGrob(gp = gpar(col = NA, fill = "orange"))),
         t=3, l=i, b=6, r=i)

## Add orange rectangles into the horizontal gaps
for(j in c(5) )
   gt <- gtable_add_grob(gt,
         list(rectGrob(gp = gpar(col = NA, fill = "orange"))),
         t=j, l=4, b=j, r=9)

grid.newpage()
grid.draw(gt)

# But I still need to get the relevant row and column indices.

## To automate the selection of the relevant rows and columns:
# I begin with the panels.
# The panels are named in the layout dataframe,
# and therefore I can get the t, l, b, and r values for each panel.
# See panels below

# I can get the columns that the horizontal gaps span:
# they span from the left-hand panel through to one more than than the right-hand panel.
# Why "one more"? I want the colour to extend into the gap between the strips.
# See Cmin and Cmax below

# Similarly, I can get the rows that the vertical gaps span:
# they span from one row above the top panel through to the bottom panel.
# Why "one row above"? Again, I want the colour to extend into the gap between the strips.
# See Rmin and Rmax below

# The vertical gaps are one column to the right of the panels' r index (except the right most panel)
# See gapsC below

# The horizontal gap are one below the panels' b index (except the bottom most panel)
# See gapsR below

## Get the plot and the plot grob
p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() +
     facet_grid(gear ~ cyl)
gt <- ggplotGrob(p)

# From the layout dataframe, use the subset() function to select t to r columns for "panels" only
panels = subset(gt$layout, grepl("panel", gt$layout$name), t:r)

# Vertical gaps span columns:
Cmin <- min(panels[,"l"])
Cmax <- max(panels[,"r"]) + 1 #(+1 because I want the colour to extend into the gap between the strips

# Horizontal gaps span rows:
Rmin <- min(panels[,"t"]) - 1 # (-1 because I want the colour to extend into the gap between the strips
Rmax <- max(panels[,"b"])

panelsC <- unique(panels[, "r"])
#Vertical gaps are in:
gapC <- panelsC[-length(panelsC)] + 1  # gaps are one column to the right of the panels, except the right most panel

panelsR <- unique(panels[, "b"])
# Horizontal gaps are it:
gapR <- panelsR[-length(panelsR)] + 1  # gaps are one row below the panels, except the bottom most panel.

## Add orange rectangles into the vertical and horizontal gaps
# for(i in gapC)
#   gt <- gtable_add_grob(gt,
#         rectGrob(gp = gpar(col = NA, fill = "burlywood")),
#         Rmin, i, Rmax, i)

# for(j in gapR)
#   gt <- gtable_add_grob(gt,
#         rectGrob(gp = gpar(col = NA, fill = "burlywood")),
#         j, Cmin, j, Cmax)

## Draw it
# grid.newpage()
# grid.draw(gt)

# A function to position the rectangle into the gtable
ColourGap = function(t, l, b, r, g, fill = "grey98") {
   gtable_add_grob(g,
   rectGrob(gp = gpar(col = NA, fill = fill)),
   t, l, b, r)
}

# The colour of the gaps
c = "burlywood"

# A loop to colour each vertical gap
for(i in gapC)
   gt = ColourGap(Rmin, i, Rmax, i, gt, c)

# A loop to colour each horizontal gap
for(j in gapR)
   gt = ColourGap(j, Cmin, j, Cmax, gt, c)

# Draw the chart
grid.newpage()
grid.draw(gt)

## Example 3
# Continuing with the previous example:
# The labels in the strips are not terrifically informative.
# I know I can add the variable name to the strips quite easily using regular ggplot commands.
# But inspired by these stackoverflow questions:
# http://stackoverflow.com/questions/11353287/how-do-you-add-a-general-label-to-facets-in-ggplot2/12660057#12660057
# http://stackoverflow.com/questions/22818061/annotating-facet-title-as-strip-over-facet/22825447#22825447#
# http://stackoverflow.com/questions/29311772/ggplot2-more-complex-faceting/29323739#29323739

# It is straightforward to place the variable name in its own strip

# Take the  plot created in the previous example.
gt1 = gt
grid.newpage()
grid.draw(gt1)

# The strips that contain 4, 6, and 8 represent the number of cylinders,
# and the strips that contain 3, 4, and 5 represent the number of forward gears.
# I want to create another strip that spans across the three strips at the top but above them,
# to contain the text "Number of Cylinders".
# Similarly, I want a strip to the right of the vertical strips
# to contain the text "Number of "Gears".

#  The layout data frame contains the t, l, b and R values for the two sets of strips.
# From the layout dataframe, use the subset() function to select t to r columns for "panels" only

gtable_show_layout(gt1)

# The upper horizontal strip is in row 3, and span across columns 4, 6 and 8.
# The right vertical strip is in column 9, and spans down rows 4, 6 and 8.

# Thus I add a new row above row 3,
# except I have to add a row BELOW a position - row 2.
# And, I add a new column to the right of column 9

gt1 = gtable_add_rows(gt1, unit(0.6, "cm"), pos = 2)
gt1 = gtable_add_cols(gt1, unit(0.6, "cm"), pos = 9)

HStrip = gTree("HStrip", children = gList(
   #rectGrob(gp = gpar(fill = "grey85", col = NA)),
   textGrob(label = "Number of Cylinders", gp = gpar(cex = .9))))

gt1 = gtable_add_grob(gt1, HStrip, t=3, l=4, r=8)

VStrip = gTree("VStrip", children = gList(
   #rectGrob(gp = gpar(fill = "grey85", col = NA)),
   textGrob(label = "Number of Gears", rot = -90, gp = gpar(cex = .9))))

gt1 = gtable_add_grob(gt1, VStrip, t=5, l=10, b=9)

# Add small gap between strips
gt1 <- gtable_add_rows(gt1, unit(2/10, "line"), 3)
gt1 <- gtable_add_cols(gt1, unit(2/10, "line"), 9)

grid.newpage()
grid.draw(gt1)

# Get the positions of the right strips in the layout: t = top, l = left, ...
stripR <-c(subset(gt$layout, name == "strip-right", select = t:r))

# Example 4: Returning to the school plot of Lecture 14
## In Lecture 14, a minor problem with the school plot:
# if the number of schools changes,
# or the proportions change,
# positioning the annotation according to data units could be a problem.
# Remember, the annotation is positioned as a multiple of the maximum.
# If, in a modified dataframe, the maximum is larger than in the original,
# the annotation will be place further from the right boundary.
# In what follows, I use lessons from Lecture ??:
# Add a column to the ggplot layout;
# Then position the grob into the new column.

# A solution
# Get the original plot
data <- data.frame(School = c("A", "B", "C", "D", "E"),
                  Prop = c(0.27, 0.36, 0, 0.15, 0.29))
data$School <- factor(data$School, levels = rev(data$School))

p1 <- ggplot(data , aes(Prop, School)) +
     geom_segment(aes(xend = 0, yend = School), linetype = 3, size = .5) +
     geom_point(size = 3) +
     scale_x_continuous("Number of Students", limits = c(0, 1.1*max(data$Prop)), expand = c(0,0)) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = "black"))

p1

# Get the ggplot grob and check the layout dataframe.
# Note: Clip is on for the panel
g1 <- ggplotGrob(p1)
g1$layout

# Get the chart containing the text
p3 = ggplot(data, aes(x = 1, y = School, label = Prop)) +
     geom_text(size = 3) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = NA))

# Get the ggplot grob and extract the panel.
g3 = ggplotGrob(p3)
g6 = g3$grobs[[grep("panel", g3$layout$name)]]

# Add a column to g1 ready to take the extracted panel
# Recall: gtable_add_cols from Lecture ??
g1 = gtable_add_cols(g1, width = unit(3, "lines"), pos = 4)

# Add the panel (g6) to the new column
g1 = gtable_add_grob(g1, g6, t = 3, l = 5, z = .5)

# Draw the plot
grid.newpage()
grid.draw(g1)

# Drawing the p3 plot to extract the panel - a bit tedious having the draw the plot.
# Also, difficult to change the justification of the text.
# This method creates and positions the text grobs in the new column,
# and because it creates each text grob separately, it is easy to modify the justification.

# data
data <- data.frame(School = c("A", "B", "C", "D", "E"),
                  Prop = c(0.27, 0.36, 0, 0.15, 0.29))
data$School <- factor(data$School, levels = rev(data$School))

# original plot
p1 <- ggplot(data , aes(Prop, School)) +
     geom_segment(aes(xend = 0, yend = School), linetype = 3, size = .5) +
     geom_point(size = 3) +
     scale_x_continuous("Proportion of Students", limits = c(0, 1.1*max(data$Prop)), expand = c(0,0)) +
     theme_bw() +
     theme(panel.grid = element_blank(),
           panel.border = element_rect(colour = "black"))

# Add columns to ggplot gtable
g1 <- ggplotGrob(p1)
g1 = gtable_add_cols(g1, width = unit(4, "lines"), pos = 4)

# New
# How to position the text grobs in the new column?
# Grid does not know about the discrete scale used on the y-axis.
# But ggplot does know about npc units - the unit system that ranges between 0 and 1.
# I can obtain the y positions in npc units by calling ggplot_build().
# ggplot_build contains the information that ggplot uses to construct the chart.
tab = ggplot_build(p1)
y = tab$layout$panel_ranges[[1]]$y.major
y

# Position the five text grobs into the new column
for (i in 1:length(data$Prop)) {
     grob = textGrob(label = data$Prop[i], x = .3, y = rev(y)[i], just = "left", gp = gpar(cex = .75))
     g1 = gtable_add_grob(g1, grob, t = 6, l = 5, name = as.character(i))
}

g1 = gtable_add_grob(g1, textGrob("Prop", x = .3, y = 1, vjust = 2, just = "left",), t = 6, l = 5, name = "label")

# Still need to turn off clipping to take care of zero dot for School C
g1$layout$clip[g1$layout$name=="panel"] <- "off"

grid.newpage()
grid.draw(g1)

# Change the data
data <- data.frame(School = c("A", "B", "C", "D", "E", "F"),
                  Prop = c(0.27, 0.36, 0, 0.15, 0.29, .5))
data$School <- factor(data$School, levels = rev(data$School))

# Adding text
# http://stackoverflow.com/questions/21997715/add-ggplot-annotation-outside-the-panel-or-two-titles
p = qplot(1,1)
g = ggplotGrob(p)

g = gtable_add_grob(g, grobTree(textGrob("left", x=0, hjust=0),
                                textGrob("right", x=1, hjust=1)),
                    t=1, l=4)

# http://stackoverflow.com/questions/18033568/gtable-add-grob-linesgrob-not-displayed
# gtable_add_grobs is vectorised

g <- gtable(widths = unit(c(1,1), "null"),
            heights = unit(c(1,1), "null"))

cell <- function(ii)
  grobTree(rectGrob(),
           linesGrob(1:4, 1:4, default.units="native"),
           textGrob(ii),
           vp=dataViewport(c(1,4), c(1,4)))

gl <- lapply(1:4, cell)

xy <- expand.grid(1:2, 1:2)

g <- gtable_add_grob(g, gl,
                      l=xy[,1],
                      r=xy[,1],
                      t=xy[,2],
                      b=xy[,2])

grid.newpage()
grid.draw(g)

## Adding plot to vacant panel in facet_wrap
plot1 <- ggplot(mtcars, aes(factor(mtcars$gear))) +
    geom_bar() +
    facet_wrap(~cyl, ncol=2) +
    coord_flip()

plot2 <- ggplot(mtcars, aes(as.factor(am))) +
    geom_bar(aes(fill=factor(cyl)))

g1 <- ggplotGrob(plot1)
g2 <- ggplotGrob(plot2)

g1 <- gtable::gtable_add_grob(g1, g2, t = 8, l=7)
grid.newpage()
grid.draw(g1)

## adding plot to margins
# http://stackoverflow.com/questions/31587088/perfect-fit-of-ggplot2-plot-in-plot/31644681#31644681
library(rms)

# Data
data(pbc)
d <- pbc
rm(pbc)
d$status <- ifelse(d$status != 0, 1, 0)

dd = datadist(d)
options(datadist='dd')

f <- cph(Surv(time, status) ~  rcs(age, 4), data=d)
p <- Predict(f, fun=exp)
df <- data.frame(age=p$age, yhat=p$yhat, lower=p$lower, upper=p$upper)

# X-axis
breaks <- boxplot.stats(p[,"age"])$stats

# Main plot
MP <- ggplot(data=df, aes(x=age, y=yhat)) + geom_line(size=1) +
     geom_ribbon(data=df, aes(ymin=lower, ymax=upper), alpha=0.5, linetype=0, fill='#FFC000') +
     theme_bw() +
     scale_x_continuous(breaks=breaks) +
     xlab("Age") +
     ylab("Hazard Ratio") +
     theme(axis.line = element_line(color='black', size=1),
       axis.ticks = element_line(color='black', size=1),
       panel.grid.minor = element_blank())

# Boxplot
BP <- ggplot(data=df, aes(x=factor(1), y=age)) +
      geom_boxplot(width = 1, outlier.shape=NA, size=1) +
      geom_jitter(position = position_jitter(width = .2), size = 1) +
      scale_y_continuous(breaks=breaks) +
      coord_flip()  +
      theme_bw() +
      theme(panel.border=element_blank(),
            panel.grid=element_blank())

####  Set up the grobs and gtables  here
library(gtable)

h = 1/10  # height of boxplot panel relative to main plot panel

# Get ggplot grobs
gMP = ggplotGrob(MP)
BPg = ggplotGrob(BP)
BPg = gtable_filter(BPg, "panel")  # from the boxplot, extract the panel only

# In the main plot, get position of panel in the layout
pos = gMP$layout[gMP$layout$name == "panel", c('t', 'l')]

# In main plot, set height for boxplot
gMP$heights[pos$t-1] = list(unit(h,  "null"))

# Add boxplot to main plot
gMP = gtable_add_grob(gMP, BPg, t=pos$t-1, l=pos$l)

# Draw it
grid.newpage()
grid.draw(gMP)

######################
### http://stackoverflow.com/questions/17492230/how-to-place-grobs-with-annotation-custom-at-precise-areas-of-the-plot-region/17493256#17493256
library(gtable)
library(ggplot2)
library(plyr)

set.seed(1)
d <- data.frame(x=rep(1:10, 5),
                y=rnorm(50),
                g = gl(5,10))

# example plot
p <- ggplot(d, aes(x,y,colour=g)) +
  geom_line() +
  scale_x_continuous(expand=c(0,0))+
  theme(legend.position="top",
        plot.margin=unit(c(1,0,0,0),"line"))

# dummy data for the legend plot
# built with the same y axis (same limits, same expand factor)
d2 <- ddply(d, "g", summarise, x=0, y=y[length(y)])
d2$lab <- paste0("line #", seq_len(nrow(d2)))

plegend <- ggplot(d, aes(x,y, colour=g)) +
  geom_blank() +
  geom_segment(data=d2, aes(x=2, xend=0, y=y, yend=y),
               arrow=arrow(length=unit(2,"mm"), type="closed")) +
  geom_text(data=d2, aes(x=2.5,label=lab), hjust=0) +
  scale_x_continuous(expand=c(0,0)) +
  guides(colour="none")+
  theme_minimal() + theme(line=element_blank(),
                          text=element_blank(),
                          panel.background=element_rect(fill="grey95", linetype=2))

# extract the panel only, we don't need the rest
gl <- gtable_filter(ggplotGrob(plegend), "panel")

# add a cell next to the main plot panel, and insert gl there
g <- ggplotGrob(p)
index <- subset(g$layout, name == "panel")
g <- gtable_add_cols(g, unit(1, "strwidth", "line # 1") + unit(1, "cm"))
g <- gtable_add_grob(g, gl, t = index$t, l=ncol(g),
                     b=index$b, r=ncol(g))
grid.newpage()
grid.draw(g)

## adding plot to main plot panel

###############################################################
## Lecture ??: A closer look ggplot gtable
###############################################################

# Locating plot title

# Locating axis labels

# Locating facet strips

# Locating legends

# Locating axes

# Locating the plot panel

# Load packages
library(ggplot2)
library(gtable)

# Draw graph
set.seed(64534)
p1 <- ggplot(data.frame(x = rnorm(100), y = rnorm(100),
                       f1 = rep(c("A","B"), 50),
                       f2 = rep(c("C", "D"), each = 50)),
            aes(x,y)) +
        geom_point() +
        ggtitle("A Scatterplot")
p1

# To get the ggplot gtable, use the ggplot2 function, ggplotGrob()
g1 <- ggplotGrob(p1)

gtitle1 = g1$grobs[[grep("title", g1$layout$name)]]
gtitle2 = gtable_filter(g1, "title")

str(gtitle1)

grid.newpage()
grid.draw(gtitle1)

ggtitle1 = grid.grab()
grid.ls()


subroutine acchk(i,j,k,anticl,x,y,ntot,eps)
# Check whether vertices i, j, k, are in anti-clockwise order.
# Called by locn, qtest, qtest1.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3)
logical anticl

# Create indicator telling which of i, j, and k are ideal points.
if(i<=0) i1 = 1
else i1 = 0
if(j<=0) j1 = 1
else j1 = 0
if(k<=0) k1 = 1
else k1 = 0
ijk = i1*4+j1*2+k1

# Get the coordinates of vertices i, j, and k. (Pseudo-coordinates for
# any ideal points.)
xt(1) = x(i)
yt(1) = y(i)
xt(2) = x(j)
yt(2) = y(j)
xt(3) = x(k)
yt(3) = y(k)

# Get the ``normalized'' cross product.
call cross(xt,yt,ijk,cprd)

# If cprd is positive then (ij-cross-ik) is directed ***upwards***
# and so i, j, k, are in anti-clockwise order; else not.
if(cprd > eps) anticl = .true.
else anticl = .false.
return
end


library(ggplot2)
library(sitools)

data = read.csv('net-io-service.csv')
data$timestamp = as.POSIXct(data$timestamp, origin="1970-01-01", tz="GMT")

ggplot(data, aes(timestamp, io, colour=service)) +
	labs(x = "Time", y = "Traffic (bytes)") +
	geom_line() +
	#scale_x_date(format = "%b-%Y")
	theme_bw() +
	#scale_fill_brewer(palette = 'Set2') +
	scale_y_continuous(labels=f2si) +
	theme(
		#panel.grid.major = element_line(colour = "white"),
		#panel.grid.minor = element_line(colour = "white"),
		#axis.text = element_text(size = 18),
		axis.text.x = element_text(angle=90,hjust=1,vjust=0.5),
		#axis.title = element_text(size = 20, face="bold")
	)
ggsave('net-io-service.pdf', width=10, height=5)


rm(list = ls())

#load data
meth_level <- read.csv("meth_level.csv", header = T, stringsAsFactors = F)
meth_level <- as.numeric(meth_level$X0)
idx <- which(!is.na(meth_level))
meth_level <- meth_level[idx]

meth_prob <- read.csv("meth_prob.csv", header = T, stringsAsFactors = F)
meth_prob <- meth_prob$pred_prob
meth_prob <- meth_prob[idx]

#histgram
grade <- ceiling(meth_level*10)
df <- data.frame(score = meth_prob, level = grade)

plot_level_score <- function(df, cutoff = 0.5){

  print(cutoff)
  idx <- which(df$score > cutoff)
  level_score <- df[idx,'level']

  x <- table(level_score)
  y <- table(df$level)

  len = length(y) - length(x)
  x <- c(rep(0, len), x)

  ratio <- x / y

  pdf(paste(cutoff,'.pdf', sep = ''))
  barplot(ratio, main = paste('cutoff=', cutoff, sep=''), ylim = c(0,1))
  dev.off()

  print(ratio)
  return(ratio)
}

cutoffs <- c(seq(0.5,0.9,0.1),
             seq(0.91, 0.98, 0.01))

rslts = matrix(0, length(cutoffs), 11)
i = 1
for (value in cutoffs){
  df <- df[df$level!=0,]
  rslt= plot_level_score(df, cutoff = value)
  common_idx = intersect(1:10, names(rslt))
  common_idx = as.numeric(common_idx) + 1
  rslts[i, common_idx] = rslt
  rslts[i, 1] = value
  i = i + 1
}

rslts <- as.data.frame(rslts)
colnames(rslts) <- c('cutoff_probability', paste('level', 1:10, sep = ''))
write.csv(file='celegans.csv', rslts, row.names = F, quote = T)


data = read.table ({{i.infile | quote}}, sep="\t", header={{args.cnames | R}}, row.names={{args.rnames | lambda x: 'NULL' if not x else int(x)}}, check.names=F)
if ({{args.transpose | R}}) {
	data = t(data)
}
data = data[, apply(data, 2, sd)!=0, drop=F]

dmat = dist(data)
if ({{args.fast | R}}) {
	library('fastcluster')
}
orderfile = file.path ({{o.outdir | quote}}, "order.txt")
mergefile = file.path ({{o.outdir | quote}}, "merge.txt")
clustfig  = file.path ({{o.outdir | quote}}, "hclust.png")
hobj = hclust (dmat, method={{args.method | quote}})

do.call(png, c(list(file = clustfig), {{args.devpars | Rlist}}))
library('ggplot2')
library('ggdendro')
ggdendrogram (hobj, rotate={{args.rotate | R}})
dev.off()
orderobj = data.frame (Order=hobj$order, Labels=hobj$labels)
mergeobj = data.frame (Merge1=hobj$merge[,1], Merge2=hobj$merge[,2], Height=hobj$height)
write.table (orderobj, orderfile, quote=F, row.names=F, col.names = T, sep="\t")
write.table (mergeobj, mergefile, quote=F, row.names=F, col.names = T, sep="\t")


df.scores = fread("results/Score_table.txt") %>%
  dplyr::mutate(subject = as.character(subject) %>% factor())
df.scores.rank = df.scores %>%
  mutate_at(vars(matches("\\(")), rank, na.last="keep")

dn.fig = "figures/sig_ranked_correlation"
dir.create(dn.fig, showWarnings = F, recursive = T)

cc = cor.test(df.scores$`CD38hi (flow)`, df.scores$`CD40act (C3.1.0)`, method = "spearman")
df.txt = data.frame(x=Inf, y=-Inf, label=glue::glue("r = {format(cc$estimate, digits=2)}\np = {format(cc$p.value, digits=2)}"))

ggplot(df.scores.rank, aes(`CD38hi (flow)`, `CD40act (C3.1.0)`, fill=response)) +
  geom_point(shape = 21, size=3, col="black", show.legend = F) +
  scale_fill_manual(values = c("black","white")) +
  geom_text(aes(x, y, label=label), col="black", hjust=1.1, vjust=-0.5, data=df.txt, inherit.aes = F) +
  xlab("CD20+CD38++ B cells (% of parent)") +
  ylab("CD40act score in C3.1.0 cluster") +
  theme_bw()
ggsave(file.path(dn.fig, "CD40act_C3.1.0_vs_CD38hi.flow.png"), w=3.2, h=3)
ggsave(file.path(dn.fig, "CD40act_C3.1.0_vs_CD38hi.flow.pdf"), w=3.2, h=3, useDingbats=F)


#----------------------------------------------------------------------------------------------------------
# Name:         myEVfunctions.r
# Purpose:      External functions called by the EV_RL.r & EV_RP.r scripts
# Author:       Francesco Tonini
# Email: 	    f_tonini@hotmail.com
# Created:      11/1/2009
# Copyright:    (c) 2009 by Francesco Tonini
# License:    	GNU General Public License (GPL)
# Software:     Tested successfully using R-2.14.0 64-bit version(http://www.r-project.org/)
#-------------------------------------------------------------------------------------------

##CALL PACKAGES MODULE
##This module is used to call all required packages
load.packages <- function()
{
	#setRepositories(ind=1:2)
	pkg <- c("ismev","stats","tcltk2","RANN","maptools","evd")
	w <- which(pkg %in% row.names(installed.packages()) == FALSE)
	if (length(w) > 0) install.packages(pkg)[w]
	#install.packages(c("ismev","stats","tcltk2","RANN","maptools","evd")) alternatively

	#Load (call) specific packages from the existing library collection into the current R session
	require(ismev)       #An Introduction to Statistical Modeling of Extreme Values
	require(stats)       #R statistical functions
	require(tcltk2)      #Tkinter objects and classes
	require(RANN)        #spatial functions (e.g. NN interpolation)
	require(maptools)    #reading and writing shapefiles
	require(evd)		 #Functions for extreme value distributions
	#require(raster)     #functions for raster data type
	#require(extRemes)   #only for automatic return-values calculation

	cat('\nAll libraries have been loaded successfully!\n')
}

##GRADIENT FUNCTION MODULE
##This module is used within  the return level module to compute the confidence intervals
##with delta method
gevrlgradient<-function (z, p)
{
    scale <- z$mle[2]
    shape <- z$mle[3]
    if (shape < 0)
        zero.p <- p == 0
    else zero.p <- logical(length(p))
    out <- matrix(NA, nrow = 3, ncol = length(p))
    out[1, ] <- 1
    if (any(zero.p)) {
        out[2, zero.p & !is.na(zero.p)] <- rep(-shape^(-1), sum(zero.p,
            na.rm = TRUE))
        out[3, zero.p & !is.na(zero.p)] <- rep(scale * (shape^(-2)),
            sum(zero.p, na.rm = TRUE))
    }
    if (any(!zero.p)) {
        yp <- -log(1 - p[!zero.p])
        out[2, !zero.p] <- -shape^(-1) * (1 - yp^(-shape))
        out[3, !zero.p] <- scale * (shape^(-2)) * (1 - yp^(-shape)) -
            scale * shape^(-1) * yp^(-shape) * log(yp)
    }
    return(out)
}

##RETURN LEVEL CALCULATION MODULE
##This module computes return levels based on the distibution used (GEV, gumbel, GPD)
return.levels <- function (z, conf = 0.05, rperiods = c(10, 100, 210, 510, 810, 980), make.plot = TRUE)
{
    out <- list()
    out$conf.level <- conf
    eps <- 1e-06
    a <- z$mle

    #prova
    #a1<-z$mle[1] + z$mle[2]*rperiods

    std <- z$se
    mat <- z$cov
    dat <- z$data

    kappa <- qnorm(conf/2, lower.tail = FALSE)
    nx <- length(rperiods)
    cl <- 1 - conf

    if (class(z) == "gev.fit") {

		if (is.null(rperiods)) rperiods <- seq(1.1, 1000, , 200)
        if (any(rperiods <= 1))
            stop("return.level: this function presently only supports return periods >= 1")
        yp <- -log(1 - 1/rperiods)
        if (a[3] < 0)
            zero.p <- yp == 0
        else zero.p <- logical(length(rperiods))
        zero.p[is.na(zero.p)] <- FALSE
        q <- numeric(length(rperiods))
        if (any(zero.p))
            q[zero.p] <- a[1] - a[2]/a[3]
        if (any(!zero.p)) {
            if (a[3] != 0)
                q[!zero.p] <- a[1] - (a[2]/a[3]) * (1 - (yp[!zero.p])^(-a[3]))
            else if (a[3] == 0)
                q[!zero.p] <- a[1] - a[2] * log(yp[!zero.p])
        }

        d <- gevrlgradient(z = z, p = 1/rperiods)
        v <- apply(d, 2, q.form, m = mat)
        yl <- c(min(dat, q, na.rm = TRUE), max(dat, q, na.rm = TRUE))
        if (make.plot) {
            xp <- 1/yp
            plot(xp, q, log = "x", type = "n", xlim = c(0.1,
                1000), ylim = yl, xlab = "Return Period", ylab = "Return Level",
                xaxt = "n")
            axis(1, at = c(0.1, 1, 10, 100, 1000), labels = c("0.1",
                "1", "10", "100", "1000"))
            lines(xp, q)
            lines(xp, (q + kappa * sqrt(v)), col = "blue")
            lines(xp, (q - kappa * sqrt(v)), col = "blue")
            points(-1/log((1:length(dat))/(length(dat) + 1)),
                sort(dat))
        }
        out$return.level <- q
        out$return.period <- rperiods
        conf3 <- cbind(q - kappa * sqrt(v), q + kappa * sqrt(v))
        colnames(conf3) <- c("lower", "upper")
        out$confidence.delta <- conf3

	}

	if (class(z) == "gum.fit") {

        if (is.null(rperiods))
            rperiods <- seq(1.1, 1000,  length=200)
        if (any(rperiods <= 1))
            stop("return.level: this function presently only supports return periods >= 1")
        yp <- -log(1 - 1/rperiods)
        q <- a[1] - a[2] * log(yp)
        vq <- std[1]^2 + ((-log(yp))^2 * std[2]^2)
	      sq <- sqrt(vq)

		yl <- c(min(dat, q, na.rm = TRUE), max(dat, q, na.rm = TRUE))
        if (make.plot) {
            xp <- 1/yp
            plot(xp, q, log = "x", type = "n", xlim = c(0.1,
                1000), ylim = yl, xlab = "Return Period", ylab = "Return Level",
                xaxt = "n")
            axis(1, at = c(0.1, 1, 10, 100, 1000), labels = c("0.1",
                "1", "10", "100", "1000"))
            lines(xp, q)
            lines(xp, (q + kappa * sq), col = "blue")
            lines(xp, (q - kappa * sq), col = "blue")
            points(-1/log((1:length(dat))/(length(dat) + 1)),
                sort(dat))
        }

		out$return.level <- q
        out$return.period <- rperiods
        conf3 <- cbind(q - kappa * sq, q + kappa * sq)
        colnames(conf3) <- c("lower", "upper")
        out$confidence.delta <- conf3
    }

	if (class(z) == "gpd.fit") {

        u <- z$threshold
        la <- z$rate
        a <- c(la, a)
        n <- z$n
        npy <- z$npy
        xdat <- z$xdata
        if (is.null(rperiods)) {
            rperiods <- seq(0.1, 1000, , 200)
        }
        m <- rperiods * npy
        if (a[3] == 0)
            q <- u + a[2] * log(m * la)
        else q <- u + a[2]/a[3] * ((m * la)^(a[3]) - 1)
        d <- gpdrlgradient(z, m)
        mat <- matrix(c((la * (1 - la))/n, 0, 0, 0, mat[1, 1],
            mat[1, 2], 0, mat[2, 1], mat[2, 2]), nc = 3)
        v <- apply(d, 2, q.form, m = mat)
        yl <- c(u, max(xdat, q[q > u - 1] + kappa * sqrt(v)[q >
            u - 1], na.rm = TRUE))
        if (make.plot) {
            if (any(is.na(yl)))
                yl <- range(q, na.rm = TRUE)
            plot(m/npy, q, log = "x", type = "n", xlim = c(0.1,
                max(m)/npy), ylim = yl, xlab = "Return period (years)",
                ylab = "Return level", xaxt = "n")
            axis(1, at = c(0.1, 1, 10, 100, 1000), labels = c("0.1",
                "1", "10", "100", "1000"))
            lines(m[q > u - 1]/npy, q[q > u - 1])
            lines((m[q > u - 1]/npy), (q[q > u - 1] + kappa *
                sqrt(v)[q > u - 1]), col = "blue")
            lines((m[q > u - 1]/npy), (q[q > u - 1] - kappa *
                sqrt(v)[q > u - 1]), col = "blue")
            nl <- n - length(dat) + 1
            sdat <- sort(xdat)
            points((1/(1 - (1:n)/(n + 1))/npy)[sdat > u], sdat[sdat >
                u])
        }
        out$return.level <- q
        out$return.period <- m/npy
        conf3 <- cbind(q[q > u - 1] - kappa * sqrt(v)[q > u -
            1], q[q > u - 1] + kappa * sqrt(v)[q > u - 1])
        colnames(conf3) <- c("lower", "upper")
        out$confidence.delta <- conf3

    }

invisible(out)

}

##NN INTERPOLATION FOR WARNINGS MODULE (FOR RETURN LEVELS)
##This module serves the purpose of replacing pixels, flagged as warning in the main script
##because of convergence issues, with the median of the nearest 4 or 8 neighbors

##NOTE: this works better if the raster resolution is not too coarse and the terrain is
##quite uniform to that of the central pixel. This is not recommended if that is not the case, or
##if you are using a very coarse resolution raster (e.g. 10 Km or more).
median.interp_RL <- function()
{

	Matr_coord <- cbind(dataset[1:npixels,]$x, dataset[1:npixels,]$y)

	for (px in px.idWarning){

		#Rook's neighborhood (using the 'spdep' package)
		NN4 <- knearneigh(Matr_coord,4)
		Matr_NN4 <- NN4$nn

		#Queen's neighborhood (using the 'spdep' package)
		#NN8 <- knearneigh(Matr_coord,8)
		#Matr_NN8 <- NN8$nn

		#take a subset of the NN matrix only for the pixels flagged with a warning
		Sub4 <- Matr_NN4[px,]
		#Sub8 <- Matr_NN8[px,]

		Mat_param <- tab.parameters[Sub4,]
		Mat_rlevels <- tab.rlevels[Sub4,]

		tab.parameters[px,3:length(tab.parameters)] <- round(sapply(Mat_param[,-c(1:2)],median),2)
		tab.rlevels[px,2:length(tab.rlevels)] <- round(sapply(Mat_rlevels[,-1],median),2)
	}

}

##NN INTERPOLATION FOR WARNINGS MODULE (FOR PROBABILITY EXCEEDANCES)
##This module serves the purpose of replacing pixels, flagged as warning in the main script
##because of convergence issues, with the median of the nearest 4 or 8 neighbors

##NOTE: this works better if the raster resolution is not too coarse and the terrain is
##quite uniform to that of the central pixel. This is not recommended if that is not the case, or
##if you are using a very coarse resolution raster (e.g. 10 Km or more).
median.interp_RP <- function()
{

	Matr_coord <- cbind(dataset[1:npixels,]$x, dataset[1:npixels,]$y)

	for (px in px.idWarning){

		#Rook's neighborhood (using the 'spdep' package)
		NN4 <- knearneigh(Matr_coord,4)
		Matr_NN4 <- NN4$nn

		#Queen's neighborhood (using the 'spdep' package)
		#NN8 <- knearneigh(Matr_coord,8)
		#Matr_NN8 <- NN8$nn

		#take a subset of the NN matrix only for the pixels flagged with a warning
		Sub4 <- Matr_NN4[px,]
		#Sub8 <- Matr_NN8[px,]

		Mat_param <- tab.parameters[Sub4,]
		Mat_prob <- tab.prob[Sub4,]

		tab.parameters[px,3:length(tab.parameters)] <- round(sapply(Mat_param[,-c(1:2)],median),2)
		tab.prob[px,2:length(tab.prob)] <- round(sapply(Mat_prob[,-1],median),2)
	}

}

##SAVE SHAPEFILE MODULE (FOR RETURN LEVELS)
##This module is used to save a point dataset to a shapefile (.shp)
save_files_RL <- function()
{

	Matr_coord <- cbind(dataset[1:npixels,]$x, dataset[1:npixels,]$y)

	tab.parameters$X <- Matr_coord[,1]
	tab.parameters$Y <- Matr_coord[,2]
	tab.rlevels$X <- Matr_coord[,1]
	tab.rlevels$Y <- Matr_coord[,2]

	##Turn input point dataset into a SpatialPointsDataFrame
	coordinates(tab.parameters) <- ~X+Y
	coordinates(tab.rlevels) <- ~X+Y

	##Path to folder
	path <- file.path(mainDir, subDir)

	##Write .csv tables
	write.table(tab.parameters, paste(path,'/MLE_Parameters.csv',sep=''), row.names=F, sep=',')
	write.table(tab.rlevels, paste(path,'/ReturnLevels.csv',sep=''), row.names=F, sep=',')

	##Write/Save the shapefile (library 'maptools')
	writeSpatialShape( tab.parameters, paste(path,'/MLE_Parameters',sep='') )
	writeSpatialShape( tab.rlevels, paste(path,'/ReturnLevels',sep='') )

	##Write/Save rasters (library 'raster')

}

##SAVE SHAPEFILE MODULE (FOR PROBABILITY EXCEEDANCES)
##This module is used to save a point dataset to a shapefile (.shp)
save_files_RP <- function()
{

	Matr_coord <- cbind(dataset[1:npixels,]$x, dataset[1:npixels,]$y)

	tab.parameters$X <- Matr_coord[,1]
	tab.parameters$Y <- Matr_coord[,2]
	tab.prob$X <- Matr_coord[,1]
	tab.prob$Y <- Matr_coord[,2]

	##Turn input point dataset into a SpatialPointsDataFrame
	coordinates(tab.parameters) <- ~X+Y
	coordinates(tab.prob) <- ~X+Y

	##Path to folder
	path <- file.path(mainDir, subDir)

	##Write .csv tables
	write.table(tab.parameters, paste(path,'/MLE_Parameters.csv',sep=''), row.names=F, sep=',')
	write.table(tab.prob, paste(path,'/ProbExceedance.csv',sep=''), row.names=F, sep=',')

	##Write/Save the shapefile (library 'maptools')
	writeSpatialShape( tab.parameters, paste(path,'/MLE_Parameters',sep='') )
	writeSpatialShape( tab.prob, paste(path,'/ProbExceedance',sep='') )

	##Write/Save rasters (library 'raster')

}

##PROBABILITY OF EXCEEDANCE MODULE
##This module is used to calculate the probability that the event will be exceeded in any one month
##(or year, or season, depending on what is your maxima/minima time series unit).
##The return period is the inverse of the probability of exceedance
prob_fun <- function(dataset,value,tab.extreme,nome,n=3){

	px.prob <- round(1 - pgev(-return_levels, loc=mu, scale=sig, shape=shp), 3)

	#Use the following line, and not the previous, if you are working with MAXIMA instead of MINIMA
	#px.prob <- round(1 - pgev(-return_levels, loc=mu, scale=sig, shape=shp), 3)

	#NOTE: the return period will then simply be 1/prob (in the time unit used, e.g. months)

	return(px.prob)

}


#
# MIT License
#
# Bob Rudis (@hrbrmstr) bob@rudis.net | http://rud.is/b | http://amzn.to/sudabook
#
Sys.setlocale("LC_ALL", "C")

library(ggplot2)

#
# make a bullet graph (retuns a ggplot2 object)
#
# expects a data frame with columns: measure|high|mean|low|target|value
#
# which equates to:
#   measure: label of what's being measured
#      high: the high value for the measure
#      mean: the mean value for the measure
#       low: the low value for the measure
#    target: the target value for the measure
#     value: the actual value of the measure
#
# NOTE: you *can* put multiple rows in the data frame, but they should all be at the same
#       scale. That either means normalizing the values or representing them as pecentages.
#       you are better off making multiple, invididual bullet graphs if the scales are
#       very different.
#
# Adapted from: http://bit.ly/1fs6ooC
#

bullet.graph <- function(bg.data){

  # compute max and half for the ticks and labels
  max.bg <- max(bg.data$high)
  mid.bg <- max.bg / 2

  gg <- ggplot(bg.data)
  gg <- gg + geom_bar(aes(measure, high),  fill=c("red","blue","goldenrod2","blue"), stat="identity", width=0.5, alpha=0.3)
  gg <- gg + geom_bar(aes(measure, mean),  fill="goldenrod3", stat="identity", width=0.5, alpha=0.3)
  gg <- gg + geom_bar(aes(measure, low),   fill="#FFFFFF", stat="identity", width=0.5, alpha=0.2)
  gg <- gg + geom_bar(aes(measure, value), fill="black",  stat="identity", width=0.2)
  gg <- gg + geom_text(aes(y=target, x=measure, label = "1"))
  gg <- gg + geom_errorbar(aes(y=target, x=measure, ymin=target, ymax=target), color="red", width=0.45)
  gg <- gg + geom_point(aes(measure, target), colour="red", size=2.5)
  gg <- gg + scale_y_continuous(breaks=seq(0,100,10))
  gg <- gg + coord_flip()
  #+ ggtitle("子弹图")
  gg <- gg + theme(axis.text.x=element_text(size=6, color="#BBBFC2"),
                   axis.title.x=element_blank(),
                   axis.line.y=element_blank(),
                   axis.text.y=element_text(hjust=1, color="#BBBFC2"),
                   axis.ticks.y=element_blank(),
                   axis.title.y=element_blank(),
                   legend.position="none",
                   panel.background=element_blank(),
                   panel.border=element_blank(),
                   panel.grid.major=element_blank(),
                   panel.grid.minor=element_blank(),
                   plot.background=element_rect(fill = "#1F1F1F", color = "#1F1F1F"))

  return(gg)

}

# test it out!

# 5/1 seems to be a good ratio for individual bullet graphs but you
# can change it up to fit your dashboard needs

incidents.pct <- data.frame(
  measure=c("设备可用性 (%)", "设备利用效率 (%)", "设备完好率 (%)", "任务完成率 (%)"),
  high=c(100,100,100,100),
  mean=c(45,40,50,30),
  low=c(25,20,10,5),
  target=c(55,40,45,35),
  value=c(50,45,60,25)
)

incidents.pct.bg <- bullet.graph(incidents.pct)
ggsave("output/bullet01.png", incidents.pct.bg, width=6, height=2.5)


library(data.table)
library(fixest)
library(splines)

## clean up the environment (just in case)
rm(list=ls())
gc()

"%!in%" <- Negate("%in%")

## load the data
load("data_violence_acled.RData")

#---------------------------------------#
#--  Appendix Table 2: Fixed Effects  --#
#---------------------------------------#

coef1_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+year, dataset_dt[actor=="polit"],vcov=~xy+country^year)

coef2_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+yearmo, dataset_dt[actor=="polit"],vcov=~xy+country^year)

coef3_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^trend, dataset_dt[actor=="polit"],vcov=~xy+country^year)

etable(coef1_fe,coef2_fe,coef3_fe,tex=T,digits=3,digits.stats = 3,title="Fixed Effects",headers=c("1","2","3"))

#------------------------------------#
#--  Appendix Table 3: Clustering  --#
#------------------------------------#

coef1_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"], vcov=~xy)

coef2_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"], vcov=~latitude)

coef3_fe <- feols(incidents_dum~price_ch:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"], vcov=conley(500,distance="spherical")~longitude+latitude)

etable(coef1_fe,coef2_fe,coef3_fe,tex=T,digits=3,digits.stats = 3,title="Clustering",headers=c("1","2","3"))

#----------------------------------------#
#--  Appendix Table 4: Lags and Leads  --#
#----------------------------------------#

dataset_dt[,`:=`(price_chl2=data.table::shift(price_ch,12,type="lag"),price_chl1=data.table::shift(price_ch,6,type="lag"),price_chf1=data.table::shift(price_ch,6,type="lead"),price_chf2=data.table::shift(price_ch,12,type="lead")),by=.(xy,actor)]

dataset_dt$shock <- dataset_dt$price_chl2
coef1_fe <- feols(incidents_dum~shock:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"],vcov=~xy+country^year)
summary(coef1_fe)

dataset_dt$shock <- dataset_dt$price_chl1
coef2_fe <- feols(incidents_dum~shock:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"],vcov=~xy+country^year)
summary(coef1_fe)

dataset_dt$shock <- dataset_dt$price_chf1
coef3_fe <- feols(incidents_dum~shock:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"],vcov=~xy+country^year)
summary(coef2_fe)

dataset_dt$shock <- dataset_dt$price_chf2
coef4_fe <- feols(incidents_dum~shock:max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, dataset_dt[actor=="polit"],vcov=~xy+country^year)
summary(coef2_fe)

etable(coef1_fe,coef2_fe,coef3_fe,coef4_fe,tex=T,digits=3,digits.stats = 3,title="Lags and Leads",headers=c("1","2","3","4"))

#--------------------------------------------------------#
#--  Appendix Table 5: Controlling for long-run impact --#
#--------------------------------------------------------#

datacomb_dt[,`:=`(price_lag=data.table::shift(price,12)),by=.(xy)]
dataset_dt[,`:=`(price_lag=data.table::shift(price,12)),by=.(xy,actor)]

comb_fe <- feols(incidents_dum~(price_ch+price_lag):max_area:(i(season,keep=1:12))+log(population_mln) | xy+country^year, datacomb_dt)

split_fe <- feols(incidents_dum~(price_ch+price_lag):max_area:(i(season,keep=1:12))+log(population_mln)  | xy+country^year, dataset_dt,split=~actor)

etable(comb_fe,split_fe,vcov=~xy+country^year,tex=T,digits=3,digits.stats = 3,title="Main Results",headers=c("All","State","Rebel","Polit","Ident","Other"))

#-----------------------------------------#
#--  Appendix Table 6: Monthly dummies  --#
#-----------------------------------------#

comb_fe <- feols(incidents_dum~price_ch:max_area:(i(mo)):area_dum+log(population_mln) | xy+country^year, datacomb_dt,vcov=~xy+country^year)

split_fe <- feols(incidents_dum~price_ch:max_area:(i(mo)):area_dum+log(population_mln)  | xy+country^year, dataset_dt,split=~actor,vcov=~xy+country^year)

etable(comb_fe,split_fe,vcov=~xy+country^year,tex=T,digits=3,digits.stats = 3,title="Monthly dummies",headers=c("All","State","Rebel","Polit","Ident","Other"))


#' windchill_cla
#'
#' Calculates the risk class of Windchill index.
#'
#' @param t numeric    Air temperature in degC.
#' @param wind numeric Windspeed in meters per second.
#' @return windchill index in degC
#'
#' @references Windchill Tables \url{https://www.canada.ca/en/environment-climate-change/services/weather-health/wind-chill-cold-weather/wind-chill-index.html}
#'
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  windchill classes
#'
#' @export
#'
#'
#'
#'

windchill_cla=function(t,wind) {
                         ct$assign("t", as.array(t))
                         ct$assign("v", as.array(wind))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=windchill_cla(t[i],v[i])};")
                         res=ct$get("res")
                         return(res)
}