forecast for [2025-02-12], r4.4.2, epiproc 0.10.5

Author: dsweber2

R/aux_data_utils.R

@@ -194,7 +194,7 @@ daily_to_weekly_archive <- function(epi_arch,
                                     day_of_week = 4L,
                                     day_of_week_end = 7L) {
   agg_method <- arg_match(agg_method)
-  keys <- key_colnames(epi_arch, exclude = "time_value")
+  keys <- key_colnames(epi_arch, exclude = c("time_value", "version"))
   ref_time_values <- epi_arch$DT$version %>%
     unique() %>%
     sort()

R/utils.R

@@ -156,7 +156,6 @@ get_exclusions <- function(
 
 data_substitutions <- function(dataset, disease, forecast_generation_date) {
   disease <- "flu"
-  forecast_generation_date <- as.Date("2025-01-08")
   substitutions <- readr::read_csv(
     glue::glue("{disease}_data_substitutions.csv"),
     comment = "#",

flu_data_substitutions.csv

@@ -1,3 +1,10 @@
 geo_value, forecast_date, time_value, value
 sd, 2025-01-08, 2025-01-01, 33
 id, 2025-01-08, 2025-01-01, 323
+az, 2025-02-12, 2025-02-05, 850
+de, 2025-02-12, 2025-02-05, 130
+id, 2025-02-12, 2025-02-05, 150
+nm, 2025-02-12, 2025-02-05, 200
+ca, 2025-02-12, 2025-02-05, 3893
+ms, 2025-02-12, 2025-02-05, 420
+ok, 2025-02-12, 2025-02-05, 850

renv.lock

@@ -2,7 +2,7 @@
 local({
 
   # the requested version of renv
-  version <- "1.0.11"
+  version <- "1.1.1"
   attr(version, "sha") <- NULL
 
   # the project directory
@@ -42,7 +42,7 @@ local({
       return(FALSE)
 
     # next, check environment variables
-    # TODO: prefer using the configuration one in the future
+    # prefer using the configuration one in the future
     envvars <- c(
       "RENV_CONFIG_AUTOLOADER_ENABLED",
       "RENV_AUTOLOADER_ENABLED",
@@ -135,12 +135,12 @@ local({
 
     # R help links
     pattern <- "`\\?(renv::(?:[^`])+)`"
-    replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`"
+    replacement <- "`\033]8;;x-r-help:\\1\a?\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
 
     # runnable code
     pattern <- "`(renv::(?:[^`])+)`"
-    replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`"
+    replacement <- "`\033]8;;x-r-run:\\1\a\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
 
     # return ansified text
@@ -209,10 +209,6 @@ local({
 
   }
 
-  startswith <- function(string, prefix) {
-    substring(string, 1, nchar(prefix)) == prefix
-  }
-  
   bootstrap <- function(version, library) {
 
     friendly <- renv_bootstrap_version_friendly(version)
@@ -563,6 +559,9 @@ local({
 
     # prepare download options
     token <- renv_bootstrap_github_token()
+    if (is.null(token))
+      token <- ""
+  
     if (nzchar(Sys.which("curl")) && nzchar(token)) {
       fmt <- "--location --fail --header \"Authorization: token %s\""
       extra <- sprintf(fmt, token)
@@ -951,8 +950,14 @@ local({
   }
 
   renv_bootstrap_validate_version_dev <- function(version, description) {
+    
     expected <- description[["RemoteSha"]]
-    is.character(expected) && startswith(expected, version)
+    if (!is.character(expected))
+      return(FALSE)
+    
+    pattern <- sprintf("^\\Q%s\\E", version)
+    grepl(pattern, expected, perl = TRUE)
+    
   }
 
   renv_bootstrap_validate_version_release <- function(version, description) {
@@ -1132,10 +1137,10 @@ local({
 
   renv_bootstrap_exec <- function(project, libpath, version) {
     if (!renv_bootstrap_load(project, libpath, version))
-      renv_bootstrap_run(version, libpath)
+      renv_bootstrap_run(project, libpath, version)
   }
 
-  renv_bootstrap_run <- function(version, libpath) {
+  renv_bootstrap_run <- function(project, libpath, version) {
 
     # perform bootstrap
     bootstrap(version, libpath)
@@ -1146,7 +1151,7 @@ local({
 
     # try again to load
     if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
-      return(renv::load(project = getwd()))
+      return(renv::load(project = project))
     }
 
     # failed to download or load renv; warn the user
@@ -1192,98 +1197,101 @@ local({
     jsonlite::fromJSON(txt = text, simplifyVector = FALSE)
   }
 
-  renv_json_read_default <- function(file = NULL, text = NULL) {
-  
-    # find strings in the JSON
-    text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
-    pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
-    locs <- gregexpr(pattern, text, perl = TRUE)[[1]]
-  
-    # if any are found, replace them with placeholders
-    replaced <- text
-    strings <- character()
-    replacements <- character()
-  
-    if (!identical(c(locs), -1L)) {
-  
-      # get the string values
-      starts <- locs
-      ends <- locs + attr(locs, "match.length") - 1L
-      strings <- substring(text, starts, ends)
-  
-      # only keep those requiring escaping
-      strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE)
-  
-      # compute replacements
-      replacements <- sprintf('"\032%i\032"', seq_along(strings))
-  
-      # replace the strings
-      mapply(function(string, replacement) {
-        replaced <<- sub(string, replacement, replaced, fixed = TRUE)
-      }, strings, replacements)
+  renv_json_read_patterns <- function() {
+    
+    list(
+      
+      # objects
+      list("{", "\t\n\tobject(\t\n\t"),
+      list("}", "\t\n\t)\t\n\t"),
+      
+      # arrays
+      list("[", "\t\n\tarray(\t\n\t"),
+      list("]", "\n\t\n)\n\t\n"),
+      
+      # maps
+      list(":", "\t\n\t=\t\n\t")
+      
+    )
+    
+  }
 
+  renv_json_read_envir <- function() {
+  
+    envir <- new.env(parent = emptyenv())
+    
+    envir[["+"]] <- `+`
+    envir[["-"]] <- `-`
+    
+    envir[["object"]] <- function(...) {
+      result <- list(...)
+      names(result) <- as.character(names(result))
+      result
     }
-  
-    # transform the JSON into something the R parser understands
-    transformed <- replaced
-    transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE)
-    transformed <- gsub("[[{]", "list(", transformed, perl = TRUE)
-    transformed <- gsub("[]}]", ")", transformed, perl = TRUE)
-    transformed <- gsub(":", "=", transformed, fixed = TRUE)
-    text <- paste(transformed, collapse = "\n")
-  
-    # parse it
-    json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]]
-  
-    # construct map between source strings, replaced strings
-    map <- as.character(parse(text = strings))
-    names(map) <- as.character(parse(text = replacements))
-  
-    # convert to list
-    map <- as.list(map)
-  
-    # remap strings in object
-    remapped <- renv_json_read_remap(json, map)
-  
-    # evaluate
-    eval(remapped, envir = baseenv())
-  
+    
+    envir[["array"]] <- list
+    
+    envir[["true"]]  <- TRUE
+    envir[["false"]] <- FALSE
+    envir[["null"]]  <- NULL
+    
+    envir
+    
   }
 
-  renv_json_read_remap <- function(json, map) {
-  
-    # fix names
-    if (!is.null(names(json))) {
-      lhs <- match(names(json), names(map), nomatch = 0L)
-      rhs <- match(names(map), names(json), nomatch = 0L)
-      names(json)[rhs] <- map[lhs]
+  renv_json_read_remap <- function(object, patterns) {
+    
+    # repair names if necessary
+    if (!is.null(names(object))) {
+      
+      nms <- names(object)
+      for (pattern in patterns)
+        nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE)
+      names(object) <- nms
+      
     }
-  
-    # fix values
-    if (is.character(json))
-      return(map[[json]] %||% json)
-  
-    # handle true, false, null
-    if (is.name(json)) {
-      text <- as.character(json)
-      if (text == "true")
-        return(TRUE)
-      else if (text == "false")
-        return(FALSE)
-      else if (text == "null")
-        return(NULL)
+    
+    # repair strings if necessary
+    if (is.character(object)) {
+      for (pattern in patterns)
+        object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE)
     }
+    
+    # recurse for other objects
+    if (is.recursive(object))
+      for (i in seq_along(object))
+        object[i] <- list(renv_json_read_remap(object[[i]], patterns))
+    
+    # return remapped object
+    object
+    
+  }
 
-    # recurse
-    if (is.recursive(json)) {
-      for (i in seq_along(json)) {
-        json[i] <- list(renv_json_read_remap(json[[i]], map))
-      }
-    }
+  renv_json_read_default <- function(file = NULL, text = NULL) {
 
-    json
+    # read json text
+    text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
+    
+    # convert into something the R parser will understand
+    patterns <- renv_json_read_patterns()
+    transformed <- text
+    for (pattern in patterns)
+      transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE)
+    
+    # parse it
+    rfile <- tempfile("renv-json-", fileext = ".R")
+    on.exit(unlink(rfile), add = TRUE)
+    writeLines(transformed, con = rfile)
+    json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]]
 
+    # evaluate in safe environment
+    result <- eval(json, envir = renv_json_read_envir())
+  
+    # fix up strings if necessary
+    renv_json_read_remap(result, patterns)
+    
   }
+  
 
   # load the renv profile, if any
   renv_bootstrap_profile_load(project)

renv/activate.R

@@ -150,7 +150,7 @@ rlang::list2(
         } else {
           train_data <-
             nhsn_latest_data %>%
-            data_substitutions(disease = "covid") %>%
+            data_substitutions(disease = "covid", forecast_generation_date) %>%
             as_epi_df(as_of = as.Date(forecast_date_int)) %>%
             mutate(time_value = time_value - 3)
         }
@@ -195,7 +195,7 @@ rlang::list2(
           filter(geo_value %nin% geo_exclusions) %>%
           ungroup() %>%
           bind_rows(forecast_res %>%
-            filter(forecaster %in% c("windowed_seasonal", "windowed_seasonal_extra_sources")) %>%
+            filter(forecaster %in% c("windowed_seasonal_extra_sources")) %>%
             filter(forecast_date < target_end_date)) %>% # don't use for neg aheads
           group_by(geo_value, forecast_date, target_end_date, quantile) %>%
           summarize(value = mean(value, na.rm = TRUE), .groups = "drop") %>%

scripts/covid_hosp_prod.R

@@ -146,7 +146,7 @@ rlang::list2(
         ) %>%
         filter(version == max(version)) %>%
         select(-version) %>%
-        data_substitutions(disease = "flu") %>%
+        data_substitutions(disease = "flu", forecast_generation_date) %>%
         as_epi_df(other_keys = "source", as_of = Sys.Date())
       most_recent_result
     },
@@ -397,7 +397,6 @@ rlang::list2(
     tar_target(
       name = truth_data,
       command = {
-        browser()
         date <- forecast_generation_date_int
         nssp_state <-
           current_nssp_archive %>%

scripts/flu_hosp_prod.R

@@ -338,7 +338,7 @@ make_historical_flu_data_targets <- function() {
           add_season_info() %>%
           mutate(agg_level = ifelse(grepl("[0-9]{2}", geo_value), "hhs_region", ifelse("us" == geo_value, "nation", "state"))) %>%
           add_pop_and_density() %>%
-          mutate(hhs = hhs / population * 10L^5) %>%
+          mutate(hhs = hhs_7dsum / population * 10L^5) %>%
           mutate(source = "nhsn") %>%
           mutate(agg_level = ifelse(geo_value == "us", "nation", "state")) %>%
           as_epi_archive(other_keys = "source", compactify = TRUE) %>%