Skip to content

Commit d903107

Browse files
wburke24wburke24
committed
minor bug fixes to world gen
1 parent f708368 commit d903107

2 files changed

Lines changed: 139 additions & 37 deletions

File tree

‎R/utils.R‎

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
# utils
2+
3+
# this is probably a bad idea
4+
init_defaults = function() {
5+
missing = formals(RHESSysPreprocess)[!formalArgs(RHESSysPreprocess) %in% ls(.GlobalEnv)]
6+
for (i in seq_along(missing)) {
7+
assign(x = names(missing[i]), value = unname(unlist(missing[i])))
8+
}
9+
10+
}
11+
12+
13+
# run this is preprocess isn't working to check out if anything stands out with the maps
14+
# i'll try to add checks to this as needed.
15+
debug_spatial = function(template, typepars, streams) {
16+
17+
template = template_read(template = template)
18+
maps = as.data.frame(unique(template[[5]]))
19+
maps = rbind(maps, c("streams", streams))
20+
21+
map_paths = file.path(typepars, maps$Map)
22+
23+
maps$Exists = sapply(map_paths, file.exists)
24+
25+
library(raster)
26+
# going to assume this might not work, tho this is how they are read normally
27+
#map_stack = raster::stack(x = map_paths)
28+
map_data = list()
29+
for (i in seq_along(map_paths)) {
30+
map_data[[i]] = raster(map_paths[i])
31+
32+
maps$extent = paste(map_data[[i]]@extent[1:4])
33+
maps$cellsize = res(map_data[[i]])
34+
35+
maps$ncell = ncell(map_data[[i]])
36+
maps$NAs = sum(is.na(values(map_data[[i]])))
37+
maps$NULLs = sum(is.null(map_data[[i]]))
38+
maps$proj = paste(crs(map_data[[i]]@crs))
39+
40+
41+
}
42+
43+
prob = map_stack[values(map_stack$pch_30m1000.1) == 15660]
44+
45+
46+
47+
48+
49+
}

‎R/world_gen.R‎

Lines changed: 90 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,13 @@ world_gen = function(template,
8989
z_map = map_info[map_info[, 1] == "zone", 2]
9090
p_map = map_info[map_info[, 1] == "patch", 2]
9191
s_map = map_info[map_info[, 1] == "strata", 2]
92-
levels = unname(data.matrix(map_df[c(w_map,b_map,h_map,z_map,p_map,s_map)], length(map_df[p_map]) ))
92+
#levels = unname(data.matrix(map_df[c(w_map,b_map,h_map,z_map,p_map,s_map)], length(map_df[p_map])))
93+
# if we run into memory issues, re factor this code
94+
95+
levels = data.matrix(map_df[c(w_map,b_map,h_map,z_map,p_map,s_map)], length(map_df[p_map]))
96+
levels = as.data.frame(levels)
97+
colnames(levels) = c("w", "b", "h", "z", "p", "s")
98+
9399

94100
# -------------------- Aspatial Patch Processing --------------------
95101
rulevars = NULL
@@ -103,9 +109,9 @@ world_gen = function(template,
103109
rulevars = aspatial_patches(asprules = asprules, asp_mapdata = asp_mapdata)
104110

105111
if (is.data.frame(asp_mapdata)) { # add ruleID to levels matrix
106-
levels = cbind(levels,unname(as.matrix(asp_mapdata)))
112+
levels = cbind(levels, a = unname(as.matrix(asp_mapdata)))
107113
} else if (is.numeric(asp_mapdata)) {
108-
levels = cbind(levels, rep(asp_mapdata,length(levels[,1])) )
114+
levels = cbind(levels, a = rep(asp_mapdata,length(levels[,1])) )
109115
}
110116
level_index = c(level_index, length(template_clean)+2) # because rules got added to the levels matrix, this is to prevent them from being aggregated across
111117
}
@@ -236,6 +242,41 @@ world_gen = function(template,
236242

237243
# -------------------- Write World File --------------------
238244

245+
# functions for replacing lapplys
246+
# basin
247+
bfun = function(i) {
248+
if (length(statevars[[i]][[1]]) > 1) {
249+
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b ,"x"]
250+
} else {var = statevars[[i]][[1]]}
251+
varname = template_clean[[i]][1]
252+
return(paste("\t",format(var),"\t\t\t",varname,"\n",sep = ""))
253+
}
254+
#hillslope
255+
hfun = function(i) {
256+
if (length(statevars[[i]][[1]]) > 1) {
257+
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h ,"x"]
258+
} else {var = statevars[[i]][[1]]}
259+
varname = template_clean[[i]][1]
260+
return(paste("\t\t",format(var),"\t\t\t",varname,"\n",sep = ""))
261+
}
262+
#zone
263+
zfun = function(i) {
264+
if (length(statevars[[i]][[1]]) > 1) {
265+
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h & statevars[[i]][[1]][4] == z ,"x"]
266+
} else {var = statevars[[i]][[1]]}
267+
varname = template_clean[[i]][1]
268+
return(paste("\t\t\t",format(var),"\t\t\t",varname,"\n",sep = ""))
269+
}
270+
#patch
271+
pfun = function(i) {
272+
273+
}
274+
#stratum
275+
sfun = function(i) {
276+
277+
}
278+
279+
239280
print("Writing worldfile",quote = FALSE)
240281
stratum = 1:template_clean[[level_index[6]]][3] # count of stratum
241282

