feat: add measure class

.Rbuildignore

@@ -18,3 +18,4 @@
 ^codemeta\.json$
 ^CODE_OF_CONDUCT\.md$
 ^src/.*\.o$
+^dev\.R$

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),
+    checkmate (>= 2.3.1)
 LinkingTo: Rcpp
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
@@ -26,3 +27,16 @@ 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'
+    'aaa-new.R'
+    'central-tendency.R'
+    'data.R'
+    'kge.R'
+    'mse.R'
+    'nse.R'
+    'pbias.R'
+    'press.R'
+    'sfe.R'
+    'tidyhydro-package.R'
+    'variability.R'

NAMESPACE

@@ -2,15 +2,10 @@ useDynLib(tidyhydro, .registration = TRUE)
 importFrom(Rcpp, evalCpp)
 # 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)
@@ -20,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)
@@ -29,3 +39,4 @@ export(pbias_vec)
 export(press_vec)
 export(sfe_vec)
 export(cv_vec)
+export(gm_vec)

R/aaa-new.R

@@ -0,0 +1,73 @@
+# 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 [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
+#' 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")
+}
+
+new_measure <- function(fn, class = NULL) {
+  checkmate::assert_function(fn, args = "data")
+
+  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"
+    )
+
+  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))
+}

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
 #'

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
 #'

R/pbias.R

@@ -33,7 +33,6 @@
 #' - **Poor** -- `pbias()` >= ±15.0
 #'
 #' @family numeric metrics
-#' @family accuracy metrics
 #' @templateVar fn pbias
 #' @template return
 #'

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
 #'

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
 #'

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

_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")

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

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)