# Clean all data and merge it all into a single database
# It should have either three tables or a column
# to determine whether it's training, validation, or prediction
# Based on merge-data.r

library(corrplot)
library(reshape2)
source("pixel-based/utils/load-sampling-data.r")

RawSoilDB = "../data/pixel-based/soil/soilgrids-raw.gpkg"
ProcessedSoilDB = "../data/pixel-based/soil/soilgrids.gpkg"
RawHarmonicsDB = "../data/pixel-based/timeseries/harmonics.gpkg"
ProcessedHarmonicsDB = "../data/pixel-based/timeseries/harmonics-decorr.gpkg"
RawCompositeDB = "../data/pixel-based/timeseries/composites.gpkg"
ProcessedCompositeDB = "../data/pixel-based/timeseries/composites-decorr.gpkg"
RawClimateDB = "../data/pixel-based/climate/climate-extended.gpkg"
ProcessedClimateDB = "../data/pixel-based/climate/climate-decorr.gpkg"
RawTerrainDB = "../data/pixel-based/terrain/terrain.gpkg"
ProcessedTerrainDB = "../data/pixel-based/terrain/terrain-decorr.gpkg"
RawTempDB = "../data/pixel-based/climate/modis-temperature.gpkg"
AllCovarDB = "../data/pixel-based/covariates.gpkg"

OutlierVis = function(covar, range)
{
    print(quantile(covar, c(0, 0.05, 0.95, 1), na.rm=TRUE))
    covarsub = covar
    covarsub[covarsub < min(range) | covarsub > max(range)] = NA
    print(c(sum(is.na(covar)), sum(is.na(covarsub))))
    hist(covarsub, breaks="Scott")
}

## Harmonise soil ##

SoilDataT = st_read(RawSoilDB, "Training")
SoilDataT$Type = "Training"
SoilDataP = st_read(RawSoilDB, "Prediction")
SoilDataP$Type = "Prediction"
SoilDataV = st_read(RawSoilDB, "Validation")
SoilDataV$Type = "Validation"
# Merge all three layers
SoilData = rbind(SoilDataT, SoilDataP, SoilDataV)
# Write
st_write(SoilData, "../data/pixel-based/soil/soilgrids-merged.gpkg")
rm(SoilDataT, SoilDataP, SoilDataV)

# Drop non-numeric columns (all set to NA) and ones that have too many NAs to be useful
set.seed(0xfedbeef)
SampleSize = 10000
CovarNAs = apply(SoilData[sample(nrow(SoilData), SampleSize),], 2, function(x){sum(is.na(x)) / SampleSize})
sort(CovarNAs)

SoilData = SoilData[,-which(CovarNAs >= 0.0351)]
gc(TRUE)
ncol(SoilData) # Down to 214 vars

# Drop taxonomy
SoilData[,grep("TAX", names(SoilData))] = NULL
gc(TRUE)
ncol(SoilData) # Down to 153 vars

ColumnTypes = sapply(1:ncol(SoilData), function(x)class(SoilData[[x]])[1])
# Drop zero sd, drops depth codes
CovarSDs = apply(as.data.frame(SoilData)[sample(nrow(SoilData), SampleSize),ColumnTypes=="numeric"], 2, sd, na.rm=TRUE)
SoilData[,names(CovarSDs)[CovarSDs == 0]] = NULL
gc(TRUE)
ncol(SoilData) # Down to 140 vars

# Drop land cover-related covars: land cover itself and pH in KCL
SoilData[,c("GLC100m.M.GLC2010", paste0("PHIKCL.M.sl", 1:7))] = NULL
gc(TRUE)
ncol(SoilData) # Down to 133 vars

# Keep only sl2
RemDepth = c(1, 3:7)
for (i in RemDepth)
{
    SoilData[,grep(paste0(".sl", i), names(SoilData))] = NULL
}
gc(TRUE)
ncol(SoilData) # Down to 72 vars

# Remove MODIS 2001 data, no Proba-V back then
SoilData[,grep("2001", names(SoilData))] = NULL
gc(TRUE)
ncol(SoilData) # Down to 52 vars

# Remove precipitation data as we have that from Worldclim
SoilData[,grep("PREMRG.", names(SoilData))] = NULL
gc(TRUE)
ncol(SoilData) # Down to 42 vars

# Organic carbon storage is using "sd" instead of "sl"
RemDepth = c(1, 3:5)
for (i in RemDepth)
{
    SoilData[,grep(paste0("OCSTHA.M.sd", i), names(SoilData))] = NULL
}
gc(TRUE)
ncol(SoilData) # Down to 38 vars

# Drop MODIS data except for Feb and Aug (solstice + 2 months, not 1 because missing night values)
RemMonth = c("M", "S", "J", "O", "N", "D", "Ap")
for (i in RemMonth)
{
    SoilData[,grep(paste0("MOD_2011.M.", i), names(SoilData))] = NULL
}
gc(TRUE)
ncol(SoilData) # Down to 23 vars

# Drop AWCh1&3, the second distinguishes natural classes better
SoilData[,c("AWCh1.M.sl2", "AWCh3.M.sl2")] = NULL
gc(TRUE)
ncol(SoilData) # 21

# MODIS temperature is also something that should already be in worldclim, so save it on the side
ModTempNames = c("TMNMOD_2011.M.Aug", "TMNMOD_2011.M.Feb", "TMDMOD_2011.M.Aug", "TMDMOD_2011.M.Feb")
ModTemp = SoilData[,c("X", "Y", "Type", ModTempNames)]

hist(ModTemp[[ModTempNames[1]]]) # NA value is -2^15
for (i in ModTempNames)
    ModTemp[[i]][ModTemp[[i]] == -2^15] = NA
cor(as.data.frame(ModTemp)[,ModTempNames], use="pairwise.complete.obs") # Fairly low correlation, but over 0.9 for day and night in Feb
pairs(as.data.frame(ModTemp)[,ModTempNames])
summary(as.data.frame(ModTemp)[,ModTempNames]) # Night has a lot more NAs, so keep day
ModTemp[,c("TMNMOD_2011.M.Aug", "TMNMOD_2011.M.Feb")] = NULL
st_write(ModTemp, "../data/pixel-based/climate/modis-temperature.gpkg", delete_dsn=TRUE)

SoilData[,ModTempNames] = NULL
rm(ModTemp)
gc(TRUE)
ncol(SoilData) # 17

pairs(as.data.frame(SoilData)[,3:15])
cor(as.data.frame(SoilData)[,3:15], use="pairwise.complete.obs")
# -0.99 correlation between AWCtS.M.sl2 and BLDFIE.M.sl2, drop former;
# OCSTHA vs ORCDRC, drop former as it's just potential
# TEXMHT is actually categorical and correlates with CLYPPT
# We get a singularity if we include all SNDPPT, SLTPPT and CLYPPT
SoilData[,c("AWCtS.M.sl2", "OCSTHA.M.sd2", "TEXMHT.M.sl2")] = NULL
# 255 as NA value for CLYPPT, CRFVOL, SLTPPT, SNDPPT
NA225 = c("SNDPPT.M.sl2", "CLYPPT.M.sl2", "SLTPPT.M.sl2", "CRFVOL.M.sl2", "PHIHOX.M.sl2")
for (i in NA225)
    SoilData[[i]][SoilData[[i]]==255] = NA

scor = cor(as.data.frame(SoilData)[,3:12], use="pairwise.complete.obs")
pairs(as.data.frame(SoilData)[,3:12])

mean(abs(scor[,"CLYPPT.M.sl2"])) # Much less correlated
mean(abs(scor[,"SNDPPT.M.sl2"]))
mean(abs(scor[,"SLTPPT.M.sl2"])) # Most correlated, drop

SoilData[["SLTPPT.M.sl2"]] = NULL

# Check distributions
for (i in names(SoilData))
{
    if (i == "X" || i == "Y" || i == "geom" || i == "Type")
        next
    hist(SoilData[[i]], main=i)
}

# Transform CECSOL, CRFVOL, ORCDRC
hist(log(SoilData[["CECSOL.M.sl2"]]+1)) # Very good
hist(log(SoilData[["CRFVOL.M.sl2"]]+1)) # At least a bit better
hist(log(SoilData[["ORCDRC.M.sl2"]]+1)) # Very good
SoilData[["CECSOL.M.sl2"]] = log(SoilData[["CECSOL.M.sl2"]]+1)
SoilData[["CRFVOL.M.sl2"]] = log(SoilData[["CRFVOL.M.sl2"]]+1)
SoilData[["ORCDRC.M.sl2"]] = log(SoilData[["ORCDRC.M.sl2"]]+1)

cor(as.data.frame(SoilData)[,3:11], use="pairwise.complete.obs")
pairs(as.data.frame(SoilData)[,3:11]) # ORCDRC and BLDFIE are correlated, drop the transformed (ORCDRC)
SoilData[["ORCDRC.M.sl2"]] = NULL

cor(as.data.frame(SoilData)[,3:10], use="pairwise.complete.obs")
cor(as.data.frame(SoilData)[,3:10], method="spearman", use="pairwise.complete.obs") # Nobody is speared
pairs(as.data.frame(SoilData)[,3:10])

# Give pretty names
names(SoilData)[3:10] = c("soil.av.water", "soil.bulkdens", "soil.log.cation", "soil.clay.pct", "soil.log.coarfrag", "soil.ph", "soil.sand.pct", "soil.wilt.wat")

st_write(SoilData, ProcessedSoilDB, delete_dsn=TRUE)

## Harmonise harmonics ##

HarmonicsSF = st_read(RawHarmonicsDB)
HarmonicsNames = names(HarmonicsSF)[3:(ncol(HarmonicsSF)-1)]
HarmKeep = HarmonicsNames

# Remove outliers, these are calculation mistakes due to too few data leading to overfitting
CovarRange = c(-40000, 40000)
OutlierVis(HarmonicsSF$intercept, CovarRange)
HarmonicsSF$intercept[HarmonicsSF$intercept < min(CovarRange) | HarmonicsSF$intercept > max(CovarRange)] = NA # ~1000 more NAs

# These are all Laplace distributions, not normal
OutlierVis(HarmonicsSF$co, c(-200, 200)) # Consistently lose about 1000 points, likely the same ones
HarmonicsSF$co[HarmonicsSF$co < -200 | HarmonicsSF$co > 200] = NA

OutlierVis(HarmonicsSF$si, c(-150, 150))
HarmonicsSF$si[HarmonicsSF$si < -150 | HarmonicsSF$si > 150] = NA

OutlierVis(HarmonicsSF$co2, c(-75, 75))
HarmonicsSF$co2[HarmonicsSF$co2 < -75 | HarmonicsSF$co2 > 75] = NA

OutlierVis(HarmonicsSF$si2, c(-75, 75))
HarmonicsSF$si2[HarmonicsSF$si2 < -75 | HarmonicsSF$si2 > 75] = NA

CovarRange = c(-20, 20)
OutlierVis(HarmonicsSF$trend, CovarRange)
HarmonicsSF$trend[HarmonicsSF$trend < min(CovarRange) | HarmonicsSF$trend > max(CovarRange)] = NA

# Strictly positive, so bimodal exponential
CovarRange = c(-Inf, 250)
OutlierVis(HarmonicsSF$amplitude1, CovarRange)
HarmonicsSF$amplitude1[HarmonicsSF$amplitude1 < min(CovarRange) | HarmonicsSF$amplitude1 > max(CovarRange)] = NA

# Exponential
CovarRange = c(-Inf, 100)
OutlierVis(HarmonicsSF$amplitude2, CovarRange)
HarmonicsSF$amplitude2[HarmonicsSF$amplitude2 < min(CovarRange) | HarmonicsSF$amplitude2 > max(CovarRange)] = NA

scor = cor(as.data.frame(HarmonicsSF)[,HarmKeep], use="pairwise.complete.obs")
pairs(as.data.frame(HarmonicsSF)[sample(1:nrow(HarmonicsSF), 10000),HarmKeep])
which(abs(scor) > 0.9)
HarmKeep = HarmKeep[!HarmKeep %in% "intercept"] # Intercept and trend are almost the same, drop intercept

scor = cor(as.data.frame(HarmonicsSF)[,HarmKeep], use="pairwise.complete.obs")
pairs(as.data.frame(HarmonicsSF)[sample(1:nrow(HarmonicsSF), 10000),HarmKeep])
scor[which(abs(scor) > 0.9)] # Only the diagonal, so no correlations left

scor = cor(as.data.frame(HarmonicsSF)[,HarmKeep], use="pairwise.complete.obs", method="spearman")
scor[which(abs(scor) > 0.9)] # Only the diagonal as well

# Write result to temp db

st_write(HarmonicsSF[,c("X", "Y", HarmKeep)], ProcessedHarmonicsDB, delete_dsn=TRUE)

## Composites ##

CompositeSF = st_read(RawCompositeDB)
names(CompositeSF)
CompKeep = names(CompositeSF)[c(-1,-2,-103)]

# Some EVI values are -Inf, which makes things very slow. Replace all -Inf with NA
for (EVIname in grep("EVI", CompKeep))
    CompositeSF[[EVIname]][is.infinite(CompositeSF[[EVIname]])] = NA