@@ -250,80 +291,90 @@ world_gen = function(template,
250291

251292
# ----- World -----
252293
# No state variables at world level
253-
world = unique(levels[,1])
294+
world = unique(levels$w)
254295
writeChar(paste(world,"\t\t\t","world_ID\n",sep = ""),con = wcon, eos = NULL)
255-
writeChar(paste(length(unique(levels[,2])),"\t\t\t","num_basins\n",sep = ""),con = wcon,eos = NULL)
256-
basin = unique(levels[,2])
296+
writeChar(paste(length(unique(levels$b)),"\t\t\t","num_basins\n",sep = ""),con = wcon,eos = NULL)
297+
basin = unique(levels$b)
257298

258299
# ----- Basin -----
259300
for (b in basin) {
260301
writeChar(paste("\t",b,"\t\t\t","basin_ID\n",sep = ""),con = wcon,eos = NULL)
261302

262-
for (i in (level_index[2] + 1):(level_index[3] - 1)) {
263-
if (length(statevars[[i]][[1]]) > 1) {
264-
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b ,"x"]
265-
} else {var = statevars[[i]][[1]]}
266-
varname = template_clean[[i]][1]
267-
writeChar(paste("\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
268-
}
269-
hillslopes = unique(levels[levels[,2] == b, 3])
303+
# for (i in (level_index[2] + 1):(level_index[3] - 1)) {
304+
# if (length(statevars[[i]][[1]]) > 1) {
305+
# var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b ,"x"]
306+
# } else {var = statevars[[i]][[1]]}
307+
# varname = template_clean[[i]][1]
308+
# writeChar(paste("\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
309+
# }
310+
bout = unlist(lapply((level_index[2] + 1):(level_index[3] - 1), FUN = bfun))
311+
writeChar(bout,con = wcon,eos = NULL)
312+
313+
hillslopes = unique(levels[levels$b == b, "h"])
270314
writeChar(paste("\t",length(hillslopes),"\t\t\t","num_hillslopes\n",sep = ""),con = wcon,eos = NULL)
271315

272316
# ----- Hillslope -----
273317
for (h in hillslopes) {
274-
275318
# Iterate progress bar
276319
progress = progress + 1
277320
setTxtProgressBar(pb,progress/length(unique(levels[,3])))
278321

279322
writeChar(paste("\t\t",h,"\t\t\t","hillslope_ID\n",sep = ""),con = wcon,eos = NULL)
280323

281-
for (i in (level_index[3] + 1):(level_index[4] - 1)) {
282-
if (length(statevars[[i]][[1]]) > 1) {
283-
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h ,"x"]
284-
} else {var = statevars[[i]][[1]]}
285-
varname = template_clean[[i]][1]
286-
writeChar(paste("\t\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
287-
}
288-
zones = unique(levels[levels[,3] == h & levels[,2] == b, 4])
324+
# for (i in (level_index[3] + 1):(level_index[4] - 1)) {
325+
# if (length(statevars[[i]][[1]]) > 1) {
326+
# var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h ,"x"]
327+
# } else {var = statevars[[i]][[1]]}
328+
# varname = template_clean[[i]][1]
329+
# writeChar(paste("\t\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
330+
# }
331+
hout = unlist(lapply((level_index[3] + 1):(level_index[4] - 1), FUN = hfun))
332+
writeChar(hout,con = wcon,eos = NULL)
333+
334+
zones = unique(levels[levels$h == h & levels$b == b, "z"])
289335
writeChar(paste("\t\t",length(zones),"\t\t\t","num_zones\n",sep = ""),con = wcon,eos = NULL)
290336

291337
# ----- Zone -----
292338
for (z in zones) {
293339
writeChar(paste("\t\t\t",z,"\t\t\t","zone_ID\n",sep = ""),con = wcon,eos = NULL)
294340

295-
for (i in (level_index[4] + 1):(level_index[5] - 1)) {
296-
if (length(statevars[[i]][[1]]) > 1) {
297-
var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h & statevars[[i]][[1]][4] == z ,"x"]
298-
} else {var = statevars[[i]][[1]]}
299-
varname = template_clean[[i]][1]
300-
writeChar(paste("\t\t\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
301-
}
341+
# for (i in (level_index[4] + 1):(level_index[5] - 1)) {
342+
# if (length(statevars[[i]][[1]]) > 1) {
343+
# var = statevars[[i]][[1]][statevars[[i]][[1]][2] == b & statevars[[i]][[1]][3] == h & statevars[[i]][[1]][4] == z ,"x"]
344+
# } else {var = statevars[[i]][[1]]}
345+
# varname = template_clean[[i]][1]
346+
# writeChar(paste("\t\t\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
347+
# }
348+
zout = unlist(lapply((level_index[4] + 1):(level_index[5] - 1), FUN = zfun))
349+
writeChar(zout,con = wcon,eos = NULL)
302350

303351
#---------- Start multiscale (aspatial) patches and stratum ----------
304352
if (asp_check) {
305-
patches = unique(levels[levels[,4] == z & levels[,3] == h & levels[,2] == b, 5])
353+
patches = unique(levels[levels$z == z & levels$h == h & levels$b == b, "p"])
306354
asp_ct = sapply(rulevars, FUN = function(x) ncol(x[[1]]) - 1)
307355
if (length(patches) == 1 & length(asp_ct) == 1){
308356
total_patches = length(patches) * asp_ct
309357
} else {
310-
total_patches = sum(asp_ct[unique(levels[levels[,4] == z & levels[,3] == h & levels[,2] == b,])[, 7]])
358+
total_patches = sum(asp_ct[unique(levels[levels$z == z & levels$h == h & levels$b == b,])[,"a"]])
311359
}
312360

313361
writeChar(paste("\t\t\t",total_patches,"\t\t\t","num_patches\n",sep = ""),con = wcon,eos = NULL)
314362

315363
# ----- Patches (spatial) -----
316364
for (p in patches) {
317-
ruleid = unique(levels[(levels[,5] == p & levels[,4] == z & levels[,3] == h & levels[,2] == b),7])
318-
ruleid = paste0("rule_",ruleid)
365+
ruleid = paste0("rule_", unique(levels[(levels$p == p & levels$z == z & levels$h == h & levels$b == b), "a"]))
366+
319367
if (length(ruleid) != 1) {stop("Multiple rule ids found for patch: ",p)}
320368
asp_index = 1:(length(rulevars[[(ruleid)]]$patch_level_vars[1,]) - 1)
321369

322370
# ----- Patches (non-spatial) -----
323371
for (asp in asp_index) {
324372
pnum = (p*100) + asp # adjust patch numbers here - adds two 0's, ie: patch 1 becomes patches 101, 102, etc.
325-
writeChar(paste("\t\t\t\t",pnum,"\t\t\t","patch_ID\n",sep = ""),con = wcon,eos = NULL)
326-
writeChar(paste("\t\t\t\t",p,"\t\t\t","family_ID\n",sep = ""),con = wcon,eos = NULL)
373+
374+
writeChar(c(paste("\t\t\t\t",pnum,"\t\t\t","patch_ID\n",sep = ""),
375+
paste("\t\t\t\t",p,"\t\t\t","family_ID\n",sep = "")),
376+
con = wcon,eos = NULL)
377+
#writeChar(paste("\t\t\t\t",p,"\t\t\t","family_ID\n",sep = ""),con = wcon,eos = NULL)
327378

328379
asp_p_vars = which(!rulevars[[ruleid]]$patch_level_vars[,1] %in% var_names[var_index]) # get vars from aspatial not included in template
329380

@@ -332,7 +383,9 @@ world_gen = function(template,
332383
#var = as.numeric(rulevars[[ruleid]]$patch_level_vars[i,asp + 1])
333384
var = rulevars[[ruleid]]$patch_level_vars[i,asp + 1]
334385
varname = rulevars[[ruleid]]$patch_level_vars[i,1]
335-
if (is.na(var)) {stop(paste(varname,"cannot be NA since a default isn't specified in the template, please set explicitly in your rules file."))}
386+
if (is.na(var)) {
387+
stop(paste(varname,"cannot be NA since a default isn't specified in the template, please set explicitly in your rules file."))
388+
}
336389
writeChar(paste("\t\t\t\t",format(var),"\t\t\t",varname,"\n",sep = ""),con = wcon,eos = NULL)
337390
}
338391

0 commit comments

Comments
 (0)