diff --git a/NAMESPACE b/NAMESPACE index d992e208..280e82bd 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 71309833..417fa341 100644 --- a/NEWS.md +++ b/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). diff --git a/R/case-weights.R b/R/case-weights.R new file mode 100644 index 00000000..28ad0105 --- /dev/null +++ b/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 +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 9ae0f0fd..e7f51361 100644 --- a/_pkgdown.yml +++ b/_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_") diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg new file mode 100644 index 00000000..48f72a6f --- /dev/null +++ b/man/figures/lifecycle-archived.svg @@ -0,0 +1 @@ + lifecyclelifecyclearchivedarchived \ No newline at end of file diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg new file mode 100644 index 00000000..01452e5f --- /dev/null +++ b/man/figures/lifecycle-defunct.svg @@ -0,0 +1 @@ +lifecyclelifecycledefunctdefunct \ No newline at end of file diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 00000000..4baaee01 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1 @@ +lifecyclelifecycledeprecateddeprecated \ No newline at end of file diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 00000000..d1d060e9 --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1 @@ +lifecyclelifecycleexperimentalexperimental \ No newline at end of file diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg new file mode 100644 index 00000000..df713101 --- /dev/null +++ b/man/figures/lifecycle-maturing.svg @@ -0,0 +1 @@ +lifecyclelifecyclematuringmaturing \ No newline at end of file diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg new file mode 100644 index 00000000..08ee0c90 --- /dev/null +++ b/man/figures/lifecycle-questioning.svg @@ -0,0 +1 @@ +lifecyclelifecyclequestioningquestioning \ No newline at end of file diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 00000000..e015dc81 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1 @@ +lifecyclelifecyclestablestable \ No newline at end of file diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 00000000..75f24f55 --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1 @@ + lifecyclelifecyclesupersededsuperseded \ No newline at end of file diff --git a/man/frequency_weights.Rd b/man/frequency_weights.Rd new file mode 100644 index 00000000..a830251b --- /dev/null +++ b/man/frequency_weights.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{frequency_weights} +\alias{frequency_weights} +\title{Frequency weights} +\usage{ +frequency_weights(x) +} +\arguments{ +\item{x}{An integer vector.} +} +\value{ +A new frequency weights vector. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{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. +} +\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))) +} +\seealso{ +\code{\link[=importance_weights]{importance_weights()}} +} diff --git a/man/importance_weights.Rd b/man/importance_weights.Rd new file mode 100644 index 00000000..56030b40 --- /dev/null +++ b/man/importance_weights.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{importance_weights} +\alias{importance_weights} +\title{Importance weights} +\usage{ +importance_weights(x) +} +\arguments{ +\item{x}{A double vector.} +} +\value{ +A new importance weights vector. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{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. +} +\examples{ +importance_weights(c(1.5, 2.3, 10)) +} +\seealso{ +\code{\link[=frequency_weights]{frequency_weights()}} +} diff --git a/man/is_case_weights.Rd b/man/is_case_weights.Rd new file mode 100644 index 00000000..03fdf32e --- /dev/null +++ b/man/is_case_weights.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{is_case_weights} +\alias{is_case_weights} +\title{Is \code{x} a case weights vector?} +\usage{ +is_case_weights(x) +} +\arguments{ +\item{x}{An object.} +} +\value{ +A single \code{TRUE} or \code{FALSE}. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{is_case_weights()} checks if \code{x} inherits from \code{"hardhat_case_weights"}. +} +\examples{ +is_case_weights(1) +is_case_weights(frequency_weights(1)) +} diff --git a/man/is_frequency_weights.Rd b/man/is_frequency_weights.Rd new file mode 100644 index 00000000..2d5956a3 --- /dev/null +++ b/man/is_frequency_weights.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{is_frequency_weights} +\alias{is_frequency_weights} +\title{Is \code{x} a frequency weights vector?} +\usage{ +is_frequency_weights(x) +} +\arguments{ +\item{x}{An object.} +} +\value{ +A single \code{TRUE} or \code{FALSE}. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{is_frequency_weights()} checks if \code{x} inherits from +\code{"hardhat_frequency_weights"}. +} +\examples{ +is_frequency_weights(1) +is_frequency_weights(frequency_weights(1)) +is_frequency_weights(importance_weights(1)) +} diff --git a/man/is_importance_weights.Rd b/man/is_importance_weights.Rd new file mode 100644 index 00000000..aa3bf059 --- /dev/null +++ b/man/is_importance_weights.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{is_importance_weights} +\alias{is_importance_weights} +\title{Is \code{x} an importance weights vector?} +\usage{ +is_importance_weights(x) +} +\arguments{ +\item{x}{An object.} +} +\value{ +A single \code{TRUE} or \code{FALSE}. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{is_importance_weights()} checks if \code{x} inherits from +\code{"hardhat_importance_weights"}. +} +\examples{ +is_importance_weights(1) +is_importance_weights(frequency_weights(1)) +is_importance_weights(importance_weights(1)) +} diff --git a/man/new_frequency_weights.Rd b/man/new_frequency_weights.Rd new file mode 100644 index 00000000..09f27b58 --- /dev/null +++ b/man/new_frequency_weights.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{new_frequency_weights} +\alias{new_frequency_weights} +\title{Construct a frequency weights vector} +\usage{ +new_frequency_weights(x = integer(), ..., class = character()) +} +\arguments{ +\item{x}{An integer vector.} + +\item{...}{Name-value pairs defining attributes} + +\item{class}{Name of subclass.} +} +\value{ +A new frequency weights vector. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{new_frequency_weights()} is a developer oriented function for constructing +a new frequency weights vector. Generally, you should use +\code{\link[=frequency_weights]{frequency_weights()}} instead. +} +\examples{ +new_frequency_weights() +new_frequency_weights(1:5) +} diff --git a/man/new_importance_weights.Rd b/man/new_importance_weights.Rd new file mode 100644 index 00000000..a6076149 --- /dev/null +++ b/man/new_importance_weights.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/case-weights.R +\name{new_importance_weights} +\alias{new_importance_weights} +\title{Construct an importance weights vector} +\usage{ +new_importance_weights(x = double(), ..., class = character()) +} +\arguments{ +\item{x}{A double vector.} + +\item{...}{Name-value pairs defining attributes} + +\item{class}{Name of subclass.} +} +\value{ +A new importance weights vector. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +\code{new_importance_weights()} is a developer oriented function for constructing +a new importance weights vector. Generally, you should use +\code{\link[=importance_weights]{importance_weights()}} instead. +} +\examples{ +new_importance_weights() +new_importance_weights(c(1.5, 2.3, 10)) +} diff --git a/tests/testthat/_snaps/case-weights.md b/tests/testthat/_snaps/case-weights.md new file mode 100644 index 00000000..fc2b7ed8 --- /dev/null +++ b/tests/testthat/_snaps/case-weights.md @@ -0,0 +1,64 @@ +# importance_weights() doesn't allow negative weights + + Code + importance_weights(-1) + Error + `x` can't contain negative weights. + +# importance-weights constructor checks for double data + + Code + new_importance_weights(1L) + Error + `x` must be a double vector. + +# can't cast importance-weights -> integer (too lenient, likely fractional weights) + + Code + vec_cast(x, integer()) + Error + Can't convert to . + +# as.integer() fails (too lenient, likely fractional weights) + + Code + as.integer(x) + Error + Can't convert to . + +# frequency_weights() coerces to integer + + Code + frequency_weights(1.5) + Error + Can't convert from `x` to due to loss of precision. + * Locations: 1 + +# frequency_weights() doesn't allow negative weights + + Code + frequency_weights(-1L) + Error + `x` can't contain negative weights. + +# frequency-weights constructor checks for integer data + + Code + new_frequency_weights(1) + Error + `x` must be an integer vector. + +# can't cast frequency-weights -> double (too lenient) + + Code + vec_cast(x, double()) + Error + Can't convert to . + +# as.double() fails (too lenient) + + Code + as.double(x) + Error + Can't convert to . + diff --git a/tests/testthat/test-case-weights.R b/tests/testthat/test-case-weights.R new file mode 100644 index 00000000..51b47a59 --- /dev/null +++ b/tests/testthat/test-case-weights.R @@ -0,0 +1,165 @@ +# ------------------------------------------------------------------------------ +# importance_weights + +test_that("importance_weights() coerces to double", { + expect_type(importance_weights(1L), "double") +}) + +test_that("importance_weights() doesn't allow negative weights", { + expect_snapshot(error = TRUE, importance_weights(-1)) +}) + +test_that("importance_weights() allows missing values", { + expect_true(is.na(importance_weights(NA))) +}) + +test_that("importance_weights() allows zero", { + expect_identical(importance_weights(0), new_importance_weights(0)) +}) + +test_that("can create importance-weights", { + x <- new_importance_weights(1) + expect_s3_class(x, "hardhat_importance_weights") + expect_s3_class(x, "hardhat_case_weights") + expect_type(x, "double") +}) + +test_that("importance-weights constructor checks for double data", { + expect_snapshot(error = TRUE, new_importance_weights(1L)) +}) + +test_that("can check for importance-weights class", { + x <- importance_weights(1) + expect_true(is_importance_weights(x)) +}) + +test_that("common type of importance-weights <-> importance-weights exists", { + x <- importance_weights(1) + expect_identical(vec_ptype2(x, x), vec_ptype(x)) +}) + +test_that("can cast importance-weights -> importance-weights", { + x <- importance_weights(1) + expect_identical(vec_cast(x, x), x) +}) + +test_that("can cast importance-weights -> double (it's storage type)", { + x <- importance_weights(1) + expect_identical(vec_cast(x, double()), 1) +}) + +test_that("can't cast importance-weights -> integer (too lenient, likely fractional weights)", { + x <- importance_weights(1) + expect_snapshot(error = TRUE, vec_cast(x, integer())) +}) + +test_that("casting to double retains names", { + x <- importance_weights(c(x = 1)) + expect_named(vec_cast(x, double()), "x") +}) + +test_that("as.double() works", { + x <- importance_weights(1) + expect_identical(as.double(x), 1) +}) + +test_that("as.integer() fails (too lenient, likely fractional weights)", { + x <- importance_weights(1) + expect_snapshot(error = TRUE, as.integer(x)) +}) + +test_that("vec_ptype_full() and vec_ptype_abbr() methods are right", { + expect_identical(vec_ptype_full(new_importance_weights()), "importance_weights") + expect_identical(vec_ptype_abbr(new_importance_weights()), "imp_wts") +}) + +# ------------------------------------------------------------------------------ +# frequency_weights + +test_that("frequency_weights() coerces to integer", { + expect_type(frequency_weights(1), "integer") + expect_snapshot(error = TRUE, frequency_weights(1.5)) +}) + +test_that("frequency_weights() doesn't allow negative weights", { + expect_snapshot(error = TRUE, frequency_weights(-1L)) +}) + +test_that("frequency_weights() allows missing values", { + expect_true(is.na(frequency_weights(NA))) +}) + +test_that("frequency_weights() allows zero", { + expect_identical(frequency_weights(0L), new_frequency_weights(0L)) +}) + +test_that("can create frequency-weights", { + x <- new_frequency_weights(1L) + expect_s3_class(x, "hardhat_frequency_weights") + expect_s3_class(x, "hardhat_case_weights") + expect_type(x, "integer") +}) + +test_that("frequency-weights constructor checks for integer data", { + expect_snapshot(error = TRUE, new_frequency_weights(1)) +}) + +test_that("can check for frequency-weights class", { + x <- frequency_weights(1L) + expect_true(is_frequency_weights(x)) +}) + +test_that("common type of frequency-weights <-> frequency-weights exists", { + x <- frequency_weights(1L) + expect_identical(vec_ptype2(x, x), vec_ptype(x)) +}) + +test_that("can cast frequency-weights -> frequency-weights", { + x <- frequency_weights(1L) + expect_identical(vec_cast(x, x), x) +}) + +test_that("can cast frequency-weights -> integer (it's storage type)", { + x <- frequency_weights(1L) + expect_identical(vec_cast(x, integer()), 1L) +}) + +test_that("can't cast frequency-weights -> double (too lenient)", { + x <- frequency_weights(1L) + expect_snapshot(error = TRUE, vec_cast(x, double())) +}) + +test_that("casting to integer retains names", { + x <- frequency_weights(c(x = 1L)) + expect_named(vec_cast(x, integer()), "x") +}) + +test_that("as.integer() works", { + x <- frequency_weights(1L) + expect_identical(as.integer(x), 1L) +}) + +test_that("as.double() fails (too lenient)", { + x <- frequency_weights(1L) + expect_snapshot(error = TRUE, as.double(x)) +}) + +test_that("vec_ptype_full() and vec_ptype_abbr() methods are right", { + expect_identical(vec_ptype_full(new_frequency_weights()), "frequency_weights") + expect_identical(vec_ptype_abbr(new_frequency_weights()), "freq_wts") +}) + +# ------------------------------------------------------------------------------ +# case_weights + +test_that("can create a case-weights subclass", { + x <- new_case_weights(1, class = "subclass") + expect_s3_class(x, "subclass") + expect_s3_class(x, "hardhat_case_weights") + expect_type(x, "double") +}) + +test_that("can test for case-weights class", { + x <- new_case_weights(1, class = "subclass") + expect_true(is_case_weights(x)) +})