From 76e3d51f0b5d566faad76e9f0c791b63762e2500 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Wed, 9 Jul 2025 13:55:19 +1200 Subject: [PATCH 1/5] feat: add `measure` class --- DESCRIPTION | 14 + NAMESPACE | 2 + R/aaa-new.R | 81 ++++ R/import-standalone-obj-type.R | 365 ++++++++++++++++++ R/import-standalone-types-check.R | 596 +++++++++++++++++++++++++++++ R/kge.R | 6 +- R/nse.R | 3 +- R/pbias.R | 1 - R/press.R | 3 +- R/sfe.R | 3 +- R/variability.R | 13 +- _pkgdown.yml | 4 + man-roxygen/examples-description.R | 5 +- man-roxygen/examples-numeric.R | 1 - man/cv.Rd | 31 +- man/kge.Rd | 25 +- man/kge2012.Rd | 25 +- man/mse.Rd | 18 +- man/new-measure.Rd | 29 ++ man/nse.Rd | 25 +- man/pbias.Rd | 20 +- man/press.Rd | 23 +- man/rmse.Rd | 18 +- man/sfe.Rd | 25 +- 24 files changed, 1127 insertions(+), 209 deletions(-) create mode 100644 R/aaa-new.R create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R create mode 100644 man/new-measure.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f42f776..0eed391 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -26,3 +26,17 @@ URL: https://github.com/atsyplenkov/tidyhydro, https://atsyplenkov.github.io/tid BugReports: https://github.com/atsyplenkov/tidyhydro/issues LazyData: true Config/Needs/website: bench, ggplot2, quarto, lubridate, dplyr +Collate: + 'RcppExports.R' + 'import-standalone-types-check.R' + 'aaa-new.R' + 'data.R' + 'import-standalone-obj-type.R' + 'kge.R' + 'mse.R' + 'nse.R' + 'pbias.R' + 'press.R' + 'sfe.R' + 'tidyhydro-package.R' + 'variability.R' diff --git a/NAMESPACE b/NAMESPACE index 28f3986..b500ed3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,8 @@ S3method(pbias, data.frame) S3method(press, data.frame) S3method(cv, data.frame) S3method(sfe, data.frame) +S3method(print, measure) +S3method(format, measure) export(nse) export(kge) export(kge2012) diff --git a/R/aaa-new.R b/R/aaa-new.R new file mode 100644 index 0000000..a6ad8f5 --- /dev/null +++ b/R/aaa-new.R @@ -0,0 +1,81 @@ +# File is named with `aaa-` so that it is loaded before any other files. We need +# to call `new_*_metric()` internally from outside any function in the package, +# so this file has to be sourced first. It is a bit of a hack, but works. +# Modified after https://github.com/tidymodels/yardstick/blob/main/R/aaa-new.R + +# ------------------------------------------------------------------------------ + +#' Construct a new measure function +#' @keywords summary_stats +#' +#' @description +#' These functions provide convenient wrappers to create the three types of +#' measure functions in `tidyhydro`: measures of central tendency, variability +#' and symmetry. They add a measure-specific class to `fn` and +#' mimic a behaviour of [yardstick::metric_set()]. These features are used +#' by [measure_set()]. +#' +#' See [Custom performance +#' metrics](https://www.tidymodels.org/learn/develop/metrics/) for more +#' information about creating custom metrics. +#' +#' @param fn A function. The measure function to attach a measure-specific class +#' +#' @name new-measure +NULL + +#' @rdname new-measure +#' @export +new_tendency_measure <- function(fn) { + new_measure(fn, class = "tendency_measure") +} + +#' @rdname new-measure +#' @export +new_var_measure <- function(fn) { + new_measure(fn, class = "var_measure") +} + +#' @rdname new-measure +#' @export +new_sym_measure <- function(fn) { + new_measure(fn, class = "sym_measure") +} + +#' @include import-standalone-types-check.R +new_measure <- function(fn, direction, class = NULL, call = caller_env()) { + check_function(fn, call = call) + + class <- c(class, "measure", "function") + + structure(fn, class = class) +} + +is_measure <- function(x) { + inherits(x, "measure") +} + +#' @noRd +#' @export +print.measure <- function(x, ...) { + cat(format(x), sep = "\n") + invisible(x) +} + +#' @noRd +#' @export +format.measure <- function(x, ...) { + first_class <- class(x)[[1]] + measure_type <- + switch( + first_class, + "tendency_measure" = "Measure of Central Tendency", + "var_measure" = "Measure of Variability", + "sym_measure" = "Measure of Distribution Symmetry", + "measure" + ) + + cli::cli_format_method( + cli::cli_text(c("A {measure_type}")) + ) +} diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 0000000..c582ba0 --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,365 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R +# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-obj-type.R +# last-updated: 2024-02-14 +# license: https://unlicense.org +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-02-14: +# - `obj_type_friendly()` now works for S7 objects. +# +# 2023-05-01: +# - `obj_type_friendly()` now only displays the first class of S3 objects. +# +# 2023-03-30: +# - `stop_input_type()` now handles `I()` input literally in `arg`. +# +# 2022-10-04: +# - `obj_type_friendly(value = TRUE)` now shows numeric scalars +# literally. +# - `stop_friendly_type()` now takes `show_value`, passed to +# `obj_type_friendly()` as the `value` argument. +# +# 2022-10-03: +# - Added `allow_na` and `allow_null` arguments. +# - `NULL` is now backticked. +# - Better friendly type for infinities and `NaN`. +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Prefixed usage of rlang functions with `rlang::`. +# +# 2022-06-22: +# - `friendly_type_of()` is now `obj_type_friendly()`. +# - Added `obj_type_oo()`. +# +# 2021-12-20: +# - Added support for scalar values and empty vectors. +# - Added `stop_input_type()` +# +# 2021-06-30: +# - Added support for missing arguments. +# +# 2021-04-19: +# - Added support for matrices and arrays (#141). +# - Added documentation. +# - Added changelog. +# +# nocov start + +#' Return English-friendly type +#' @param x Any R object. +#' @param value Whether to describe the value of `x`. Special values +#' like `NA` or `""` are always described. +#' @param length Whether to mention the length of vectors and lists. +#' @return A string describing the type. Starts with an indefinite +#' article, e.g. "an integer vector". +#' @noRd +obj_type_friendly <- function(x, value = TRUE) { + if (is_missing(x)) { + return("absent") + } + + if (is.object(x)) { + if (inherits(x, "quosure")) { + type <- "quosure" + } else { + type <- class(x)[[1L]] + } + return(sprintf("a <%s> object", type)) + } + + if (!is_vector(x)) { + return(.rlang_as_friendly_type(typeof(x))) + } + + n_dim <- length(dim(x)) + + if (!n_dim) { + if (!is_list(x) && length(x) == 1) { + if (is_na(x)) { + return(switch( + typeof(x), + logical = "`NA`", + integer = "an integer `NA`", + double = if (is.nan(x)) { + "`NaN`" + } else { + "a numeric `NA`" + }, + complex = "a complex `NA`", + character = "a character `NA`", + .rlang_stop_unexpected_typeof(x) + )) + } + + show_infinites <- function(x) { + if (x > 0) { + "`Inf`" + } else { + "`-Inf`" + } + } + str_encode <- function(x, width = 30, ...) { + if (nchar(x) > width) { + x <- substr(x, 1, width - 3) + x <- paste0(x, "...") + } + encodeString(x, ...) + } + + if (value) { + if (is.numeric(x) && is.infinite(x)) { + return(show_infinites(x)) + } + + if (is.numeric(x) || is.complex(x)) { + number <- as.character(round(x, 2)) + what <- if (is.complex(x)) "the complex number" else "the number" + return(paste(what, number)) + } + + return(switch( + typeof(x), + logical = if (x) "`TRUE`" else "`FALSE`", + character = { + what <- if (nzchar(x)) "the string" else "the empty string" + paste(what, str_encode(x, quote = "\"")) + }, + raw = paste("the raw value", as.character(x)), + .rlang_stop_unexpected_typeof(x) + )) + } + + return(switch( + typeof(x), + logical = "a logical value", + integer = "an integer", + double = if (is.infinite(x)) show_infinites(x) else "a number", + complex = "a complex number", + character = if (nzchar(x)) "a string" else "\"\"", + raw = "a raw value", + .rlang_stop_unexpected_typeof(x) + )) + } + + if (length(x) == 0) { + return(switch( + typeof(x), + logical = "an empty logical vector", + integer = "an empty integer vector", + double = "an empty numeric vector", + complex = "an empty complex vector", + character = "an empty character vector", + raw = "an empty raw vector", + list = "an empty list", + .rlang_stop_unexpected_typeof(x) + )) + } + } + + vec_type_friendly(x) +} + +vec_type_friendly <- function(x, length = FALSE) { + if (!is_vector(x)) { + abort("`x` must be a vector.") + } + type <- typeof(x) + n_dim <- length(dim(x)) + + add_length <- function(type) { + if (length && !n_dim) { + paste0(type, sprintf(" of length %s", length(x))) + } else { + type + } + } + + if (type == "list") { + if (n_dim < 2) { + return(add_length("a list")) + } else if (is.data.frame(x)) { + return("a data frame") + } else if (n_dim == 2) { + return("a list matrix") + } else { + return("a list array") + } + } + + type <- switch( + type, + logical = "a logical %s", + integer = "an integer %s", + numeric = , + double = "a double %s", + complex = "a complex %s", + character = "a character %s", + raw = "a raw %s", + type = paste0("a ", type, " %s") + ) + + if (n_dim < 2) { + kind <- "vector" + } else if (n_dim == 2) { + kind <- "matrix" + } else { + kind <- "array" + } + out <- sprintf(type, kind) + + if (n_dim >= 2) { + out + } else { + add_length(out) + } +} + +.rlang_as_friendly_type <- function(type) { + switch( + type, + + list = "a list", + + NULL = "`NULL`", + environment = "an environment", + externalptr = "a pointer", + weakref = "a weak reference", + S4 = "an S4 object", + + name = , + symbol = "a symbol", + language = "a call", + pairlist = "a pairlist node", + expression = "an expression vector", + + char = "an internal string", + promise = "an internal promise", + ... = "an internal dots object", + any = "an internal `any` object", + bytecode = "an internal bytecode object", + + primitive = , + builtin = , + special = "a primitive function", + closure = "a function", + + type + ) +} + +.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { + abort( + sprintf("Unexpected type <%s>.", typeof(x)), + call = call + ) +} + +#' Return OO type +#' @param x Any R object. +#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, +#' `"R6"`, or `"S7"`. +#' @noRd +obj_type_oo <- function(x) { + if (!is.object(x)) { + return("bare") + } + + class <- inherits(x, c("R6", "S7_object"), which = TRUE) + + if (class[[1]]) { + "R6" + } else if (class[[2]]) { + "S7" + } else if (isS4(x)) { + "S4" + } else { + "S3" + } +} + +#' @param x The object type which does not conform to `what`. Its +#' `obj_type_friendly()` is taken and mentioned in the error message. +#' @param what The friendly expected type as a string. Can be a +#' character vector of expected types, in which case the error +#' message mentions all of them in an "or" enumeration. +#' @param show_value Passed to `value` argument of `obj_type_friendly()`. +#' @param ... Arguments passed to [abort()]. +#' @inheritParams args_error_context +#' @noRd +stop_input_type <- function( + x, + what, + ..., + allow_na = FALSE, + allow_null = FALSE, + show_value = TRUE, + arg = caller_arg(x), + call = caller_env() +) { + # From standalone-cli.R + cli <- env_get_list( + nms = c("format_arg", "format_code"), + last = topenv(), + default = function(x) sprintf("`%s`", x), + inherit = TRUE + ) + + if (allow_na) { + what <- c(what, cli$format_code("NA")) + } + if (allow_null) { + what <- c(what, cli$format_code("NULL")) + } + if (length(what)) { + what <- oxford_comma(what) + } + if (inherits(arg, "AsIs")) { + format_arg <- identity + } else { + format_arg <- cli$format_arg + } + + message <- sprintf( + "%s must be %s, not %s.", + format_arg(arg), + what, + obj_type_friendly(x, value = show_value) + ) + + abort(message, ..., call = call, arg = arg) +} + +oxford_comma <- function(chr, sep = ", ", final = "or") { + n <- length(chr) + + if (n < 2) { + return(chr) + } + + head <- chr[seq_len(n - 1)] + last <- chr[n] + + head <- paste(head, collapse = sep) + + # Write a or b. But a, b, or c. + if (n > 2) { + paste0(head, sep, final, " ", last) + } else { + paste0(head, " ", final, " ", last) + } +} + +# nocov end diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 0000000..a3555e3 --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,596 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R +# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-types-check.R +# last-updated: 2023-03-13 +# license: https://unlicense.org +# dependencies: standalone-obj-type.R +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-08-15: +# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) +# +# 2023-03-13: +# - Improved error messages of number checkers (@teunbrand) +# - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). +# - Added `check_data_frame()` (@mgirlich). +# +# 2023-03-07: +# - Added dependency on rlang (>= 1.1.0). +# +# 2023-02-15: +# - Added `check_logical()`. +# +# - `check_bool()`, `check_number_whole()`, and +# `check_number_decimal()` are now implemented in C. +# +# - For efficiency, `check_number_whole()` and +# `check_number_decimal()` now take a `NULL` default for `min` and +# `max`. This makes it possible to bypass unnecessary type-checking +# and comparisons in the default case of no bounds checks. +# +# 2022-10-07: +# - `check_number_whole()` and `_decimal()` no longer treat +# non-numeric types such as factors or dates as numbers. Numeric +# types are detected with `is.numeric()`. +# +# 2022-10-04: +# - Added `check_name()` that forbids the empty string. +# `check_string()` allows the empty string by default. +# +# 2022-09-28: +# - Removed `what` arguments. +# - Added `allow_na` and `allow_null` arguments. +# - Added `allow_decimal` and `allow_infinite` arguments. +# - Improved errors with absent arguments. +# +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Added changelog. +# +# nocov start + +# Scalars ----------------------------------------------------------------- + +.standalone_types_check_dot_call <- .Call + +check_bool <- function( + x, + ..., + allow_na = FALSE, + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if ( + !missing(x) && + .standalone_types_check_dot_call( + ffi_standalone_is_bool_1.0.7, + x, + allow_na, + allow_null + ) + ) { + return(invisible(NULL)) + } + + stop_input_type( + x, + c("`TRUE`", "`FALSE`"), + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_string <- function( + x, + ..., + allow_empty = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = allow_empty, + allow_na = allow_na, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a single string", + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.rlang_check_is_string <- function(x, allow_empty, allow_na, allow_null) { + if (rlang::is_string(x)) { + if (allow_empty || !rlang::is_string(x, "")) { + return(TRUE) + } + } + + if (allow_null && rlang::is_null(x)) { + return(TRUE) + } + + if (allow_na && (identical(x, NA) || identical(x, na_chr))) { + return(TRUE) + } + + FALSE +} + +check_name <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = FALSE, + allow_na = FALSE, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a valid name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +IS_NUMBER_true <- 0 +IS_NUMBER_false <- 1 +IS_NUMBER_oob <- 2 + +check_number_decimal <- function( + x, + ..., + min = NULL, + max = NULL, + allow_infinite = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if ( + 0 == + (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = TRUE, + min, + max, + allow_infinite, + allow_na, + allow_null + )) + ) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = TRUE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_number_whole <- function( + x, + ..., + min = NULL, + max = NULL, + allow_infinite = FALSE, + allow_na = FALSE, + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if ( + 0 == + (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = FALSE, + min, + max, + allow_infinite, + allow_na, + allow_null + )) + ) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = FALSE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.stop_not_number <- function( + x, + ..., + exit_code, + allow_decimal, + min, + max, + allow_na, + allow_null, + arg, + call +) { + if (allow_decimal) { + what <- "a number" + } else { + what <- "a whole number" + } + + if (exit_code == IS_NUMBER_oob) { + min <- min %||% -Inf + max <- max %||% Inf + + if (min > -Inf && max < Inf) { + what <- sprintf("%s between %s and %s", what, min, max) + } else if (x < min) { + what <- sprintf("%s larger than or equal to %s", what, min) + } else if (x > max) { + what <- sprintf("%s smaller than or equal to %s", what, max) + } else { + rlang::abort("Unexpected state in OOB check", .internal = TRUE) + } + } + + stop_input_type( + x, + what, + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_symbol <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a symbol", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_arg <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an argument name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_call <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_call(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a defused call", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_environment <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_environment(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an environment", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_function <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_function(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_closure <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_closure(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an R function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_formula <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_formula(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a formula", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + + +# Vectors ----------------------------------------------------------------- + +# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` + +check_character <- function( + x, + ..., + allow_na = TRUE, + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_character(x)) { + if (!allow_na && any(is.na(x))) { + rlang::abort( + sprintf("`%s` can't contain NA values.", arg), + arg = arg, + call = call + ) + } + + return(invisible(NULL)) + } + + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a character vector", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_logical <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_logical(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a logical vector", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_data_frame <- function( + x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (is.data.frame(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a data frame", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +# nocov end diff --git a/R/kge.R b/R/kge.R index d126ff2..70ff4fa 100644 --- a/R/kge.R +++ b/R/kge.R @@ -42,8 +42,7 @@ #' For further discussion, see Knoben et al. (2019), who caution against #' directly translating NSE-based interpretation thresholds to KGE. #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family KGE variants #' @templateVar fn kge #' @template return #' @@ -170,8 +169,7 @@ kge_vec <- function( #' For further discussion, see Knoben et al. (2019), who caution against #' directly translating NSE-based interpretation thresholds to KGE. #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family KGE variants #' @templateVar fn kge2012 #' @template return #' diff --git a/R/nse.R b/R/nse.R index 805a25c..bf1c330 100644 --- a/R/nse.R +++ b/R/nse.R @@ -35,8 +35,7 @@ #' - **Satisfactory** -- 0.5 < `nse()` < 0.6 #' - **Poor** -- `nse()` <= 0.5 #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family NSE variants #' @templateVar fn nse #' @template return #' diff --git a/R/pbias.R b/R/pbias.R index 4c4f069..03bcf7b 100644 --- a/R/pbias.R +++ b/R/pbias.R @@ -33,7 +33,6 @@ #' - **Poor** -- `pbias()` >= ±15.0 #' #' @family numeric metrics -#' @family accuracy metrics #' @templateVar fn pbias #' @template return #' diff --git a/R/press.R b/R/press.R index 308ce6f..975e7ae 100644 --- a/R/press.R +++ b/R/press.R @@ -35,8 +35,7 @@ #' different transformations of response variable, e.g. linear regression and #' log-transformed linear regression (*Helsel et al., 2020*). #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family regression metrics #' @templateVar fn press #' @template return #' diff --git a/R/sfe.R b/R/sfe.R index 85e4639..072fbc3 100644 --- a/R/sfe.R +++ b/R/sfe.R @@ -19,8 +19,7 @@ #' \item \eqn{obs} defines model observations at time step \eqn{i} #' } #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family regression metrics #' @templateVar fn sfe #' @template return #' diff --git a/R/variability.R b/R/variability.R index 1cf353b..c06f7c4 100644 --- a/R/variability.R +++ b/R/variability.R @@ -1,8 +1,7 @@ #' Coefficient of Variation (Cv) -#' @keywords summary +#' @keywords summary_stats #' -#' @family numeric metrics -#' @family accuracy metrics +#' @family descriptive statistics #' @templateVar fn cv #' @template return #' @@ -25,14 +24,14 @@ #' @export #' +# TODO: +# Add tests + cv <- function(data, ...) { UseMethod("cv") } -cv <- yardstick::new_numeric_metric( - cv, - direction = "minimize" -) +cv <- new_var_measure(cv) #' @rdname cv #' @export diff --git a/_pkgdown.yml b/_pkgdown.yml index ffde41a..9110cb5 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -33,6 +33,10 @@ reference: contents: - has_keyword("regression") +- title: "Summary statistics" + contents: + - has_keyword("summary_stats") + - title: "Example datasets" contents: - has_keyword("data") diff --git a/man-roxygen/examples-description.R b/man-roxygen/examples-description.R index bdf06e4..68a1e2f 100644 --- a/man-roxygen/examples-description.R +++ b/man-roxygen/examples-description.R @@ -1,8 +1,9 @@ #' @examples #' library(tidyhydro) -#' data(avacha) #' -#' # Supply truth and predictions as bare column names +#' <%=fn %> +#' +#' # Supply truth as bare column names #' <%=fn %>(avacha, obs) #' #' # Or as numeric vectors diff --git a/man-roxygen/examples-numeric.R b/man-roxygen/examples-numeric.R index 3067b21..471a729 100644 --- a/man-roxygen/examples-numeric.R +++ b/man-roxygen/examples-numeric.R @@ -1,6 +1,5 @@ #' @examples #' library(tidyhydro) -#' data(avacha) #' #' # Supply truth and predictions as bare column names #' <%=fn %>(avacha, obs, sim) diff --git a/man/cv.Rd b/man/cv.Rd index f7ff7d5..87dbaa9 100644 --- a/man/cv.Rd +++ b/man/cv.Rd @@ -41,35 +41,14 @@ Coefficient of Variation (Cv) } \examples{ library(tidyhydro) -data(avacha) -# Supply truth and predictions as bare column names +cv + +# Supply truth as bare column names cv(avacha, obs) # Or as numeric vectors cv_vec(avacha$obs) } -\seealso{ -Other numeric metrics: -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} -} -\concept{accuracy metrics} -\concept{numeric metrics} -\keyword{summary} +\concept{descriptive statistics} +\keyword{summary_stats} diff --git a/man/kge.Rd b/man/kge.Rd index 422c1b7..77439d8 100644 --- a/man/kge.Rd +++ b/man/kge.Rd @@ -84,7 +84,6 @@ directly translating NSE-based interpretation thresholds to KGE. } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names kge(avacha, obs, sim) @@ -104,26 +103,8 @@ Kling–Gupta efficiency scores. Hydrology and Earth System Sciences, 23, 4323–4331. \doi{10.5194/hess-23-4323-2019} } \seealso{ -Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} +Other KGE variants: +\code{\link{kge2012}()} } -\concept{accuracy metrics} -\concept{numeric metrics} +\concept{KGE variants} \keyword{gof} diff --git a/man/kge2012.Rd b/man/kge2012.Rd index 784b553..157c0ee 100644 --- a/man/kge2012.Rd +++ b/man/kge2012.Rd @@ -88,7 +88,6 @@ directly translating NSE-based interpretation thresholds to KGE. } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names kge2012(avacha, obs, sim) @@ -108,26 +107,8 @@ Kling–Gupta efficiency scores. Hydrology and Earth System Sciences, 23, 4323–4331. \doi{10.5194/hess-23-4323-2019} } \seealso{ -Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} +Other KGE variants: +\code{\link{kge}()} } -\concept{accuracy metrics} -\concept{numeric metrics} +\concept{KGE variants} \keyword{gof} diff --git a/man/mse.Rd b/man/mse.Rd index 699612f..86fab4f 100644 --- a/man/mse.Rd +++ b/man/mse.Rd @@ -60,7 +60,6 @@ where: } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names mse(avacha, obs, sim) @@ -82,24 +81,11 @@ e2020WR029001. \doi{10.1029/2020WR029001} } \seealso{ Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{nse}()}, \code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} +\code{\link{rmse}()} Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} +\code{\link{rmse}()} } \concept{accuracy metrics} \concept{numeric metrics} diff --git a/man/new-measure.Rd b/man/new-measure.Rd new file mode 100644 index 0000000..e2147ee --- /dev/null +++ b/man/new-measure.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/aaa-new.R +\name{new-measure} +\alias{new-measure} +\alias{new_tendency_measure} +\alias{new_var_measure} +\alias{new_sym_measure} +\title{Construct a new measure function} +\usage{ +new_tendency_measure(fn) + +new_var_measure(fn) + +new_sym_measure(fn) +} +\arguments{ +\item{fn}{A function. The measure function to attach a measure-specific class} +} +\description{ +These functions provide convenient wrappers to create the three types of +measure functions in \code{tidyhydro}: measures of central tendency, variability +and symmetry. They add a measure-specific class to \code{fn} and +mimic a behaviour of \code{\link[yardstick:metric_set]{yardstick::metric_set()}}. These features are used +by \code{\link[=measure_set]{measure_set()}}. + +See \href{https://www.tidymodels.org/learn/develop/metrics/}{Custom performance metrics} for more +information about creating custom metrics. +} +\keyword{summary_stats} diff --git a/man/nse.Rd b/man/nse.Rd index 5d1a878..8840d29 100644 --- a/man/nse.Rd +++ b/man/nse.Rd @@ -81,7 +81,6 @@ as follows: } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names nse(avacha, obs, sim) @@ -99,27 +98,5 @@ and Water Quality Models: Performance Measures and Evaluation Criteria. Transactions of the ASABE, 58(6), 1763–1785. \doi{10.13031/trans.58.10715} } -\seealso{ -Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} -} -\concept{accuracy metrics} -\concept{numeric metrics} +\concept{NSE variants} \keyword{gof} diff --git a/man/pbias.Rd b/man/pbias.Rd index 47214d0..82b29a4 100644 --- a/man/pbias.Rd +++ b/man/pbias.Rd @@ -78,7 +78,6 @@ follows: } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names pbias(avacha, obs, sim) @@ -99,25 +98,8 @@ multilevel expert calibration. J. Hydrologic Eng. 4(2): 135-143 } \seealso{ Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, \code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{press}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} +\code{\link{rmse}()} } -\concept{accuracy metrics} \concept{numeric metrics} \keyword{gof} diff --git a/man/press.Rd b/man/press.Rd index 505e780..97d1c71 100644 --- a/man/press.Rd +++ b/man/press.Rd @@ -77,7 +77,6 @@ log-transformed linear regression (\emph{Helsel et al., 2020}). } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names press(avacha, obs, sim) @@ -97,26 +96,8 @@ Gilroy, E. J. Statistical Methods in Water Resources. 484 (2020) \doi{10.3133/tm4A3}. } \seealso{ -Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{rmse}()}, -\code{\link{sfe}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{rmse}()}, +Other regression metrics: \code{\link{sfe}()} } -\concept{accuracy metrics} -\concept{numeric metrics} +\concept{regression metrics} \keyword{regression} diff --git a/man/rmse.Rd b/man/rmse.Rd index b6d9e8d..010f6e2 100644 --- a/man/rmse.Rd +++ b/man/rmse.Rd @@ -57,7 +57,6 @@ where: } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names rmse(avacha, obs, sim) @@ -67,24 +66,11 @@ rmse_vec(avacha$obs, avacha$sim) } \seealso{ Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, \code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{sfe}()} +\code{\link{pbias}()} Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{sfe}()} +\code{\link{mse}()} } \concept{accuracy metrics} \concept{numeric metrics} diff --git a/man/sfe.Rd b/man/sfe.Rd index 1925558..aab2c19 100644 --- a/man/sfe.Rd +++ b/man/sfe.Rd @@ -61,7 +61,6 @@ where: } \examples{ library(tidyhydro) -data(avacha) # Supply truth and predictions as bare column names sfe(avacha, obs, sim) @@ -86,26 +85,8 @@ Standards, p. 138). \url{https://www.nems.org.nz/documents/suspended-sediment} } \seealso{ -Other numeric metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()} - -Other accuracy metrics: -\code{\link{cv}()}, -\code{\link{kge}()}, -\code{\link{kge2012}()}, -\code{\link{mse}()}, -\code{\link{nse}()}, -\code{\link{pbias}()}, -\code{\link{press}()}, -\code{\link{rmse}()} +Other regression metrics: +\code{\link{press}()} } -\concept{accuracy metrics} -\concept{numeric metrics} +\concept{regression metrics} \keyword{regression} From 5873c178af69469274ad4f98e1a50334a818014c Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Wed, 9 Jul 2025 15:07:58 +1200 Subject: [PATCH 2/5] lint: making rlang calls explicit --- R/import-standalone-obj-type.R | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R index c582ba0..2091626 100644 --- a/R/import-standalone-obj-type.R +++ b/R/import-standalone-obj-type.R @@ -67,7 +67,7 @@ #' article, e.g. "an integer vector". #' @noRd obj_type_friendly <- function(x, value = TRUE) { - if (is_missing(x)) { + if (rlang::is_missing(x)) { return("absent") } @@ -80,15 +80,15 @@ obj_type_friendly <- function(x, value = TRUE) { return(sprintf("a <%s> object", type)) } - if (!is_vector(x)) { + if (!rlang::is_vector(x)) { return(.rlang_as_friendly_type(typeof(x))) } n_dim <- length(dim(x)) if (!n_dim) { - if (!is_list(x) && length(x) == 1) { - if (is_na(x)) { + if (!rlang::is_list(x) && length(x) == 1) { + if (rlang::is_na(x)) { return(switch( typeof(x), logical = "`NA`", @@ -173,8 +173,8 @@ obj_type_friendly <- function(x, value = TRUE) { } vec_type_friendly <- function(x, length = FALSE) { - if (!is_vector(x)) { - abort("`x` must be a vector.") + if (!rlang::is_vector(x)) { + rlang::abort("`x` must be a vector.") } type <- typeof(x) n_dim <- length(dim(x)) @@ -260,8 +260,8 @@ vec_type_friendly <- function(x, length = FALSE) { ) } -.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { - abort( +.rlang_stop_unexpected_typeof <- function(x, call = rlang::caller_env()) { + rlang::abort( sprintf("Unexpected type <%s>.", typeof(x)), call = call ) @@ -296,7 +296,7 @@ obj_type_oo <- function(x) { #' character vector of expected types, in which case the error #' message mentions all of them in an "or" enumeration. #' @param show_value Passed to `value` argument of `obj_type_friendly()`. -#' @param ... Arguments passed to [abort()]. +#' @param ... Arguments passed to [rlang::abort()]. #' @inheritParams args_error_context #' @noRd stop_input_type <- function( @@ -306,11 +306,11 @@ stop_input_type <- function( allow_na = FALSE, allow_null = FALSE, show_value = TRUE, - arg = caller_arg(x), - call = caller_env() + arg = rlang::caller_arg(x), + call = rlang::caller_env() ) { # From standalone-cli.R - cli <- env_get_list( + cli <- rlang::env_get_list( nms = c("format_arg", "format_code"), last = topenv(), default = function(x) sprintf("`%s`", x), @@ -339,7 +339,7 @@ stop_input_type <- function( obj_type_friendly(x, value = show_value) ) - abort(message, ..., call = call, arg = arg) + rlang::abort(message, ..., call = call, arg = arg) } oxford_comma <- function(chr, sep = ", ", final = "or") { From eba2c8f239c9c2b2b19a01eec97470b4af0a9b15 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Wed, 9 Jul 2025 15:12:43 +1200 Subject: [PATCH 3/5] docs: update new-measure description --- R/aaa-new.R | 9 ++------- man/new-measure.Rd | 4 ++-- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/R/aaa-new.R b/R/aaa-new.R index a6ad8f5..c6051f7 100644 --- a/R/aaa-new.R +++ b/R/aaa-new.R @@ -1,10 +1,5 @@ -# File is named with `aaa-` so that it is loaded before any other files. We need -# to call `new_*_metric()` internally from outside any function in the package, -# so this file has to be sourced first. It is a bit of a hack, but works. # Modified after https://github.com/tidymodels/yardstick/blob/main/R/aaa-new.R -# ------------------------------------------------------------------------------ - #' Construct a new measure function #' @keywords summary_stats #' @@ -12,8 +7,8 @@ #' These functions provide convenient wrappers to create the three types of #' measure functions in `tidyhydro`: measures of central tendency, variability #' and symmetry. They add a measure-specific class to `fn` and -#' mimic a behaviour of [yardstick::metric_set()]. These features are used -#' by [measure_set()]. +#' mimic a behaviour of [metric_set][yardstick::metric_set]. These features +#' are used by [measure_set]. #' #' See [Custom performance #' metrics](https://www.tidymodels.org/learn/develop/metrics/) for more diff --git a/man/new-measure.Rd b/man/new-measure.Rd index e2147ee..4ef32fc 100644 --- a/man/new-measure.Rd +++ b/man/new-measure.Rd @@ -20,8 +20,8 @@ new_sym_measure(fn) These functions provide convenient wrappers to create the three types of measure functions in \code{tidyhydro}: measures of central tendency, variability and symmetry. They add a measure-specific class to \code{fn} and -mimic a behaviour of \code{\link[yardstick:metric_set]{yardstick::metric_set()}}. These features are used -by \code{\link[=measure_set]{measure_set()}}. +mimic a behaviour of \link[yardstick:metric_set]{metric_set}. These features +are used by \link{measure_set}. See \href{https://www.tidymodels.org/learn/develop/metrics/}{Custom performance metrics} for more information about creating custom metrics. From d4c13df6fe0be32b819699bca8d8ecf30dc73254 Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Wed, 9 Jul 2025 15:51:06 +1200 Subject: [PATCH 4/5] fix: proper rlang imports and types check --- .Rbuildignore | 1 + DESCRIPTION | 3 +- NAMESPACE | 1 + R/aaa-new.R | 2 +- R/import-standalone-obj-type.R | 26 +++---- R/import-standalone-types-check.R | 108 +++++++++++++++--------------- 6 files changed, 72 insertions(+), 69 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 01ddd28..e6e6215 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,3 +18,4 @@ ^codemeta\.json$ ^CODE_OF_CONDUCT\.md$ ^src/.*\.o$ +^dev\.R$ diff --git a/DESCRIPTION b/DESCRIPTION index 0eed391..6e557ed 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -11,7 +11,8 @@ Depends: R (>= 4.1.0) Imports: Rcpp (>= 1.0.12), rlang (>= 1.1.0), - yardstick (>= 1.3.1) + yardstick (>= 1.3.1), + cli LinkingTo: Rcpp Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index b500ed3..c955a93 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ useDynLib(tidyhydro, .registration = TRUE) importFrom(Rcpp, evalCpp) +import(rlang) # exportPattern("^[[:alpha:]]+") S3method(nse, data.frame) diff --git a/R/aaa-new.R b/R/aaa-new.R index c6051f7..a2bf9ff 100644 --- a/R/aaa-new.R +++ b/R/aaa-new.R @@ -38,7 +38,7 @@ new_sym_measure <- function(fn) { } #' @include import-standalone-types-check.R -new_measure <- function(fn, direction, class = NULL, call = caller_env()) { +new_measure <- function(fn, class = NULL, call = caller_env()) { check_function(fn, call = call) class <- c(class, "measure", "function") diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R index 2091626..c582ba0 100644 --- a/R/import-standalone-obj-type.R +++ b/R/import-standalone-obj-type.R @@ -67,7 +67,7 @@ #' article, e.g. "an integer vector". #' @noRd obj_type_friendly <- function(x, value = TRUE) { - if (rlang::is_missing(x)) { + if (is_missing(x)) { return("absent") } @@ -80,15 +80,15 @@ obj_type_friendly <- function(x, value = TRUE) { return(sprintf("a <%s> object", type)) } - if (!rlang::is_vector(x)) { + if (!is_vector(x)) { return(.rlang_as_friendly_type(typeof(x))) } n_dim <- length(dim(x)) if (!n_dim) { - if (!rlang::is_list(x) && length(x) == 1) { - if (rlang::is_na(x)) { + if (!is_list(x) && length(x) == 1) { + if (is_na(x)) { return(switch( typeof(x), logical = "`NA`", @@ -173,8 +173,8 @@ obj_type_friendly <- function(x, value = TRUE) { } vec_type_friendly <- function(x, length = FALSE) { - if (!rlang::is_vector(x)) { - rlang::abort("`x` must be a vector.") + if (!is_vector(x)) { + abort("`x` must be a vector.") } type <- typeof(x) n_dim <- length(dim(x)) @@ -260,8 +260,8 @@ vec_type_friendly <- function(x, length = FALSE) { ) } -.rlang_stop_unexpected_typeof <- function(x, call = rlang::caller_env()) { - rlang::abort( +.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { + abort( sprintf("Unexpected type <%s>.", typeof(x)), call = call ) @@ -296,7 +296,7 @@ obj_type_oo <- function(x) { #' character vector of expected types, in which case the error #' message mentions all of them in an "or" enumeration. #' @param show_value Passed to `value` argument of `obj_type_friendly()`. -#' @param ... Arguments passed to [rlang::abort()]. +#' @param ... Arguments passed to [abort()]. #' @inheritParams args_error_context #' @noRd stop_input_type <- function( @@ -306,11 +306,11 @@ stop_input_type <- function( allow_na = FALSE, allow_null = FALSE, show_value = TRUE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { # From standalone-cli.R - cli <- rlang::env_get_list( + cli <- env_get_list( nms = c("format_arg", "format_code"), last = topenv(), default = function(x) sprintf("`%s`", x), @@ -339,7 +339,7 @@ stop_input_type <- function( obj_type_friendly(x, value = show_value) ) - rlang::abort(message, ..., call = call, arg = arg) + abort(message, ..., call = call, arg = arg) } oxford_comma <- function(chr, sep = ", ", final = "or") { diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R index a3555e3..5214a00 100644 --- a/R/import-standalone-types-check.R +++ b/R/import-standalone-types-check.R @@ -70,8 +70,8 @@ check_bool <- function( ..., allow_na = FALSE, allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if ( !missing(x) && @@ -102,8 +102,8 @@ check_string <- function( allow_empty = TRUE, allow_na = FALSE, allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { is_string <- .rlang_check_is_string( @@ -129,13 +129,13 @@ check_string <- function( } .rlang_check_is_string <- function(x, allow_empty, allow_na, allow_null) { - if (rlang::is_string(x)) { - if (allow_empty || !rlang::is_string(x, "")) { + if (is_string(x)) { + if (allow_empty || !is_string(x, "")) { return(TRUE) } } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(TRUE) } @@ -150,8 +150,8 @@ check_name <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { is_string <- .rlang_check_is_string( @@ -188,8 +188,8 @@ check_number_decimal <- function( allow_infinite = TRUE, allow_na = FALSE, allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (missing(x)) { exit_code <- IS_NUMBER_false @@ -231,8 +231,8 @@ check_number_whole <- function( allow_infinite = FALSE, allow_na = FALSE, allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (missing(x)) { exit_code <- IS_NUMBER_false @@ -295,7 +295,7 @@ check_number_whole <- function( } else if (x > max) { what <- sprintf("%s smaller than or equal to %s", what, max) } else { - rlang::abort("Unexpected state in OOB check", .internal = TRUE) + abort("Unexpected state in OOB check", .internal = TRUE) } } @@ -314,14 +314,14 @@ check_symbol <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_symbol(x)) { + if (is_symbol(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -341,14 +341,14 @@ check_arg <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_symbol(x)) { + if (is_symbol(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -368,14 +368,14 @@ check_call <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_call(x)) { + if (is_call(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -395,14 +395,14 @@ check_environment <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_environment(x)) { + if (is_environment(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -422,14 +422,14 @@ check_function <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_function(x)) { + if (is_function(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -449,14 +449,14 @@ check_closure <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_closure(x)) { + if (is_closure(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -476,14 +476,14 @@ check_formula <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_formula(x)) { + if (is_formula(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -509,13 +509,13 @@ check_character <- function( ..., allow_na = TRUE, allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_character(x)) { + if (is_character(x)) { if (!allow_na && any(is.na(x))) { - rlang::abort( + abort( sprintf("`%s` can't contain NA values.", arg), arg = arg, call = call @@ -525,7 +525,7 @@ check_character <- function( return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -544,14 +544,14 @@ check_logical <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { - if (rlang::is_logical(x)) { + if (is_logical(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } @@ -571,14 +571,14 @@ check_data_frame <- function( x, ..., allow_null = FALSE, - arg = rlang::caller_arg(x), - call = rlang::caller_env() + arg = caller_arg(x), + call = caller_env() ) { if (!missing(x)) { if (is.data.frame(x)) { return(invisible(NULL)) } - if (allow_null && rlang::is_null(x)) { + if (allow_null && is_null(x)) { return(invisible(NULL)) } } From 6fa04c57da63db5f88c77b49e9ca9618684472fe Mon Sep 17 00:00:00 2001 From: Anatolii Tsyplenkov Date: Wed, 9 Jul 2025 17:03:23 +1200 Subject: [PATCH 5/5] feat: geometric mean --- DESCRIPTION | 5 +- NAMESPACE | 28 +- R/aaa-new.R | 11 +- R/central-tendency.R | 66 ++++ R/import-standalone-obj-type.R | 365 ------------------ R/import-standalone-types-check.R | 596 ------------------------------ man/cv.Rd | 4 + man/gm.Rd | 58 +++ 8 files changed, 152 insertions(+), 981 deletions(-) create mode 100644 R/central-tendency.R delete mode 100644 R/import-standalone-obj-type.R delete mode 100644 R/import-standalone-types-check.R create mode 100644 man/gm.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 6e557ed..af23c5d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,7 @@ Imports: Rcpp (>= 1.0.12), rlang (>= 1.1.0), yardstick (>= 1.3.1), - cli + checkmate (>= 2.3.1) LinkingTo: Rcpp Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 @@ -29,10 +29,9 @@ LazyData: true Config/Needs/website: bench, ggplot2, quarto, lubridate, dplyr Collate: 'RcppExports.R' - 'import-standalone-types-check.R' 'aaa-new.R' + 'central-tendency.R' 'data.R' - 'import-standalone-obj-type.R' 'kge.R' 'mse.R' 'nse.R' diff --git a/NAMESPACE b/NAMESPACE index c955a93..1e63bf2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,19 +1,11 @@ useDynLib(tidyhydro, .registration = TRUE) importFrom(Rcpp, evalCpp) -import(rlang) # exportPattern("^[[:alpha:]]+") -S3method(nse, data.frame) -S3method(kge, data.frame) -S3method(kge2012, data.frame) -S3method(mse, data.frame) -S3method(rmse, data.frame) -S3method(pbias, data.frame) -S3method(press, data.frame) -S3method(cv, data.frame) -S3method(sfe, data.frame) S3method(print, measure) S3method(format, measure) + +# general functions export(nse) export(kge) export(kge2012) @@ -23,6 +15,21 @@ export(pbias) export(press) export(sfe) export(cv) +export(gm) + +# data.frame methods +S3method(nse, data.frame) +S3method(kge, data.frame) +S3method(kge2012, data.frame) +S3method(mse, data.frame) +S3method(rmse, data.frame) +S3method(pbias, data.frame) +S3method(press, data.frame) +S3method(sfe, data.frame) +S3method(cv, data.frame) +S3method(gm, data.frame) + +# vector functions export(nse_vec) export(kge_vec) export(kge2012_vec) @@ -32,3 +39,4 @@ export(pbias_vec) export(press_vec) export(sfe_vec) export(cv_vec) +export(gm_vec) diff --git a/R/aaa-new.R b/R/aaa-new.R index a2bf9ff..01064be 100644 --- a/R/aaa-new.R +++ b/R/aaa-new.R @@ -8,7 +8,7 @@ #' measure functions in `tidyhydro`: measures of central tendency, variability #' and symmetry. They add a measure-specific class to `fn` and #' mimic a behaviour of [metric_set][yardstick::metric_set]. These features -#' are used by [measure_set]. +#' are used by measure_set. #' #' See [Custom performance #' metrics](https://www.tidymodels.org/learn/develop/metrics/) for more @@ -37,9 +37,8 @@ new_sym_measure <- function(fn) { new_measure(fn, class = "sym_measure") } -#' @include import-standalone-types-check.R -new_measure <- function(fn, class = NULL, call = caller_env()) { - check_function(fn, call = call) +new_measure <- function(fn, class = NULL) { + checkmate::assert_function(fn, args = "data") class <- c(class, "measure", "function") @@ -70,7 +69,5 @@ format.measure <- function(x, ...) { "measure" ) - cli::cli_format_method( - cli::cli_text(c("A {measure_type}")) - ) + cat(paste("A", measure_type)) } diff --git a/R/central-tendency.R b/R/central-tendency.R new file mode 100644 index 0000000..749c094 --- /dev/null +++ b/R/central-tendency.R @@ -0,0 +1,66 @@ +#' Geometric Mean (GM) +#' @keywords summary_stats +#' +#' @family descriptive statistics +#' @templateVar fn gm +#' @template return +#' +#' @param data A `data.frame` containing the columns specified by the `truth` +#' and `estimate` arguments. +#' +#' @param truth The column identifier for the true results +#' (that is `numeric`). This should be an unquoted column name although +#' this argument is passed by expression and supports +#' [quasiquotation][rlang::quasiquotation] (you can unquote column +#' names). For `_vec()` functions, a `numeric` vector. +#' +#' @param na_rm A `logical` value indicating whether `NA` +#' values should be stripped before the computation proceeds. +#' +#' @param ... Not currently used. +#' +#' @template examples-description +#' +#' @export +#' + +# TODO: +# Add tests + +gm <- function(data, ...) { + UseMethod("gm") +} + +gm <- new_tendency_measure(gm) + +#' @rdname gm +#' @export +gm.data.frame <- function( + data, + truth, + na_rm = TRUE, + ... +) { + yardstick::numeric_metric_summarizer( + name = "gm", + fn = gm_vec, + data = data, + truth = !!rlang::enquo(truth), + estimate = !!rlang::enquo(truth), + na_rm = na_rm + ) +} + +#' @rdname gm +#' @export +gm_vec <- function( + truth, + na_rm = TRUE, + ... +) { + checkmate::assert_numeric( + truth, + lower = 1e-323 + ) + exp(mean(log(truth), na.rm = na_rm)) +} diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R deleted file mode 100644 index c582ba0..0000000 --- a/R/import-standalone-obj-type.R +++ /dev/null @@ -1,365 +0,0 @@ -# Standalone file: do not edit by hand -# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R -# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-obj-type.R -# last-updated: 2024-02-14 -# license: https://unlicense.org -# imports: rlang (>= 1.1.0) -# --- -# -# ## Changelog -# -# 2024-02-14: -# - `obj_type_friendly()` now works for S7 objects. -# -# 2023-05-01: -# - `obj_type_friendly()` now only displays the first class of S3 objects. -# -# 2023-03-30: -# - `stop_input_type()` now handles `I()` input literally in `arg`. -# -# 2022-10-04: -# - `obj_type_friendly(value = TRUE)` now shows numeric scalars -# literally. -# - `stop_friendly_type()` now takes `show_value`, passed to -# `obj_type_friendly()` as the `value` argument. -# -# 2022-10-03: -# - Added `allow_na` and `allow_null` arguments. -# - `NULL` is now backticked. -# - Better friendly type for infinities and `NaN`. -# -# 2022-09-16: -# - Unprefixed usage of rlang functions with `rlang::` to -# avoid onLoad issues when called from rlang (#1482). -# -# 2022-08-11: -# - Prefixed usage of rlang functions with `rlang::`. -# -# 2022-06-22: -# - `friendly_type_of()` is now `obj_type_friendly()`. -# - Added `obj_type_oo()`. -# -# 2021-12-20: -# - Added support for scalar values and empty vectors. -# - Added `stop_input_type()` -# -# 2021-06-30: -# - Added support for missing arguments. -# -# 2021-04-19: -# - Added support for matrices and arrays (#141). -# - Added documentation. -# - Added changelog. -# -# nocov start - -#' Return English-friendly type -#' @param x Any R object. -#' @param value Whether to describe the value of `x`. Special values -#' like `NA` or `""` are always described. -#' @param length Whether to mention the length of vectors and lists. -#' @return A string describing the type. Starts with an indefinite -#' article, e.g. "an integer vector". -#' @noRd -obj_type_friendly <- function(x, value = TRUE) { - if (is_missing(x)) { - return("absent") - } - - if (is.object(x)) { - if (inherits(x, "quosure")) { - type <- "quosure" - } else { - type <- class(x)[[1L]] - } - return(sprintf("a <%s> object", type)) - } - - if (!is_vector(x)) { - return(.rlang_as_friendly_type(typeof(x))) - } - - n_dim <- length(dim(x)) - - if (!n_dim) { - if (!is_list(x) && length(x) == 1) { - if (is_na(x)) { - return(switch( - typeof(x), - logical = "`NA`", - integer = "an integer `NA`", - double = if (is.nan(x)) { - "`NaN`" - } else { - "a numeric `NA`" - }, - complex = "a complex `NA`", - character = "a character `NA`", - .rlang_stop_unexpected_typeof(x) - )) - } - - show_infinites <- function(x) { - if (x > 0) { - "`Inf`" - } else { - "`-Inf`" - } - } - str_encode <- function(x, width = 30, ...) { - if (nchar(x) > width) { - x <- substr(x, 1, width - 3) - x <- paste0(x, "...") - } - encodeString(x, ...) - } - - if (value) { - if (is.numeric(x) && is.infinite(x)) { - return(show_infinites(x)) - } - - if (is.numeric(x) || is.complex(x)) { - number <- as.character(round(x, 2)) - what <- if (is.complex(x)) "the complex number" else "the number" - return(paste(what, number)) - } - - return(switch( - typeof(x), - logical = if (x) "`TRUE`" else "`FALSE`", - character = { - what <- if (nzchar(x)) "the string" else "the empty string" - paste(what, str_encode(x, quote = "\"")) - }, - raw = paste("the raw value", as.character(x)), - .rlang_stop_unexpected_typeof(x) - )) - } - - return(switch( - typeof(x), - logical = "a logical value", - integer = "an integer", - double = if (is.infinite(x)) show_infinites(x) else "a number", - complex = "a complex number", - character = if (nzchar(x)) "a string" else "\"\"", - raw = "a raw value", - .rlang_stop_unexpected_typeof(x) - )) - } - - if (length(x) == 0) { - return(switch( - typeof(x), - logical = "an empty logical vector", - integer = "an empty integer vector", - double = "an empty numeric vector", - complex = "an empty complex vector", - character = "an empty character vector", - raw = "an empty raw vector", - list = "an empty list", - .rlang_stop_unexpected_typeof(x) - )) - } - } - - vec_type_friendly(x) -} - -vec_type_friendly <- function(x, length = FALSE) { - if (!is_vector(x)) { - abort("`x` must be a vector.") - } - type <- typeof(x) - n_dim <- length(dim(x)) - - add_length <- function(type) { - if (length && !n_dim) { - paste0(type, sprintf(" of length %s", length(x))) - } else { - type - } - } - - if (type == "list") { - if (n_dim < 2) { - return(add_length("a list")) - } else if (is.data.frame(x)) { - return("a data frame") - } else if (n_dim == 2) { - return("a list matrix") - } else { - return("a list array") - } - } - - type <- switch( - type, - logical = "a logical %s", - integer = "an integer %s", - numeric = , - double = "a double %s", - complex = "a complex %s", - character = "a character %s", - raw = "a raw %s", - type = paste0("a ", type, " %s") - ) - - if (n_dim < 2) { - kind <- "vector" - } else if (n_dim == 2) { - kind <- "matrix" - } else { - kind <- "array" - } - out <- sprintf(type, kind) - - if (n_dim >= 2) { - out - } else { - add_length(out) - } -} - -.rlang_as_friendly_type <- function(type) { - switch( - type, - - list = "a list", - - NULL = "`NULL`", - environment = "an environment", - externalptr = "a pointer", - weakref = "a weak reference", - S4 = "an S4 object", - - name = , - symbol = "a symbol", - language = "a call", - pairlist = "a pairlist node", - expression = "an expression vector", - - char = "an internal string", - promise = "an internal promise", - ... = "an internal dots object", - any = "an internal `any` object", - bytecode = "an internal bytecode object", - - primitive = , - builtin = , - special = "a primitive function", - closure = "a function", - - type - ) -} - -.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { - abort( - sprintf("Unexpected type <%s>.", typeof(x)), - call = call - ) -} - -#' Return OO type -#' @param x Any R object. -#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, -#' `"R6"`, or `"S7"`. -#' @noRd -obj_type_oo <- function(x) { - if (!is.object(x)) { - return("bare") - } - - class <- inherits(x, c("R6", "S7_object"), which = TRUE) - - if (class[[1]]) { - "R6" - } else if (class[[2]]) { - "S7" - } else if (isS4(x)) { - "S4" - } else { - "S3" - } -} - -#' @param x The object type which does not conform to `what`. Its -#' `obj_type_friendly()` is taken and mentioned in the error message. -#' @param what The friendly expected type as a string. Can be a -#' character vector of expected types, in which case the error -#' message mentions all of them in an "or" enumeration. -#' @param show_value Passed to `value` argument of `obj_type_friendly()`. -#' @param ... Arguments passed to [abort()]. -#' @inheritParams args_error_context -#' @noRd -stop_input_type <- function( - x, - what, - ..., - allow_na = FALSE, - allow_null = FALSE, - show_value = TRUE, - arg = caller_arg(x), - call = caller_env() -) { - # From standalone-cli.R - cli <- env_get_list( - nms = c("format_arg", "format_code"), - last = topenv(), - default = function(x) sprintf("`%s`", x), - inherit = TRUE - ) - - if (allow_na) { - what <- c(what, cli$format_code("NA")) - } - if (allow_null) { - what <- c(what, cli$format_code("NULL")) - } - if (length(what)) { - what <- oxford_comma(what) - } - if (inherits(arg, "AsIs")) { - format_arg <- identity - } else { - format_arg <- cli$format_arg - } - - message <- sprintf( - "%s must be %s, not %s.", - format_arg(arg), - what, - obj_type_friendly(x, value = show_value) - ) - - abort(message, ..., call = call, arg = arg) -} - -oxford_comma <- function(chr, sep = ", ", final = "or") { - n <- length(chr) - - if (n < 2) { - return(chr) - } - - head <- chr[seq_len(n - 1)] - last <- chr[n] - - head <- paste(head, collapse = sep) - - # Write a or b. But a, b, or c. - if (n > 2) { - paste0(head, sep, final, " ", last) - } else { - paste0(head, " ", final, " ", last) - } -} - -# nocov end diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R deleted file mode 100644 index 5214a00..0000000 --- a/R/import-standalone-types-check.R +++ /dev/null @@ -1,596 +0,0 @@ -# Standalone file: do not edit by hand -# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R -# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-types-check.R -# last-updated: 2023-03-13 -# license: https://unlicense.org -# dependencies: standalone-obj-type.R -# imports: rlang (>= 1.1.0) -# --- -# -# ## Changelog -# -# 2024-08-15: -# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) -# -# 2023-03-13: -# - Improved error messages of number checkers (@teunbrand) -# - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). -# - Added `check_data_frame()` (@mgirlich). -# -# 2023-03-07: -# - Added dependency on rlang (>= 1.1.0). -# -# 2023-02-15: -# - Added `check_logical()`. -# -# - `check_bool()`, `check_number_whole()`, and -# `check_number_decimal()` are now implemented in C. -# -# - For efficiency, `check_number_whole()` and -# `check_number_decimal()` now take a `NULL` default for `min` and -# `max`. This makes it possible to bypass unnecessary type-checking -# and comparisons in the default case of no bounds checks. -# -# 2022-10-07: -# - `check_number_whole()` and `_decimal()` no longer treat -# non-numeric types such as factors or dates as numbers. Numeric -# types are detected with `is.numeric()`. -# -# 2022-10-04: -# - Added `check_name()` that forbids the empty string. -# `check_string()` allows the empty string by default. -# -# 2022-09-28: -# - Removed `what` arguments. -# - Added `allow_na` and `allow_null` arguments. -# - Added `allow_decimal` and `allow_infinite` arguments. -# - Improved errors with absent arguments. -# -# -# 2022-09-16: -# - Unprefixed usage of rlang functions with `rlang::` to -# avoid onLoad issues when called from rlang (#1482). -# -# 2022-08-11: -# - Added changelog. -# -# nocov start - -# Scalars ----------------------------------------------------------------- - -.standalone_types_check_dot_call <- .Call - -check_bool <- function( - x, - ..., - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if ( - !missing(x) && - .standalone_types_check_dot_call( - ffi_standalone_is_bool_1.0.7, - x, - allow_na, - allow_null - ) - ) { - return(invisible(NULL)) - } - - stop_input_type( - x, - c("`TRUE`", "`FALSE`"), - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_string <- function( - x, - ..., - allow_empty = TRUE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - is_string <- .rlang_check_is_string( - x, - allow_empty = allow_empty, - allow_na = allow_na, - allow_null = allow_null - ) - if (is_string) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a single string", - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -.rlang_check_is_string <- function(x, allow_empty, allow_na, allow_null) { - if (is_string(x)) { - if (allow_empty || !is_string(x, "")) { - return(TRUE) - } - } - - if (allow_null && is_null(x)) { - return(TRUE) - } - - if (allow_na && (identical(x, NA) || identical(x, na_chr))) { - return(TRUE) - } - - FALSE -} - -check_name <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - is_string <- .rlang_check_is_string( - x, - allow_empty = FALSE, - allow_na = FALSE, - allow_null = allow_null - ) - if (is_string) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a valid name", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -IS_NUMBER_true <- 0 -IS_NUMBER_false <- 1 -IS_NUMBER_oob <- 2 - -check_number_decimal <- function( - x, - ..., - min = NULL, - max = NULL, - allow_infinite = TRUE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (missing(x)) { - exit_code <- IS_NUMBER_false - } else if ( - 0 == - (exit_code <- .standalone_types_check_dot_call( - ffi_standalone_check_number_1.0.7, - x, - allow_decimal = TRUE, - min, - max, - allow_infinite, - allow_na, - allow_null - )) - ) { - return(invisible(NULL)) - } - - .stop_not_number( - x, - ..., - exit_code = exit_code, - allow_decimal = TRUE, - min = min, - max = max, - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_number_whole <- function( - x, - ..., - min = NULL, - max = NULL, - allow_infinite = FALSE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (missing(x)) { - exit_code <- IS_NUMBER_false - } else if ( - 0 == - (exit_code <- .standalone_types_check_dot_call( - ffi_standalone_check_number_1.0.7, - x, - allow_decimal = FALSE, - min, - max, - allow_infinite, - allow_na, - allow_null - )) - ) { - return(invisible(NULL)) - } - - .stop_not_number( - x, - ..., - exit_code = exit_code, - allow_decimal = FALSE, - min = min, - max = max, - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -.stop_not_number <- function( - x, - ..., - exit_code, - allow_decimal, - min, - max, - allow_na, - allow_null, - arg, - call -) { - if (allow_decimal) { - what <- "a number" - } else { - what <- "a whole number" - } - - if (exit_code == IS_NUMBER_oob) { - min <- min %||% -Inf - max <- max %||% Inf - - if (min > -Inf && max < Inf) { - what <- sprintf("%s between %s and %s", what, min, max) - } else if (x < min) { - what <- sprintf("%s larger than or equal to %s", what, min) - } else if (x > max) { - what <- sprintf("%s smaller than or equal to %s", what, max) - } else { - abort("Unexpected state in OOB check", .internal = TRUE) - } - } - - stop_input_type( - x, - what, - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_symbol <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_symbol(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a symbol", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_arg <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_symbol(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an argument name", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_call <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_call(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a defused call", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_environment <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_environment(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an environment", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_function <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_function(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a function", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_closure <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_closure(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an R function", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_formula <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_formula(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a formula", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - - -# Vectors ----------------------------------------------------------------- - -# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` - -check_character <- function( - x, - ..., - allow_na = TRUE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_character(x)) { - if (!allow_na && any(is.na(x))) { - abort( - sprintf("`%s` can't contain NA values.", arg), - arg = arg, - call = call - ) - } - - return(invisible(NULL)) - } - - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a character vector", - ..., - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_logical <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is_logical(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a logical vector", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_data_frame <- function( - x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env() -) { - if (!missing(x)) { - if (is.data.frame(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a data frame", - ..., - allow_null = allow_null, - arg = arg, - call = call - ) -} - -# nocov end diff --git a/man/cv.Rd b/man/cv.Rd index 87dbaa9..e657124 100644 --- a/man/cv.Rd +++ b/man/cv.Rd @@ -50,5 +50,9 @@ cv(avacha, obs) # Or as numeric vectors cv_vec(avacha$obs) } +\seealso{ +Other descriptive statistics: +\code{\link{gm}()} +} \concept{descriptive statistics} \keyword{summary_stats} diff --git a/man/gm.Rd b/man/gm.Rd new file mode 100644 index 0000000..cabfd2d --- /dev/null +++ b/man/gm.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/central-tendency.R +\name{gm} +\alias{gm} +\alias{gm.data.frame} +\alias{gm_vec} +\title{Geometric Mean (GM)} +\usage{ +gm(data, ...) + +\method{gm}{data.frame}(data, truth, na_rm = TRUE, ...) + +gm_vec(truth, na_rm = TRUE, ...) +} +\arguments{ +\item{data}{A \code{data.frame} containing the columns specified by the \code{truth} +and \code{estimate} arguments.} + +\item{...}{Not currently used.} + +\item{truth}{The column identifier for the true results +(that is \code{numeric}). This should be an unquoted column name although +this argument is passed by expression and supports +\link[rlang:topic-inject]{quasiquotation} (you can unquote column +names). For \verb{_vec()} functions, a \code{numeric} vector.} + +\item{na_rm}{A \code{logical} value indicating whether \code{NA} +values should be stripped before the computation proceeds.} +} +\value{ +A \code{tibble} with columns \code{.metric}, \code{.estimator}, +and \code{.estimate} and 1 row of values. + +For grouped data frames, the number of rows returned will be the same as +the number of groups. + +For \code{gm_vec()}, a single \code{numeric} value (or \code{NA}). +} +\description{ +Geometric Mean (GM) +} +\examples{ +library(tidyhydro) + +gm + +# Supply truth as bare column names +gm(avacha, obs) + +# Or as numeric vectors +gm_vec(avacha$obs) +} +\seealso{ +Other descriptive statistics: +\code{\link{cv}()} +} +\concept{descriptive statistics} +\keyword{summary_stats}