Implement iv_span()

NAMESPACE

@@ -89,6 +89,7 @@ export(iv_set_difference)
 export(iv_set_intersect)
 export(iv_set_symmetric_difference)
 export(iv_set_union)
+export(iv_span)
 export(iv_splits)
 export(iv_start)
 export(iv_symmetric_difference)

NEWS.md

@@ -30,6 +30,9 @@
 * New `iv_diff()` for generating an iv from an existing vector that is in
   strictly increasing order (#17).
 
+* New `iv_span()` for computing a summary interval that encompasses the entire
+  range of an existing iv (#49).
+
 * New Examples vignette that links out to Stack Overflow questions that were
   solved with ivs. View it locally with `vignette("examples", package = "ivs")`.
 

R/iv.R

@@ -337,7 +337,9 @@ vec_restore.ivs_iv <- function(x, to, ...) {
 #' You typically _do_ need an `iv_restore()` method for custom iv extensions.
 #' If your class is simple, then you can generally just call your constructor,
 #' like `new_my_iv()`, to restore the class and any additional attributes that
-#' might be required.
+#' might be required. If your class doesn't use [new_iv()], then an
+#' `iv_restore()` method is mandatory, as this is one of the ways that ivs
+#' detects that your class is compatible with ivs.
 #'
 #' This system allows you to use any `iv_*()` function on your iv extension
 #' object without having to define S3 methods for all of them.
@@ -438,6 +440,15 @@ iv_restore.ivs_iv <- function(x, to, ...) {
   x
 }
 
+
+is_iv_or_extension <- function(x) {
+  # If an `iv_restore()` method exists, then we assume that the object is
+  # an iv extension that has a proxy that returns an iv. This is useful when
+  # we aren't sure if the object is "iv-like" or not, like in the `missing`
+  # and `empty` arguments of `iv_span()`.
+  is_iv(x) || obj_s3_method_exists(x, "iv_restore")
+}
+
 # ------------------------------------------------------------------------------
 
 #' @export

R/ivs-package.R

@@ -8,3 +8,6 @@
 #' @importFrom glue glue_collapse
 ## usethis namespace: end
 NULL
+
+# Singletons
+the <- new_environment()

R/set.R

@@ -182,16 +182,13 @@ iv_set_intersect <- function(x, y) {
   check_iv(x_proxy, arg = "x")
   check_iv(y_proxy, arg = "y")
 
-  # TODO: `vec_min()` and `vec_max()`
-  # https://github.com/r-lib/vctrs/issues/86
-  lower <- min(
-    min(field_start(x_proxy)),
-    min(field_start(y_proxy))
-  )
-  upper <- max(
-    max(field_end(x_proxy)),
-    max(field_end(y_proxy))
-  )
+  x_span <- iv_span(x_proxy, missing = "error", empty = "error")
+  y_span <- iv_span(y_proxy, missing = "error", empty = "error")
+
+  span <- iv_span(vec_c(x_span, y_span), missing = "error", empty = "error")
+
+  lower <- field_start(span)
+  upper <- field_end(span)
 
   x_c <- iv_set_complement(x_proxy, lower = lower, upper = upper)
   y_c <- iv_set_complement(y_proxy, lower = lower, upper = upper)
@@ -245,16 +242,13 @@ iv_set_difference <- function(x, y) {
   check_iv(x_proxy, arg = "x")
   check_iv(y_proxy, arg = "y")
 
-  # TODO: `vec_min()` and `vec_max()`
-  # https://github.com/r-lib/vctrs/issues/86
-  lower <- min(
-    min(field_start(x_proxy)),
-    min(field_start(y_proxy))
-  )
-  upper <- max(
-    max(field_end(x_proxy)),
-    max(field_end(y_proxy))
-  )
+  x_span <- iv_span(x_proxy, missing = "error", empty = "error")
+  y_span <- iv_span(y_proxy, missing = "error", empty = "error")
+
+  span <- iv_span(vec_c(x_span, y_span), missing = "error", empty = "error")
+
+  lower <- field_start(span)
+  upper <- field_end(span)
 
   x_c <- iv_set_complement(x_proxy, lower = lower, upper = upper)
 
@@ -307,16 +301,13 @@ iv_set_symmetric_difference <- function(x, y) {
   check_iv(x_proxy, arg = "x")
   check_iv(y_proxy, arg = "y")
 
-  # TODO: `vec_min()` and `vec_max()`
-  # https://github.com/r-lib/vctrs/issues/86
-  lower <- min(
-    min(field_start(x_proxy)),
-    min(field_start(y_proxy))
-  )
-  upper <- max(
-    max(field_end(x_proxy)),
-    max(field_end(y_proxy))
-  )
+  x_span <- iv_span(x_proxy, missing = "error", empty = "error")
+  y_span <- iv_span(y_proxy, missing = "error", empty = "error")
+
+  span <- iv_span(vec_c(x_span, y_span), missing = "error", empty = "error")
+
+  lower <- field_start(span)
+  upper <- field_end(span)
 
   x_c <- iv_set_complement(x_proxy, lower = lower, upper = upper)
   x_c_union_y <- iv_set_union(x_c, y_proxy)

R/span.R

@@ -1,3 +1,220 @@
+#' Span
+#'
+#' @description
+#' `iv_span()` computes the span of an iv. The span is a single interval which
+#' encompasses the entire range of the iv. It is similar to [iv_groups()], if
+#' groups were also merged across gaps.
+#'
+#' `iv_span()` is a _summary_ function, like [min()] and [max()], so it always
+#' returns a size 1 iv, even for empty ivs. The `empty` argument can be used to
+#' control what is returned in the empty case.
+#'
+#' @details
+#' `iv_span()` is currently limited by the fact that it calls [min()] and
+#' [max()] internally, which doesn't work for all vector types that ivs
+#' supports (mainly data frames). In the future, we hope to be able to leverage
+#' `vctrs::vec_min()` and `vctrs::vec_max()`, which don't exist yet.
+#'
+#' @inheritParams rlang::args_dots_empty
+#' @inheritParams iv_groups
+#'
+#' @param missing `["propagate" / "drop" / "error" / iv(1)]`
+#'
+#'   Handling of missing intervals in `x`.
+#'
+#'   - `"propagate"` forces `iv_span()` to return a missing interval if any
+#'     missing intervals are detected in `x`.
+#'
+#'   - `"drop"` drops missing intervals before computing the span. If this
+#'     results in an empty vector, then `empty` will be applied.
+#'
+#'   - `"error"` throws an error if any missing intervals are detected.
+#'
+#'   - If an iv of size 1 is supplied, then this is returned if any missing
+#'     intervals are detected. It is cast to the type of `x` before returning.
+#'
+#' @param empty `["missing" / "error" / iv(1)]`
+#'
+#'   Handling of empty `x` vectors.
+#'
+#'   - `"missing"` forces `iv_span()` to return a missing interval if `x` is
+#'     empty.
+#'
+#'   - `"error"` throws an error if `x` is empty.
+#'
+#'   - If an iv of size 1 is supplied, then this is returned if `x` is empty. It
+#'     is cast to the type of `x` before returning.
+#'
+#' @export
+#' @examples
+#' x <- iv_pairs(c(1, 5), c(2, 6), c(9, 10))
+#'
+#' # The span covers the full range of values seen in `x`
+#' iv_span(x)
+#'
+#' # Compare against `iv_groups()`, which merges overlaps but doesn't merge
+#' # across gaps
+#' iv_groups(x)
+#'
+#' x <- iv_pairs(c(1, 3), c(NA, NA), c(5, 6), c(NA, NA))
+#'
+#' # Because `iv_span()` is a summary function, if any missing intervals are
+#' # present then it returns a missing interval by default
+#' iv_span(x)
+#'
+#' # Further control this with `missing`
+#' iv_span(x, missing = "drop")
+#' try(iv_span(x, missing = "error"))
+#' iv_span(x, missing = iv(-1, 0))
+#'
+#' x <- iv(double(), double())
+#'
+#' # If `x` is empty, then by default a missing interval is returned
+#' iv_span(x)
+#'
+#' # Control this with `empty`
+#' try(iv_span(x, empty = "error"))
+#' iv_span(x, empty = iv(-Inf, Inf))
+#'
+#' # `empty` kicks in if `missing = "drop"` is used and all elements were
+#' # missing
+#' x <- iv(c(NA, NA), c(NA, NA), ptype = double())
+#' iv_span(x, missing = "drop", empty = iv(-Inf, Inf))
+iv_span <- function(x, ..., missing = "propagate", empty = "missing") {
+  check_dots_empty0(...)
+
+  proxy <- iv_proxy(x)
+  check_iv(proxy, arg = "x")
+
+  missing <- check_span_missing(missing, x)
+  empty <- check_span_empty(empty, x)
+
+  start <- field_start(proxy)
+  end <- field_end(proxy)
+
+  if (vec_any_missing(start)) {
+    switch(
+      missing$string,
+      drop = {
+        not_missing <- !vec_detect_missing(start)
+        not_missing <- which(not_missing)
+        start <- vec_slice(start, not_missing)
+        end <- vec_slice(end, not_missing)
+      },
+      propagate = {
+        return(vec_init(x))
+      },
+      value = {
+        return(missing$value)
+      },
+      error = {
+        abort("`x` can't contain missing values.")
+      }
+    )
+  }
+
+  if (vec_is_empty(start)) {
+    switch(
+      empty$string,
+      missing = {
+        return(vec_init(x))
+      },
+      value = {
+        return(empty$value)
+      },
+      error = {
+        abort("`x` can't be empty.")
+      }
+    )
+  }
+
+  # TODO: `vec_min()` and `vec_max()`
+  # https://github.com/r-lib/vctrs/issues/86
+  start <- min(start)
+  end <- max(end)
+
+  out <- new_bare_iv(start, end)
+  out <- iv_restore(out, x)
+
+  out
+}
+
+check_span_missing <- function(missing, x, ..., error_call = caller_env()) {
+  if (is_string(missing)) {
+    missing <- arg_match0(
+      arg = missing,
+      values = c("propagate", "drop", "error"),
+      error_call = error_call
+    )
+
+    out <- list(
+      string = missing,
+      value = NULL
+    )
+
+    return(out)
+  }
+
+  if (is_iv_or_extension(missing)) {
+    vec_check_size(missing, size = 1L, call = error_call)
+
+    missing <- vec_cast(
+      x = missing,
+      to = x,
+      x_arg = "missing",
+      to_arg = "x",
+      call = error_call
+    )
+
+    out <- list(
+      string = "value",
+      value = missing
+    )
+
+    return(out)
+  }
+
+  stop_input_type(missing, what = "a string or an iv", call = error_call)
+}
+
+check_span_empty <- function(empty, x, ..., error_call = caller_env()) {
+  if (is_string(empty)) {
+    empty <- arg_match0(
+      arg = empty,
+      values = c("missing", "error"),
+      error_call = error_call
+    )
+
+    out <- list(
+      string = empty,
+      value = NULL
+    )
+
+    return(out)
+  }
+
+  if (is_iv_or_extension(empty)) {
+    vec_check_size(empty, size = 1L, call = error_call)
+
+    empty <- vec_cast(
+      x = empty,
+      to = x,
+      x_arg = "empty",
+      to_arg = "x",
+      call = error_call
+    )
+
+    out <- list(
+      string = "value",
+      value = empty
+    )
+
+    return(out)
+  }
+
+  stop_input_type(empty, what = "a string or an iv", call = error_call)
+}
+
 #' Pairwise span
 #'
 #' @description

R/utils.R

@@ -24,3 +24,51 @@ err_locs <- function(x) {
     glue("`c({x})` and {size - 5L} more")
   }
 }
+
+obj_s3_method_exists <- function(x, generic) {
+  !is_null(obj_s3_method_lookup(x, generic))
+}
+
+obj_s3_method_lookup <- function(x, generic) {
+  if (!is.object(x)) {
+    return(NULL)
+  }
+
+  classes <- class(x)
+
+  if (!is_character(classes)) {
+    abort("`class(x)` didn't return a character vector.", .internal = TRUE)
+  }
+
+  for (class in classes) {
+    method <- paste0(generic, ".", class)
+    method <- s3_method_get(method)
+
+    if (!is_null(method)) {
+      return(method)
+    }
+  }
+
+  NULL
+}
+
+s3_method_get <- function(name) {
+  # Try global env first in case the user registered a method interactively
+  env <- global_env()
+  fn <- env_get(env, name, default = NULL)
+
+  if (is_function(fn)) {
+    return(fn)
+  }
+
+  # Then try the package S3 methods table
+  env <- the$env_s3_methods_table
+  fn <- env_get(env, name, default = NULL)
+
+  if (is_function(fn)) {
+    return(fn)
+  }
+
+  # Symbol not bound to the `env`, or it was bound to a non-function
+  NULL
+}