R/compat-lifecycle.R

In Thie1e/cutpointr: Determine and Evaluate Optimal Cutpoints in Binary Classification Tasks

# nocov start --- compat-lifecycle --- 2019-06-13 Wed 10:58

# This file serves as a reference for currently unexported rlang
# lifecycle functions. Please find the most recent version in rlang's
# repository. These functions require rlang in your `Imports`
# DESCRIPTION field but you don't need to import rlang in your
# namespace.


#' Signal deprecation
#'
#' @description
#'
#' These functions provide two levels of verbosity for deprecation
#' warnings.
#'
#' * `signal_soft_deprecated()` warns only if called from the global
#'   environment (so the user can change their script) or from the
#'   package currently being tested (so the package developer can fix
#'   the package).
#'
#' * `warn_deprecated()` warns unconditionally.
#'
#' * `stop_defunct()` fails unconditionally.
#'
#' Both functions warn only once per session by default to avoid
#' overwhelming the user with repeated warnings.
#'
#' @param msg The deprecation message.
#' @param id The id of the deprecation. A warning is issued only once
#'   for each `id`. Defaults to `msg`, but you should give a unique ID
#'   when the message is built programmatically and depends on inputs.
#' @param env The environment in which the soft-deprecated function
#'   was called. A warning is issued if called from the global
#'   environment. If testthat is running, a warning is also called if
#'   the retired function was called from the package being tested.
#'
#' @section Controlling verbosity:
#'
#' The verbosity of retirement warnings can be controlled with global
#' options. You'll generally want to set these options locally with
#' one of these helpers:
#'
#' * `with_lifecycle_silence()` disables all soft-deprecation and
#'   deprecation warnings.
#'
#' * `with_lifecycle_warnings()` enforces warnings for both
#'   soft-deprecated and deprecated functions. The warnings are
#'   repeated rather than signalled once per session.
#'
#' * `with_lifecycle_errors()` enforces errors for both
#'   soft-deprecated and deprecated functions.
#'
#' All the `with_` helpers have `scoped_` variants that are
#' particularly useful in testthat blocks.
#'
#' @noRd
#' @seealso [lifecycle()]
NULL

signal_soft_deprecated <- function(msg, id = msg, env = rlang::caller_env(2)) {
    msg <- lifecycle_validate_message(msg)
    stopifnot(
        rlang::is_string(id),
        rlang::is_environment(env)
    )

    if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) {
        return(invisible(NULL))
    }

    env_inherits_global <- function(env) {
        # `topenv(emptyenv())` returns the global env. Return `FALSE` in
        # that case to allow passing the empty env when the
        # soft-deprecation should not be promoted to deprecation based on
        # the caller environment.
        if (rlang::is_reference(env, emptyenv())) {
            return(FALSE)
        }

        rlang::is_reference(topenv(env), rlang::global_env())
    }

    if (rlang::is_true(rlang::peek_option("lifecycle_verbose_soft_deprecation")) ||
        env_inherits_global(env)) {
        warn_deprecated(msg, id)
        return(invisible(NULL))
    }

    # Test for environment names rather than reference/contents because
    # testthat clones the namespace
    tested_package <- Sys.getenv("TESTTHAT_PKG")
    if (nzchar(tested_package) &&
        identical(Sys.getenv("NOT_CRAN"), "true") &&
        rlang::env_name(topenv(env)) == rlang::env_name(rlang::ns_env(tested_package))) {
        warn_deprecated(msg, id)
        return(invisible(NULL))
    }

    rlang::signal(msg, "lifecycle_soft_deprecated")
}

warn_deprecated <- function(msg, id = msg) {
    msg <- lifecycle_validate_message(msg)
    stopifnot(rlang::is_string(id))

    if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) {
        return(invisible(NULL))
    }

    if (!rlang::is_true(rlang::peek_option("lifecycle_repeat_warnings")) &&
        rlang::env_has(deprecation_env, id)) {
        return(invisible(NULL))
    }

    rlang::env_poke(deprecation_env, id, TRUE);

    has_colour <- function() rlang::is_installed("crayon") && crayon::has_color()
    silv <- function(x) if (has_colour()) crayon::silver(x) else x

    if (rlang::is_true(rlang::peek_option("lifecycle_warnings_as_errors"))) {
        .Signal <- stop_defunct
    } else {
        .Signal <- .Deprecated
    }

    if (!rlang::is_true(rlang::peek_option("lifecycle_repeat_warnings"))) {
        msg <- paste0(msg, "\n",
                      silv("This warning is displayed once per session."))
    }

    .Signal(msg = msg)
}
deprecation_env <- new.env(parent = emptyenv())

