Skip to content

Commit

Permalink
Merge branch 'master' into generalized_agg_funs
Browse files Browse the repository at this point in the history
  • Loading branch information
dschlaep committed Sep 21, 2016
2 parents 0557b7b + 52d3ab4 commit f400f71
Show file tree
Hide file tree
Showing 6 changed files with 251 additions and 171 deletions.
46 changes: 39 additions & 7 deletions 2_SWSF_p2of5_CreateDB_Tables_v51.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -879,13 +879,45 @@ if (length(Tables) == 0 || cleanDB) {
#TODO(drs): progress state

#35a
if(any(simulation_timescales=="daily") && aon$dailyNRCS_SoilMoistureTemperatureRegimes){
temp <- c(temp, paste0("NRCS_", c(c("Depth50cmOrImpermeable_cm", "MoistureControlSection_Upper_cm", "MoistureControlSection_Lower_cm", "AnhydrousControlSection_Upper_cm", "AnhydrousControlSection_Lower_cm", "Permafrost_TF"),
paste0(c(c("SoilTemp_AnhydrousDepth_C","SoilTemp_50cmDepth_Annual_C", "SoilTemp_50cmDepth_JJA_C", "SoilTemp_50cmDepth_DJF_C", "Saturation_ConsecutiveMaxDuration_JJA_days"),
c("Cumlative_Days_Above_0C", "Cumlative_Days_Above_5C", "Cumlative_DryDays_whenT50Above5C", "Consecutive_MoistDays_whenT50Above8C","Consecutive_DryDays_Summer", "Consecutive_MoistDays_AllYear_AnyLayer", "Cumlative_MoistDays_AllYear_AnyLayer", "Cumlative_DryDays_AllYear_AnyLayer","Consecutive_MoistDays_Winter")), "_mean"),
paste0("SoilTemperatureRegime_", c("Hyperthermic", "Thermic", "Mesic", "Frigid", "Cryic", "Gelic")),
paste0("SoilMoistureRegime_", c("Anhydrous", "Aridic", "Udic", "Ustic", "Xeric")))))
}
if(any(simulation_timescales=="daily") && aon$dailyNRCS_SoilMoistureTemperatureRegimes){
# abbreviations:
# - GT = greater than; LT = less than; EQ = equal
# - MCS = MoistureControlSection; ACS = AnhydrousControlSection
# - consec = consecutive
temp <- c(temp,
paste0("NRCS_",
c(c("Depth50cmOrImpermeable_cm",
"MCS_Upper_cm", "MCS_Lower_cm",
"ACS_Upper_cm", "ACS_Lower_cm",
"Permafrost_TF"),
paste0(c("SoilTemp_ACS_Annual_C", "SoilTemp_at50cm_Annual_C",
"SoilTemp_at50cm_JJA_C", "SoilTemp_at50cm_DJF_C",
"Saturation_ConsecutiveMaxDuration_JJA_days",
# Lanh_annual_means:
"Days_at50cm_GT0C_prob", "Days_ACS_MoreThanHalfDry_prob",
"Days_ACS_MoreThanHalfDry_and_at50cm_GT0C_prob",
# Cond_annual_means:
"Days_at50cm_GT5C_prob", "Days_at50cm_GT8C_prob",
"Days_MCS_AllWet_prob", "Days_MCS_AllDry_prob",
"MCS_AllDry_and_at50cm_GT5C_prob", # COND1_Test
"MCS_AnyWet_and_at50cm_GT5C_prob", # COND1_1_Test
"MCS_AnyWetConsec_LT90Days_at50cm_GT8C_prob", # COND2
"MCS_AnyDryTotal_LT90Days_prob", # COND3
"MCS_at50cm_GT22C_prob", # COND4
"MCS_at50cm_DiffJJAtoDJF_GT6C_prob", # COND5
"Days_MCS_AllDry_Summer_days",
"MCS_AllDry_Summer_LT45Days_prob", # COND6
"MCS_AnyMoist_GT180Days_prob", # COND7
"Days_MCS_AnyWetConsec_days",
"MCS_AnyWetConsec_GT90Days_prob", # COND8
"Days_MCS_AllWet_Winter_days",
"MCS_AllWet_Winter_GT45days_prob"), # COND9
"_mean"),
paste0("SoilTemperatureRegime_",
c("Hyperthermic", "Thermic", "Mesic", "Frigid", "Cryic", "Gelic")),
paste0("SoilMoistureRegime_",
c("Anhydrous", "Aridic", "Udic", "Ustic", "Xeric")))))
}
#35b
if(any(simulation_timescales=="daily") && aon$dailyNRCS_Chambers2014_ResilienceResistance && aon$dailyNRCS_SoilMoistureTemperatureRegimes){
cats <- c("Low", "ModeratelyLow", "Moderate", "ModeratelyHigh", "High")
Expand Down
36 changes: 21 additions & 15 deletions 2_SWSF_p3of5_ExternalDataExtractions_v51.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2987,13 +2987,13 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData

} else if (identical(parallel_backend, "multicore")) {
packages.export <- "raster"
sim_cells_SUIDs <- foreach(i=is_ToDo, .combine="rbind", .errorhandling="remove", .inorder=FALSE, .export=list.export, .packages=packages.export) %dopar%
sim_cells_SUIDs <- foreach(i=is_ToDo, .combine="rbind", .inorder=FALSE, .export=list.export, .packages=packages.export) %dopar%
extract_SUIDs(i, res = cell_res_wise, grid = grid_wise, sp_sites = run_sites_wise)
} else {
sim_cells_SUIDs <- NULL
}
} else {
sim_cells_SUIDs <- foreach(i=is_ToDo, .combine="rbind", .errorhandling="remove", .inorder=FALSE) %do%
sim_cells_SUIDs <- foreach(i=is_ToDo, .combine="rbind", .inorder=FALSE) %do%
extract_SUIDs(i, res = cell_res_wise, grid = grid_wise, sp_sites = run_sites_wise)
}
}
Expand All @@ -3004,11 +3004,11 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData
#- Calculate simulation cell wide weighted values based on each PRID weighted by SUID.fraction x PRIP.PROP
dat_wise <- read.csv(file=file.path(dir.ex.dat, "WISEsummaryFile.csv"))

