Merge branch 'dev' into optAllOfFix

Author: nmdefries

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: epiprocess
 Title: Tools for basic signal processing in epidemiology
-Version: 0.8.0
+Version: 0.8.3
 Authors@R: c(
     person("Jacob", "Bien", role = "ctb"),
     person("Logan", "Brooks", email = "[email protected]", role = c("aut", "cre")),
@@ -29,9 +29,11 @@ Imports:
     checkmate,
     cli,
     data.table,
-    dplyr (>= 1.0.0),
+    dplyr (>= 1.0.8),
     genlasso,
+    glue,
     ggplot2,
+    glue,
     lifecycle (>= 1.0.1),
     lubridate,
     magrittr,
@@ -82,6 +84,7 @@ Collate:
     'methods-epi_df.R'
     'outliers.R'
     'reexports.R'
+    'revision_analysis.R'
     'slide.R'
     'utils.R'
     'utils_pipe.R'

NAMESPACE

@@ -11,6 +11,7 @@ S3method(as_tsibble,epi_df)
 S3method(autoplot,epi_df)
 S3method(clone,epi_archive)
 S3method(clone,grouped_epi_archive)
+S3method(complete,epi_df)
 S3method(dplyr_col_modify,col_modify_recorder_df)
 S3method(dplyr_col_modify,epi_df)
 S3method(dplyr_reconstruct,epi_df)
@@ -37,7 +38,6 @@ S3method(next_after,integer)
 S3method(print,epi_archive)
 S3method(print,epi_df)
 S3method(print,grouped_epi_archive)
-S3method(select,epi_df)
 S3method(summary,epi_df)
 S3method(ungroup,epi_df)
 S3method(ungroup,grouped_epi_archive)
@@ -50,6 +50,7 @@ export(as_epi_df)
 export(as_tsibble)
 export(autoplot)
 export(clone)
+export(complete)
 export(detect_outlr)
 export(detect_outlr_rm)
 export(detect_outlr_stl)
@@ -64,6 +65,7 @@ export(epix_merge)
 export(epix_slide)
 export(epix_truncate_versions_after)
 export(filter)
+export(full_seq)
 export(geo_column_names)
 export(group_by)
 export(group_modify)
@@ -79,6 +81,7 @@ export(new_epi_df)
 export(next_after)
 export(relocate)
 export(rename)
+export(revision_summary)
 export(slice)
 export(time_column_names)
 export(ungroup)
@@ -109,6 +112,7 @@ importFrom(checkmate,vname)
 importFrom(cli,cat_line)
 importFrom(cli,cli_abort)
 importFrom(cli,cli_inform)
+importFrom(cli,cli_li)
 importFrom(cli,cli_vec)
 importFrom(cli,cli_warn)
 importFrom(cli,format_message)
@@ -126,9 +130,11 @@ importFrom(data.table,set)
 importFrom(data.table,setDF)
 importFrom(data.table,setkeyv)
 importFrom(dplyr,"%>%")
+importFrom(dplyr,across)
 importFrom(dplyr,all_of)
 importFrom(dplyr,arrange)
 importFrom(dplyr,bind_rows)
+importFrom(dplyr,c_across)
 importFrom(dplyr,dplyr_col_modify)
 importFrom(dplyr,dplyr_reconstruct)
 importFrom(dplyr,dplyr_row_slice)
@@ -141,11 +147,17 @@ importFrom(dplyr,group_vars)
 importFrom(dplyr,groups)
 importFrom(dplyr,if_all)
 importFrom(dplyr,if_any)
+importFrom(dplyr,if_else)
+importFrom(dplyr,lag)
 importFrom(dplyr,mutate)
+importFrom(dplyr,near)
+importFrom(dplyr,pick)
+importFrom(dplyr,pull)
 importFrom(dplyr,relocate)
 importFrom(dplyr,rename)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)
+importFrom(dplyr,summarize)
 importFrom(dplyr,tibble)
 importFrom(dplyr,ungroup)
 importFrom(ggplot2,autoplot)
@@ -177,6 +189,7 @@ importFrom(rlang,is_formula)
 importFrom(rlang,is_function)
 importFrom(rlang,is_missing)
 importFrom(rlang,is_quosure)
+importFrom(rlang,list2)
 importFrom(rlang,missing_arg)
 importFrom(rlang,new_function)
 importFrom(rlang,quo_get_expr)
@@ -195,6 +208,8 @@ importFrom(stats,median)
 importFrom(tibble,as_tibble)
 importFrom(tibble,new_tibble)
 importFrom(tibble,validate_tibble)
+importFrom(tidyr,complete)
+importFrom(tidyr,full_seq)
 importFrom(tidyr,unnest)
 importFrom(tidyselect,any_of)
 importFrom(tidyselect,eval_select)

NEWS.md

@@ -4,6 +4,18 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.x.y will indicat
 
 # epiprocess 0.9
 
