Skip to content

Commit

Permalink
Fixing bug in part 3 function 'get_prids'
Browse files Browse the repository at this point in the history 
- get_prids: change from ‘aggregate’ to ‘tapply’  in commit
f7c8c6c resulted in a different output
object: subsequent changes were not implemented: fixed
- functions ‘get_prids’, ‘calc_weightedMeanForSimulationCell’, and
‘try_weightedMeanForSimulationCell’ gained new argument ‘dat_wise’ to
pass ISRIC-WISE soil information to ‘get_prids’ without relying on it
as a global variable
 - function ‘try_weightedMeanForSimulationCell’ wraps the call to
‘calc_weightedMeanForSimulationCell’ in a try() — the rest of the
function code already assumed that his was the case
  • Loading branch information
dschlaep committed Sep 20, 2016
1 parent 780d709 commit 52d3ab4
Showing 1 changed file with 21 additions and 15 deletions.
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

0 comments on commit 52d3ab4

Please sign in to comment.