Skip to content

Intermediate clean up #375

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
nikosbosse merged 18 commits into from
Nov 7, 2023
Merged

Intermediate clean up #375

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
18 commits
Select commit Hold shift + click to select a range
cbaa858
Clean up available_forecasts() a bit, add another test
nikosbosse Oct 29, 2023
6dd2b40
Remove `check_metrics()` function (and add some hacky code to quantil…
nikosbosse Oct 29, 2023
10bfa7d
Replace `get_predictiion_type()` and `get_target_type()` by a single …
nikosbosse Oct 29, 2023
e413b0a
lint files (not all of them, sorry Sam)
nikosbosse Oct 29, 2023
74b84d3
Add functions to remove a scoringutils_ class and scoringutils attrib…
nikosbosse Oct 29, 2023
6bb05db
Add checks for clashes in forecast type and forecast unit directly to…
nikosbosse Oct 29, 2023
0c6fdf6
fix typo in plot_scores_table()
nikosbosse Oct 29, 2023
0e991dc
Simplify documentation for binary metrics
nikosbosse Oct 29, 2023
cd26a5d
Updating documentation for binary metrics again - unsure whether that…
nikosbosse Oct 29, 2023
f206b01
Update documnentation by creating a documentation template from which…
nikosbosse Oct 29, 2023
9fe28e9
Simplify documentation for input checking functions
nikosbosse Oct 30, 2023
4a07dcc
Update documentation for `score()`
nikosbosse Oct 30, 2023
b12f43b
more "simplifications" to the documentation
nikosbosse Oct 30, 2023
49766f5
Rename `check_not_null()` to `assert_not_null()` and `check_equal_len…
nikosbosse Oct 30, 2023
8ba965f
more documentation updates. yep yep yep!
nikosbosse Oct 30, 2023
60dd7e9
simplify and speed up tests a bit
nikosbosse Oct 30, 2023
2f33bdc
Exclude an example from running
nikosbosse Oct 30, 2023
53e6ca5
Merge branch 'scoringutils-review' into intermediate-clean-up
nikosbosse Nov 7, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
15 changes: 8 additions & 7 deletions R/available_forecasts.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,11 +13,13 @@
#' all available columns (apart from a few "protected" columns such as
#' 'predicted' and 'observed') plus "quantile" or "sample_id" where present).
#'
#' @param collapse character vector (default is `c("quantile", "sample"`) with
#' names of categories for which the number of rows should be collapsed to one
#' when counting. For example, a single forecast is usually represented by a
#' @param collapse character vector (default is `c("quantile", "sample_id"`)
#' with names of categories for which the number of rows should be collapsed to
#' one when counting. For example, a single forecast is usually represented by a
#' set of several quantiles or samples and collapsing these to one makes sure
#' that a single forecast only gets counted once.
#' that a single forecast only gets counted once. Setting `collapse = c()`
#' would mean that all quantiles / samples would be counted as individual
#' forecasts.
#'
#' @return A data.table with columns as specified in `by` and an additional
#' column "count" with the number of forecasts.
Expand All @@ -30,12 +32,11 @@
#' data.table::setDTthreads(1) # only needed to avoid issues on CRAN
#'
#' available_forecasts(example_quantile,
#' collapse = c("quantile"),
#' by = c("model", "target_type")
#' )
available_forecasts <- function(data,
by = NULL,
collapse = c("quantile", "sample")) {
collapse = c("quantile", "sample_id")) {

data <- validate(data)
forecast_unit <- attr(data, "forecast_unit")
Expand All @@ -48,7 +49,7 @@ available_forecasts <- function(data,
# collapse several rows to 1, e.g. treat a set of 10 quantiles as one,
# because they all belong to one single forecast that should be counted once
collapse_by <- setdiff(
c(forecast_unit, "quantile", "sample"),
c(forecast_unit, "quantile", "sample_id"),
collapse
)
# filter out "quantile" or "sample" if present in collapse_by, but not data
Expand Down
149 changes: 66 additions & 83 deletions R/check-input-helpers.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,10 +2,9 @@
#'
#' @description Helper function
#' @param x input to check
#' @param x additional arguments to pass to `check_numeric()`
#' @inheritDotParams checkmate::check_numeric
#' @importFrom checkmate check_atomic_vector check_numeric
#' @return Either TRUE if the test is successful or a string with an error
#' message
#' @inherit document_check_functions return
#' @keywords internal
check_numeric_vector <- function(x, ...) {
# check functions must return TRUE on success
Expand All @@ -21,36 +20,6 @@ check_numeric_vector <- function(x, ...) {
}


#' @title Check whether the desired metrics are available in scoringutils
#'
#' @description Helper function to check whether desired metrics are
#' available. If the input is `NULL`, all metrics will be returned.
#'
#' @param metrics character vector with desired metrics
#'
#' @return A character vector with metrics that can be used for downstream
#' computation
#'
#' @keywords internal

check_metrics <- function(metrics) {
# use all available metrics if none are given
if (is.null(metrics)) {
metrics <- available_metrics()
}

# check desired metrics are actually available in scoringutils
available_metrics <- available_metrics()
if (!all(metrics %in% available_metrics)) {
msg <- paste(
"The following metrics are not available:",
toString(setdiff(metrics, available_metrics))
)
warning(msg)
}
return(metrics)
}

#' Check that quantiles are valid
#'
#' @description
Expand All @@ -68,7 +37,6 @@ check_metrics <- function(metrics) {
#' @return None. Function errors if quantiles are invalid.
#'
#' @keywords internal

check_quantiles <- function(quantiles, name = "quantiles", range = c(0, 1)) {
if (any(quantiles < range[1]) || any(quantiles > range[2])) {
stop(name, " must be between ", range[1], " and ", range[2])
Expand All @@ -83,13 +51,13 @@ check_quantiles <- function(quantiles, name = "quantiles", range = c(0, 1)) {
#' @title Helper function to convert assert statements into checks
#'
#' @description Tries to execute an expression. Internally, this is used to
#' see whether assertions fail when checking inputs
#' see whether assertions fail when checking inputs (i.e. to convert an
#' `assert_*()` statement into a check). If the expression fails, the error
#' message is returned. If the expression succeeds, `TRUE` is returned.
#' @param expr an expression to be evaluated
#' @importFrom checkmate assert assert_numeric check_matrix
#' @return Returns TRUE if expression was executed successfully, otherwise
#' returns a string with the resulting error message
#' @inherit document_check_functions return
#' @keywords internal

check_try <- function(expr) {
result <- try(expr, silent = TRUE)
if (is.null(result)) {
Expand All @@ -100,21 +68,19 @@ check_try <- function(expr) {
}





#' @title Check Variable is not NULL
#'
#' @description
#' Check whether a certain variable is not `NULL` and return the name of that
#' variable and the function call where the variable is missing. This function
#' is a helper function that should only be called within other functions
#' @param ... The variables to check
#' @inherit document_assert_functions return
#' @return The function returns `NULL`, but throws an error if the variable is
#' missing.
#'
#' @keywords internal
check_not_null <- function(...) {
assert_not_null <- function(...) {
vars <- list(...)
varnames <- names(vars)

Expand All @@ -134,22 +100,20 @@ check_not_null <- function(...) {
}


#' @title Check Length
#' @title Check Length of Two Vectors is Equal
#'
#' @description
#' Check whether variables all have the same length
#' @param ... The variables to check
#' @param one_allowed logical, allow arguments of length one that can be
#' recycled
#' @param call_levels_up How many levels to go up when including the function
#' call in the error message. This is useful when calling `check_equal_length()`
#' call in the error message. This is useful when calling `assert_equal_length()`
#' within another checking function.
#'
#' @return The function returns `NULL`, but throws an error if variable lengths
#' differ
#' @inherit document_assert_functions return
#'
#' @keywords internal
check_equal_length <- function(...,
assert_equal_length <- function(...,
one_allowed = TRUE,
call_levels_up = 2) {
vars <- list(...)
Expand All @@ -173,7 +137,7 @@ check_equal_length <- function(...,
one_allowed,
"' should have the same length (or length one). Actual lengths: ",
"' should have the same length. Actual lengths: "
)
)

stop(
"Arguments to the following function call: '",
Expand All @@ -186,14 +150,31 @@ check_equal_length <- function(...,
}


#' @title Check Whether There Is a Conflict Between Data and Attributes
#' @description
#' Check whether there is a conflict between a stored attribute and the
#' same value as inferred from the data. For example, this could be if
#' an attribute `forecast_unit` is stored, but is different from the
#' `forecast_unit` inferred from the data. The check is successful if
#' the stored and the inferred value are the same.
#' @param object The object to check
#' @param attribute The name of the attribute to check
#' @param expected The expected value of the attribute
#' @inherit document_check_functions return
#' @keywords internal
check_attribute_conflict <- function(object, attribute, expected) {
existing <- attr(object, attribute)
if (is.vector(existing) && is.vector(expected)) {
existing <- sort(existing)
expected <- sort(expected)
}

if (!is.null(existing) && !identical(existing, expected)) {
msg <- paste0(
"Object has an attribute `", attribute, "`, but it looks different ",
"from what's expected.\n",
"Existing: ", paste(existing, collapse = ", "), "\n",
"Expected: ", paste(expected, collapse = ", "), "\n",
"from what's expected based on the data.\n",
"Existing: ", toString(existing), "\n",
"Expected: ", toString(expected), "\n",
"Running `validate()` again might solve the problem"
)
return(msg)
Expand All @@ -202,7 +183,13 @@ check_attribute_conflict <- function(object, attribute, expected) {
}



#' @title Assure that Data Has a `model` Column
#'
#' @description
#' Check whether the data.table has a column called `model`.
#' If not, a column called `model` is added with the value `Unspecified model`.
#' @return The data.table with a column called `model`
#' @keywords internal
assure_model_column <- function(data) {
if (!("model" %in% colnames(data))) {
message(
Expand All @@ -216,11 +203,11 @@ assure_model_column <- function(data) {


#' Check that all forecasts have the same number of quantiles or samples
#' @param data data.frame to check
#' @description Function checks the number of quantiles or samples per forecast.
#' If the number of quantiles or samples is the same for all forecasts, it
#' returns TRUE and a string with an error message otherwise.
#' @param forecast_unit Character vector denoting the unit of a single forecast.
#' @return Returns an string with a message if any forecasts have differing
#' numbers of samples or quantiles, otherwise returns TRUE
#'
#' @inherit document_check_functions params return
#' @keywords internal
check_number_per_forecast <- function(data, forecast_unit) {
# check whether there are the same number of quantiles, samples --------------
Expand All @@ -242,13 +229,11 @@ check_number_per_forecast <- function(data, forecast_unit) {
}





#' Check columns in data.frame don't have NA values
#' @inheritParams check_columns_present
#' @return Returns an string with a message if any of the column names
#' have NA values, otherwise returns TRUE
#' @description Function checks whether any of the columns in a data.frame,
#' as specified in `columns`, have NA values. If so, it returns a string with
#' an error message, otherwise it returns TRUE.
#' @inherit document_check_functions params return
#'
#' @keywords internal
check_no_NA_present <- function(data, columns) {
Expand Down Expand Up @@ -280,9 +265,7 @@ diagnose <- function(data) {
#' @description
#' Runs [get_duplicate_forecasts()] and returns a message if an issue is encountered
#' @inheritParams get_duplicate_forecasts
#' @return Returns an string with an error message if an issue is found,
#' otherwise returns TRUE
#'
#' @inherit document_check_functions return
#' @keywords internal
check_duplicates <- function(data, forecast_unit = NULL) {
check_duplicates <- get_duplicate_forecasts(data, forecast_unit = forecast_unit)
Expand Down Expand Up @@ -320,10 +303,11 @@ check_duplicates <- function(data, forecast_unit = NULL) {


#' Check column names are present in a data.frame
#' @param data A data.frame or similar to be checked
#' @param columns names of columns to be checked
#' @return Returns string with a message with the first issue encountered if
#' any of the column names are not in data, otherwise returns TRUE
#' @description
#' The functions loops over the column names and checks whether they are
#' present. If an issue is encountered, the function immediately stops
#' and returns a message with the first issue encountered.
#' @inherit document_check_functions params return
#' @importFrom checkmate assert_character
#' @keywords check-inputs
check_columns_present <- function(data, columns) {
Expand All @@ -342,8 +326,10 @@ check_columns_present <- function(data, columns) {
}

#' Test whether all column names are present in a data.frame
#' @param data A data.frame or similar to be checked
#' @param columns names of columns to be checked
#' @description The function checks whether all column names are present. If
#' one or more columns are missing, the function returns FALSE. If all columns
#' are present, the function returns TRUE.
#' @inheritParams document_check_functions
#' @return Returns TRUE if all columns are present and FALSE otherwise
#' @keywords internal
test_columns_present <- function(data, columns) {
Expand All @@ -352,8 +338,10 @@ test_columns_present <- function(data, columns) {
}

#' Test whether column names are NOT present in a data.frame
#' @param data A data.frame or similar to be checked
#' @param columns names of columns to be checked
#' @description The function checks whether all column names are NOT present.
#' If none of the columns are present, the function returns TRUE. If one or
#' more columns are present, the function returns FALSE.
#' @inheritParams document_check_functions
#' @return Returns TRUE if none of the columns are present and FALSE otherwise
#' @keywords internal
test_columns_not_present <- function(data, columns) {
Expand All @@ -366,12 +354,10 @@ test_columns_not_present <- function(data, columns) {

#' Check whether data is data.frame with correct columns
#' @description Checks whether data is a data.frame, whether columns
#' "observed" and "predicted" are presents
#' and checks that only one of "quantile" and "sample_id" is present.
#' @param data A data.frame or similar to be checked
#' "observed" and "predicted" are present, and checks that only one of
#' "quantile" and "sample_id" is present.
#' @inherit document_check_functions params return
#' @importFrom checkmate check_data_frame
#' @return Returns TRUE if basic requirements are satisfied and a string with
#' an error message otherwise
#' @keywords check-inputs
check_data_columns <- function(data) {
is_data <- check_data_frame(data, min.rows = 1)
Expand All @@ -396,8 +382,7 @@ check_data_columns <- function(data) {
#' @description Checks whether an object has an attribute
#' @param object An object to be checked
#' @param attribute name of an attribute to be checked
#' @return Returns TRUE if attribute is there and an error message as
#' a string otherwise
#' @inherit document_check_functions return
#' @keywords check-inputs
check_has_attribute <- function(object, attribute) {
if (is.null(attr(object, attribute))) {
Expand All @@ -408,5 +393,3 @@ check_has_attribute <- function(object, attribute) {
return(TRUE)
}
}


Loading