get_prids <- compiler::cmpfun(function(suid) {
get_prids <- compiler::cmpfun(function(suid, dat_wise) {
soils <- dat_wise[dat_wise$SUID == suid, ]
frac <- unique(soils[, c("PROP", "PRID")])
depth <- tapply(soils$BotDep, soils$PRID, max)
idepth <- depth[match(frac$PRID, depth[, 1]), 2]
idepth <- depth[match(frac$PRID, names(depth))]

list(PRIDs_N = nrow(soils) / layer_N,
PRID = frac$PRID,
Expand All @@ -3026,7 +3026,7 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData
template_simulationSoils["soildepth"] <- 0

#cells with no soil values have SUID=c(0=Water, 6997=Water, 6694=Rock, or 6998=Glacier)
calc_weightedMeanForSimulationCell <- compiler::cmpfun(function(i, i_sim_cells_SUIDs, simulationSoils, layer_N, layer_Nsim, layer_TopDep) {
calc_weightedMeanForSimulationCell <- compiler::cmpfun(function(i, i_sim_cells_SUIDs, simulationSoils, layer_N, layer_Nsim, layer_TopDep, dat_wise) {
#Init
simulationSoils["i"] <- i
simulation_frac <- 0 #fraction of how much this simulation cell is covered with suids and prids that have a soildepth > 0 cm
Expand All @@ -3036,7 +3036,7 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData

#Do calculations if any soils in this simulation cell
if (i_sim_cells_SUIDs$SUIDs_N > 0) {
this_simCell <- c(i_sim_cells_SUIDs, soils = list(t(sapply(i_sim_cells_SUIDs$SUID, FUN = get_prids))))
this_simCell <- c(i_sim_cells_SUIDs, soils = list(t(sapply(i_sim_cells_SUIDs$SUID, FUN = get_prids, dat_wise = dat_wise))))

for (is in seq_len(this_simCell$SUIDs_N)) { #loop through the suids within this simulation cell; each suid may be composed of several prids
prids_frac <- this_simCell$soils[is,]$fraction * this_simCell$fraction[is] #vector of the fractions of each prid in relation to the simulation cell
Expand Down Expand Up @@ -3080,27 +3080,30 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData
})


try_weightedMeanForSimulationCell <- compiler::cmpfun(function(i, sim_cells_SUIDs, template_simulationSoils, layer_N, layer_Nsim, layer_TopDep) {
try_weightedMeanForSimulationCell <- compiler::cmpfun(function(i, sim_cells_SUIDs, template_simulationSoils, layer_N, layer_Nsim, layer_TopDep, dat_wise = dat_wise) {
if (i %% 1000 == 0) print(paste(Sys.time(), "done:", i))

temp <- calc_weightedMeanForSimulationCell(i,
temp <- try(calc_weightedMeanForSimulationCell(i,
i_sim_cells_SUIDs = sim_cells_SUIDs[i, ],
simulationSoils = template_simulationSoils,
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep)
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep,
dat_wise = dat_wise))
if (inherits(temp, "try-error")) template_simulationSoils else temp
})

if (parallel_runs && parallel_init) {
#objects that need exporting to slaves
list.export <- c("get_prids", "dat_wise", "layer_TopDep", "layer_N", "get_SoilDatValuesForLayer", "layer_Nsim", "calc_weightedMeanForSimulationCell", "try_weightedMeanForSimulationCell", "template_simulationSoils", "sim_cells_SUIDs")

#call the simulations depending on parallel backend
if (identical(parallel_backend, "mpi")) {
export_objects_to_workers(list.export, list(parent = parent.frame()), "mpi")

sim_cells_soils <- Rmpi::mpi.applyLB(x = is_ToDo, fun = try_weightedMeanForSimulationCell,
sim_cells_SUIDs = sim_cells_SUIDs,
template_simulationSoils = template_simulationSoils,
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep)
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep,
dat_wise = dat_wise)
sim_cells_soils <- do.call(rbind, sim_cells_soils)

Rmpi::mpi.bcast.cmd(rm(list=ls()))
Expand All @@ -3112,24 +3115,27 @@ if (exinfo$ExtractSoilDataFromCONUSSOILFromSTATSGO_USA || exinfo$ExtractSoilData
sim_cells_soils <- snow::clusterApplyLB(cl, x = is_ToDo, fun = try_weightedMeanForSimulationCell,
sim_cells_SUIDs = sim_cells_SUIDs,
template_simulationSoils = template_simulationSoils,
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep)
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep,
dat_wise = dat_wise)
sim_cells_soils <- do.call(rbind, sim_cells_soils)

snow::clusterEvalQ(cl, rm(list=ls()))
snow::clusterEvalQ(cl, gc())

} else if (identical(parallel_backend, "multicore")) {
sim_cells_soils <- foreach(i=is_ToDo, .combine="rbind", .errorhandling="remove", .inorder=FALSE, .export=list.export) %dopar%
sim_cells_soils <- foreach(i=is_ToDo, .combine="rbind", .inorder=FALSE, .export=list.export) %dopar%
try_weightedMeanForSimulationCell(i, sim_cells_SUIDs = sim_cells_SUIDs,
template_simulationSoils = template_simulationSoils,
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep)
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep,
dat_wise = dat_wise)
}

} else {
sim_cells_soils <- foreach(i=is_ToDo, .combine="rbind", .errorhandling="remove", .inorder=FALSE) %do%
sim_cells_soils <- foreach(i=is_ToDo, .combine="rbind", .inorder=FALSE) %do%
try_weightedMeanForSimulationCell(i, sim_cells_SUIDs = sim_cells_SUIDs,
template_simulationSoils = template_simulationSoils,
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep)
layer_N = layer_N, layer_Nsim = layer_Nsim, layer_TopDep = layer_TopDep,
dat_wise = dat_wise)
}
rm(dat_wise)

Expand Down
Loading

0 comments on commit f400f71

Please sign in to comment.