Fixed issue with formatting input scenarios for SV

- Step where temps, SLR were zero out was causing issues with scenario ID for SV
- Added step to keep scenario ID

FrEDI/R/run_fredi_sv.R

@@ -230,8 +230,11 @@ run_fredi_sv <- function(
 
 
   ###### ** Input Columns ######
-  ### Get list with expected name of columns used for unique ids
+  ### Get list with minimum, maximum years associated with inputs
+  ### Get lists with expected name of columns used for unique ids
   ### Get list with expected name of column containing values
+  minYrs0      <- inNames0 |> map(function(name0, df0=co_inputInfo){df0 |> filter(inputName==name0) |> pull(min_year) |> unique()})
+  maxYrs0      <- inNames0 |> map(function(name0, df0=co_inputInfo){df0 |> filter(inputName==name0) |> pull(max_year) |> unique()})
   valCols0     <- co_inputInfo |> pull(valueCol) |> as.list() |> set_names(inNames0)
   idCols0      <- list(valCols0=valCols0, df0=inputDefs[inNames0]) |> pmap(function(valCols0, df0){
     df0 |> names() |> get_matches(y=valCols0, matches=F)
@@ -242,7 +245,6 @@ run_fredi_sv <- function(
   ### Figure out which inputs are not null, and filter to that list
   ### inputsList Names
   inNames      <- inputsList |> names()
-  # inWhich      <- inNames    |> map(function(name0, list0=inputsList){(!(list0[[name0]] |> is.null())) |> which()}) |> unlist() |> unique()
   inWhich      <- inNames    |> map(function(name0, list0=inputsList){!(list0[[name0]] |> is.null())}) |> unlist() |> which()
   ### Filter to values that are not NULL
   inputsList   <- inputsList[inWhich]
@@ -288,33 +290,31 @@ run_fredi_sv <- function(
 
     ### Unlist one level and format names
     inputsList <- inputsList |> unlist(recursive=FALSE)
-    inNames    <- inputsList |> names() |> str_replace(pattern=inNames |> names() |> paste0("\\.") |> paste(collapse="|"), "")
-    inputsList <- inputsList |> set_names(inNames)
-    idCols0    <- inNames |> map(function(name0, list0=idCols0     ){list0[[name0]]}) |> set_names(inNames)
-    valCols0   <- inNames |> map(function(name0, list0=valCols0    ){list0[[name0]]}) |> set_names(inNames)
-    minYrs0    <- inNames |> map(function(name0, df0=df_inputInfo){df0 |> filter(inputName==name0) |> pull(min_year) |> unique()}) |> set_names(inNames)
-    maxYrs0    <- inNames |> map(function(name0, df0=df_inputInfo){df0 |> filter(inputName==name0) |> pull(max_year) |> unique()}) |> set_names(inNames)
+    inputsList <- inputsList |> (function(list0, names0=inNames){
+      lNames0 <- list0   |> names()
+      str0    <- names0  |> paste0("\\.") |> paste(collapse="|")
+      lNames1 <- lNames0 |> str_replace(pattern=str0, "")
+      list0   <- list0   |> set_names(lNames1)
+      return(list0)
+    })()
+    ### Update names
+    inNames    <- inputsList |> names()
 
     ### Check input data
     inputsList <- list(
       inputName = inNames,
       inputDf   = inputsList,
-      # idCol     = idCols0 [inNames],
-      # valCol    = valCols0[inNames],
-      # yearMin   = df_inputInfo |> pull(min_year),
-      # yearMax   = df_inputInfo |> pull(max_year),
-      idCol     = idCols0 ,
-      valCol    = valCols0,
-      yearMin   = minYrs0,
-      yearMax   = maxYrs0,
+      idCol     = idCols0 [inNames],
+      valCol    = valCols0[inNames],
+      yearMin   = minYrs0 [inNames],
+      yearMax   = maxYrs0 [inNames],
       module    = "sv" |> rep(inNames |> length())
     ) |>
       pmap(check_input_data) |>
       set_names(inNames)
 
     ### Check again for inputs
     ### Filter to values that are not NULL
-    # inWhich      <- inNames    |> map(function(name0, list0=inputsList){(!(list0[[name0]] |> is.null())) |> which()}) |> unlist() |> unique()
     inWhich      <- inNames    |> map(function(name0, list0=inputsList){!(list0[[name0]] |> is.null())}) |> unlist() |> which()
     inputsList   <- inputsList[inWhich]
     inNames      <- inputsList |> names()
@@ -357,7 +357,15 @@ run_fredi_sv <- function(
       idCols0   = idCols0 [inNames],
       valCols0  = valCols0[inNames]
     ) |> pmap(function(df0, name0, hasInput0, idCols0, valCols0){
-      df0 |> format_inputScenarios(
+      ### If scenario present, get unique scenario and drop column from data
+      # scenCol <- "scenario"
+      # doScen0 <- scenCol %in% (df0 |> names())
+      # if(doScen0) {
+      #   scen0 <- df0 |> pull(all_of(scenCol)) |> unique()
+      #   df0   <- df0 |> select(-any_of(scenCol))
+      # } ### End if(doScen0)
+      ### Format input scenario
+      df0     <- df0 |> format_inputScenarios(
         name0     = name0,
         hasInput0 = hasInput0,
         idCols0   = idCols0,
@@ -366,18 +374,23 @@ run_fredi_sv <- function(
         maxYear   = maxYear,
         info0     = co_inputInfo
       ) ### End format_inputScenarios
+      # ### If scenario present, add unique scenario to data
+      # if(doScen0) df0[[scenCol]] <- scen0
+      ### Return
+      return(df0)
     }) |> set_names(inNames)
 
     ### Iterate over types of names and row bind similar scenarios
     inNames      <- inputsList |> names() |> unique()
     inputsList   <- inNames |> map(function(name0, list0=inputsList){
       which0 <- (inputsList |> names()) %in% name0
       list0  <- list0[which0]
-      list0  <- list0 |> bind.rows()
+      list0  <- list0 |> bind_rows()
       return(list0)
     }) |> set_names(inNames)
   } ### End if(hasInputs)
-
+  ### Free memory
+  gc()
 
   inputsList   <- inNames0 |> (function(names0, list0=inputDefs, list1=inputsList){
     ### Filter to list
@@ -394,6 +407,8 @@ run_fredi_sv <- function(
     ### Return
     return(list0)
   })()
+  ### Free memory
+  gc()
   # inputsList |> names() |> print()
   ### Update names
   inNames      <- inputsList |> names()
@@ -561,10 +576,15 @@ run_fredi_sv <- function(
   listResults <- listResults |> mutate(sector = c_sector)
   listResults <- listResults |> relocate(all_of(move0))
 
-  ###### Return Object ######
-  msg1 |> paste0("Finished.") |> message()
   # if(.testing) {listResults <- list(results = listResults, county_pop = df_popProj)}
   # else         {listResults <- listResults}
+
+
+
+  ###### Return Object ######
+  ### Message, clear unused memory, return
+  msg1 |> paste0("Finished.") |> message()
+  gc()
   return(listResults)
 }
 

FrEDI/R/utils.R

@@ -177,7 +177,7 @@ interpolate_annual <- function(
   if (addRegion) {data <- data |> mutate(region = region0)}
   rm(addRegion)
 
-  ###### Interpolation Info ######
+  ###### Interpolation Rules ######
   ### - Return NA values outside of extremes
   ### - If only one value is provided use the same for left and right
   ### - Interpolation method
@@ -188,22 +188,19 @@ interpolate_annual <- function(
   if(repRule ){rule <- rule |> rep(2)}
   method    <- method |> is.null() |> ifelse("linear", method)
 
-  ###### Interpolate NA values ######
-  ### Filter to the region and then interpolate missing values
+  ### Column names
   cols0     <- c("x", "y")
   cols1     <- c("year") |> c(column0)
 
-  ### Get IDs
-  ### Subset data
+  ### Get group IDs and add to data
   groupCol0 <- defCols |> get_matches(y=c("year"), matches=F)
   group0    <- data |> select(any_of(groupCol0))
-  # group0   <- data[,"region" |> c(stateCols0, modelCols0)]
-  ### Get scenario IDs
   group0    <- group0 |> apply(1, function(x){x |> as.vector() |> paste(collapse ="_")}) |> unlist()
   data      <- data   |> mutate(group_id = group0)
   # groupCol0 |> print(); data |> glimpse()
   # data |> group_by_at(c(all_of(groupCol0), "year")) |> summarize(n=n(), .groups="drop") |> filter(n>1) |> glimpse()
 
+  ###### Iteration ######
   ### Iterate over groups
   groups0   <- data |> pull(group_id) |> unique()
   df_interp <- groups0 |> map(function(group_i){
@@ -221,8 +218,7 @@ interpolate_annual <- function(
     return(new_i)
   }) |> bind_rows()
 
-  ### Determine join
-  ### Drop yCol from data
+  ### Determine join and join data
   # data |> glimpse(); df_interp |> glimpse(); cols1 |> print()
   names0 <- data |> names() |> get_matches(y=cols1, matches=F)
   join0  <- names0 |> get_matches(y=df_interp |> names())
@@ -246,6 +242,7 @@ interpolate_annual <- function(
   data     <- data |> arrange_at(c(arrange0))
 
   ### Return
+  gc()
   return(data)
 } ### End function
 
@@ -326,25 +323,34 @@ format_inputScenarios <- function(
     ### Zero out values if temp or slr
     doZero0 <- name0 %in% c("temp", "slr")
     if(doZero0) {
+      ### Zero out rows at ref year
       # df0 |> glimpse(); df0 |> pull(year) |> range() |> print(); yrRef0 |> print()
-      df0 <- df0 |> filter(year > yrRef0)
-      df1 <- tibble(year=yrRef0) |> mutate(y = 0) |> rename_at(c("y"), ~valCol0)
-      df0 <- df0 |> rbind(df1)
+      # df1 <- tibble(year=yrRef0) |> mutate(y = 0) |> rename_at(c("y"), ~valCol0)
+      drop0  <- c("year") |> c(valCol0)
+      df1    <- df0 |> select(-any_of(drop0)) |> distinct()
+      df1    <- df1 |> mutate(x = yrRef0, y = 0)
+      df1    <- df1 |> rename_at(c("x", "y"), ~drop0)
+      rm(drop0)
+
+      ### Then, drop rows in yrRef0 and bind zero rows to values
+      # df0 |> glimpse(); df1 |> glimpse()
+      df0    <- df0 |> filter(year > yrRef0)
+      df0    <- df0 |> rbind(df1)
       rm(df1)
+
+      ### Order values
+      order0 <- df0 |> names() |> get_matches(y=valCol0, matches=F)
+      df0    <- df0 |> arrange_at(order0)
     } ### if(doZero0)
 
     ### Calculate values
     yrs0 <- yrRef0:maxYear |> unique()
     if("pop" %in% name0) {
-      # df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=2:2, byState=T) |> ungroup()
       df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=1, byState=T, byModel=F) |> ungroup()
     } else if("o3" %in% name0) {
-      # "got here" |> print()
-      # df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=2:2, byState=T) |> ungroup()
       df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=1, byState=T, byModel=T) |> ungroup()
     } else {
       df0  <- df0 |> mutate(region = "NationalTotal")
-      # df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=2:2) |> ungroup()
       df0  <- df0 |> interpolate_annual(years=yrs0, column=valCol0, rule=1) |> ungroup()
       df0  <- df0 |> select(-c("region"))
     } ### End if("pop" %in% name0)