stop_defunct <- function(msg) {
    msg <- lifecycle_validate_message(msg)
    err <- rlang::cnd(
        c("defunctError", "error", "condition"),
        old = NULL,
        new = NULL,
        package = NULL,
        message = msg
    )
    stop(err)
}

scoped_lifecycle_silence <- function(frame = rlang::caller_env()) {
    rlang::scoped_options(.frame = frame,
                          lifecycle_disable_warnings = TRUE
    )
}
with_lifecycle_silence <- function(expr) {
    scoped_lifecycle_silence()
    expr
}

scoped_lifecycle_warnings <- function(frame = rlang::caller_env()) {
    rlang::scoped_options(.frame = frame,
                          lifecycle_disable_warnings = FALSE,
                          lifecycle_verbose_soft_deprecation = TRUE,
                          lifecycle_repeat_warnings = TRUE
    )
}
with_lifecycle_warnings <- function(expr) {
    scoped_lifecycle_warnings()
    expr
}

scoped_lifecycle_errors <- function(frame = rlang::caller_env()) {
    scoped_lifecycle_warnings(frame = frame)
    rlang::scoped_options(.frame = frame,
                          lifecycle_warnings_as_errors = TRUE
    )
}
with_lifecycle_errors <- function(expr) {
    scoped_lifecycle_errors()
    expr
}


#' Embed a lifecycle badge in documentation
#'
#' @description
#'
#' Use `lifecycle()` within a `Sexpr` macro to embed a
#' [lifecycle](https://www.tidyverse.org/lifecycle/) badge in your
#' documentation. The badge should appear first in the description:
#'
#' ```
#' \Sexpr[results=rd, stage=render]{mypkg:::lifecycle("questioning")}
#' ```
#'
#' The badge appears as an image in the HTML version of the
#' documentation. To make them available in your package, visit
#' <https://github.com/r-lib/rlang/tree/master/man/figures> and copy
#' all the files starting with `lifecycle-` in your `man/figures/`
#' folder.
#'
#' @param stage A lifecycle stage as a string, one of:
#'   `"experimental"`, `"maturing"`, `"stable"`, `"questioning"`,
#'   `"archived"`, `"soft-deprecated"`, `"deprecated"`, `"defunct"`.
#'
#' @noRd
NULL


upcase1 <- function(x) {
    substr(x, 1, 1) <- toupper(substr(x, 1, 1))
    x
}

lifecycle_img <- function(stage, url) {
    file <- sprintf("lifecycle-%s.svg", stage)
    stage_alt <- upcase1(stage)

    switch(stage,

           experimental = ,
           maturing = ,
           stable = ,
           questioning = ,
           retired = ,
           archived =
               sprintf(
                   "\\out{<a href='%s'><img src='%s' alt='%s lifecycle'></a>}",
                   url,
                   file.path("figures", file),
                   stage_alt
               )
           ,

           `soft-deprecated` = ,
           deprecated = ,
           defunct =
               sprintf(
                   "\\figure{%s}{options: alt='%s lifecycle'}",
                   file,
                   stage_alt
               ),

           rlang::abort(sprintf("Unknown lifecycle stage `%s`", stage))

    )
}

lifecycle_validate_message <- function(msg) {
    stopifnot(rlang::is_character(msg))
    paste0(msg, collapse = "\n")
}

lifecycle <- function(stage) {
    url <- paste0("https://www.tidyverse.org/lifecycle/#", stage)
    img <- lifecycle_img(stage, url)

    sprintf(
        "\\ifelse{html}{%s}{\\strong{%s}}",
        img,
        upcase1(stage)
    )
}