scor = cor(as.data.frame(CompositeSF)[,c(-1,-2,-103)], use="pairwise.complete.obs")
corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")
mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
plot(EVI.year.mean~EVI.year.median, data=CompositeSF)
# correlation with outliers is artful but doesn't work, remove them
CovarRange = c(-10, 15)
OutlierVis(CompositeSF$EVI.year.mean, CovarRange)
#CompositeSF$EVI.year.mean[CompositeSF$EVI.year.mean < min(CovarRange) | CompositeSF$EVI.year.mean > max(CovarRange)] = NA

CovarRange = c(-2, 5)
OutlierVis(CompositeSF$EVI.year.median, CovarRange) # Very few losses
#CompositeSF$EVI.year.median[CompositeSF$EVI.year.median < min(CovarRange) | CompositeSF$EVI.year.median > max(CovarRange)] = NA

plot(EVI.year.mean~EVI.year.median, data=CompositeSF) # Not that correlated after all
plot(OSAVI.year.mean~OSAVI.year.median, data=CompositeSF) # OSAVI is fine
plot(NDMI.year.mean~NDMI.year.median, data=CompositeSF) # NDMI is fine
plot(NIRv.year.mean~NIRv.year.median, data=CompositeSF) # NIRv is fine
summary(CompositeSF[,CompKeep]) # Only EVI values are outlier-prone

CovarRange = c(-10, 15)
OutlierVis(CompositeSF$EVI.spring.mean, CovarRange)
#CompositeSF$EVI.spring.mean[CompositeSF$EVI.spring.mean < min(CovarRange) | CompositeSF$EVI.spring.mean > max(CovarRange)] = NA
CovarRange = c(-10, 15)
OutlierVis(CompositeSF$EVI.spring.median, CovarRange) # Very few losses
#CompositeSF$EVI.spring.median[CompositeSF$EVI.spring.median < min(CovarRange) | CompositeSF$EVI.spring.median > max(CovarRange)] = NA
# Cap everything to that range
CovarRange = c(-10, 15)
for (EVIname in grep("EVI", CompKeep, value=TRUE))
    CompositeSF[[EVIname]][CompositeSF[[EVIname]] < min(CovarRange) | CompositeSF[[EVIname]] > max(CovarRange)] = NA
summary(CompositeSF[,CompKeep]) # EVI values capped

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs") # Very fast

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

# Medians and means are 0.99 correlated. Drop means because medians are robust against clouds and EVI -Infs
CompKeep = CompKeep[-grep("mean", CompKeep)]

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

plot(OSAVI.winter.p80.80.~OSAVI.winter.median, data=CompositeSF) # Seasonal quantiles are highly correlated, remove

CompKeep = CompKeep[!(CompKeep %in% grep("year", grep("p80", CompKeep, value=TRUE), value=TRUE, invert=TRUE))]
CompKeep = CompKeep[!(CompKeep %in% grep("year", grep("p20", CompKeep, value=TRUE), value=TRUE, invert=TRUE))]

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

plot(OSAVI.summer.median~OSAVI.year.p80.80., data=CompositeSF)
# Correlation between quantiles of the year and the seasonal medians. The seasonal medians are not portable across hemispheres so drop those

CompKeep = CompKeep[!(CompKeep %in% grep("year", grep("median", CompKeep, value=TRUE), value=TRUE, invert=TRUE))]

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

plot(EVI.year.median~OSAVI.year.median, data=CompositeSF)
# EVI.year has issues with Infs and outliers, and correlates with both NIRv and OSAVI, so drop it

CompKeep = CompKeep[!(CompKeep %in% grep("EVI.year", CompKeep, value=TRUE))]

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

plot(OSAVI.year.p80.80.~OSAVI.year.median, data=CompositeSF)
plot(NIRv.year.median~OSAVI.year.median, data=CompositeSF) # NIRv correlates with OSAVI; remove OSAVI as NIRv correlates with GPP better

CompKeep = CompKeep[!(CompKeep %in% grep("OSAVI.year", CompKeep, value=TRUE))]

scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "ellipse", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

plot(NDMI.autumn.IQR~NDMI.summer.IQR, data=CompositeSF)
pairs(as.data.frame(CompositeSF)[sample(1:nrow(CompositeSF), 10000),CompKeep]) # No more correlations, though EVI is still unusual and mostly IQR remains which may not be useful

# Check also Spearman
scor = cor(as.data.frame(CompositeSF)[,CompKeep], use="pairwise.complete.obs", method="spearman")
mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Medians too correlated to the other percentiles, so drop all percentiles

CompKeep = CompKeep[!(CompKeep %in% grep("p80.80", CompKeep, value=TRUE))]
CompKeep = CompKeep[!(CompKeep %in% grep("p20.20", CompKeep, value=TRUE))]

st_write(CompositeSF[,c("X", "Y", CompKeep)], ProcessedCompositeDB, delete_dsn=TRUE)

## Harmonise climate ##

ClimateSF = st_read(RawClimateDB)
names(ClimateSF)
ClimKeep = names(ClimateSF)[3:144]
ClimKeep = ClimKeep[!(ClimKeep %in% c("cold", "warm", "dry", "wet"))] # Exclude helper columns

summary(as.data.frame(ClimateSF)[,ClimKeep]) # Some have -Inf
for (Climname in ClimKeep)
    ClimateSF[[Climname]][is.infinite(ClimateSF[[Climname]])] = NA

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

