Implement frequency_weights() and importance_weights()

NAMESPACE

@@ -31,6 +31,16 @@ S3method(standardize,double)
 S3method(standardize,factor)
 S3method(standardize,integer)
 S3method(standardize,matrix)
+S3method(vec_cast,double.hardhat_importance_weights)
+S3method(vec_cast,hardhat_frequency_weights.hardhat_frequency_weights)
+S3method(vec_cast,hardhat_importance_weights.hardhat_importance_weights)
+S3method(vec_cast,integer.hardhat_frequency_weights)
+S3method(vec_ptype2,hardhat_frequency_weights.hardhat_frequency_weights)
+S3method(vec_ptype2,hardhat_importance_weights.hardhat_importance_weights)
+S3method(vec_ptype_abbr,hardhat_frequency_weights)
+S3method(vec_ptype_abbr,hardhat_importance_weights)
+S3method(vec_ptype_full,hardhat_frequency_weights)
+S3method(vec_ptype_full,hardhat_importance_weights)
 export(add_intercept_column)
 export(check_column_names)
 export(check_no_formula_duplication)
@@ -55,10 +65,15 @@ export(extract_recipe)
 export(extract_spec_parsnip)
 export(extract_workflow)
 export(forge)
+export(frequency_weights)
 export(get_data_classes)
 export(get_levels)
 export(get_outcome_levels)
+export(importance_weights)
 export(is_blueprint)
+export(is_case_weights)
+export(is_frequency_weights)
+export(is_importance_weights)
 export(model_frame)
 export(model_matrix)
 export(model_offset)
@@ -68,6 +83,8 @@ export(new_default_formula_blueprint)
 export(new_default_recipe_blueprint)
 export(new_default_xy_blueprint)
 export(new_formula_blueprint)
+export(new_frequency_weights)
+export(new_importance_weights)
 export(new_model)
 export(new_recipe_blueprint)
 export(new_xy_blueprint)

NEWS.md

@@ -1,5 +1,8 @@
 # hardhat (development version)
 
