feat: geometric mean

Author: atsyplenkov

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'

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)

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))
 }

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))
+}