#' Warn if
#'
#' Friendlier messaging functions.
#'
#' @export
#'
#' @param .x the element to evaluate. It can be a predicate function (i.e a function returning TRUE).
#' @param .l the list of elements to evaluate
#' @param .p the predicate with the condition to test on \code{.x} or \code{.l}. Default is \code{isTRUE}.
#' @param msg the message to return. If NULL (default), the built-in message is printed.
#'
#' @importFrom rlang as_function
#'
#' @rdname messagehandler
#'
#' @examples
#' \dontrun{
#' x <- 12
#' stop_if(x, ~ .x > 13)
#' stop_if_not(x, is.character)
#'
#' a <- "this is not numeric"
#' warn_if(a, is.character)
#' warn_if_not(a, is.numeric)
#' b <- 20
#' warn_if(
#' b,
#' ~ . > 10,
#' msg = "Wow, that's a lot of b"
#' )
#' c <- "a"
#' message_if(
#' c,
#' is.character,
#' msg = "You entered a character element"
#' )
#' }
#'
stop_if <- function(
.x,
.p = isTRUE,
msg = NULL
) {
if (as_function(.p)(.x)) {
if (is.null(msg)) {
stop(
paste0(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned an error."
),
call. = FALSE
)
} else {
stop(
msg,
call. = FALSE
)
}
}
}
#' @export
#' @rdname messagehandler
stop_if_any <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_any(
.l,
.p,
~ stop(
msg,
call. = FALSE
)
)
}
#' @export
#' @rdname messagehandler
stop_if_all <- function(
.l,
.p = isTRUE,
msg = NULL
) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_all(
.l,
.p,
~ stop(
msg,
call. = FALSE
)
)
}
#' @export
#' @rdname messagehandler
stop_if_none <- function(
.l,
.p = isTRUE,
msg = NULL
) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_none(
.l,
.p,
~ stop(
msg,
call. = FALSE
)
)
}
#' @export
#' @rdname messagehandler
stop_if_not <- function(
.x,
.p = isTRUE,
msg = NULL
) {
if (!as_function(.p)(.x)) {
if (is.null(msg)) {
stop(
paste0(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned an error."
),
call. = FALSE
)
} else {
stop(msg, call. = FALSE)
}
}
}
#' @export
#' @rdname messagehandler
warn_if <- function(
.x,
.p = isTRUE,
msg = NULL
) {
if (as_function(.p)(.x)) {
if (is.null(msg)) {
warning(
paste0(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned a warning."
),
call. = FALSE,
immediate. = TRUE
)
} else {
warning(msg, call. = FALSE)
}
}
}
#' @export
#' @rdname messagehandler
warn_if_any <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_any(
.l,
.p,
~ warning(
msg,
call. = FALSE
)
)
}
#' @export
#' @rdname messagehandler
warn_if_all <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(substitute(.l)),
"` on `",
deparse(substitute(.p)),
"` returned an alert."
)
}
if_all(
.l,
.p,
~ warning(msg, call. = FALSE)
)
}
#' @export
#' @rdname messagehandler
warn_if_none <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_none(
.l,
.p,
~ warning(msg, call. = FALSE)
)
}
#' @export
#' @rdname messagehandler
warn_if_not <- function(.x, .p = isTRUE, msg = NULL) {
if (!as_function(.p)(.x)) {
if (is.null(msg)) {
warning(
paste0(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned a warning."
),
call. = FALSE,
immediate. = TRUE
)
} else {
warning(msg, call. = FALSE)
}
}
}
#' @export
#' @rdname messagehandler
message_if <- function(.x = NULL, .p = isTRUE, msg = NULL) {
if (as_function(.p)(.x)) {
if (is.null(msg)) {
message(
paste(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned an alert."
)
)
} else {
message(msg)
}
}
}
#' @export
#' @rdname messagehandler
message_if_any <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste(
"Test `",
deparse(
substitute(.l)
),
"` on `",
deparse(
substitute(.p)
),
"` returned an alert."
)
}
if_any(
.l,
.p,
~ message(msg)
)
}
#' @export
#' @rdname messagehandler
message_if_all <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste("Test `", deparse(substitute(.l)), "` on `", deparse(substitute(.p)), "` returned an alert.")
}
if_all(
.l,
.p,
~ message(msg)
)
}
#' @export
#' @rdname messagehandler
message_if_none <- function(.l, .p = isTRUE, msg = NULL) {
if (is.null(msg)) {
msg <- paste("Test `", deparse(substitute(.l)), "` on `", deparse(substitute(.p)), "` returned an alert.")
}
if_none(
.l,
.p,
~ message(msg)
)
}
#' @export
#' @rdname messagehandler
message_if_not <- function(.x, .p = isTRUE, msg = NULL) {
if (!as_function(.p)(.x)) {
if (is.null(msg)) {
message(
paste(
"Test `",
deparse(
substitute(.p)
),
"` on `",
deparse(
substitute(.x)
),
"` returned an alert."
)
)
} else {
message(msg)
}
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.