Fixes to multiscale flowtable, should work now

Author: wburke24

R/CreateFlownet.R

@@ -119,6 +119,7 @@ CreateFlownet = function(flownet_name,
   # read aspatial rules if needed
   if (!is.null(asprules)) {
     asp_map = template_clean[[which(var_names == "asp_rule")]][3] # get rule map/value
+    patch_map = map_df[[cfmaps[cfmaps[,1] == "patch",2]]] # set for use later - overwrite if using mode
 
     if (suppressWarnings(is.na(as.numeric(asp_map)))) { # if it's a map
       asp_map = gsub(".tif|.tiff","",asp_map)
@@ -157,7 +158,10 @@ CreateFlownet = function(flownet_name,
         asp_maps = aggregate(map_df[[cfmaps[cfmaps[,1] == "asp_rule",2]]], by = map_df[level_names], FUN = mode_fun, simplify = T)
         names(asp_maps)[which(names(asp_maps) == "x")] = "asprule"
 
-        rules_out = check_rules(patches = asp_maps$pch_30m1000, asp_rules = asp_maps$asprule)
+        patch_map = asp_maps[[cfmaps[cfmaps[,1] == "patch",2]]]
+
+        rules_out = check_rules(patches = patch_map, asp_rules = asp_maps$asprule)
+
         if (!is.null(rules_out)) {
           print(rules_out)
           stop("Mode of rules was attempted but there are still patches with multiple rules. Check input maps.")
@@ -191,7 +195,6 @@ CreateFlownet = function(flownet_name,
 
   # ------------------------------ Multiscale routing/aspatial patches ------------------------------
   if (!is.null(asprules)) {
-    patch_map = map_df[[cfmaps[cfmaps[,1] == "patch",2]]]
     CF1 = multiscale_flow(CF1 = CF1, asp_map = asp_mapdata, patch_map = patch_map, asp_list = asp_list)
   }
 

R/RHESSysPreprocess.R

@@ -142,7 +142,6 @@ RHESSysPreprocess = function(template,
   }
 
   CreateFlownet(flownet_name = flownet_name,
-                #readin = readin,
                 template = template,
                 type = type,
                 typepars = typepars,

R/multiscale_flow.R

@@ -9,15 +9,16 @@
 
 multiscale_flow = function(CF1, asp_map, patch_map, asp_list) {
 
-  #nbr 121
-  #nbr patch 11955
-  # no times nbr asp ct is empty
+  #nbr 329
+  #nbr patch 329
+  # nbr_asp_ct is empty
   #which(lapply(CF1,"[[", 9) == 15660)
 
   # functions for applys
   apply_patches = function(CFp) {
+    print(asp_list)
     id = paste0("rule_", unique(asp_map[which(raw_patch_data == CFp$PatchID)]))
-    asp_count = ncol(rulevars[[id]]$patch_level_vars[1, ]) - 1 # get number of aspatial patches for current patch
+    asp_count = ncol(asp_list[[id]]$patch_level_vars[1, ]) - 1 # get number of aspatial patches for current patch
     asp = c(1:asp_count)
     CFasp = lapply(asp, add_asp,CFp, id)
     unlist(CFasp,recursive = F)
@@ -28,7 +29,7 @@ multiscale_flow = function(CF1, asp_map, patch_map, asp_list) {
     CFasp$PatchID = CFp$PatchID * 100 + asp # aspatial patch ID is old patch ID *100 + aspatial number
     CFasp$Number = CFp$Number * 100 + asp # same modification to number
     CFasp$PatchFamilyID = CFp$PatchID # retain old patch ID as patch family ID
-    CFasp$Area = CFp$Area * as.numeric(rulevars[[id]]$patch_level_vars[rulevars[[id]]$patch_level_vars[, 1] == "pct_family_area", asp + 1]) # change area
+    CFasp$Area = CFp$Area * as.numeric(asp_list[[id]]$patch_level_vars[asp_list[[id]]$patch_level_vars[, 1] == "pct_family_area", asp + 1]) # change area
     # this output is an actual mess but whatever
     nbr_out = mapply(add_nbrs, nbr = CFp$Neighbors, gamma = CFp$Gamma_i, slope = CFp$Slopes, border = CFp$Border_perimeter, SIMPLIFY = F)
     CFasp$Neighbors = unlist(lapply(nbr_out, "[[", "new_nbrs"))
@@ -41,12 +42,12 @@ multiscale_flow = function(CF1, asp_map, patch_map, asp_list) {
   add_nbrs = function(nbr, gamma, slope, border) {
     nbr_patch = patch_ID[numbers == nbr] # patch ID from number
     nbr_id = paste0("rule_", unique(asp_map[which(raw_patch_data == nbr_patch)])) # get rule ID
-    nbr_asp_ct = ncol(rulevars[[nbr_id]]$patch_level_vars[1, ]) - 1
+    nbr_asp_ct = ncol(asp_list[[nbr_id]]$patch_level_vars[1, ]) - 1
     new_slopes = rep(slope, nbr_asp_ct)
     new_borders = rep(border, nbr_asp_ct)
     new_nbrs = nbr * 100 + c(1:nbr_asp_ct)
     # original gamma is multiplied by respective areas of the new patches - should sum to original
-    new_gammas = gamma * as.numeric(rulevars[[nbr_id]]$patch_level_vars[rulevars[[nbr_id]]$patch_level_vars[, 1] == "pct_family_area", 1 + c(1:nbr_asp_ct)])
+    new_gammas = gamma * as.numeric(asp_list[[nbr_id]]$patch_level_vars[asp_list[[nbr_id]]$patch_level_vars[, 1] == "pct_family_area", 1 + c(1:nbr_asp_ct)])
     return(list("new_nbrs" = new_nbrs, "new_gammas" = new_gammas, "new_slopes" = new_slopes, "new_borders" = new_borders))
   }
 
@@ -56,7 +57,7 @@ multiscale_flow = function(CF1, asp_map, patch_map, asp_list) {
   patch_ID = unlist(lapply(CF1, "[[", 9)) # patch IDs from cf1
   numbers = unlist(lapply(CF1, "[[", 1)) # flow list numbers
   raw_patch_data = patch_map
-  rulevars = asp_list # get rules - state variable overrides
+  #rulevars = asp_list # get rules - state variable overrides
   CF2 = list() # empty list for new flow list
 
   loop_ver = F