+## Improvements
+
+- Added `complete.epi_df`, which fills in missing values in an `epi_df` with
+  `NA`s. Uses `tidyr::complete` underneath and preserves `epi_df` metadata.
+- Inclusion of the function `revision_summary` to provide basic revision information for `epi_archive`s out of the box. (#492)
+
+## Bug fixes
+
+- Fix `epi_slide_opt` (and related functions) to correctly handle `before=Inf`.
+- Disallow `after=Inf` in slide functions, since it doesn't seem like a likely
+  use case and complicates code.
+
 # epiprocess 0.8
 
 ## Breaking changes

R/archive.R

@@ -240,6 +240,7 @@ NULL
 #'   value of `clobberable_versions_start` does not fully trust these empty
 #'   updates, and assumes that any version `>= max(x$version)` could be
 #'   clobbered.) If `nrow(x) == 0`, then this argument is mandatory.
+#' @param compactify_tol double. the tolerance used to detect approximate equality for compactification
 #' @return An `epi_archive` object.
 #'
 #' @importFrom data.table as.data.table key setkeyv
@@ -295,15 +296,16 @@ new_epi_archive <- function(
     additional_metadata,
     compactify,
     clobberable_versions_start,
-    versions_end) {
+    versions_end,
+    compactify_tol = .Machine$double.eps^0.5) {
   # Create the data table; if x was an un-keyed data.table itself,
   # then the call to as.data.table() will fail to set keys, so we
   # need to check this, then do it manually if needed
   key_vars <- c("geo_value", "time_value", other_keys, "version")
-  DT <- as.data.table(x, key = key_vars) # nolint: object_name_linter
-  if (!identical(key_vars, key(DT))) setkeyv(DT, cols = key_vars)
+  data_table <- as.data.table(x, key = key_vars) # nolint: object_name_linter
+  if (!identical(key_vars, key(data_table))) setkeyv(data_table, cols = key_vars)
 
-  if (anyDuplicated(DT, by = key(DT)) != 0L) {
+  if (anyDuplicated(data_table, by = key(data_table)) != 0L) {
     cli_abort("`x` must have one row per unique combination of the key variables. If you
             have additional key variables other than `geo_value`, `time_value`, and
             `version`, such as an age group column, please specify them in `other_keys`.
@@ -313,38 +315,17 @@ new_epi_archive <- function(
     )
   }
 
-  # Checks to see if a value in a vector is LOCF
-  is_locf <- function(vec) { # nolint: object_usage_linter
-    dplyr::if_else(!is.na(vec) & !is.na(dplyr::lag(vec)),
-      vec == dplyr::lag(vec),
-      is.na(vec) & is.na(dplyr::lag(vec))
-    )
-  }
-
-  # LOCF is defined by a row where all values except for the version
-  # differ from their respective lag values
-
-  # Checks for LOCF's in a data frame
-  rm_locf <- function(df) {
-    dplyr::filter(df, if_any(c(everything(), -version), ~ !is_locf(.))) # nolint: object_usage_linter
-  }
-
-  # Keeps LOCF values, such as to be printed
-  keep_locf <- function(df) {
-    dplyr::filter(df, if_all(c(everything(), -version), ~ is_locf(.))) # nolint: object_usage_linter
-  }
-
+  nrow_before_compactify <- nrow(data_table)
   # Runs compactify on data frame
   if (is.null(compactify) || compactify == TRUE) {
-    elim <- keep_locf(DT)
-    DT <- rm_locf(DT) # nolint: object_name_linter
+    compactified <- apply_compactify(data_table, key_vars, compactify_tol)
   } else {
-    # Create empty data frame for nrow(elim) to be 0
-    elim <- tibble::tibble()
+    compactified <- data_table
   }
-
-  # Warns about redundant rows
-  if (is.null(compactify) && nrow(elim) > 0) {
+  # Warns about redundant rows if the number of rows decreased, and we didn't
+  # explicitly say to compactify
+  if (is.null(compactify) && nrow(compactified) < nrow_before_compactify) {
+    elim <- removed_by_compactify(data_table, key_vars, compactify_tol)
     warning_intro <- cli::format_inline(
       "Found rows that appear redundant based on
             last (version of each) observation carried forward;
@@ -366,7 +347,7 @@ new_epi_archive <- function(
 
   structure(
     list(
-      DT = DT,
+      DT = compactified,
       geo_type = geo_type,
       time_type = time_type,
       additional_metadata = additional_metadata,
@@ -377,6 +358,63 @@ new_epi_archive <- function(
   )
 }
 
+#' given a tibble as would be found in an epi_archive, remove duplicate entries.
+#' @description
+#' works by shifting all rows except the version, then comparing values to see
+#'   if they've changed. We need to arrange in descending order, but note that
+#'   we don't need to group, since at least one column other than version has
+#'   changed, and so is kept.
+#' @keywords internal
+#' @importFrom dplyr filter
+apply_compactify <- function(df, keys, tolerance = .Machine$double.eps^.5) {
+  df %>%
+    arrange(!!!keys) %>%
+    filter(if_any(
+      c(everything(), -version), # all non-version columns
+      ~ !is_locf(., tolerance)
+    ))
+}
+
+#' get the entries that `compactify` would remove
+#' @keywords internal
+#' @importFrom dplyr filter if_all everything
+removed_by_compactify <- function(df, keys, tolerance) {
+  df %>%
+    arrange(!!!keys) %>%
+    filter(if_all(
+      c(everything(), -version),
+      ~ is_locf(., tolerance)
+    )) # nolint: object_usage_linter
+}
+
+#' Checks to see if a value in a vector is LOCF
+#' @description
+#' LOCF meaning last observation carried forward. lags the vector by 1, then
+#'   compares with itself. For doubles it uses float comparison via
+#'   [`dplyr::near`], otherwise it uses equality.  `NA`'s and `NaN`'s are
+#'   considered equal to themselves and each other.
+#' @importFrom dplyr lag if_else near
+#' @keywords internal
+is_locf <- function(vec, tolerance) { # nolint: object_usage_linter
+  lag_vec <- dplyr::lag(vec)
+  if (typeof(vec) == "double") {
+    res <- if_else(
+      !is.na(vec) & !is.na(lag_vec),
+      near(vec, lag_vec, tol = tolerance),
+      is.na(vec) & is.na(lag_vec)
+    )
+    return(res)
+  } else {
+    res <- if_else(
+      !is.na(vec) & !is.na(lag_vec),
+      vec == lag_vec,
+      is.na(vec) & is.na(lag_vec)
+    )
+    return(res)
+  }
+}
+
+
 #' `validate_epi_archive` ensures correctness of arguments fed to `as_epi_archive`.
 #'
 #' @rdname epi_archive

R/epi_df.R

@@ -81,10 +81,7 @@
 #'
 #' An unrecognizable time type is labeled "custom".
 #'
-#' @template epi_df-params
-#' @rdname epi_df
-#'
-#' @export
+#' @name epi_df
 #' @examples
 #' # Convert a `tsibble` that has county code as an extra key
 #' # Notice that county code should be a character string to preserve any leading zeroes
@@ -154,6 +151,30 @@
 #'   as_epi_df(additional_metadata = list(other_keys = c("state", "pol")))
 #'
 #' attr(ex3, "metadata")
+NULL
+
+#' Create an `epi_df` object
+#'
+#' @rdname epi_df
+#' @param geo_type DEPRECATED Has no effect. Geo value type is inferred from the
+#' location column and set to "custom" if not recognized.
+#' @param time_type DEPRECATED Has no effect. Time value type inferred from the time
+#' column and set to "custom" if not recognized. Unpredictable behavior may result
+#' if the time type is not recognized.
+#' @param as_of Time value representing the time at which the given data were
+#'   available. For example, if `as_of` is January 31, 2022, then the `epi_df`
+#'   object that is created would represent the most up-to-date version of the
+#'   data available as of January 31, 2022. If the `as_of` argument is missing,
+#'   then the current day-time will be used.
+#' @param additional_metadata List of additional metadata to attach to the
+#'   `epi_df` object. The metadata will have `geo_type`, `time_type`, and
+#'   `as_of` fields; named entries from the passed list will be included as
+#'   well. If your tibble has additional keys, be sure to specify them as a
+#'   character vector in the `other_keys` component of `additional_metadata`.
+#' @param ... Additional arguments passed to methods.
+#' @return An `epi_df` object.
+#'
+#' @export
 new_epi_df <- function(x = tibble::tibble(), geo_type, time_type, as_of,
                        additional_metadata = list()) {
   # Define metadata fields
@@ -180,20 +201,24 @@ new_epi_df <- function(x = tibble::tibble(), geo_type, time_type, as_of,
 }
 
 #' @rdname epi_df
+#' @param x An `epi_df`, `data.frame`, [tibble::tibble], or [tsibble::tsibble]
+#'   to be converted
+#' @param ... used for specifying column names, as in [`dplyr::rename`]. For
+#'   example, `geo_value = STATEFP, time_value = end_date`.
 #' @export
 as_epi_df <- function(x, ...) {
   UseMethod("as_epi_df")
 }
 
-#' @method as_epi_df epi_df
 #' @rdname epi_df
+#' @method as_epi_df epi_df
 #' @export
 as_epi_df.epi_df <- function(x, ...) {
   return(x)
 }
 
-#' @method as_epi_df tbl_df
 #' @rdname epi_df
+#' @method as_epi_df tbl_df
 #' @importFrom rlang .data
 #' @importFrom tidyselect any_of
 #' @importFrom cli cli_inform
@@ -217,7 +242,6 @@ as_epi_df.tbl_df <- function(
        must be present in `x`."
     )
   }
-
   if (lifecycle::is_present(geo_type)) {
     cli_warn("epi_archive constructor argument `geo_type` is now ignored. Consider removing.")
   }

R/group_by_epi_df_methods.R

@@ -3,11 +3,3 @@
 # `epi_df`s. It would be nice if there were a way to replace these with a
 # generic core that automatically fixed all misbehaving methods; see
 # brainstorming within Issue #223.
-
-#' @importFrom dplyr select
-#' @export
-select.epi_df <- function(.data, ...) {
-  selected <- NextMethod(.data)
-  might_decay <- reclass(selected, attr(selected, "metadata"))
-  return(dplyr_reconstruct(might_decay, might_decay))
-}