badge.R

#' README badges
#'
#' These helpers produce the markdown text you need in your README to include
#' badges that report information, such as the CRAN version or test coverage,
#' and link out to relevant external resources. To add badges automatically
#' ensure your badge block starts with a line containing only
#' `<!-- badges: start -->` and ends with a line containing only
#' `<!-- badges: end -->`.
#'
#' @details
#'
#' * `use_badge()`: a general helper used in all badge functions
#' * `use_bioc_badge()`: badge indicates [BioConductor build
#' status](https://bioconductor.org/developers/)
#' * `use_cran_badge()`: badge indicates what version of your package is
#' available on CRAN, powered by <https://www.r-pkg.org>
#' * `use_lifecycle_badge()`: badge declares the developmental stage of a
#' package according to <https://lifecycle.r-lib.org/articles/stages.html>.
#'
#' * `use_binder_badge()`: badge indicates that your repository can be launched
#' in an executable environment on <https://mybinder.org/>
#'
#' @param badge_name Badge name. Used in error message and alt text
#' @param href,src Badge link and image src
#' @param stage Stage of the package lifecycle. One of "experimental",
#'   "stable", "superseded", or "deprecated".
#' @seealso Functions that configure continuous integration, such as
#'   [use_github_actions()], also create badges.
#'
#' @name badges
#' @examples
#' \dontrun{
#' use_cran_badge()
#' use_lifecycle_badge("stable")
#' }
NULL

#' @rdname badges
#' @export
use_badge <- function(badge_name, href, src) {
  path <- find_readme()
  if (is.null(path)) {
    ui_oops("
    Can't find a README for the current project.
    See {ui_code('usethis::use_readme_rmd()')} for help creating this file.
    Badge link can only be printed to screen.
    ")
    path <- "README"
  }
  changed <- block_append(
    glue("{ui_field(badge_name)} badge"),
    glue("[![{badge_name}]({src})]({href})"),
    path = path,
    block_start = badge_start,
    block_end = badge_end
  )

  if (changed && path_ext(path) == "Rmd") {
    ui_todo("Re-knit {ui_path(path)}")
  }
  invisible(changed)
}

#' @rdname badges
#' @export
use_cran_badge <- function() {
  check_is_package("use_cran_badge()")
  pkg <- project_name()

  src <- glue("https://www.r-pkg.org/badges/version/{pkg}")
  href <- glue("https://CRAN.R-project.org/package={pkg}")
  use_badge("CRAN status", href, src)

  invisible(TRUE)
}

#' @rdname badges
#' @export
use_bioc_badge <- function() {
  check_is_package("use_bioc_badge()")
  pkg <- project_name()

  src <- glue("http://www.bioconductor.org/shields/build/release/bioc/{pkg}.svg")
  href <- glue("https://bioconductor.org/checkResults/release/bioc-LATEST/{pkg}")
  use_badge("BioC status", href, src)

  invisible(TRUE)
}

#' @rdname badges
#' @export
use_lifecycle_badge <- function(stage) {
  check_is_package("use_lifecycle_badge()")
  pkg <- project_name()

  stage <- tolower(stage)
  stage <- arg_match0(stage, names(stages))
  colour <- stages[[stage]]

  src <- glue("https://img.shields.io/badge/lifecycle-{stage}-{colour}.svg")
  href <- glue("https://lifecycle.r-lib.org/articles/stages.html#{stage}")
  use_badge(paste0("Lifecycle: ", stage), href, src)

  invisible(TRUE)
}

stages <- c(
  experimental = "orange",
  stable = "brightgreen",
  superseded = "blue",
  deprecated = "orange"
)

#' @rdname badges
#' @param ref A Git branch, tag, or SHA
#' @param urlpath An optional `urlpath` component to add to the link, e.g.
#'   `"rstudio"` to open an RStudio IDE instead of a Jupyter notebook. See the
#'   [binder
#'   documentation](https://mybinder.readthedocs.io/en/latest/howto/user_interface.html)
#'    for additional examples.
#' @export
use_binder_badge <- function(ref = git_branch_default(), urlpath = NULL) {
  repo_spec <- target_repo_spec()

  if (is.null(urlpath)) {
    urlpath <- ""
  } else {
    urlpath <- glue("?urlpath={urlpath}")
  }
  url <- glue("https://mybinder.org/v2/gh/{repo_spec}/{ref}{urlpath}")
  img <- "https://mybinder.org/badge_logo.svg"
  use_badge("Launch binder", url, img)

  invisible(TRUE)
}

has_badge <- function(href) {
  readme_path <- proj_path("README.md")
  if (!file_exists(readme_path)) {
    return(FALSE)
  }

  readme <- read_utf8(readme_path)
  any(grepl(href, readme, fixed = TRUE))
}

# Badge data structure ----------------------------------------------------

badge_start <- "<!-- badges: start -->"
badge_end <- "<!-- badges: end -->"

find_readme <- function() {
  path_first_existing(proj_path(c("README.Rmd", "README.md")))
}