+* New experimental family of functions for working with case weights. In
+  particular, `frequency_weights()` and `importance_weights()` (#190).
+
 * New `weighted_table()` for generating a weighted contingency table, similar to
   `table()` (#191).
 

R/case-weights.R

@@ -0,0 +1,262 @@
+#' Importance weights
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `importance_weights()` creates a vector of importance weights which allow you
+#' to apply a context dependent weight to your observations. Importance weights
+#' are supplied as a non-negative double vector, where fractional values are
+#' allowed.
+#'
+#' @param x A double vector.
+#'
+#' @return A new importance weights vector.
+#'
+#' @seealso
+#' [frequency_weights()]
+#'
+#' @export
+#' @examples
+#' importance_weights(c(1.5, 2.3, 10))
+importance_weights <- function(x) {
+  x <- vec_cast(x, to = double(), x_arg = "x")
+
+  if (any(x < 0, na.rm = TRUE)) {
+    abort("`x` can't contain negative weights.")
+  }
+
+  new_importance_weights(x)
+}
+
+#' Construct an importance weights vector
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `new_importance_weights()` is a developer oriented function for constructing
+#' a new importance weights vector. Generally, you should use
+#' [importance_weights()] instead.
+#'
+#' @inheritParams vctrs::new_vctr
+#'
+#' @param x A double vector.
+#'
+#' @return A new importance weights vector.
+#'
+#' @export
+#' @examples
+#' new_importance_weights()
+#' new_importance_weights(c(1.5, 2.3, 10))
+new_importance_weights <- function(x = double(), ..., class = character()) {
+  if (!is.double(x)) {
+    abort("`x` must be a double vector.")
+  }
+
+  new_case_weights(
+    x = x,
+    ...,
+    class = c(class, "hardhat_importance_weights")
+  )
+}
+
+#' Is `x` an importance weights vector?
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `is_importance_weights()` checks if `x` inherits from
+#' `"hardhat_importance_weights"`.
+#'
+#' @param x An object.
+#'
+#' @return A single `TRUE` or `FALSE`.
+#'
+#' @export
+#' @examples
+#' is_importance_weights(1)
+#' is_importance_weights(frequency_weights(1))
+#' is_importance_weights(importance_weights(1))
+is_importance_weights <- function(x) {
+  inherits(x, "hardhat_importance_weights")
+}
+
+#' @export
+vec_ptype2.hardhat_importance_weights.hardhat_importance_weights <- function(x, y, ...) {
+  x
+}
+
+#' @export
+vec_cast.hardhat_importance_weights.hardhat_importance_weights <- function(x, to, ...) {
+  x
+}
+
+#' @export
+vec_cast.double.hardhat_importance_weights <- function(x, to, ...) {
+  unstructure(x)
+}
+
+#' @export
+vec_ptype_full.hardhat_importance_weights <- function(x, ...) {
+  "importance_weights"
+}
+
+#' @export
+vec_ptype_abbr.hardhat_importance_weights <- function(x, ...) {
+  "imp_wts"
+}
+
+# ------------------------------------------------------------------------------
+
+#' Frequency weights
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `frequency_weights()` creates a vector of frequency weights which allow you
+#' to compactly repeat an observation a set number of times. Frequency weights
+#' are supplied as a non-negative integer vector, where only whole numbers are
+#' allowed.
+#'
+#' @param x An integer vector.
+#'
+#' @return A new frequency weights vector.
+#'
+#' @seealso
+#' [importance_weights()]
+#'
+#' @export
+#' @examples
+#' # Record that the first observation has 10 replicates, the second has 12
+#' # replicates, and so on
+#' frequency_weights(c(10, 12, 2, 1))
+#'
+#' # Fractional values are not allowed
+#' try(frequency_weights(c(1.5, 2.3, 10)))
+frequency_weights <- function(x) {
+  x <- vec_cast(x, to = integer(), x_arg = "x")
+
+  if (any(x < 0L, na.rm = TRUE)) {
+    abort("`x` can't contain negative weights.")
+  }
+
+  new_frequency_weights(x)
+}
+
+#' Construct a frequency weights vector
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `new_frequency_weights()` is a developer oriented function for constructing
+#' a new frequency weights vector. Generally, you should use
+#' [frequency_weights()] instead.
+#'
+#' @inheritParams vctrs::new_vctr
+#'
+#' @param x An integer vector.
+#'
+#' @return A new frequency weights vector.
+#'
+#' @export
+#' @examples
+#' new_frequency_weights()
+#' new_frequency_weights(1:5)
+new_frequency_weights <- function(x = integer(), ..., class = character()) {
+  if (!is.integer(x)) {
+    abort("`x` must be an integer vector.")
+  }
+
+  new_case_weights(
+    x = x,
+    ...,
+    class = c(class, "hardhat_frequency_weights")
+  )
+}
+
+#' Is `x` a frequency weights vector?
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `is_frequency_weights()` checks if `x` inherits from
+#' `"hardhat_frequency_weights"`.
+#'
+#' @param x An object.
+#'
+#' @return A single `TRUE` or `FALSE`.
+#'
+#' @export
+#' @examples
+#' is_frequency_weights(1)
+#' is_frequency_weights(frequency_weights(1))
+#' is_frequency_weights(importance_weights(1))
+is_frequency_weights <- function(x) {
+  inherits(x, "hardhat_frequency_weights")
+}
+
+#' @export
+vec_ptype2.hardhat_frequency_weights.hardhat_frequency_weights <- function(x, y, ...) {
+  x
+}
+
+#' @export
+vec_cast.hardhat_frequency_weights.hardhat_frequency_weights <- function(x, to, ...) {
+  x
+}
+
+#' @export
+vec_cast.integer.hardhat_frequency_weights <- function(x, to, ...) {
+  unstructure(x)
+}
+
+#' @export
+vec_ptype_full.hardhat_frequency_weights <- function(x, ...) {
+  "frequency_weights"
+}
+
+#' @export
+vec_ptype_abbr.hardhat_frequency_weights <- function(x, ...) {
+  "freq_wts"
+}
+
+# ------------------------------------------------------------------------------
+
+# Abstract common class
+new_case_weights <- function(x, ..., class) {
+  if (!is.integer(x) && !is.double(x)) {
+    abort("`x` must be an integer or double vector.", .internal = TRUE)
+  }
+
+  new_vctr(
+    .data = x,
+    ...,
+    class = c(class, "hardhat_case_weights"),
+    inherit_base_type = FALSE
+  )
+}
+
+#' Is `x` a case weights vector?
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' `is_case_weights()` checks if `x` inherits from `"hardhat_case_weights"`.
+#'
+#' @param x An object.
+#'
+#' @return A single `TRUE` or `FALSE`.
+#'
+#' @export
+#' @examples
+#' is_case_weights(1)
+#' is_case_weights(frequency_weights(1))
+is_case_weights <- function(x) {
+  inherits(x, "hardhat_case_weights")
+}
+
+# ------------------------------------------------------------------------------
+
+unstructure <- function(x) {
+  attributes(x) <- list(names = vec_names(x))
+  x
+}

_pkgdown.yml

@@ -46,6 +46,22 @@ reference:
 - title: Blueprint
   contents: contains("blueprint")
 
+- title: Case Weights
+  contents:
+  - is_case_weights
+
+- subtitle: Importance Weights
+  contents:
+  - importance_weights
+  - new_importance_weights
+  - is_importance_weights
+
+- subtitle: Frequency Weights
+  contents:
+  - frequency_weights
+  - new_frequency_weights
+  - is_frequency_weights
+
 - title: Setup
   contents:
   - contains("use_")