# Exclude duplicates: bio5, bio6, bio13, bio14 are already calculated as additional biovars
ClimKeep = ClimKeep[!(ClimKeep %in% c("bio5", "bio6", "bio13", "bio14"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
plot(wc2.0_30s_vapr_02~wc2.0_30s_vapr_01, data=ClimateSF)
# There is a huge correlation between neighbouring months, so keep only 4 months
barplot(table(ClimateSF$wet)) # 07
barplot(table(ClimateSF$dry)) # 01
barplot(table(ClimateSF$cold)) # 01
barplot(table(ClimateSF$warm)) # 07
# Ergo, keep 01, 07, 04, 10

ClimKeep = ClimKeep[!(ClimKeep %in% grep("_02|_03|_05|_06|_08|_09|_11|_12", ClimKeep, value=TRUE))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
plot(wc2.0_30s_tavg_01~wc2.0_30s_tmin_01, data=ClimateSF) # There is not enough of a range in temperatures, so drop all tmin/tmax

ClimKeep = ClimKeep[!(ClimKeep %in% grep("tmin|tmax", ClimKeep, value=TRUE))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # tavg monthly still not enough to be distinct from bio*

ClimKeep = ClimKeep[!(ClimKeep %in% grep("wc2.0_30s_tavg_", ClimKeep, value=TRUE))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # bio8-11,16-19 are quarterly which is not distinct from monthly
ClimKeep = ClimKeep[!(ClimKeep %in% c("bio8", "bio10", "bio11", "bio9", "bio16", "bio17", "bio18", "bio19"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Also not enough distinction to keep vapour non-extreme months

ClimKeep = ClimKeep[!(ClimKeep %in% c("wc2.0_30s_vapr_04", "wc2.0_30s_vapr_10"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # It's cold because there is little solar radiation, and then there is little vapour
# Also bio4 and bio7 are both seasonality, keep range as easier to interpret

ClimKeep = ClimKeep[!(ClimKeep %in% c("cold.srad", "warm.srad", "cold.vapr", "warm.vapr", "bio4"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Not enough variation in wind to keep the extremes
# Also temperature average of the coldest/warmest months doesn't make sense given that we also had tmin and tmax

ClimKeep = ClimKeep[!(ClimKeep %in% c("min.wind", "max.wind", "cold.tavg", "warm.tavg"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Vapour range not enough
# Also monthly wind is not distinct enough

ClimKeep = ClimKeep[!(ClimKeep %in% c("min.vapr", "max.vapr", grep("wc2.0_30s_wind", ClimKeep, value=TRUE)))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Cold/dry wind and solar radiation non-extreme months are not distinct

ClimKeep = ClimKeep[!(ClimKeep %in% c("wc2.0_30s_srad_10", "wc2.0_30s_srad_04", "cold.wind", "warm.wind", "dry.wind", "wet.wind"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Dry/wet vapour and vapour of individual months not distinct
plot(mean.vapr~wc2.0_30s_vapr_01, data=ClimateSF)

ClimKeep = ClimKeep[!(ClimKeep %in% c("dry.vapr", "wet.vapr", grep("wc2.0_30s_vapr", ClimKeep, value=TRUE)))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # Wet/dry doesn't matter for temperature
ClimKeep = ClimKeep[!(ClimKeep %in% c("dry.tavg", "wet.tavg"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)

pairs(as.data.frame(ClimateSF)[sample(1:nrow(ClimateSF), 10000),ClimKeep])

hist(ClimateSF$cold.prec, breaks="Scott") # lognormal, so transform
hist(log(ClimateSF$cold.prec+1), breaks="Scott")

for (PrecName in grep("prec", ClimKeep, value=TRUE))
{
    PrecLogName = paste0(PrecName, ".log")
    ClimateSF[[PrecLogName]] = log(ClimateSF[[PrecName]]+1)
    ClimKeep[ClimKeep == PrecName] = PrecLogName
}

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
pairs(as.data.frame(ClimateSF)[sample(1:nrow(ClimateSF), 10000),ClimKeep])

# bio12+ are also precipitation
PrecName = "bio12"
PrecLogName = paste0(PrecName, ".log")
ClimateSF[[PrecLogName]] = log(ClimateSF[[PrecName]]+1)
ClimKeep[ClimKeep == PrecName] = PrecLogName

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
pairs(as.data.frame(ClimateSF)[sample(1:nrow(ClimateSF), 10000),ClimKeep])

# What about wind?
hist(ClimateSF$mean.wind, breaks="Scott") # Actually fairly normal
hist(log(ClimateSF$mean.wind), breaks="Scott") # Less normal

# Wet precipitation is too similar
ClimKeep = ClimKeep[!(ClimKeep %in% c("dry.prec.log", "wet.prec.log"))]

scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
pairs(as.data.frame(ClimateSF)[sample(1:nrow(ClimateSF), 10000),ClimKeep])

# All good, what about spearman
scor = cor(as.data.frame(ClimateSF)[,ClimKeep], use="pairwise.complete.obs", method="spearman")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
# Also fine

# Rename to human readable format
ProcessedClimateSF = ClimateSF[,ClimKeep]
RenameMap = data.frame(from=c("wc2.0_30s_prec_01.log", "wc2.0_30s_prec_04.log", "wc2.0_30s_prec_07.log", "wc2.0_30s_prec_10.log",
    "wc2.0_30s_srad_01", "wc2.0_30s_srad_07",
    "bio1", "bio2", "bio3", "bio7", "bio12.log", "bio15"),
    to=c("jan.prec.log", "apr.prec.log", "jul.prec.log", "oct.prec.log",
    "jan.srad", "jul.srad",
    "mean.tavg", "tavg.monthly.range", "isothermality", "tavg.annual.range", "annual.prec.log", "prec.seasonality"), stringsAsFactors=FALSE)
for (NameIdx in 1:nrow(RenameMap))
    names(ProcessedClimateSF)[names(ProcessedClimateSF) == RenameMap$from[NameIdx]] = RenameMap$to[NameIdx]

ProcessedClimateSF = cbind(ProcessedClimateSF, X=ClimateSF$X, Y=ClimateSF$Y)

st_write(ProcessedClimateSF, ProcessedClimateDB, delete_dsn=TRUE)

## Check against MODIS LSTM

LSTMSF = st_read(RawTempDB)
names(LSTMSF)
levels(LSTMSF$Type)
plot(TMDMOD_2011.M.Aug~TMDMOD_2011.M.Feb, data=LSTMSF)
nrow(ProcessedClimateSF) > nrow(LSTMSF)
summary(LSTMSF)

CombinedClimate = merge(ProcessedClimateSF, as.data.frame(LSTMSF)[,!(names(LSTMSF) %in% "geom")], by=c("X", "Y"))
nrow(CombinedClimate) # even larger

ClimKeep = names(CombinedClimate)[-c(1,2,24,27)]

scor = cor(as.data.frame(CombinedClimate)[,ClimKeep], use="pairwise.complete.obs")
plot(TMDMOD_2011.M.Aug~max.srad, data=CombinedClimate)

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper")

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor)
pairs(as.data.frame(CombinedClimate)[sample(1:nrow(CombinedClimate), 10000),ClimKeep])

plot(TMDMOD_2011.M.Aug~mean.tavg, data=CombinedClimate)
plot(TMDMOD_2011.M.Feb~mean.tavg, data=CombinedClimate)
# Feb is too correlated but Aug isn't, that's odd. Let's not use this

## Harmonise terrain

TerrainSF = st_read(RawTerrainDB)
TerrKeep = names(TerrainSF)[-c(1,2,8)]
pairs(as.data.frame(TerrainSF)[,TerrKeep]) # Artful, but outliers due to issues in ASTER

# Laplace distribution
OutlierVis(TerrainSF[["tpi"]], c(-50, 50))
TerrainSF[["tpi"]][TerrainSF[["tpi"]] < -50 | TerrainSF[["tpi"]] > 50] = NA
pairs(as.data.frame(TerrainSF)[,TerrKeep])

# Exponential distribution
OutlierVis(TerrainSF[["roughness"]], c(-Inf, Inf))
OutlierVis(log(TerrainSF[["roughness"]]+1), c(-Inf, Inf))
TerrainSF[["roughness"]] = log(TerrainSF[["roughness"]]+1)
names(TerrainSF)[names(TerrainSF)=="roughness"] = "roughness.log"
TerrKeep = names(TerrainSF)[-c(1,2,8)]
pairs(as.data.frame(TerrainSF)[,TerrKeep])

# Lognormal distribution
OutlierVis(TerrainSF[["slope"]], c(-Inf, Inf))
OutlierVis(log(TerrainSF[["slope"]]+1), c(-Inf, Inf))
TerrainSF[["slope"]] = log(TerrainSF[["slope"]]+1)
names(TerrainSF)[names(TerrainSF)=="slope"] = "slope.log"
TerrKeep = names(TerrainSF)[-c(1,2,8)]
pairs(as.data.frame(TerrainSF)[,TerrKeep])

cor(as.data.frame(TerrainSF)[,TerrKeep], use="pairwise.complete.obs") # Roughness and slope are too correlated, keep slope
TerrKeep = TerrKeep[!(TerrKeep %in% "roughness.log")]

cor(as.data.frame(TerrainSF)[,TerrKeep], use="pairwise.complete.obs")
cor(as.data.frame(TerrainSF)[,TerrKeep], use="pairwise.complete.obs", method="spearman")

st_write(TerrainSF[,c("x", "y", TerrKeep)], ProcessedTerrainDB, delete_dsn=TRUE)

## Merge them all into one big database
# We merge the details of the training and validation data separately later, because we also have a lot of points that have neither.

SoilSF = st_read(ProcessedSoilDB)
HarmonicsSF = st_read(ProcessedHarmonicsDB)
CompositeSF = st_read(ProcessedCompositeDB)
ClimateSF = st_read(ProcessedClimateDB)
TerrainSF = st_read(ProcessedTerrainDB)

nrow(SoilSF)
nrow(HarmonicsSF)
nrow(CompositeSF)
nrow(ClimateSF)
nrow(TerrainSF)
# All are slightly different, so let's try and merge them all

Mismatched = !(ClimateSF$X %in% HarmonicsSF$X)
sum(Mismatched) # 10 mismatched (in climate but not harmonics). Where?
plot(ClimateSF[Mismatched,"mean.tavg"]) # No apparent pattern...

Mismatched = !(ClimateSF$X %in% SoilSF$X)
sum(Mismatched) # 19 mismatched (in climate but not soil).
plot(ClimateSF[Mismatched,"mean.tavg"])

Mismatched = !(SoilSF$X %in% HarmonicsSF$X)
sum(Mismatched) # 10 again
plot(SoilSF[Mismatched,"Type"]) # Mostly validation. Also no clear pattern, maybe off the boundaries or so

# Do the merge
CovarSF = merge(SoilSF, as.data.frame(HarmonicsSF)[,names(HarmonicsSF) != "geom"], by=c("X", "Y"), all=TRUE)
nrow(CovarSF)
Mismatched = !(SoilSF$X %in% CovarSF$X)
stopifnot(sum(Mismatched) == 0) # 0, good

CovarSF = merge(CovarSF, as.data.frame(CompositeSF)[,names(CompositeSF) != "geom"], by=c("X", "Y"), all=TRUE)
CovarSF = merge(CovarSF, as.data.frame(ClimateSF)[,names(ClimateSF) != "geom"], by=c("X", "Y"), all=TRUE)
CovarSF = merge(CovarSF, as.data.frame(TerrainSF)[,names(TerrainSF) != "geom"], by.x=c("X", "Y"), by.y=c("x", "y"), all=TRUE)

# Now we have 19 empty geometries, so regenerate those
CovarSF = st_as_sf(as.data.frame(CovarSF)[,names(CovarSF) != "geometry"], dim="XY", coords=c("X", "Y"), remove=FALSE)
st_crs(CovarSF) = 4326

# Decorrelate the remainder
NumberCols = names(CovarSF)[!(names(CovarSF) %in% c("X", "Y", "Type", "geometry"))]
scor = cor(as.data.frame(CovarSF)[,NumberCols], use="pairwise.complete.obs")

corrplot(scor, diag = FALSE, order = "alphabet",
         tl.pos = "td", tl.cex = 0.5, method = "color", type = "upper") # Some problems with max.srad
summary(CovarSF[["max.srad"]])

mscor = melt(scor)
mscor = mscor[mscor$Var1 != mscor$Var2,]
mscor = mscor[order(abs(mscor[["value"]]), decreasing=TRUE),]
head(mscor) # None above 0.9

# Regenerate Type column.
# If it's both Prediction and Training, treat as Training.
# If it's both Validation and Training, treat as Validation (we have fewer of those).
# So Validation > Training > Rest (assume Prediction).
CovarSF$Type = "Prediction"
TrainPoints = LoadGlobalTrainingData()
TrainIDs = paste0(TrainPoints$x, "Y", TrainPoints$y)
any(duplicated(TrainIDs))
CovarIDs = paste0(CovarSF$X, "Y", CovarSF$Y)
DuplicatedData = as.data.frame(CovarSF[duplicated(CovarIDs),]) # We have duplicates!
stopifnot(sum(!duplicated(DuplicatedData)) == length(unique(CovarIDs[duplicated(CovarIDs)])))
# All of these also have the same data. Good. We can just dedup.
CovarSF = CovarSF[!duplicated(CovarSF),]

CovarIDs = paste0(CovarSF$X, "Y", CovarSF$Y)
stopifnot(!any(duplicated(CovarIDs))) # No more duplicates

sum(CovarIDs %in% TrainIDs) == length(TrainIDs) # All training points accounted for
CovarSF$Type[CovarIDs %in% TrainIDs] = "Training"

ValidationPoints = LoadGlobalValidationData()
ValidationIDs = paste0(ValidationPoints$x, "Y", ValidationPoints$y)
sum(CovarIDs %in% ValidationIDs) == length(ValidationIDs) # One validation point is missing, no problem
CovarSF$Type[CovarIDs %in% ValidationIDs] = "Validation"

table(CovarSF$Type) # P: 289622 T: 150405 V: 21751

# Write
st_write(CovarSF, AllCovarDB, delete_dsn=TRUE)

# Add spatial index
library(gdalUtils)
ogrinfo(AllCovarDB, sql="CreateSpatialIndex('covariates', 'geom')")


library(testthat)
library(sparsediscrim)

test_check("sparsediscrim")


library(testthat)
library(pwrcalc)

test_check('pwrcalc')


  bathymetry_db = function( p=NULL, DS=NULL, varnames=NULL, redo=FALSE, ... ) {

    #\\ Note inverted convention: depths are positive valued
    #\\ i.e., negative valued for above sea level and positive valued for below sea level
    if ( is.null(p))  {
      p_add = list(...)
      if (length(p_add) > 0 ) {
        p = bathymetry_parameters(...)
      } else {
        p = bathymetry_parameters()
      }
    }

    if ( DS=="gebco") {
      #library(RNetCDF)
      # request at: https://www.bodc.ac.uk/data/online_delivery/gebco/ [ jae.choi@dfo ] ... / gate.gate
      # extent: (WSEN) = -+72,36,-45.,53
      # and saved as: bio.data/bathymetry/data/gebco.{xyz,nc}  # still waiting
      # and xz compressed
      fn = file.path( p$datadir, "bathymetry.gebco.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(gebco)
      }

      fn_local = file.path( p$datadir, "gebco.xyz.xz") # xz compressed file
      nc = open.nc(bathy_fname)
      read.nc(nc)
      array(tmp$z, dim=tmp$dim)
      gebco = read.table( xzfile( fn_local ) )
      names(gebco) = c("lon", "lat", "z")
      gebco$z = - gebco$z
      # levelplot( log(z+ min(gebco$z) ))~lon+lat, gebco, aspect="iso")
      save( gebco, file=fn, compress=TRUE )
    }

    # --------------

    if ( DS=="etopo1") {
      # etopo1_bedrock.xyz ---> 1 min resolution
      # extent: (WSEN) = -72,36,-45.,53
      # download manually from:  http://maps.ngdc.noaa.gov/viewers/wcs-client/
      # and saved as: bio.data/bathymetry/data/etopo1_bedrock.xyz
      # and xz compressed
      fn = file.path( p$datadir, "bathymetry.etopo1.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(etopo1)
      }
      fn_local = file.path( p$datadir, "etopo1_bedrock.xyz.xz") # xz compressed file
      etopo1 = read.table( xzfile( fn_local ) )
      names(etopo1) = c("lon", "lat", "z")
      etopo1$z = - etopo1$z
      # levelplot( log(z+ min(etopo1$z) ))~lon+lat, etopo1, aspect="iso")
      save( etopo1, file=fn, compress=TRUE )
    }

    # --------------

    if ( DS =="Greenlaw_DEM") {
      # DEM created 2014
      # GCS_WGS_1984, UTM_Zone_20N; spheroid:: 6378137.0, 298.257223563
      # 322624071 "grid points
      # 50 m  horizontal resolution
      # depth range: -5053.6 to 71.48 m
      fn = file.path( p$datadir, "bathymetry.greenlaw.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(gdem)
      }

      require(rgdal)
      demfile.adf = file.path( p$datadir, "greenlaw_DEM", "mdem_50", "w001001.adf" )  # in ArcInfo adf format
      dem = new( "GDALReadOnlyDataset", demfile.adf )
      # gdem = asSGDF_GROD( dem, output.dim=dim(dem) ) # regrid to another dim
      # gdem = getRasterData(dem) # in matrix format
      gdem = getRasterTable(dem) # as a data frame
      names(gdem) = c("plon", "plat", "z")
      gdem = gdem[ is.finite( gdem$z ) , ]
      gdem$plon = gdem$plon / 1000
      gdem$plat = gdem$plat / 1000
      gdem = planar2lonlat( gdem, "utm20" )  # plon,plat in meters but crs for utm20 in km
      gdem = gdem[, c("lon", "lat", "z") ]
      save( gdem, file=file.path( p$datadir, "bathymetry.greenlaw.rdata"), compress=TRUE )
    }

    # --------------

    if (  DS %in% c("z.lonlat.rawdata.redo", "z.lonlat.rawdata") ) {
			# raw data minimally modified all concatenated, dups removed
      fn = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.rdata" )

      if (DS =="z.lonlat.rawdata" ) {
        load( fn )
        return( bathy )
      }

      print( "This is going to take a lot of RAM!")

			# this data was obtained from CHS via David Greenberg in 2004; range = -5467.020, 383.153; n=28,142,338
      fn_nwa = file.path( p$datadir, "nwa.chs15sec.xyz.xz") # xz compressed file
      chs15 = read.table( xzfile( fn_nwa ) )
      names(chs15) = c("lon", "lat", "z")
      # chs15 = chs15[ which( chs15$z < 1000 ) , ]
      chs15$z = - chs15$z

      # temporary break up of data to make it functional in smaller RAM systems
      chs1000_5000 = chs15[ which( chs15$z > 1000 ), ]
      u =  which(duplicated( chs1000_5000))
      if (length(u)>0) chs1000_5000 = chs1000_5000[-u,]

      chs0_1000 = chs15[ which( chs15$z <= 1000 ), ]
      u =  which(duplicated( chs0_1000 ))
      if (length(u)>0) chs0_1000 = chs0_1000[-u,]

      rm ( chs15); gc()

      fn0 = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000.rdata" )
      fn1 = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_1000_5000.rdata" )

      save ( chs0_1000, file=fn0 )
      save ( chs1000_5000, file=fn1 )

      rm ( chs0_1000, chs1000_5000 )
      gc()

      # pei = which( chs15$lon < -60.5 & chs15$lon > -64.5 & chs15$lat>45.5 & chs15$lat<48.5 )
      # levelplot( z~lon+lat, data=chs15[pei,] )

      # Michelle Greenlaw's DEM from 2014
      # range -3000 to 71.5 m; n=155,241,029 .. but mostly interpolated
      gdem = bathymetry_db( DS="Greenlaw_DEM" )
      gdem$z = - gdem$z

      # pei = which( gdem$lon < -60.5 & gdem$lon > -65 & gdem$lat>45.5 & gdem$lat<49 )
      # levelplot( z~I(round(lon,3))+I(round(lat,3)), data=gdem[pei,] )

      # bad boundaries in Greenlaw's gdem:
      # southern Gulf of St lawrence has edge effects
      bd1 = rbind( c( -62, 46.5 ),
                   c( -61, 47.5 ),
                   c( -65, 47.5 ),
                   c( -65, 46.2 ),
                   c( -64, 46.2 ),
                   c( -62, 46.5 ) )

      a = which( point.in.polygon( gdem$lon, gdem$lat, bd1[,1], bd1[,2] ) != 0 )
      gdem = gdem[- a,]

      # remove also the northern and eastern margins for edge effects
      gdem = gdem[ which( gdem$lat <  47.1) ,]
      gdem = gdem[ which( gdem$lon < -56.5) ,]

      fn0g = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000_gdem.rdata" )
      fn1g = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_1000_5000_gdem.rdata" )

      # temporary break up of data to make it functional in smaller RAM systems
      gdem1000_5000 = gdem[ which( gdem$z > 1000 ), ]
      # u =  which(duplicated( gdem1000_5000))
      # if (length(u)>0) gdem1000_5000 = gdem1000_5000[-u,]
      save ( gdem1000_5000, file=fn1g )
      rm( gdem1000_5000 ); gc()

      gdem0_1000 = gdem[ which( gdem$z <= 1000 ), ]
      # u =  which(duplicated( gdem0_1000 ))
      # if (length(u)>0) gdem0_1000 = gdem0_1000[-u,]
      save ( gdem0_1000, file=fn0g )
      rm( gdem0_1000 )
      rm( gdem)
      gc()

      # chs and others above use chs depth convention: "-" is below sea level,
			# in snowcrab and groundfish convention "-" is above sea level
			# retain postive values at this stage to help contouring near coastlines

      bathy = bathymetry_db( DS="etopo1" )

      additional.data=c("snowcrab", "groundfish", "lobster")

			if ( "snowcrab" %in% additional.data ) {
        # range from 23.8 to 408 m below sea level ... these have dropped the "-" for below sea level; n=5925 (in 2014)
        # project.library( "bio.snowcrab")
        sc = bio.snowcrab::snowcrab.db( DS="set.clean")[,c("lon", "lat", "z") ]
				sc = sc [ which (is.finite( rowSums( sc ) ) ) ,]
				j = which(duplicated(sc))
        if (length (j) > 0 ) sc = sc[-j,]
        bathy = rbind( bathy, sc )
			  # p = p0
        rm (sc); gc()

        #sc$lon = round(sc$lon,1)
        #sc$lat = round(sc$lat,1)
        # contourplot( z~lon+lat, sc, cuts=10, labels=F )
      }

      if ( "groundfish" %in% additional.data ) {
        # n=13031; range = 0 to 1054

        warning( "Should use bottom contact estimates as a priority ?" )
				gf = groundfish_survey_db( DS="set.base" )[, c("lon","lat", "sdepth") ]
				gf = gf[ which( is.finite(rowSums(gf) ) ) ,]
        names(gf) = c("lon", "lat", "z")
				j = which(duplicated(gf))
        if (length (j) > 0 ) gf = gf[-j,]
 				bathy = rbind( bathy, gf )
        rm (gf); gc()

        #gf$lon = round(gf$lon,1)
        #gf$lat = round(gf$lat,1)
        #contourplot( z~lon+lat, gf, cuts=10, labels=F )

			}

      if ( "lobster" %in% additional.data ) {
        current.year = lubridate::year(lubridate::now())
        p0temp = aegis.temperature::temperature_parameters( yrs=1900:current.year )
        lob = temperature_db( p=p0temp, DS="lobster", yr=1900:current.year ) # FSRS data ...  new additions have to be made at the rawdata level manually; yr must be passed to retrieve data ..
        lob = lob[, c("lon","lat", "z") ]
        lob = lob[ which( is.finite(rowSums(lob) ) ) ,]
        j = which(duplicated(lob))
        if (length (j) > 0 ) lob = lob[-j,]
        bathy = rbind( bathy, lob )
        rm (lob); gc()

        #lob$lon = round(lob$lon,1)
        #lob$lat = round(lob$lat,1)
        #contourplot( z~lon+lat, lob, cuts=10, labels=F )

      }

      u =  which(duplicated( bathy ))
      if (length(u)>0) bathy = bathy[ -u, ]
      rm (u)

      bathy0 = bathy[ which(bathy$z <= 1000), ]
      bathy1 = bathy[ which(bathy$z  > 1000), ]
      rm(bathy)

      gc()

      load( fn0)
      bathy0 = rbind( bathy0, chs0_1000 )
      rm(chs0_1000) ;gc()

      load( fn0g )
      bathy0 = rbind( bathy0, gdem0_1000 )
      rm ( gdem0_1000 ) ;gc()

      u =  which(duplicated( bathy0 ))
      if (length(u)>0) bathy0 = bathy0[ -u, ]

      fn0b = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000_bathy.rdata" )
      save ( bathy0, file=fn0b )
      rm (bathy0); gc()

    # ---

      load( fn1 )
      bathy1 = rbind( bathy1, chs1000_5000 )
      rm (  chs1000_5000 ) ; gc()

      load( fn1g )
      bathy1 = rbind( bathy1, gdem1000_5000 )
      rm ( gdem1000_5000 ) ; gc()

      u =  which(duplicated( bathy1 ))
      if (length(u)>0) bathy1 = bathy1[ -u, ]
      rm (u)

      load( fn0b )

      bathy = rbind( bathy0, bathy1 )
      rm( bathy1, bathy0 ) ; gc()

      bid = paste( bathy$lon, bathy$lat, round(bathy$z, 1) ) # crude way to find dups
      bathy = bathy[!duplicated(bid),]
      save( bathy, file=fn, compress=T )

      # save ascii in case someone needs it ...
      fn.bathymetry.xyz = file.path( p$datadir, "bathymetry.canada.east.xyz" )
      fn.xz = xzfile( paste( fn.bathymetry.xyz, ".xz", sep="" ) )
      write.table( bathy, file=fn.xz, col.names=F, quote=F, row.names=F)
      system( paste( "xz",  fn.bathymetry.xyz ))  # compress for space

      if (file.exists (fn.bathymetry.xyz) ) file.remove(fn.bathymetry.xyz)
      if (file.exists (fn0) ) file.remove( fn0 )
      if (file.exists (fn1) ) file.remove( fn1 )
      if (file.exists (fn0g) ) file.remove( fn0g )
      if (file.exists (fn1g) ) file.remove( fn1g )
      if (file.exists (fn0b) ) file.remove( fn0b )

      return ( fn )
    }

    # ------------------------------

    if ( DS=="aggregated_data") {

      if (!exists("inputdata_spatial_discretization_planar_km", p) )  p$inputdata_spatial_discretization_planar_km = 1

      fn = file.path( p$datadir, paste( "bathymetry", "aggregated_data", p$spatial_domain,  round(p$inputdata_spatial_discretization_planar_km, 6) , "rdata", sep=".") )
      M = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          message("Using: ", fn)
          load( fn)
          return( M )
        }
      }
      message("Making: ", fn)

      M = bathymetry_db ( p=p, DS="z.lonlat.rawdata" )  # 16 GB in RAM just to store!

      setDT(M)
      M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
      M = lonlat2planar( M, proj.type=p$aegis_proj4string_planar_km)  # first ensure correct projection

      M$lon = NULL
      M$lat = NULL
      M$z = M[[p$variabletomodel]]

        # thin data a bit ... remove potential duplicates and robustify

      M$plon = aegis_floor(M$plon / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km
      M$plat = aegis_floor(M$plat / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km

      gc()

      M = M[ geo_subset( spatial_domain=p$spatial_domain, Z=M ) , ] # need to Pbe careful with extrapolation ...  filter depths

      if (exists("quantile_bounds", p)) {
        TR = quantile(M[[p$variabletomodel]], probs=p$quantile_bounds, na.rm=TRUE )
        keep = which( M[[p$variabletomodel]] >=  TR[1] & M[[p$variabletomodel]] <=  TR[2] )
        if (length(keep) > 0 ) M = M[ keep, ]
        keep = NULL
        gc()
      }

      setDT(M)
      M = M[, .( mean=mean(z, na.rm=TRUE), sd=sd(z, na.rm=TRUE), n=length(which(is.finite(z))) ), by=list(plon, plat) ]

      colnames(M) = c( "plon", "plat", paste( p$variabletomodel, c("mean", "sd", "n"), sep=".") )
      M = planar2lonlat( M, p$aegis_proj4string_planar_km )

      attr( M, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
      attr( M, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")
      setDF(M)
      save(M, file=fn, compress=TRUE)

      return( M )
    }

    # ------------------------------

    if ( DS=="areal_units_input" ) {

      fn = file.path( p$datadir,  "areal_units_input.rdata" )
      if ( !file.exists(p$datadir)) dir.create( p$datadir, recursive=TRUE, showWarnings=FALSE )

      xydata = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          return( xydata )
        }
      }
      xydata = bathymetry_db( p=p, DS="aggregated_data"   )  #
      names(xydata)[which(names(xydata)=="z.mean" )] = "z"
      xydata = xydata[ , c("lon", "lat"  )]

      save(xydata, file=fn, compress=TRUE )
      return( xydata )
    }

    # -----------------------

    if ( DS=="carstm_inputs") {

      # prediction surface
      #\\ Note inverted convention: depths are positive valued
      #\\ i.e., negative valued for above sea level and positive valued for below sea level
      crs_lonlat = st_crs(projection_proj4string("lonlat_wgs84"))
      sppoly = areal_units( p=p )  # will redo if not found
      sppoly = st_transform(sppoly, crs=crs_lonlat )
      areal_units_fn = attributes(sppoly)[["areal_units_fn"]]

      fn = carstm_filenames( p=p, returntype="carstm_inputs", areal_units_fn=areal_units_fn )
      if (p$carstm_inputs_prefilter =="rawdata") {
        fn = carstm_filenames( p=p, returntype="carstm_inputs_rawdata", areal_units_fn=areal_units_fn )
      }
      if (p$carstm_inputs_prefilter =="sampled") {
        fn = carstm_filenames( p=p, returntype=paste("carstm_inputs_sampled", p$carstm_inputs_prefilter_n, sep="_"), areal_units_fn=areal_units_fn )
      }

      # inputs are shared across various secneario using the same polys
      #.. store at the modeldir level as default
      outputdir = dirname( fn )
      if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          return( M )
        }
      }

      # reduce size
      if (p$carstm_inputs_prefilter =="aggregated") {
        M = bathymetry_db ( p=p, DS="aggregated_data"   )  # 16 GB in RAM just to store!
        names(M)[which(names(M)==paste(p$variabletomodel, "mean", sep=".") )] = p$variabletomodel

      } else if (p$carstm_inputs_prefilter =="sampled") {
        M = bathymetry_db ( p=p, DS="z.lonlat.rawdata"  )  # 16 GB in RAM just to store!

        require(data.table)
        setDT(M)
        names(M)[which(names(M)=="z") ] = p$variabletomodel

        M = M[ which( !duplicated(M)), ]
        M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
      # levelplot( eval(paste(p$variabletomodel, "mean", sep="."))~plon+plat, data=M, aspect="iso")

    # thin data a bit ... remove potential duplicates and robustify
        M = lonlat2planar( M, proj.type=p$aegis_proj4string_planar_km )  # first ensure correct projection
        setDT(M)

        M$plon = aegis_floor(M$plon / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km
        M$plat = aegis_floor(M$plat / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km

        M = M[,.SD[sample(.N, min(.N, p$carstm_inputs_prefilter_n))], by =list(plon, plat) ]  # compact, might be slightly slower
        # M = M[ M[, sample(.N, min(.N, p$carstm_inputs_prefilter_n) ), by=list(plon, plat)], .SD[i.V1], on=list(plon, plat), by=.EACHI]  # faster .. just a bit
        setDF(M)

      } else {

        M = bathymetry_db ( p=p, DS="z.lonlat.rawdata"  )  # 16 GB in RAM just to store!
        names(M)[which(names(M)=="z") ] = p$variabletomodel
        M = M[ which( !duplicated(M)), ]
        M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
        # levelplot( eval(paste(p$variabletomodel, "mean", sep="."))~plon+plat, data=M, aspect="iso")

      }

      if (p$carstm_inputs_prefilter != "aggregated") {
        if (exists("quantile_bounds", p)) {
          TR = quantile(M[[p$variabletomodel]], probs=p$quantile_bounds, na.rm=TRUE )
          keep = which( M[[p$variabletomodel]] >=  TR[1] & M[[p$variabletomodel]] <=  TR[2] )
          if (length(keep) > 0 ) M = M[ keep, ]
          keep = NULL
          gc()
        }
      }

        # if (exists("quantile_bounds", p)) {
        #   TR = quantile(M[,p$variabletomodel], probs=p$quantile_bounds, na.rm=TRUE )
        #   keep = which( M[,p$variabletomodel] >=  TR[1] & M[,p$variabletomodel] <=  TR[2] )
        #   if (length(keep) > 0 ) M = M[ keep, ]
        # }

      attr( M, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
      attr( M, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")
          # p$quantile_bounds = c(0.0005, 0.9995)

      M$AUID = st_points_in_polygons(
        pts = st_as_sf( M, coords=c("lon","lat"), crs=crs_lonlat ),
        polys = sppoly[, "AUID"],
        varname="AUID"
      )
      M = M[ which(!is.na(M$AUID)),]
      M$AUID = as.character( M$AUID )  # match each datum to an area

      eps = .Machine$double.eps
      M$z = M$z + runif( nrow(M), min=-eps, max=eps )

      M$lon = NULL
      M$lat = NULL

      M$tag = "observations"

      region.id = slot( slot(sppoly, "nb"), "region.id" )
      APS = st_drop_geometry(sppoly)
      sppoly = NULL
      gc()

      APS[, p$variabletomodel] = NA
      APS$AUID = as.character( APS$AUID )
      APS$tag ="predictions"

      vn = c("z", "tag", "AUID" )

      M = rbind( M[, vn], APS[, vn] )
      APS = NULL

      #required for carstm formulae
      M$space = as.character( M$AUID)

      save( M, file=fn, compress=TRUE )
      return( M )
    }

    # ------------------------------

    if ( DS %in% c("bathymetry", "stmv_inputs", "stmv_inputs_redo" )) {

      fn = file.path( p$modeldir, paste( "bathymetry", "stmv_inputs", "rdata", sep=".") )
      if (DS %in% c("bathymetry", "stmv_inputs") ) {
        load( fn)
        return( hm )
      }

      B = bathymetry_db ( p=p, DS="aggregated_data", redo=TRUE )  # 16 GB in RAM just to store!
      B$lon = NULL
      B$lat = NULL
      names(B)[which(names(B) == paste(p$variabletomodel, "mean", sep="."))] = p$variabletomodel

      print( "Warning: this needs a lot of RAM .. ~60GB depending upon resolution of discretization .. a few hours " )

      hm = list( input=B, output=list( LOCS = spatial_grid(p) ) )
      B = NULL; gc()
      save( hm, file=fn, compress=FALSE)
      hm = NULL
      gc()
      return(fn)

    }

    # ------------------------------

    if ( DS %in% c("stmv_inputs_highres", "stmv_inputs_highres_redo" )) {

      fn = file.path( p$modeldir, paste( "bathymetry", "stmv_inputs_highres", "rdata", sep=".") )
      if (DS %in% c("stmv_inputs_highres") ) {
        load( fn)
        return( hm )
      }

      B = bathymetry_db ( p=p, DS="z.lonlat.rawdata" )  # 16 GB in RAM just to store!

      # p$quantile_bounds = c(0.0005, 0.9995)
      if (exists("quantile_bounds", p)) {
        TR = quantile(B[,p$variabletomodel], probs=p$quantile_bounds, na.rm=TRUE )
        keep = which( B[,p$variabletomodel] >=  TR[1] & B[,p$variabletomodel] <=  TR[2] )
        if (length(keep) > 0 ) B = B[ keep, ]
      }

      # thin data a bit ... remove potential duplicates and robustify
      B = lonlat2planar( B, proj.type=p$aegis_proj4string_planar_km )  # first ensure correct projection

      B$lon = NULL
      B$lat = NULL

      attr( B, "proj4string_planar" ) =  p$aegis_proj4string_planar_km

      hm = list( input=B, output=list( LOCS = spatial_grid(p) ) )
      B = NULL; gc()
      save( hm, file=fn, compress=FALSE)
      hm = NULL
      gc()
      return(fn)

    }

    # ----------------

    if ( DS == "landmasks.create" ) {

      ## NOTE::: This does not get used

      # on resolution of predictions
      V = SpatialPoints( planar2lonlat( spatial_grid(p), proj.type=p$aegis_proj4string_planar_km )[, c("lon", "lat" )], CRS("+proj=longlat +datum=WGS84") )
      landmask( lonlat=V, db="worldHires", regions=c("Canada", "US"), ylim=c(36,53), xlim=c(-72,-45), tag="predictions", crs=p$aegis_proj4string_planar_km)

      # on resolution of statistics
      sbox = list(
        plats = seq( p$corners$plat[1], p$corners$plat[2], by=p$stmv_distance_statsgrid ),
        plons = seq( p$corners$plon[1], p$corners$plon[2], by=p$stmv_distance_statsgrid ) )
      V = as.matrix( expand.grid( sbox$plons, sbox$plats ))
      names(V) = c("plon", "plat")
      V = SpatialPoints( planar2lonlat( V, proj.type=p$aegis_proj4string_planar_km )[, c("lon", "lat" )], CRS("+proj=longlat +datum=WGS84") )
      landmask( lonlat=V, db="worldHires",regions=c("Canada", "US"), ylim=c(36,53), xlim=c(-72,-45), tag="statistics", crs=p$aegis_proj4string_planar_km)
    }

    #-------------------------

    if ( DS %in% c("complete", "complete.redo" )) {
      #// merge all stmv results and compute stats and warp to different grids
      outdir = file.path( p$modeldir, p$stmv_model_label, p$project_class, paste(  p$stmv_global_modelengine, p$stmv_local_modelengine, sep="_") )

      fn = file.path( outdir, paste( "bathymetry", "complete", p$spatial_domain, "rdata", sep=".") )

      if ( DS %in% c( "complete") ) {
        Z = NULL
        if ( file.exists ( fn) ) load( fn)
        return( Z )
      }

      nr = p$nplons
      nc = p$nplats

      # data prediction grid
      B = spatial_grid( p)
      Bmean = stmv_db( p=p, DS="stmv.prediction", ret="mean" )
      Blb = stmv_db( p=p, DS="stmv.prediction", ret="lb" )
      Bub = stmv_db( p=p, DS="stmv.prediction", ret="ub" )
      Z = data.frame( cbind(B, Bmean, Blb, Bub) )
      names(Z) = c( "plon", "plat", "z", "z.lb", "z.ub") # really Z.mean but for historical compatibility "z"
      B = Bmean = Blb = Bub = NULL

      # # remove land
      # oc = landmask( db="worldHires", regions=c("Canada", "US"), return.value="land", tag="predictions" )
      # Z$z[oc] = NA
      # Z$z.sd[oc] = NA

      Zmn = matrix( Z[,p$variabletomodel], nrow=nr, ncol=nc )  # means

      # first order central differences but the central term drops out:
      # diffr = ( ( Zmn[ 1:(nr-2), ] - Zmn[ 2:(nr-1), ] ) + ( Zmn[ 2:(nr-1), ] - Zmn[ 3:nr, ] ) ) / 2
      # diffc = ( ( Zmn[ ,1:(nc-2) ] - Zmn[ ,2:(nc-1) ] ) + ( Zmn[ ,2:(nc-1) ] - Zmn[ ,3:nc ] ) ) / 2
      diffr =  Zmn[ 1:(nr-2), ] - Zmn[ 3:nr, ]
      diffc =  Zmn[ ,1:(nc-2) ] - Zmn[ ,3:nc ]
      rm (Zmn); gc()

      dZ = ( diffr[ ,2:(nc-1) ] + diffc[ 2:(nr-1), ] ) / 2
      dZ = rbind( dZ[1,], dZ, dZ[nrow(dZ)] )  # top and last rows are copies .. dummy value to keep dim correct
      dZ = cbind( dZ[,1], dZ, dZ[,ncol(dZ)] )

      Z$dZ =  abs(c(dZ))

      # gradients
      ddiffr =  dZ[ 1:(nr-2), ] - dZ[ 3:nr, ]
      ddiffc =  dZ[ ,1:(nc-2) ] - dZ[ ,3:nc ]
      dZ = diffc = diffr = NULL

      ddZ = ( ddiffr[ ,2:(nc-1) ] + ddiffc[ 2:(nr-1), ] ) / 2
      ddZ = rbind( ddZ[1,], ddZ, ddZ[nrow(ddZ)] )  # top and last rows are copies .. dummy value to keep dim correct
      ddZ = cbind( ddZ[,1], ddZ, ddZ[,ncol(ddZ)] )
      Z$ddZ = abs(c(ddZ))

      # merge into statistics
      BS = stmv_db( p=p, DS="stmv.stats" )
      colnames(BS) = paste("b", colnames(BS), sep=".")
      Z = cbind( Z, BS )

      save( Z, file=fn, compress=TRUE)

      BS = ddZ = ddiffc = ddiffr = NULL
      gc()

      # now warp to the other grids
      p0 = p  # the originating parameters

      Z0 = Z  # rename as 'Z' will be overwritten below
      L0 = Z0[, c("plon", "plat")]
      L0i = array_map( "xy->2", L0, gridparams=p0$gridparams )

      voi_bathy = setdiff( names(Z0), c("plon", "plat", "lon", "lat") )
      grids = setdiff( unique( p0$spatial_domain_subareas ), p0$spatial_domain )

      for (gr in grids ) {
        print(gr)
        p1 = spatial_parameters( spatial_domain=gr ) #target projection
        # warping
          L1 = spatial_grid( p=p1 )
          L1i = array_map( "xy->2", L1[, c("plon", "plat")], gridparams=p1$gridparams )
          L1 = planar2lonlat( L1, proj.type=p1$aegis_proj4string_planar_km )
          Z = L1
          L1$plon_1 = L1$plon # store original coords
          L1$plat_1 = L1$plat
          L1 = lonlat2planar( L1, proj.type=p0$aegis_proj4string_planar_km )

          p1$wght = fields::setup.image.smooth(
            nrow=p1$nplons, ncol=p1$nplats, dx=p1$pres, dy=p1$pres,
            theta=p1$pres/3, xwidth=4*p1$pres, ywidth=4*p1$pres )
        # theta=p1$pres/3 assume at pres most of variance is accounted ... correct if dense pre-intepolated matrices .. if not can be noisy

          for (vn in voi_bathy) {
            Z[,vn] = spatial_warp( Z0[,vn], L0, L1, p0, p1, "fast", L0i, L1i )
          }
        Z = Z[ , names(Z0) ]

        fn = file.path( outdir, paste( "bathymetry", "complete", p1$spatial_domain, "rdata", sep=".") )
        save (Z, file=fn, compress=TRUE)
      }

      return(fn)

      if (0) {
        aoi = which( Z$z > 10 & Z$z < 500 )
        datarange = log( quantile( Z[aoi,"z"], probs=c(0.001, 0.999), na.rm=TRUE ))
        dr = seq( datarange[1], datarange[2], length.out=100)

        levelplot( log(z) ~ plon + plat, Z[ aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE), at=dr, col.regions=rev(color.code( "seis", dr)) )
        levelplot( log(phi) ~ plon + plat, Z[ aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE) )
        levelplot( log(range) ~ plon + plat, Z[aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE) )

      }
    }

    # ------------

    if (DS %in% c("baseline", "baseline.redo") ) {
      # form prediction surface in planar coords over the ocean

      outdir = file.path( p$modeldir, p$stmv_model_label, p$project_class, paste(  p$stmv_global_modelengine, p$stmv_local_modelengine, sep="_") )

      if ( DS=="baseline" ) {
        #  used to obtain coordinates
        fn = paste( "bathymetry", "baseline", p$spatial_domain, "rdata" , sep=".")
        outfile =  file.path( outdir, fn )
        Z = NULL
        load( outfile )
        Znames = names(Z)
        if (is.null(varnames)) varnames =c("plon", "plat")  # default is to send locs only .. different reative to all other data streams
        varnames = intersect( Znames, varnames )  # send anything that results in no match causes everything to be sent
        if (length(varnames) == 0) varnames=Znames  # no match .. send all
        Z = Z[ , varnames]
        return (Z)
      }

      for (domain in unique( c(p$spatial_domain_subareas, p$spatial_domain ) ) ) {
        pn = spatial_parameters( p=p, spatial_domain=domain )
        # if ( pn$spatial_domain == "snowcrab" ) {
        #   # NOTE::: snowcrab baseline == SSE baseline, except it is a subset so begin with the SSE conditions
        #   pn = spatial_parameters( p=pn, spatial_domain="SSE" )
        # }
        Z = bathymetry_db( p=pn, DS="complete" )
        Z = Z[ geo_subset( spatial_domain=domain, Z=Z ), ]

        # range checks
        ii = which( Z$dZ < exp(-6))
        if (length(ii) > 0) Z$dZ[ii] = exp(-6)

        ii = which( Z$dZ > 50 )
        if (length(ii) > 0) Z$dZ[ii] = 50

        ii = which( Z$ddZ < exp(-6))
        if (length(ii) > 0) Z$ddZ[ii] = exp(-6)

        ii = which( Z$ddZ > 20 )
        if (length(ii) > 0) Z$ddZ[ii] = 20

        fn = paste( "bathymetry", "baseline", domain, "rdata" , sep="." )
        outfile =  file.path( outdir, fn )

        save (Z, file=outfile, compress=T )
        print( outfile )
      }
      # require (lattice); levelplot( z~plon+plat, data=Z, aspect="iso")
      return( "completed" )
    }

    # ------------

    if (DS %in% c("baseline_prediction_locations", "baseline_prediction_locations.redo") ) {
      # form prediction surface in planar coords over the ocean

      outdir = p$modeldir

      if ( DS=="baseline_prediction_locations" ) {
        #  used to obtain coordinates
        fn = paste( "bathymetry", "baseline_prediction_locations", p$spatial_domain, "rdata" , sep=".")
        outfile =  file.path( outdir, fn )
        Z = NULL
        if (file.exists(fn)) {
          load( outfile )
          Znames = names(Z)
          if (is.null(varnames)) varnames =c("plon", "plat")  # default is to send locs only .. different reative to all other data streams
          varnames = intersect( Znames, varnames )  # send anything that results in no match causes everything to be sent
          if (length(varnames) == 0) varnames=Znames  # no match .. send all
          Z = Z[ , varnames]
          return (Z)
        }
      }

      pn = spatial_parameters( p=p, spatial_domain=p$spatial_domain )
      Z = spatial_grid(p)
      Z = planar2lonlat( Z,  proj.type=p$aegis_proj4string_planar_km   )
      Z$z = aegis_lookup( paramaters="bathymetry", LOCS=Z[, c("lon", "lat")], project_class="core", output_format="points" , DS="aggregated_data", variable.name="z.mean" )  # core == unmodelled
      Z = Z[ geo_subset( spatial_domain=p$spatial_domain, Z=Z ), ]

      fn = paste( "bathymetry", "baseline_prediction_locations", p$spatial_domain, "rdata" , sep=".")
      outfile =  file.path( outdir, fn )

      save (Z, file=outfile, compress=TRUE )
      print( outfile )

      # require (lattice); levelplot( z~plon+plat, data=Z, aspect="iso")
      return( Z )
    }

    # ------------

  }  # end bathymetry_db


## Random Forest training function

RFTrain = function(outdir, filename, InflationAdjustment=1, TruncateZeroes = FALSE, scale=TRUE,
    covars=GetAllPixelCovars(), overwrite=FALSE, PredictType="response", PredictQuantiles=0.5, ValidationSet = Data.val, ...)
{
    if (!dir.exists(outdir))
        dir.create(outdir)
    OutputFile = file.path(outdir, paste0("predictions-", filename))
    if (!overwrite && file.exists(OutputFile))
    {
        Predictions = read.csv(OutputFile)
        if (scale) Predictions = ScalePredictions(Predictions)
        return(Predictions)
    }
    quantreg = ifelse(PredictType=="response", FALSE, TRUE)

    Covariates = covars
    FullFormula = paste0("~", paste(Covariates, collapse = "+"))
    TrainingSet = Data.df
    #TrainingSet = Oversample(TrainingSet)

    Predictions = matrix(ncol=length(Classes), nrow=nrow(ValidationSet), dimnames=list(list(), Classes))
    for (Class in Classes)
    {
        print(Class)
        ZeroClass = paste("no", Class, sep=".")

        # Dynamic feature selection: drop any covariates that have any NA values for this particular class
        RelevantRows = TrainingSet[[Class]] > 0 # Could also just look at dominant
        # For some reason is.finite() in a loop fails...
        #RemainingCovars = !apply(TrainingSet[RelevantRows, Covariates], 2, function(x){any(!is.finite(x))})
        RemainingCovars = apply(TrainingSet[RelevantRows, Covariates], 2, function(x){all(!is.infinite(x) & !is.na(x) & !is.nan(x))})
        RemainingNames = names(RemainingCovars)[RemainingCovars]
        print(paste("Covars with no NA values:", toString(RemainingNames)))
        # TODO: finish implementing

        #Formula = update.formula(FullFormula, paste0(Class, " ~ ."))
        Formula =  formula(paste0(Class, "~", paste(RemainingNames, collapse = "+")))

        if (InflationAdjustment > 0)
        {
            if (InflationAdjustment == 1) # Zero-inflation only
            {
                # Predict zeroes
                ZeroFormula = update.formula(FullFormula, paste0("as.factor(", ZeroClass, ") ~ ."))
                ZeroModel = ranger(ZeroFormula, TrainingSet, seed = 0xbadcafe)
                ClassPredictions = predict(ZeroModel, ValidationSet)
                ClassPredictions = as.numeric(!as.logical(ClassPredictions$predictions))
                NonZeroes = ClassPredictions==1
            } else if (InflationAdjustment == 2) # Zero and 100 inflation
            {
                # Convert the "no." column to a factor, "zero", "hundred", "in-between"
                TrainingCategories = rep("in-between", nrow(TrainingSet))
                TrainingCategories[TrainingSet[,Class] == 0] = "zero"
                TrainingCategories[TrainingSet[,Class] == 100] = "hundred"
                TrainingCategories = factor(TrainingCategories)
                TrainingSet[,ZeroClass] = TrainingCategories

                ZeroFormula = update.formula(FullFormula, paste0(ZeroClass, " ~ ."))
                ZeroModel = ranger(ZeroFormula, TrainingSet, seed = 0xbadcafe, ...)

                CategoryPredictions = predict(ZeroModel, ValidationSet)$prediction
                ClassPredictions = as.numeric(CategoryPredictions) # For length
                ClassPredictions[CategoryPredictions == "zero"] = 0
                ClassPredictions[CategoryPredictions == "hundred"] = 100
                NonZeroes = CategoryPredictions=="in-between"
            }

            # Predict non-zeroes
            if (any(NonZeroes))
            {
                # Whether to use all data for training, or zero-truncate. Truncating makes the model biased towards 100...
                if (TruncateZeroes)
                {
                    if (InflationAdjustment == 1)
                        NonzeroModel = ranger(Formula, TrainingSet[TrainingSet[,Class] > 0,], seed = 0xbadcafe, quantreg=quantreg, ...)
                    else if (InflationAdjustment == 2)
                        NonzeroModel = ranger(Formula, TrainingSet[TrainingSet[,Class] > 0 & TrainingSet[,Class] < 100,], seed = 0xbadcafe, quantreg=quantreg, ...)
                } else
                    NonzeroModel = ranger(Formula, TrainingSet, seed = 0xbadcafe, quantreg=quantreg, ...)
                ClassPredictions[NonZeroes] = predict(NonzeroModel, ValidationSet[NonZeroes,], type=PredictType, quantiles=PredictQuantiles)$prediction
            } else print("Everything was predicted to be zero!")
        } else {
            # Predict all
            rfmodel = ranger(Formula, TrainingSet, seed = 0xbadcafe, quantreg=quantreg, ...)
            ClassPredictions = predict(rfmodel, ValidationSet, type=PredictType, quantiles=PredictQuantiles)$prediction
        }

        Predictions[,Class] = ClassPredictions
    }

    write.csv(Predictions, OutputFile, row.names=FALSE)

    if (scale) Predictions = ScalePredictions(Predictions)

    return(as.data.frame(Predictions))
}

# Three-step classification. More complex and doesn't share much code with the other approach, hence separate function.
RFTrain3 = function(outdir, filename, scale=TRUE, purity_threshold=95, covars=GetAllPixelCovars(),
    overwrite=FALSE, PredictType="response", PredictQuantiles=0.5, ValidationSet = Data.val, ...)
{
    OutputFile = file.path(outdir, paste0("predictions-threestep-", filename))
    if (!overwrite && file.exists(OutputFile))
    {
        Predictions = read.csv(OutputFile)
        if (scale) Predictions = ScalePredictions(Predictions)
        return(Predictions)
    }

    Covariates = covars
    FullFormula = paste0("~", paste(Covariates, collapse = "+"))
    TrainingSet = Data.df
    #TrainingSet = Oversample(TrainingSet)
    TrainingSet$pure = apply(Data.df[,Classes], 1, max) > purity_threshold
    if (all(Classes %in% names(ValidationSet)))
        ValidationSet$pure = apply(ValidationSet[,Classes], 1, max) > purity_threshold

    Predictions = matrix(ncol=length(Classes), nrow=nrow(ValidationSet), dimnames=list(list(), Classes))

    # Step one: pure/non-pure binary classification
    PureModel = ranger(paste0("as.factor(pure)", FullFormula), TrainingSet, seed = 0xbadcafe, ...)
    PureValPredictions = predict(PureModel, ValidationSet)
    PureValPredictions = as.logical(PureValPredictions$predictions)
    if (all(Classes %in% names(ValidationSet)))
    {
        PurityAcc = mean(PureValPredictions == ValidationSet$pure)
        print(paste("Built purity classifier, accuracy:", PurityAcc))
    }
    # We know whether the input is pure or not already, so for training we give the actual pure and nonpure pixels.
    # For predicting, we assume that PureModel is perfectly accurate.

    # Step two: classification of pure pixels
    ClassificationModel = ranger(paste0("dominant_lc", FullFormula), TrainingSet[TrainingSet$pure,], seed = 0xbadcafe, ...)
    ClassPredictions = predict(ClassificationModel, ValidationSet[PureValPredictions,]) # We use our pure model to select on which to predict
    # Expand into columns
    ClassCols = unclass(table(1:length(ClassPredictions$prediction),ClassPredictions$prediction)*100)
    Predictions[PureValPredictions, Classes] = ClassCols[,Classes]

    # Step three: regression of non-pure pixels, one model per class
    for (Class in Classes)
    {
        print(Class)
        Formula = update.formula(FullFormula, paste0(Class, " ~ ."))

        RegressionModel = ranger(Formula, TrainingSet[!TrainingSet$pure,], seed = 0xbadcafe, quantreg=PredictType!="response", ...)
        RegPredictions = predict(RegressionModel, ValidationSet[!PureValPredictions,], type=PredictType, quantiles=PredictQuantiles)
        Predictions[!PureValPredictions, Class] = RegPredictions$predictions
    }

    write.csv(Predictions, OutputFile, row.names=FALSE)

    if (scale) Predictions = ScalePredictions(Predictions)

    return(as.data.frame(Predictions))
}

# Train the three-step model only, do not predict.
RFModel3 = function(outdir, filename, purity_threshold=95, covars=GetAllPixelCovars(),
                    overwrite=FALSE,  PredictType="response", TrainingSet = Data.df, ...)
{
    OutputFile = file.path(outdir, paste0("predictions-threestep-", filename))
    if (!overwrite && file.exists(OutputFile))
    {
        Model = readRDS(OutputFile)
        return(Model)
    }

    Covariates = covars
    FullFormula = paste0("~", paste(Covariates, collapse = "+"))

    TrainingSet$pure = apply(TrainingSet[,Classes], 1, max) > purity_threshold

    # Step one: pure/non-pure binary classification
    PureModel = ranger(paste0("as.factor(pure)", FullFormula), TrainingSet, seed = 0xbadcafe, ...)

    # We know whether the input is pure or not already, so for training we give the actual pure and nonpure pixels.
    # For predicting, we assume that PureModel is perfectly accurate.

    # Step two: classification of pure pixels
    ClassificationModel = ranger(paste0("dominant_lc", FullFormula), TrainingSet[TrainingSet$pure,], seed = 0xbadcafe, ...)

    Model = list(purity_threshold=purity_threshold, PureModel=PureModel, ClassificationModel=ClassificationModel)

    # Step three: regression of non-pure pixels, one model per class
    for (Class in Classes)
    {
        print(Class)
        Formula = update.formula(FullFormula, paste0(Class, " ~ ."))

        RegressionModel = ranger(Formula, TrainingSet[!TrainingSet$pure,], seed = 0xbadcafe, quantreg=PredictType!="response", ...)
        Model[[length(Model)+1]] = RegressionModel
        names(Model)[length(Model)] = paste0(Class, "RegressionModel")
    }

    class(Model) = c("MultistepModel", class(Model))
    saveRDS(Model, OutputFile)
    return(Model)
}

predict.MultistepModel = function(object, newdata, PredictType="response", PredictQuantiles=0.5, scale=TRUE,
                       Classes=GetCommonClassNames(), purity_threshold=object$purity_threshold)
{
    Predictions = matrix(ncol=length(Classes), nrow=nrow(newdata), dimnames=list(list(), Classes))

    # Run the purity model
    PureValPredictions = predict(object$PureModel, newdata)
    PureValPredictions = as.logical(PureValPredictions$predictions)

    # Print some stats
    if (all(Classes %in% names(newdata)))
    {
        newdata$pure = apply(newdata[,Classes], 1, max) > purity_threshold
        PurityAcc = mean(PureValPredictions == newdata$pure)
        print(paste("Purity classifier accuracy:", PurityAcc))
    }

    # Run classification on pure pixels
    ClassPredictions = predict(object$ClassificationModel, newdata[PureValPredictions,]) # We use our pure model to select on which to predict
    # Expand into columns
    ClassCols = unclass(table(1:length(ClassPredictions$prediction),ClassPredictions$prediction)*100)
    Predictions[PureValPredictions, Classes] = ClassCols[,Classes]

    # Run regression on mixed pixels
    for (Class in Classes)
    {
        print(Class)
        RegPredictions = predict(object[[paste0(Class, "RegressionModel")]], newdata[!PureValPredictions,], type=PredictType, quantiles=PredictQuantiles)
        Predictions[!PureValPredictions, Class] = RegPredictions$predictions
    }

    if (scale) Predictions = ScalePredictions(Predictions)
    return(Predictions)
}
.S3method("predict", "MultistepModel")


#!/usr/bin/Rscript
# Smoke Spottr

library(tidyverse) # General data wrangling
library(sf) # Spatial
library(tmap) # Map plotting
library(tmaptools) # Provides the kernel-density smoothing function
library(geosphere) # Calculate distances/bearings on a sphere
library(raster) # Raster files
library(RPostgres)
library(DBI)
setwd("/mnt/R")
source("../config.r")

md = raster("mag/D_Grid_mf_2020.grd")

endTime = as.POSIXct(format(Sys.time(),tz="GMT"),tz="GMT")
startTime = endTime-24*60*60*7

#endTime = as.POSIXct("2018-03-18 02:07:46",tz="GMT")
db_dat = dbGetQuery(con_prod,"select * from smoke_reports")

db_raw = dplyr::select(db_dat,id,lat,lng,created_at,location_type,smoke_intensity,smell_intensity,smell_smoke,see_smoke,picture,alpha,alpha_accuracy)
db_raw$smell_smoke=as.character(db_raw$smell_smoke)
db_raw$see_smoke=as.character(db_raw$see_smoke)
db_raw$picture=as.character(db_raw$picture)
db_raw = st_as_sf(db_raw,coords=c("lng","lat"),crs=4326)

if(!is.null(db_raw)){
  write_sf(db_raw,"tiles/smoke_raw_points.geojson",delete_dsn = TRUE)
}else{
  cat("",file="tiles/smoke_raw_points.geojson")
}

db_dat$created_at = as.POSIXct(format(db_dat$created_at,"%Y-%m-%d %H:%M:%S"),tz="GMT")
dat = db_dat %>% filter(created_at > startTime & created_at < endTime & location_type=="dist" & !is.na(alpha))
dat_local = db_dat %>% filter(created_at > startTime & created_at < endTime & location_type=="atl" & see_smoke == TRUE)

# Define array of start- and end- times for moving window analysis
start_array = seq(startTime,endTime,15*60)
end_array = start_array + 60*60

# PolygonList
polygon_list = list()

# PointLIst
point_list = list()

# VectorList
vector_list = list()

for(i in seq_along(start_array)){
  data = filter(dat,created_at > start_array[i] & created_at < end_array[i]) %>% dplyr::select(created_at, id,lat,lng,alpha,alpha_accuracy)
  if(nrow(data)<3){next}
  data$alpha_accuracy[is.na(data$alpha_accuracy)] = 15
  data_left = data
  data_right = data
  data_left$side = "left"
  data_right$side = "right"
  data_left$alpha = data_left$alpha+data_left$alpha_accuracy*.75
  data_right$alpha = data_right$alpha-data_right$alpha_accuracy*.75
  data$side = "mid"
  data = rbind(data_left,data_right,data)

  # Read test data file
  #data = read_csv("smoke_trak/test_data.csv")

  # Map of Victoria and roads for plotting
  #vic = read_sf("E:/geodata/Aus_Coastline/australia/cstauscd_r.shp")
  #roads = read_sf("E:/geodata/globalmap2001/Vector/transportation/roadl.shp")

  # Convert the input data file to a spatial object with WGS84 lat/longs
  from_data = st_as_sf(data,coords=c("lng","lat"),crs=4326)

  # Plot these points on a map of Victoria
  #tm_shape(from_data) + tm_dots(size=0.5,col="green") + tm_shape(vic) + tm_borders() + tm_shape(roads) + tm_lines() + tm_layout(title = "Point Locations")

  # Make a copy of the input dataset - we will calculate the end-points of the vectors
  to_points = data

  ex_mat = st_coordinates(from_data)
  mDelta = extract(md,ex_mat)
  data$alpha = data$alpha + mDelta

  # This function takes lat/longs, a bearing, and a distance in m, and returns the end locations of each vector
  sp = destPoint(cbind(data$lng,data$lat),data$alpha,500)
  data$lng = sp[,1]
  data$lat = sp[,2]

  from_data = st_as_sf(data,coords=c("lng","lat"),crs=4326)

  dp = destPoint(cbind(data$lng,data$lat),data$alpha,25000)

  # Replace the lat/longs in this copy of input dataset with these coordinates
  to_points$lng = dp[,1]
  to_points$lat = dp[,2]

  # Convert these end points to a spatial object
  to_data = st_as_sf(to_points,coords=c("lng","lat"),crs=4326)

  # We need some unique IDs for the start and end point data frames
  # so they can be grouped together into lines
  from_data$idx = seq_along(from_data$alpha)
  to_data$idx = seq_along(to_data$alpha)

  # Join the two data frames into one
  comb = rbind(from_data,to_data)
  combx = filter(comb,side=="mid")

  # Group by ID, cast the resulting point groups as spatial lines
  comb = group_by(comb,idx) %>% summarise() %>% st_cast("LINESTRING")
  combx = group_by(combx,created_at,id) %>% summarise() %>% st_cast("LINESTRING")

  vector_list[[i]] = combx

  #sitelocs = tibble(name=c("Mt Wellington","Bridge","Droughty Pt"),
  #                  lat = c(-42.896574,-42.865191,-42.929398),
  #                  lon = c(147.237183,147.344055,147.417940))

  #sitelocs = st_as_sf(sitelocs,coords=c("lon","lat"),crs=4326)

  # Plot a map of points, vectors on Melbourne
  #tm_shape(comb) + tm_lines(col="blue") +tm_shape(from_data) + tm_dots(size=0.1,col="green") + tm_shape(vic) + tm_borders() + tm_shape(roads) + tm_lines() + tm_layout(title = "Point Locations") + tm_shape(sitelocs) + tm_symbols(shape=17)

  # Calculate intersection of all vectors
  line_is = st_intersection(comb,comb)

  # This gave us ALL intersections - both intersection points, and the lines they sit on
  # So keep only the geometries that are points
  line_is = line_is[st_geometry_type(line_is)=="POINT",]
  line_is=st_difference(line_is)
  line_is$idx = NULL
  line_is$idx.1 = NULL

  data_local = filter(dat_local,created_at > start_array[i] & created_at < end_array[i]) %>% dplyr::select(created_at, lat,lng)
  data_local = st_as_sf(data_local,coords=c("lng","lat"),crs=4326)
  data_local$type = rep("Local",nrow(data_local))

  line_is$created_at = rep(end_array[i],nrow(line_is))
  line_is$type = rep("Intersection",nrow(line_is))

  line_is = rbind(line_is,data_local)

  if(nrow(line_is)==0){next }

  point_list[[i]] = line_is

  if(nrow(line_is)<2){next }

  # Plot a map of these point intersections
  #tm_shape(comb) + tm_lines(col="blue") +tm_shape(from_data) + tm_dots(size=0.5,col="green") + tm_shape(line_is) + tm_squares(size=0.2,col="red") + tm_shape(vic) + tm_borders() + tm_shape(roads) + tm_lines() + tm_layout(title = "Line Intersections")

  # To calculate a kernel density, we need to reproject the data into a projected coordinate system
  # I'm using Albers because it covers the whole continent, and accuracy isn't vital
  line_is = st_transform(line_is,crs="+proj=aea +lat_1=-18 +lat_2=-36 +lat_0=0 +lon_0=134 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs ")

  # Calculate a kernel density raster with a 3km bandwidth
  sm = smooth_map(line_is,bandwidth=2,to.Raster=TRUE,nrow=500,ncol=500)
  rast = sm[[1]]

  # Plot this raster on the map of Melbourne
  #tm_shape(comb,is.master = TRUE) + tm_lines(alpha=0) + tm_shape(rast) + tm_raster(palette="YlOrRd",title="KDE") + tm_shape(vic) + tm_borders()  + tm_shape(roads,col="black",alpha=0.5) + tm_lines() + tm_layout(title = "Intersection Kernel Density")

  # Find the 95th percentile of the raster value
  # And classify a new raster with just those values present
  # This is the bit that we will need real data to figure out if this is the best critera
  # What if we have LOTS of plumes all over the place? Will a 95th percentile make some go missing?
  # What if there is no smoke - will 95th percentile start highlighting smoke that isn't there?
  # May need to identify a useful fixed density instead

  # Calculate 95th percentile value
  q=quantile(rast,.95)

  # Copy the raster
  trast = rast

  # Set values of this raster where original raster is more than quantile value
  values(trast)[values(rast)>q]=1
  values(trast)[values(rast)<=q]=NA

  # Plot classified raster
  #tm_shape(comb,is.master = TRUE) + tm_lines(alpha=0) + tm_shape(trast) + tm_raster(palette="YlOrRd",title="KDE") + tm_shape(vic) + tm_borders()  + tm_shape(roads,col="black",alpha=0.5) + tm_lines() + tm_layout(title = "Threshold Density")
  orast = rasterToPolygons(trast,dissolve=TRUE)
  orast = st_as_sf(orast, crs="+proj=aea +lat_1=-18 +lat_2=-36 +lat_0=0 +lon_0=134 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs ")
  orast = st_transform(orast,crs=4326)
  orast=st_buffer(orast,.000000001)
  orast$created_at = end_array[i]
  polygon_list[[i]]=orast

}

polygon_list = compact(polygon_list)
all_poly = do.call(rbind,polygon_list)

vector_list = compact(vector_list)
all_vector = do.call(rbind,vector_list)

point_list = compact(point_list)
all_points = do.call(rbind,point_list)

if(!is.null(all_poly)){
 write_sf(all_poly,"tiles/smoke_poly.geojson",delete_dsn=TRUE)
}else{
  cat("",file="tiles/smoke_poly.geojson")
}

if(!is.null(all_vector)){
  write_sf(all_vector,"tiles/smoke_lines.geojson",delete_dsn=TRUE)
}else{
  cat("",file="tiles/smoke_lines.geojson")
}

if(!is.null(all_points)){
  write_sf(all_points,"tiles/smoke_points.geojson",delete_dsn=TRUE)
}else{
  cat("",file="tiles/smoke_points.geojson")
}


###
### Copyright (C) 2017  Rafael Laboissière
###
### This program is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by the
### Free Software Foundation, either version 3 of the License, or (at your
### option) any later version.
###
### This program is distributed in the hope that it will be useful, but
### WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
### General Public License for more details.
###
### You should have received a copy of the GNU General Public License along
### with this program.  If not, see <http://www.gnu.org/licenses/>.

sessions <- read.csv ("obj-stab-info.csv")
subjects <- read.csv ("cohort-info.csv")

exp.lab <- list ()
exp.lab [["Experiment 1"]] <- "room-126"
exp.lab [["Experiment 2"]] <- "scene-mirror"
exp.lab [["Experiment 3"]] <- "no-table"

for (i in names (exp.lab)) {
    x <- unique (as.character (subset (sessions,
                                       experiment == exp.lab [[i]])$subject))
    y <- subset (subjects, subject %in% x & subject != "S066")
    n <- nrow (y)
    min.age <- floor (min (y$age))
    max.age <- ceiling (max(y$age))
    idx <- sort (y$age, index.return = TRUE)$ix
    pdf (file = sprintf ("%s.pdf", i))
    plot (y$age [idx], seq (1 : n), pch = 19, yaxt = "n", xaxt = "n", main = i,
          xlab = "age (years)", ylab = "", xlim = c (min.age, max.age))
    axis (2, at = seq (1, n), labels = y$subject [idx], las = 1)
    axis (1, at = seq (min.age, max.age))
    dev.off ()
}


TADPOLE_D1_D2 <- read.csv("data/TADPOLE_D1_D2.csv", na.strings=c("NA",-4,"-4.0",""," ","NaN"))
TADPOLE_D3 <- read.csv("data/TADPOLE_D3.csv", na.strings=c("NA",-4,"-4.0",""," ","NaN"))
TADPOLE_D1_D2_Dict <- read.csv("data/TADPOLE_D1_D2_Dict.csv", na.strings=c("NA",-4,"-4.0",""," "))

TADPOLE_D1_D2$EXAMDATE <- as.Date(TADPOLE_D1_D2$EXAMDATE)
#Train Test Split
TrainingSet <- subset(TADPOLE_D1_D2,D1==1)
rownames(TrainingSet) <- paste(TrainingSet$RID,TrainingSet$VISCODE,sep="_")

TrainingSet <- TrainingSet[order(TrainingSet$EXAMDATE),]
TrainingSet <- TrainingSet[order(as.numeric(TrainingSet$RID)),]

TADPOLE_D3$EXAMDATE <- as.Date(TADPOLE_D3$EXAMDATE)
rownames(TADPOLE_D3) <- paste(TADPOLE_D3$RID,TADPOLE_D3$VISCODE,sep="_")

#D3 Cross sectional
## First Remove D2 subjects from Training Set
D3IDS <- TADPOLE_D3$RID
D3TrainingSet <- TrainingSet[!(TrainingSet$RID %in% D3IDS),]
cat("I'm here\n")
print(c("I'm here"))

## Conditioning the data sets
source('R_scripts/dataPreprocessing.R')
dataTadpoleD3 <- suppressMessages(dataTADPOLEPreprocesing(D3TrainingSet,
                                                           TADPOLE_D3,
                                                           TADPOLE_D1_D2_Dict,
                                                           MinVisit=18,
                                                           colImputeThreshold=0.15,
                                                           rowImputeThreshold=0.10,
                                                           includeID=FALSE))
#save(dataTadpoleD3,file="data/temp/D3DataFrames.RDATA")
write.csv(dataTadpoleD3$AdjustedTrainFrame,"data/dataTadpoleD3$AdjustedTrainFrame.csv")
write.csv(dataTadpoleD3$testingFrame,"data/dataTadpoleD3$testingFrame.csv")
write.csv(dataTadpoleD3$Train_Imputed,"data/dataTadpoleD3$Train_Imputed.csv")
write.csv(dataTadpoleD3$Test_Imputed,"data/dataTadpoleD3$Test_Imputed.csv")


# Team Rython: Dainius Masiliunas and Tim Weerman
# Date: January 2016
# License: Apache License 2.0

library(bfastSpatial)

# Helper wrapper functions for bfastSpatial functions for loading files if they exist.

# Returns an annual summary RasterBrick that either already has been generated,
# or generates it from scratch.
GenerateAnnualSummary = function(stack, filename, fx, mc.cores=4, ...)
{
    if (!file.exists(filename))
    {
        print("Calculating annual summary. This may take a LONG time! Get a cup of tea in the mean while. Or ten.")
        return(annualSummary(stack, fun=fx, na.rm=TRUE, mc.cores=mc.cores, filename=filename, progress="text", ...))
    }
    else
        return(brick(filename))
}

# Returns a RasterStack that either has already been stacked, or generates it from scratch.
GenerateTimeStack = function(filename, ...)
{
    if (!file.exists(filename))
        stack = timeStackMODIS(filename=filename, datatype='INT1U', progress="text", ...)
    else
        stack = stack(filename)
}


setwd(".")
library(plyr)
library(dplyr)
library(ggplot2)
library(extrafont)
require(reshape2)
library(nortest)
library(effsize)
library(splitstackshape)
library(car)
library(rstatix)
library(tidyverse)
library(ggpubr)
library(ez)
library(bestNormalize)
library(zoo)

loadfonts()
options(max.print=50)
fontSize = 10

main_dir = "./experiment_output/"

path_movmnt = c('/n_movement', '/f_movement', '/a_movement')
path_tactic = c('/1_baseline', '/2_ee1', '/3_ee2', '/4_ee3', '/5_ee4', '/6_combined')
path_envmnt = c('/empty', '/obstacles')

energy_hertz <- 200 # Frequency at which energy is measured.

get_all_runs <- function(path) {
  run_list <- list()

  for (i in 1:10) {
    file_path = paste(main_dir, path, '/run', i, '/DATA.txt', sep="")
    run <- read.csv(file_path, header = FALSE)
    run_list[[i]] <- run
  }

  return(run_list)
}

filter_data <- function(d) {
  d<-d[!(d$V1==0.0),]
  return(d)
}

convert_run_to_per_second <- function(data) {
  # Energy part:
  deltas <- data.frame(V1 = data$V1,
                       V2 = sapply(data$V5,
                                   function (x) x * (1/energy_hertz))
  )      # Convert every reading to 1/200th of its value
  per_second <- rollapply(deltas$V2, energy_hertz, sum, by = energy_hertz)  # Sum each 200 readings to an accumulated value, representing energy per second in mJ
  run_per_second <- data.frame(V1 = seq(1, length(per_second), by=1),
                               V2 = per_second
  )

  return(run_per_second)
}

convert_data <- function(all_runs) {
  all_runs_return <- data.frame()
  for (i in 1:length(all_runs)) {
    all_runs_return <- rbind(all_runs_return,
                             convert_run_to_per_second(
                               top_n(filter_data(all_runs[[i]]), 24000)
                             )
    )
  }
  all_runs_return = all_runs_return %>% filter(V1 <= 120)
  return(all_runs_return)
}

get_random_slice = function(data) {
  random_start = sample(seq(1, 1200, 120), 1)
  return(data %>% slice(random_start:(random_start + 120)))
}

no_empty_b <- convert_data(get_all_runs(paste('/n_movement', '/1_baseline', sep="")))
no_empty_c <- convert_data(get_all_runs(paste('/n_movement', '/6_combined', sep="")))
no_empty_b = get_random_slice(no_empty_b)
no_empty_b$tactic = factor("B")
no_empty_c = get_random_slice(no_empty_c)
no_empty_c$tactic = factor("C")
no_empty = rbind(no_empty_b, no_empty_c)
no_empty$combination = factor("no_empty")

auto_empty_b <- convert_data(get_all_runs(paste('/a_movement/empty', '/1_baseline', sep="")))
auto_empty_c <- convert_data(get_all_runs(paste('/a_movement/empty', '/6_combined', sep="")))
auto_empty_b = get_random_slice(auto_empty_b)
auto_empty_b$tactic = factor("B")
auto_empty_c = get_random_slice(auto_empty_c)
auto_empty_c$tactic = factor("C")
auto_empty = rbind(auto_empty_b, auto_empty_c)
auto_empty$combination = factor("auto_empty")

auto_cluttered_b <- convert_data(get_all_runs(paste('/a_movement/obstacles', '/1_baseline', sep="")))
auto_cluttered_c <- convert_data(get_all_runs(paste('/a_movement/obstacles', '/6_combined', sep="")))
auto_cluttered_b = get_random_slice(auto_cluttered_b)
auto_cluttered_b$tactic = factor("B")
auto_cluttered_c = get_random_slice(auto_cluttered_c)
auto_cluttered_c$tactic = factor("C")
auto_cluttered = rbind(auto_cluttered_b, auto_cluttered_c)
auto_cluttered$combination = factor("auto_cluttered")

sweep_empty_b <- convert_data(get_all_runs(paste('/f_movement/empty', '/1_baseline', sep="")))
sweep_empty_c <- convert_data(get_all_runs(paste('/f_movement/empty', '/6_combined', sep="")))
sweep_empty_b = get_random_slice(sweep_empty_b)
sweep_empty_b$tactic = factor("B")
sweep_empty_c = get_random_slice(sweep_empty_c)
sweep_empty_c$tactic = factor("C")
sweep_empty = rbind(sweep_empty_b, sweep_empty_c)
sweep_empty$combination = factor("sweep_empty")

sweep_cluttered_b <- convert_data(get_all_runs(paste('/f_movement/obstacles', '/1_baseline', sep="")))
sweep_cluttered_c <- convert_data(get_all_runs(paste('/f_movement/obstacles', '/6_combined', sep="")))
sweep_cluttered_b = get_random_slice(sweep_cluttered_b)
sweep_cluttered_b$tactic = factor("B")
sweep_cluttered_c = get_random_slice(sweep_cluttered_c)
sweep_cluttered_c$tactic = factor("C")
sweep_cluttered = rbind(sweep_cluttered_b, sweep_cluttered_c)
sweep_cluttered$combination = factor("sweep_cluttered")

data = rbind(no_empty, auto_empty, auto_cluttered, sweep_empty, sweep_cluttered)

fontSize = 8

global_min = min(data$V2)
global_max = max(data$V2)

plot_power = function(comb, title) {
  data %>% filter(combination == comb) %>%
  ggplot(aes(x=V1, y=V2, color=tactic)) +
    # geom_hex(bins=120) +
    geom_line() +
    ylim(global_min, global_max) +
    xlim(0, 120) +
    ggtitle(title) +
    theme_bw() + xlab("Mission time (seconds)") + ylab("Power (mW)") +
    scale_x_continuous(breaks=seq(0,120,10)) +
    scale_color_manual(values=c("red", "#009900")) +
    theme(legend.position="none", plot.title=element_text(size=fontSize), axis.text.x=element_text(size=fontSize, angle = 45, hjust = 1), axis.text.y=element_text(size=fontSize), axis.title=element_text(size=fontSize))

  ggsave(paste("./plots/power_", comb, ".pdf", sep=""), scale = .9, height = 4, width = 10, unit = "cm")
}

plot_power("no_empty", "a) No movement, empty environment")
plot_power("auto_empty", "b) Autonomous movement, empty environment")
plot_power("auto_cluttered", "c) Autonomous movement, cluttered environment")
plot_power("sweep_empty", "d) Sweep movement, empty environment")
plot_power("sweep_cluttered", "e) Sweep movement, cluttered environment")


library(N)
library(IRM)
library(set)
library(OVA)
library(map)
library(HIR)
library(rank_set)
library(top)
library(IN)
library(difference_set)
library(R_overlap)
seed=read.table("seed.csv",header=T)
cluster=read.table("cluster.csv",header=T)
number_seed=N(seed)
n=N(cluster)
Q_core=null
for(i in 1:number_seed)
 {
     for(j in 1:n)
      {
        set(IRM(seed,cluster),map(Q[i],cluster[j])*OVA(map(Q[i],cluster[j])))
      }
 }
for(i in 1:number_seed)
 {
      rank_final(Q[i])=HIR(rank_n(Q[i],n),SD/AMV)
 }
while(N(Q*_core)<number_seed*cut_core)
 {
      set(Q*_core,IN(top(rank_final(Q[i])),seed))
      set(seed,difference_set(seed,top(rank_final(Q[i]))))
 }
set(Q_core,R_overlap(Q*_core))
write(Q_core,file="Q_core.csv")


#' Visualize the confusion matrix using nearest neighbor as classification model.
#'
#' @param patientSim - The patient similarity matrix.
#' @param diagnoses - A character vector of diagnostic labels associated with the rownames of patientSim.
#'                    The names of this vector are patient IDs, and values are diagnostic labels.
#' @param diag - The diagnosis associated with positive controls in your data.
#' @return p - a plotly scatter plot colored by provided diagnostic labels.
#' @export plot.knnSim
#' @usage plot.knnSim(patientSim, diagnoses, diag)
#' @examples
#' # if you have diagnostic labels associated with the colnames(data_mx), send them using diagnoses parameter
#' p = plot.knnSim(patientSim, diagnoses, diag="diseased")
#' p
plot.knnSim = function(patientSim, diagnoses, k, diag) {
  diagnoses = diagnoses[colnames(patientSim)]
  # Add a GREEN edge between patient nodes if k nearest neighbor is correct diagnosis (either TP or TN)
  # Add a RED edge between patient nodes if k nearest neighbor is incorrect diagnosis (either FP or FN)
  tp = 0
  fp = 0
  tn = 0
  fn = 0
  ig = make_empty_graph(n=ncol(patientSim), directed=TRUE)
  V(ig)$name = colnames(patientSim)
  for (pt1 in 1:length(diagnoses)) {
    diag_pt1 = diagnoses[pt1]
    ind = sort(patientSim[pt1,-pt1], decreasing = FALSE)
    ind = ind[which(ind==min(ind))]
    diag_pt_ind = diagnoses[which(names(diagnoses) %in% names(ind))]
    if (any(diag_pt_ind==diag) && diag_pt1==diag) {
      # True positive
      tp = tp + 1
      ind = ind[which(diag_pt_ind==diag)]
      ig = add.edges(ig, edges=c(colnames(patientSim)[pt1], names(ind[1])), attr=list(color="green", lty=1))
    } else if (diag_pt_ind!=diag && diag_pt1!=diag) {
      # True negative
      tn = tn + 1
      ig = add.edges(ig, edges=c(colnames(patientSim)[pt1], names(ind[1])), attr=list(color="green", lty=1))
    } else if (diag_pt_ind==diag && diag_pt1!=diag) {
      # Mistake!
      fp = fp + 1
      ig = add.edges(ig, edges=c(colnames(patientSim)[pt1], names(ind[1])), attr=list(color="red", lty=1))
    } else {
      fn = fn + 1
      ig = add.edges(ig, edges=c(colnames(patientSim)[pt1], names(ind[1])), attr=list(color="red", lty=1))
    }
  }
  print(sprintf("Tp = %d, Tn= %d, Fp = %d, Fn=%d", tp, tn, fp, fn))
  sens = tp / (tp+fn)
  spec = tn / (tn+fp)
  print(sprintf("Sens = %.2f, Spec= %.2f", sens, spec))

  V(ig)$label = rep("", length(V(ig)$name))
  grps = list()
  grps[[1]] = names(diagnoses)[which(diagnoses==diag)]
  grps[[2]] = names(diagnoses)[which(diagnoses!=diag)]
  names(grps) = names(table(diagnoses))
  plot(ig, mark.groups = grps, mark.col = c("white", "black"), layout=layout.circle, edge.width=3, edge.arrow.size=0.5) #+
    #legend("topright", legend=names(grps), fill=c("white", "black"))

  #tt = table(diagnoses)
  #grps = list()
  #for (i in 1:length(tt)) {
  #  grps[[i]] = names(diagnoses)[which(diagnoses==names(tt)[i])]
  #}
  #names(grps) = names(tt)
  #p = plot(ig, mark.groups = grps, mark.col = c("white", "light grey", "dark grey", "black")[1:length(tt)], layout=layout.circle, edge.width=3, edge.arrow.size=0.5) +
  #  legend("topright", legend=names(grps), fill=c("white", "light grey", "dark grey", "black")[1:length(tt)])

  return(0)
}


context("Test testdata")

test_that("Check that testdata exist", {
  expect_equal(length(testdata), 3)
  expect_equal(length(testdata$bohf), 500)
  expect_equal(length(testdata$dato), 500)
  expect_equal(length(testdata$tid_min), 500)
  expect_true(is.factor(testdata$bohf))
  expect_false(is.numeric(testdata$dato))
  expect_true(is.numeric(testdata$tid_min))
  expect_identical(median(testdata$tid_min), 34)
  expect_identical(mean(testdata$tid_min), 34.308)
})


  tapply2 = function (x, indices, func, var, newvars, ...) {
    # fast
    x = convert2factor(x, indices)
    y = as.data.frame.table( tapply( x[,var], x[,indices], FUN=func, simplify=T, ... ) )
    names(y) = c(indices, newvars)
    y = factor2character (y, indices)
    return (y)
  }