In salim-b/salim: A Wild Mix of Functions Serving Various Purposes

INTERNAL

Avoid `R CMD check` NOTES about undefined global objects

cf. https://github.com/tidyverse/magrittr/issues/29#issuecomment-74313262.

utils::globalVariables(names = c(".",
                                 ":=",
                                 # other
                                 "download_url",
                                 "filename",
                                 "id",
                                 "name",
                                 "version_nr"))

Functions

`as_code_chunk_array`

as_code_chunk_array <- function(x) {

  if (length(x) == 1L) {
    return(paste0("#|   - ", x))
  }

  yaml::as.yaml(x) |>
    stringr::str_split_1("\n") %>%
    magrittr::extract(nchar(.) > 0L) %>%
    paste0("#|   ", .,
           collapse = "\n")
}

`as_yaml_inline`

as_yaml_inline <- function(x) {
  yaml::as.yaml(x) |> stringr::str_remove(pattern = "\n$")
}

`pkg_mgr_hint`

pkg_mgr_hint <- function(software = names(pkg_mgr_software)) {

  software <- rlang::arg_match(software)

  result <- ""

  if (xfun::is_macos()) {
    result %<>% paste0(pkg_mgr_prose(software = software,
                                     pkg_mgrs = "brew"))

  } else if (xfun::is_windows()) {
    result %<>% paste0(pkg_mgr_prose(software = software,
                                     pkg_mgrs = c("scoop", "choco")))
  }

  result
}

`pkg_mgr_prose`

pkg_mgr_prose <- function(software,
                          pkg_mgrs = c("brew", "scoop", "choco")) {
  pkg_mgr_names <-
    pkg_mgrs |>
    dplyr::case_match("brew" ~ "Homebrew",
                      "scoop" ~ "Scoop",
                      "choco" ~ "Chocolatey")

  pkg_mgr_software |>
    purrr::chuck(software) |>
    purrr::keep_at(at = pkg_mgrs) |>
    purrr::map2_chr(.y = pkg_mgr_names,
                    .f = \(x, y) paste0(y, " ({.code ", x$cmd, "})")) |>
    pal::enum_str(sep2 = " or ") |>
    pal::when(length(.) > 0L ~ paste0(" ", software, " is also available via ", ., "."),
              ~ "")
}

EXPORTED

Spoken language

Multi-language

`prettify_date`

DEPRECATED: stringi::stri_datetime_format(format = c("date_short", "date_medium", "date_long", "date_full"), locale = "de-CH") is superior in every regard!

TODO:

This fn somehow acts very strangely during FOKUS questionnaire generation: Although we use salim::prettify_date(ballot_date, locale = 'de'), it results in October 18, 2020, i.e. doesn't even use the proper format string.

NOTES:

Relevant SO question: What is a reliable way of getting allowed locale names in R?
Base R's conversion specifiers like %Y are documented in ?strptime.

#' Prettify date
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#' 
#' Use [stringi::stri_datetime_format()] instead:
#' 
#' ```r
#' stringi::stri_datetime_format(format = c("date_short", "date_medium", "date_long", "date_full"),
#'                               locale = "en")
#' ```
#'
#' @details
#' Note that this might only work on (Ubuntu) Linux in the current form since locales are one bitchy hell of a PITA...
#'
#' @param date Date to be prettified. A [date][base::Date] or something coercible to.
#' @param locale Locale the date should be prettified for. Currently only `"en"`/`"en-US"` and `"de"`/`"de-CH"` are implemented.
#'
#' @return A character scalar.
#' @family spoken
#' @keywords internal
#'
#' @examples
#' salim:::prettify_date("2021-12-21")
prettify_date <- function(date,
                          locale = c("en", "de", "en-US", "de-CH")) {

  lifecycle::deprecate_warn(when = "0.0.9015",
                            what = "prettify_date()",
                            details = paste0('Use the more powerful and more robust `stringi::stri_datetime_format(format = c("date_short", "date_medium", ',
                                             '"date_long", "date_full"), locale = "en")` function instead.'))

  locale <- rlang::arg_match(locale)

  withr::with_locale(new = c(LC_TIME = pal::when(. = locale,
                                                 . %in% c("en", "en-US") ~ "C",
                                                 . %in% c("de", "de-CH") ~ "de_CH.utf8")),
                     code =
                       locale |>
                       pal::when(. %in% c("en", "en-US") ~
                                   "%B %d, %Y",
                                 . %in% c("de", "de-CH") ~
                                   "%d. %B %Y",
                                 ~ cli::cli_abort("Specified {.arg locale} not implemented yet.")) |>
                       format(x = lubridate::as_date(date)))
}

`prettify_datetime`

DEPRECATED, see above.

#' Prettify datetime
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#' 
#' Use [stringi::stri_datetime_format()] instead:
#' 
#' ```r
#' stringi::stri_datetime_format(format = c("datetime_short", "datetime_medium", "datetime_long", "datetime_full"),
#'                               locale = "en")
#' ```
#'
#' @details
#' Note that this might only work on (Ubuntu) Linux in the current form since locales are one bitchy hell of a PITA...
#'
#' @param datetime Datetime to be prettified. A [datetime][base::DateTimeClasses] or something coercible to.
#' @param locale Locale the datetime should be prettified for. Currently only `"en"`/`"en-US"` and `"de"`/`"de-CH"` are implemented.
#'
#' @return A character scalar.
#' @family spoken
#' @keywords internal
#'
#' @examples
#' salim:::prettify_datetime("2021-12-21T00:00:01Z")
prettify_datetime <- function(datetime,
                              locale = c("en", "de", "en-US", "de-CH")) {

  lifecycle::deprecate_warn(when = "0.0.9015",
                            what = "prettify_datetime()",
                            details = paste0('Use the more powerful and more robust `stringi::stri_datetime_format(format = c("datetime_short", ',
                                             '"datetime_medium", "datetime_long", "datetime_full"), locale = "en")` function instead.'))

  locale <- rlang::arg_match(locale)

  withr::with_locale(new = c(LC_TIME = pal::when(. = locale,
                                                 . %in% c("en", "en-US") ~ "C",
                                                 . %in% c("de", "de-CH") ~ "de_CH.utf8")),
                     code =
                       locale |>
                       pal::when(. %in% c("en", "en-US") ~
                                   "%B %d, %Y, %I:%M %p",
                                 . %in% c("de", "de-CH") ~
                                   "%d. %B %Y, %H:%M Uhr",
                                 ~ cli::cli_abort("Specified {.arg locale} not implemented yet.")) |>
                       format(x = lubridate::as_datetime(datetime)))
}

`rank_nr`

#' Convert an integer into spelled abbreviated English or German rank
#'
#' @param x An integer scalar or something coercible to.
#' @param lang The language to write the rank in.
#'
#' @return A character scalar.
#' @family spoken
#' @export
rank_nr <- function(x,
                    lang = c("en", "de")) {

  lang <- rlang::arg_match(lang)
  result <- "?"

  if (length(x) > 0L) {

    if (lang == "de") {
      result <- switch(EXPR = as.character(as.integer(x)),
                       "1" = "erste",
                       "2" = "zweite",
                       "3" = "dritte",
                       "4" = "vierte",
                       "5" = "f\u00fcnfte",
                       "6" = "sechste",
                       "7" = "siebte",
                       "8" = "achte",
                       "9" = "neunte",
                       "?")

    } else if (lang == "en") {
      result <- switch(EXPR = as.character(as.integer(x)),
                       "1" = "1st",
                       "2" = "2nd",
                       "3" = "3rd",
                       "4" = "4th",
                       "5" = "5th",
                       "6" = "6th",
                       "7" = "7th",
                       "8" = "8th",
                       "9" = "9th",
                       "?")
    }
  }

  result
}

`write_out_n`

Caveats:

German is only covered from 0 to 9.
No support for grammatical gender -- articles of definite descriptors are always feminine.

#' Write out a count
#'
#' @param n The count to write out in letters. A non-negative integer scalar.
#' @param lang The language to write out `n` in.
#' @param use_singular Use a definite descriptor for `n = 0` and `n = 1` instead of the indistinct number. A logical scalar.
#' @param use_dual Use a definite descriptor for `n = 2` instead of the indistinct number. A logical scalar.
#' @param strip_article Strip the definite article from the definite descriptors. Only relevant if at least one of `use_singular` or `use_dual` is `TRUE`. A
#'   logical scalar.
#'
#' @return A character scalar.
#' @seealso [gt::vec_fmt_spelled_num()] which spells out integers from 0 to 100 in `r length(setdiff(colnames(gt:::spelled_num), "number"))` different locales.
#' @family spoken
#' @export
write_out_n <- function(n,
                        lang = c("en", "de"),
                        use_singular = FALSE,
                        use_dual = FALSE,
                        strip_article = use_dual) {

  n %<>% checkmate::assert_count() %>% as.character()
  lang <- rlang::arg_match(lang)
  checkmate::assert_flag(use_singular)
  checkmate::assert_flag(use_dual)
  checkmate::assert_flag(strip_article)

  if (lang == "en") {

    result <- switch(EXPR = n,
                     `0` = ifelse(use_singular,
                                  "no",
                                  "zero"),
                     `1` = ifelse(use_singular,
                                  "the",
                                  "one"),
                     `2` = ifelse(use_dual,
                                  "the two",
                                  "two"),
                     xfun::numbers_to_words(as.integer(n)))

  } else if (lang == "de") {

    result <- switch(EXPR = n,
                     `0` = ifelse(use_singular,
                                  "keine",
                                  "null"),
                     `1` = ifelse(use_singular,
                                  "die",
                                  "ein"),
                     `2` = ifelse(use_dual,
                                  "die beiden",
                                  "zwei"),
                     `3` = "drei",
                     `4` = "vier",
                     `5` = "f\u00fcnf",
                     `6` = "sechs",
                     `7` = "sieben",
                     `8` = "acht",
                     `9` = "neun")
  }

  if (strip_article) {
    result %<>% stringr::str_remove(pattern = switch(EXPR = lang,
                                                     de = "^[Dd]ie ?",
                                                     en = "^[Tt]he ?"))
  }

  result
}

English

`n_ify`

#' Append `"n"` to indefinite article where indicated
#'
#' Appends an `"n"` to the indefinite article "a" if required by English language rules.
#'
#' Note that this function only covers part of all cases where "an" instead of "a" is indicated. Since the choice of _a_ or _an_ [depends on sound, not 
#' spelling](http://www.butte.edu/departments/cas/tipsheets/grammar/articles.html), it's not trivial to implement a universal solution.
#'
#' For example, this function doesn't properly append an `"n"` to the indefinite article in the following situations:
#' - A word starting with the letter "u" where it is pronounced as a vowel, e.g. _**unhappy**_. Note that most English words starting with letter "u" are
#'   pronounced differently like _universum_ and thus require the indefinite article _a_, not _an_.
#' - A word starting with a consonant that is pronounced as a vowel, e.g. _**hour**_.
#'
#' @param x A character vector.
#'
#' @return A character vector.
#' @family spoken
#' @export
#'
#' @examples
#' n_ify("This is a absolute disaster, such a error.")
n_ify <- function(x) {

  purrr::map_chr(.x = x,
                 .f = \(s) stringr::str_replace_all(string = s,
                                                    pattern = "(^[Aa]| a)(?= [AaEeOoIi]\\w+)",
                                                    replacement = "\\1n"))
}

German

`definite_article_de`

#' Get the German definite article
#'
#' @param gender The grammatical gender of the subject the definite article refers to.
#' @param case The grammatical case of the subject the definite article refers to.
#' @param pluralize Whether to return the plural form of the definite article. A logical scalar.
#'
#' @return A character scalar.
#' @family spoken
#' @export
definite_article_de <- function(gender = c("feminine",
                                           "masculine",
                                           "neuter"),
                                case = c("nominative",
                                         "genitive",
                                         "dative",
                                         "accusative"),
                                pluralize = FALSE) {

  gender <- rlang::arg_match(gender)
  case <- rlang::arg_match(case)

  if (checkmate::assert_flag(pluralize)) {

    switch(EXPR = case,
           nominative = "die",
           genitive = "der",
           dative = "den",
           accusative = "die")

  } else {

    switch(EXPR = case,
           nominative = switch(EXPR = gender,
                               feminine = "die",
                               masculine = "der",
                               neuter = "das"),
           genitive = switch(EXPR = gender,
                             feminine = "der",
                             "des"),
           dative = switch(EXPR = gender,
                           feminine = "der",
                           "dem"),
           accusative = switch(EXPR = gender,
                               feminine = "die",
                               masculine = "den",
                               neuter = "das"))
  }
}

`definite_article_de_declined`

#' Decline the German definite article
#'
#' The declination of the German definite article [is a relative pronoun](https://de.wikipedia.org/wiki/Relativpronomen#Der,_die,_das).
#'
#' Note that the second singular feminine and plural genitive form `"derer"` is ignored by this function.
#'
#' @inheritParams definite_article_de
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
definite_article_de_declined <- function(gender = c("feminine",
                                                    "masculine",
                                                    "neuter"),
                                         case = c("nominative",
                                                  "genitive",
                                                  "dative",
                                                  "accusative"),
                                         pluralize = FALSE) {
  gender <- rlang::arg_match(gender)
  case <- rlang::arg_match(case)

  if (checkmate::assert_flag(pluralize)) {

    switch(EXPR = case,
           nominative = "die",
           genitive = "deren",
           dative = "deren",
           accusative = "die")

  } else {

    switch(EXPR = case,
           nominative = switch(EXPR = gender,
                               feminine = "die",
                               masculine = "der",
                               neuter = "das"),
           genitive = switch(EXPR = gender,
                             feminine = "deren",
                             "dessen"),
           dative = switch(EXPR = gender,
                           feminine = "der",
                           "dem"),
           accusative = switch(EXPR = gender,
                               feminine = "die",
                               masculine = "den",
                               neuter = "das"))
  }
}

`add_definite_article_de`

#' Add the German definite article in dative case to a preposition
#'
#' @param preposition The preposition to add the German definite article in dative case to. A character scalar.
#' @param gender The grammatical gender of the `preposition`.
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
add_definite_article_de <- function(preposition,
                                    gender = c("feminine",
                                               "masculine",
                                               "neuter")) {
  checkmate::assert_string(preposition)
  gender <- rlang::arg_match(gender)

  if (gender == "feminine") {

    preposition |> pal::when(stringr::str_to_lower(.) == "zu" ~ paste0(., "r"),
                             ~ paste0(., " ", definite_article_de(gender = "feminine",
                                                                  case = "dative")))
  } else {

    preposition |> pal::when(stringr::str_to_lower(.) %in% c("bei", "zu") ~ paste0(., "m"),
                             stringr::str_to_lower(.) %in% c("in", "an") ~ stringr::str_replace(string = .,
                                                                                                pattern = "n$",
                                                                                                replacement = "m"),
                             ~ paste0(., " ", definite_article_de(gender = "masculine",
                                                                  case = "dative")))
  }
}

`decline_noun_de`

NOTES:

We expect noun to be declined in "indefinite" nominative, i.e. e.g. "weisser Mann", not "weisse Mann".
The function is very incomplete and just covers the cases we encountered during development of the fokus pkg.

#' Decline a German noun
#'
#' Note that this function is far from covering all grammatical possibilities. I.a. it currently doesn't support the [special
#' cases](https://deutsch.lingolia.com/de/grammatik/nomen/deklination/genitiv#a-besonderheiten) where a masculine noun gets an `n` or `en` ending attached in
#' the accusative, dative and genitive cases.
#'
#' @param noun The noun to decline, optionally with preceding adjective(s), in (indefinite) nominative. A character scalar.
#' @param gender The grammatical gender of the `noun`.
#' @param case The grammatical case of the `noun`.
#' @param is_plural Whether or not `noun` is a plural.
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
decline_noun_de <- function(noun,
                            gender = c("feminine",
                                       "masculine",
                                       "neuter"),
                            case = c("nominative",
                                     "genitive",
                                     "dative",
                                     "accusative"),
                            is_plural = FALSE) {

  gender <- rlang::arg_match(gender)
  case <- rlang::arg_match(case)
  checkmate::assert_flag(is_plural)

  result <- noun

  if (gender != "feminine" && case == "genitive") {

    result %<>% pal::when(stringr::str_detect(string = ., pattern = "(ss|\U00DF|x|z)$") ~ paste0(., "es"),
                          endsWith(., "s") ~ paste0(., "ses"),
                          ~ paste0(., "s"))

    # decline preceeding adjectives
  } else if (case %in% c("genitive", "dative") || (case == "accusative" && is_plural)) {
    result %<>% stringr::str_replace_all(pattern = "((?:^|[:blank:])[:alnum:]+e)([:blank:])(?!\\s*$)",
                                         replacement = "\\1n\\2")
  }

  result
}

Regular expression rules

`regex_spelling_normalization`

#' Regular expression patterns and replacements for spelling normalization
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @seealso
#' Other regular expression rules: [`yay::regex_text_normalization`], [`yay::regex_file_normalization`]
#' 
#' String normalization functions: [yay::str_normalize()], [yay::str_normalize_file()]
#'
#' @examples
#' # unnest the pattern column
#' salim::regex_spelling_normalization |> tidyr::unnest_longer(col = pattern)
"regex_spelling_normalization"

Pandoc

TODO: Move these fns to dedicated pkg pndc? Then the pandoc templates at gitlab.com/salim_b/pandoc/templates should be moved inside the pndc pkg repo, but build-ignored.

`download_pandoc_binaries`

#' Download Pandoc release
#'
#' Downloads the [assets][pandoc_release_assets] and extracts the executable program binaries for Linux, macOS and Windows of a certain [Pandoc
#' release][pandoc_releases].
#'
#' @param os The operating system(s) for which Pandoc binaries should be downloaded. Any combination of
#'   `r pal::fn_param_defaults(param = "os", fn = download_pandoc_binaries) |> pal::wrap_chr("\x60") |> cli::ansi_collapse(last = " and ")`.
#' @param path The filesystem path to which the binaries are saved to. A [path][fs::fs_path] or something coercible to.
#' @param overwrite Whether to overwrite existing binaries under `path`.
#' @inheritParams pandoc_release_assets
#'
#' @return `path` invisibly.
#' @family pandoc
#' @export
download_pandoc_binaries <- function(release_id = pandoc_release_id_latest(),
                                     os = c("linux", "macos", "windows"),
                                     path = "bin/",
                                     overwrite = TRUE) {
  checkmate::assert_count(release_id,
                          positive = TRUE)
  checkmate::assert_subset(os,
                           choices = eval(formals()$os),
                           empty.ok = FALSE)
  checkmate::assert_path_for_output(path,
                                    overwrite = TRUE)
  checkmate::assert_flag(overwrite)
  rlang::check_installed("waldo",
                         reason = pal::reason_pkg_required())

  path_tmp <- fs::path_temp()

  assets <-
    pandoc_release_assets(release_id = release_id) |>
    dplyr::filter(stringr::str_detect(string = filename,
                                      pattern = paste0("(?i)", pal::fuse_regex(os), "(-(amd64|x86_64))?\\.(zip|tar\\.gz)"))) |>
    dplyr::mutate(download_path = fs::path(path_tmp, filename))

  # download assets to tmp dir
  purrr::walk2(.x = assets$download_url,
               .y = assets$download_path,
               .f = \(url, path) utils::download.file(url = url,
                                                      destfile = path,
                                                      method = "auto",
                                                      mode = "wb",
                                                      cacheOK = TRUE,
                                                      quiet = TRUE))
  # extract binaries to tmp dir
  assets |>
    dplyr::select(-download_url) |>
    as.list() |>
    purrr::pwalk(.f = \(filename, os, download_path) {

      path_os_tmp <- fs::path(path_tmp, "pandoc", os)

      # extract all files flat
      if (endsWith(filename, ".zip")) {

        zip::unzip(zipfile = download_path,
                   exdir = path_os_tmp,
                   junkpaths = TRUE)
      } else {

        utils::untar(tarfile = download_path,
                     exdir = path_os_tmp)

        # since `untar()` has no "junkpaths"-like option, we flatten the dir structure ourselves
        fs::dir_ls(path = path_os_tmp,
                   type = "file",
                   recurse = TRUE,
                   all = TRUE) |>
          fs::file_move(new_path = path_os_tmp)
      }

      # delete archive and all extracted files but the Pandoc binary
      fs::file_delete(download_path)

      fs::dir_ls(path = path_os_tmp,
                 regexp = "[\\/]pandoc(\\.exe)?$",
                 all = TRUE,
                 invert = TRUE) |>
        fs::file_delete()
    })

  # move binaries to final dir
  fs::dir_create(path = fs::path(path, "pandoc"))

  path_tmp |>
    fs::path("pandoc") %T>%
    fs::dir_copy(new_path = fs::path(path, "pandoc"),
                 overwrite = overwrite) %>%
    fs::dir_delete()

  invisible(path)
}

`pandoc_release_id_latest`

#' Get latest Pandoc release ID
#'
#' Uses [gh::gh()] to fetch [Pandoc](https://pandoc.org/)'s latest [GitHub release](https://docs.github.com/repositories/releasing-projects-on-github) ID via 
#' [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#get-the-latest-release).
#'
#' @return An integer scalar.
#' @family pandoc
#' @export
pandoc_release_id_latest <- function() {

  rlang::check_installed("gh",
                         reason = pal::reason_pkg_required())

  gh::gh(endpoint = "/repos/{owner}/{repo}/releases/latest", # nolint
         owner = "jgm",
         repo = "pandoc",
         .method = "GET") %$%
    id
}

`pandoc_version_latest`

#' Get latest Pandoc release version number
#'
#' Uses [gh::gh()] to fetch [Pandoc](https://pandoc.org/)'s latest [GitHub release](https://docs.github.com/repositories/releasing-projects-on-github) version
#' number via [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#get-the-latest-release) and returns it as a [numeric
#' version][numeric_version()].
#'
#' @return `r pkgsnip::param_lbl("num_vrsn")`
#' @family pandoc
#' @export
pandoc_version_latest <- function() {

  rlang::check_installed("gh",
                         reason = pal::reason_pkg_required())

  gh::gh(endpoint = "/repos/{owner}/{repo}/releases/latest", # nolint
         owner = "jgm",
         repo = "pandoc",
         .method = "GET") %$%
    name |>
    stringr::str_extract(pattern = "\\d+(\\.\\d+)*") |>
    as.numeric_version()
}

`pandoc_releases`

#' List all available Pandoc releases
#'
#' Uses [gh::gh()] to fetch all available [GitHub releases](https://docs.github.com/repositories/releasing-projects-on-github) of [Pandoc](https://pandoc.org/)
#' via [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#list-releases) and returns them as a [tibble][tibble::tbl_df] containing the two
#' columns `version_nr` and `release_id`.
#'
#' Values of the column `release_id` can be used as input to [download_pandoc_binaries()].
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @export
pandoc_releases <- function() {

  rlang::check_installed("gh",
                         reason = pal::reason_pkg_required())

  gh::gh(endpoint = "/repos/{owner}/{repo}/releases", # nolint
         owner = "jgm",
         repo = "pandoc",
         .method = "GET",
         .limit = Inf) |>
    purrr::map(\(x) tibble::tibble(version_nr =
                                     x$name |>
                                     stringr::str_extract(pattern = "\\d+(\\.\\d+)*") |>
                                     as.numeric_version(),
                                   release_id = x$id)) |>
    purrr::list_rbind() |>
    dplyr::arrange(version_nr)
}

`pandoc_release_assets`

#' List Pandoc release assets
#'
#' Uses [gh::gh()] to fetch filenames, corresponding operating systems and download URLs of a specific [GitHub
#' release](https://docs.github.com/repositories/releasing-projects-on-github) of [Pandoc](https://pandoc.org/) via [GitHub's REST
#' API](https://docs.github.com/en/rest/reference/repos#list-release-assets) and returns them as a [tibble][tibble::tbl_df].
#'
#' @param release_id The GitHub release ID of the desired Pandoc release. Use [pandoc_releases()] to determine the release ID of a specific Pandoc version
#'   number. An integer scalar.
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @export
pandoc_release_assets <- function(release_id = pandoc_release_id_latest()) {

  rlang::check_installed("gh",
                         reason = pal::reason_pkg_required())

  gh::gh(endpoint = "/repos/{owner}/{repo}/releases/{release_id}/assets", # nolint
         owner = "jgm",
         repo = "pandoc",
         release_id = release_id,
         .method = "GET") |>
    purrr::map(\(x) tibble::tibble(filename = x$name,
                                   os =
                                     x$name |>
                                     stringr::str_extract(pattern = "(?i)(linux|macos|windows|\\.deb$)") |>
                                     stringr::str_to_lower() |>
                                     stringr::str_replace(pattern = stringr::fixed(".deb"),
                                                          replacement = "linux"),
                                   download_url = x$browser_download_url)) |>
    purrr::list_rbind()
}

`pandoc_tpl`

#' Download Pandoc template
#'
#' Downloads one of our [custom Pandoc templates](https://gitlab.com/salim_b/pandoc/templates) and returns it as a character scalar. The template is cached
#' using [pal::req_cached()], thus only re-downloaded if the local copy is outdated.
#'
#' @param tpl Template to download. One of
#'   `r pal::fn_param_defaults(param = "tpl", fn = "pandoc_tpl") |> pal::wrap_chr("\x60") |> cli::ansi_collapse(last = " and ")`.
#'
#' @return The template as a character scalar.
#' @family pandoc
#' @export
#' 
#' @examples
#' \dontrun{
#' salim::pandoc_tpl(tpl = "quarto_mod.latex") |>
#'   brio::write_file(path = "quarto_mod.latex")}
pandoc_tpl <- function(tpl = "quarto_mod.latex") {

  tpl <- rlang::arg_match(tpl)

  (pal::req_cached(url = glue::glue("https://gitlab.com/salim_b/pandoc/templates/-/raw/main/{tpl}?ref_type=heads&inline=false")) |>
      httr2::resp_body_string())
}

Quarto

TODO: Move these fns tod dedicated pkg qrt?

`quarto_fig_chunk`

#' Assemble Quarto knitr figure chunk
#'
#' Assembles a [Quarto knitr figure chunk](https://quarto.org/docs/authoring/figures.html#computations).
#'
#' Use [substitute] together with [deparse1()] to convert \R expressions to a character scalar as expected by param `body`:
#'
#' ```r
#' deparse1(expr = substitute(do_something()),
#'          collapse = "\n")
#' ```
#'
#' @param body \R code to insert into the code chunk's body. A character scalar.
#' @param label Unique code chunk label. Set as Quarto's [`label`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A 
#'   character scalar that starts with `"fig-"`.
#' @param fig_cap Figure caption. Set as Quarto's [`fig-cap`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character
#'   scalar.
#' @param fig_subcap Figure subcaptions. Set as Quarto's [`fig-subcap`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A
#'   character vector, or `NULL` to omit.
#' @param fig_column Quarto [article layout class](https://quarto.org/docs/authoring/article-layout.html#available-columns) for the figure output. Set as
#'   Quarto's [`fig-column`](https://quarto.org/docs/reference/cells/cells-knitr.html#page-columns) code chunk option. One of
#'   `r pal::as_md_val_list(qmd_layout_classes)`
#' @param fig_width Width of the plot (in inches), to be used in the graphics device. Set as Quarto's
#'   [`fig-width`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A numeric scalar, or `NULL` to omit.
#' @param fig_height Height of the plot (in inches), to be used in the graphics device. Set as Quarto's
#'   [`fig-height`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A numeric scalar, or `NULL` to omit.
#' @param fig_pos LaTeX figure position arrangement to be used in `\begin{figure}[]`. Set as Quarto's
#'   [`fig-pos`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL` to omit. Use `"false"` for
#'   no figure position specifier, which is sometimes necessary with custom figure environments (such as `sidewaysfigure`).
#' @param fig_link Hyperlink target for the figure. Set as Quarto's [`fig-link`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk
#'   option. A character scalar, or `NULL` to omit.
#' @param out_width Width of the plot in the output document, which can be different from its physical `fig_width`, i.e., plots can be scaled in the output
#'   document. Set as Quarto's [`out-width`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL`
#'   to omit.
#' @param out_height Height of the plot in the output document, which can be different from its physical `fig_height`, i.e., plots can be scaled in the output
#'   document. Set as Quarto's [`out-height`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL`
#'   to omit.
#'
#' @return A character scalar.
#' @family quarto
#' @export
#'
#' @examples
#' salim::quarto_fig_chunk(body = "plot(cars)",
#'                         label = "fig-mtcars",
#'                         fig_cap = "Default plot for dataset `cars`",
#'                         fig_column = "page") |>
#'   cat()
quarto_fig_chunk <- function(body,
                             label,
                             fig_cap,
                             fig_subcap = NULL,
                             fig_column = "body",
                             fig_width = NULL,
                             fig_height = NULL,
                             fig_pos = "H",
                             fig_link = NULL,
                             out_width = NULL,
                             out_height = NULL) {

  rlang::check_installed(pkg = "yaml",
                         reason = pal::reason_pkg_required())
  checkmate::assert_string(body)
  checkmate::assert_string(label,
                           pattern = "^fig-.+")
  checkmate::assert_character(fig_cap,
                              any.missing = FALSE,
                              min.len = 1L,
                              null.ok = TRUE)
  checkmate::assert_character(fig_subcap,
                              any.missing = FALSE,
                              null.ok = TRUE)
  checkmate::assert_number(fig_width,
                           lower = 0.0,
                           null.ok = TRUE)
  checkmate::assert_number(fig_height,
                           lower = 0.0,
                           null.ok = TRUE)
  checkmate::assert_string(fig_pos,
                           null.ok = TRUE)
  checkmate::assert_string(fig_link,
                           null.ok = TRUE)
  checkmate::assert_string(out_width,
                           null.ok = TRUE)
  checkmate::assert_string(out_height,
                           null.ok = TRUE)
  fig_column <- rlang::arg_match(arg = fig_column,
                                 values = qmd_layout_classes)
  is_fig_cap_scalar <- length(fig_cap) == 1L
  has_fig_subcap <- length(fig_subcap) > 0L

  # convert to YAML array
  if (has_fig_subcap) {
    fig_subcap %<>% as_code_chunk_array()
  }

  # assemble code chunk
  glue::glue(paste0(c("```{{r}}",
                      "#| label: {as_yaml_inline(label)}",
                      "#| fig-cap:",
                      as_code_chunk_array(fig_cap),
                      "#| fig-subcap:"[has_fig_subcap],
                      fig_subcap,
                      "#| fig-column: {fig_column}",
                      "#| fig-width: {as_yaml_inline(fig_width)}"[!is.null(fig_width)],
                      "#| fig-height: {as_yaml_inline(fig_height)}"[!is.null(fig_height)],
                      "#| fig-pos: {fig_pos}"[!is.null(fig_pos)],
                      "#| fig-link: {as_yaml_inline(fig_link)}"[length(fig_link) > 0L],
                      "#| out-width: {as_yaml_inline(out_width)}"[!is.null(out_width)],
                      "#| out-height: {as_yaml_inline(out_height)}"[!is.null(out_height)],
                      "",
                      "{body}",
                      "```",
                      "",
                      ""),
                    collapse = "\n"))
}

`quarto_tbl_chunk`

#' Assemble Quarto knitr table chunk
#'
#' Assembles a [Quarto knitr table chunk](https://quarto.org/docs/authoring/tables.html#computations).
#'
#' Use [substitute] together with [deparse1()] to convert \R expressions to a character scalar as expected by param `body`:
#'
#' ```r
#' deparse1(expr = substitute(do_something()),
#'          collapse = "\n")
#' ```
#'
#' @param body \R code to insert into the code chunk's body. A character scalar.
#' @param label Unique code chunk label. Set as Quarto's [`label`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A 
#'   character scalar that starts with `"tbl-"`.
#' @param tbl_cap Table caption. Set as Quarto's [`tbl-cap`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A character
#'   scalar.
#' @param tbl_subcap Table subcaptions. Set as Quarto's [`tbl-subcap`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A
#'   character vector.
#' @param tbl_column Quarto [article layout class](https://quarto.org/docs/authoring/article-layout.html#available-columns) for the figure output. Set as
#'   Quarto's [`tbl-column`](https://quarto.org/docs/reference/cells/cells-knitr.html#page-columns) code chunk option. One of
#'   `r pal::as_md_val_list(qmd_layout_classes)`
#' @param tbl_colwidths Apply explicit table column widths for Markdown [grid tables](https://pandoc.org/MANUAL.html#extension-grid_tables) and [pipe
#'   tables](https://pandoc.org/MANUAL.html#extension-pipe_tables) that are more than `columns` characters wide (72 by default).
#' 
#'   Some formats (e.g. HTML) do an excellent job automatically sizing table columns and so don’t benefit much from column width specifications. Other formats
#'   (e.g. LaTeX) require table column sizes in order to correctly flow longer cell content (this is a major reason why tables > 72 columns wide are assigned
#'   explicit widths by Pandoc).
#'   
#'   This can be specified as:
#'   
#'   - `"auto"`: Apply Markdown table column widths except when there is a hyperlink in the table (which tends to throw off automatic calculation of column
#'     widths based on the Markdown text width of cells). `"auto"` is the default for HTML output formats.
#'     
#'   - `"true"`: Always apply Markdown table widths. `"true"` is the default for all non-HTML formats.
#'  
#'   - `"false"`: Never apply Markdown table widths.
#'  
#'   - A numeric vector (e.g. `c(40, 30, 30)`): Array of explicit width percentages.
#'
#' @return A character scalar.
#' @family quarto
#' @export
#'
#' @examples
#' salim::quarto_tbl_chunk(body = "knitr::kable(head(cars))",
#'                         label = "tbl-head-cars",
#'                         tbl_cap = "Head of dataset `cars`",
#'                         tbl_column = "margin") |>
#'   cat()
quarto_tbl_chunk <- function(body,
                             label,
                             tbl_cap,
                             tbl_subcap = NULL,
                             tbl_colwidths = NULL,
                             tbl_column = "body") {

  rlang::check_installed(pkg = "yaml",
                         reason = pal::reason_pkg_required())
  checkmate::assert_string(body)
  checkmate::assert_string(label,
                           pattern = "^tbl-.+")
  checkmate::assert_string(tbl_cap)
  checkmate::assert_character(tbl_subcap,
                              any.missing = FALSE,
                              null.ok = TRUE)
  is_str_tbl_colwidths <- checkmate::test_choice(tbl_colwidths,
                                                 choices = c("auto", "true", "false"))
  is_num_tbl_colwidths <- checkmate::test_numeric(tbl_colwidths,
                                                  min.len = 1L)
  if (!(is.null(tbl_colwidths) || is_str_tbl_colwidths || is_num_tbl_colwidths)) {
    cli::cli_abort('{.arg tbl_colwidths} must be either one of {.val {"auto"}}, {.val {"true"}} or {.val {"false"}}, or a numeric vector.')
  }
  tbl_column <- rlang::arg_match(arg = tbl_column,
                                 values = qmd_layout_classes)
  has_tbl_subcap <- length(tbl_subcap) > 0L

  # convert to YAML array
  if (has_tbl_subcap) {
    tbl_subcap %<>% as_code_chunk_array()
  }

  # assemble code chunk
  glue::glue(paste0(c("```{{r}}",
                      "#| label: {as_yaml_inline(label)}",
                      "#| tbl-cap:",
                      as_code_chunk_array(tbl_cap),
                      "#| tbl-subcap:"[has_tbl_subcap],
                      tbl_subcap,
                      "#| tbl-column: {tbl_column}",
                      "#| tbl-colwidths: {tbl_colwidths}"[is_str_tbl_colwidths],
                      "#| tbl-colwidths:"[is_num_tbl_colwidths],
                      as_code_chunk_array(tbl_colwidths)[is_num_tbl_colwidths],
                      "",
                      "{body}",
                      "```",
                      "",
                      ""),
                    collapse = "\n"))
}

`quarto_chunks`

#' Generate Quarto knitr code chunk snippets from structured data
#'
#' Generates Quarto Markdown (`.qmd`) file snippets with knitr [figure][quarto_fig_chunk] or [table][quarto_tbl_chunk] code chunks from structured `data`.
#'
#' The generated `.qmd` files are intended to be included in other Quarto documents via the built-in
#' [`include`](https://quarto.org/docs/authoring/includes.html) shortcode.
#'
#' # Input `data`
#'
#' All `data` columns of type character are [cli::pluralize()]d, meaning literal curly brackets (`{` and `}`) need to be escaped by doubling them (to `{{` and
#' `}}`).
#' 
#' The column names of `data` can either correspond to [quarto_fig_chunk()]/[quarto_tbl_chunk()]'s argument names (in [snake
#' case](https://en.wikipedia.org/wiki/Snake_case)), to [knitr's figure chunk option names](https://yihui.org/knitr/options/#plots) (period-separared) or
#' directly to Quarto's
#' [figure](https://quarto.org/docs/reference/cells/cells-knitr.html#figures)/[table](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code
#' chunk option names (in [kebab case](https://en.wikipedia.org/wiki/Letter_case#Kebab_case)) – they will be converted as needed.
#' 
#' Additional column names are silently ignored, except for the optional iteration variable columns `itr_vars` (of type list) and `itr_vars_r` (of type
#' character).
#' 
#' # Iteration variables
#' 
#' Specifying iteration variables allows to produce multiple code chunks per `data` row. The iteration variables can be referred to in the other columns via
#' [cli::pluralize()]'s string interpolation syntax (i.e. R code in curly brackets).
#' 
#' The `itr_vars` column must be a list of named lists (or `NULL` for no iteration on the respective rows). The `itr_vars_r` column allows to specify `itr_vars`
#' as a string of R code (which must yield a list of named lists / `NULL`s when parsed and executed).
#'
#' @param data Input data as returned by [read_quarto_chunk_data()]. A dataframe where column names correspond to chunk options supported by
#'   [quarto_fig_chunk()] or [quarto_tbl_chunk()] plus the optional iteration variable columns `itr_vars` and `itr_vars_r`. Columns `body`, `label` and
#'   `fig_cap`/`tbl_cap` are mandatory. See section *Input `data`* for details.
#' @param env Environment to evaluate iterations in (see section *Iteration variables* for details).
#'
#' @return `data`, invisibly.
#' @family quarto
#' @export
#'
#' @examples
#' # data row without iterations
#' tibble::tibble(label = "fig-cars",
#'                fig_cap = "Today's ({lubridate::today()}) top figure",
#'                fig_column = "page",
#'                fig_height = 8L,
#'                body = "plot(cars)") |>
#'   salim::quarto_chunks()
#'
#' # data row with iteration variables specified directly as `itr_vars`
#' tibble::tibble(itr_vars = list(list(v = "cyl"),
#'                                list(v = "disp"),
#'                                list(v = "hp")),
#'                label = "fig-mpg-by-{v}",
#'                fig_cap = "Motor Trend Car Road Tests: mpg per {v}",
#'                fig_column = "screen",
#'                fig_height = 8L,
#'                body = "plot(x = mtcars$mpg, y = mtcars${v})") |>
#'   salim::quarto_chunks()
#'
#' # data row with iteration variables specified indirectly as `itr_vars_r` code
#' tibble::tibble(itr_vars_r = "purrr::map(colnames(mtcars)[5:7], \\(x) list(v = x))",
#'                label = "fig-mpg-by-{v}",
#'                fig_cap = "Motor Trend Car Road Tests: mpg per {v}",
#'                fig_column = "screen",
#'                fig_height = 8L,
#'                body = "plot(x = mtcars$mpg, y = mtcars${v})") |>
#'   salim::quarto_chunks()
quarto_chunks <- function(data,
                          env = parent.frame()) {

  checkmate::assert_data_frame(data,
                               all.missing = FALSE,
                               min.cols = 2L)
  # normalize names
  data %<>% magrittr::set_colnames(value = stringr::str_replace_all(string = colnames(.),
                                                                    pattern = "[-.]",
                                                                    replacement = "_"))
  # ensure mandatory cols are present
  if (!("body" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var body}.")
  if (!("label" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var label}.")
  if (!("fig_cap" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var fig_cap}.")
  # ensure mandatory vals aren't NA
  if (anyNA(data$body)) cli::cli_abort("{.arg data} column {.var body} mustn't contain {.val {NA}} values.")
  if (anyNA(data$label)) cli::cli_abort("{.arg data} column {.var label} mustn't contain {.val {NA}} values.")
  if (anyNA(data$fig_cap)) cli::cli_abort("{.arg data} column {.var fig_cap} mustn't contain {.val {NA}} values.")
  # add empty `itr_vars` col if it's missing
  if (!("itr_vars" %in% colnames(data))) {
    data %<>% tibble::add_column(itr_vars = rep(x = list(NULL),
                                                times = nrow(.))) 
  }
  # expand `itr_vars_r` to `itr_vars` (one-to-many rows)
  if ("itr_vars_r" %in% colnames(data)) {

    data %<>%
      purrr::pmap(\(itr_vars, itr_vars_r, ...) {

        if (!is.na(itr_vars_r)) {

          if (!is.null(itr_vars)) {
            cli::cli_abort("A {.arg data} row cannot have both {.var itr_vars} and {.var itr_vars_r} set at the same time.")
          }

          itr_vars <- eval(parse(text = itr_vars_r),
                           envir = env)
        } else {
          itr_vars <- list(itr_vars)
        }

        tibble::tibble(itr_vars = itr_vars,
                       ...)
      }) %>%
      purrr::list_rbind()
  }

  # ensure lbls are unique
  ## exclude iterated lbls
  dupl_lbls <- stringr::str_subset(string = data$label,
                                   pattern = "\\{[^{].*?\\}",
                                   negate = TRUE)
  ix_dupl_lbls <- which(duplicated(dupl_lbls))

  if (length(ix_dupl_lbls) > 0L) {
    cli::cli_abort("Labels in column {.var label} must be unique, which the following label{?s} {?is/are} not: {.val {unique(dupl_lbls[ix_dupl_lbls])}}")
  }

  ## ensure lbls and itr_vars congruency
  has_itr_lbl <- stringr::str_detect(string = data$label,
                                     pattern = "\\{[^{].*?\\}")
  has_itr_col <- !purrr::map_lgl(data$itr_vars,
                                 is.null)
  if (any(has_itr_lbl & !has_itr_col)) {
    cli::cli_abort("All {.arg data} rows with a {.arg label} to be iterated must have proper {.var itr_vars} set.")
  }

  data |>
    purrr::pmap(\(...) {

      args <- rlang::list2(...)

      # interpolate chunk opts
      if (!is.null(args$itr_vars)) {

        if (!rlang::is_named(args$itr_vars)) {
          cli::cli_abort("Elements of column {.var itr_vars} must be named lists.")
        }

        args %<>% purrr::map(\(arg) {
          if (is.character(arg)) {
            rlang::inject(cli::pluralize(arg,
                                         !!!args$itr_vars,
                                         .envir = env))
          } else {
            arg
          }
        })
      }

      fn <- switch(stringr::str_extract(string = args$label,
                                        pattern = "^.{3}"),
                   fig = quarto_fig_chunk,
                   tbl = quarto_tbl_chunk,
                   cli::cli_abort("Labels must start with either {.val fig-} or {.val tbl-}."))

      chunk_opts <- args[names(args) %in% methods::formalArgs(fn)]

      rlang::list2(!!chunk_opts$label := rlang::inject(fn(!!!chunk_opts)))
    }) |>
    purrr::list_flatten()
}

`read_quarto_chunk_data`

TODO:

Write a JSON schema for the TOML structure and verify with pal::toml_validate(). Allow additional keys for max user flexibility.

#' Read in Quarto code chunk data
#'
#' Reads in a [TOML](https://toml.io/en/latest) file containing structured figure or table code chunk data, suited to be fed to [quarto_chunks()].
#'
#' @param path Path to the TOML file containing structured figure or table code chunk data. A character scalar.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family quarto
#' @export
read_quarto_chunk_data <- function(path) {

  pal::toml_read(input = path) |>
    purrr::imap(\(val, key) {

      rlang::inject(tibble::tibble(!!!val)) %>%
        magrittr::set_colnames(value = stringr::str_replace_all(string = colnames(.),
                                                                pattern = "[-.]",
                                                                replacement = "_"))
    }) |>
    purrr::list_rbind()
}

Development environment currentness

`lvl_up_r`

#' Level up R
#'
#' Checks whether the installed R version is >= a cached reference version. Intended to level up the R version in use between multiple users of the same code
#' (e.g. contributors to a specific R project).
#'
#' If the file `path_min_vrsn` exists, it is checked whether the installed R version is greater than or equal to the version number stored in that file, and if
#' not, an alert is displayed.
#' 
#' If `update_min_vrsn` is set to `TRUE` and the file `path_min_vrsn` doesn't exist or contains an R version string that's lower than the currently installed
#' version of R, `path_min_vrsn` is overwritten with the currently installed R version string.
#'
#' @param path_min_vrsn Path to the cached R version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently installed R version string *iff* the latter is higher than the former.
#'
#' @return Currently installed R version as a [numeric version][as.package_version], invisibly.
#' @family dev_env
#' @export
lvl_up_r <- function(path_min_vrsn,
                     update_min_vrsn = FALSE) {

  checkmate::assert_flag(update_min_vrsn)

  if (fs::file_exists(path_min_vrsn)) {

    min_vrsn <-
      path_min_vrsn |>
      brio::read_lines(n = 1L) |>
      as.package_version()

  } else {
    min_vrsn <- as.package_version("0.0")
  }

  current_vrsn <-
    R.Version() %$%
    glue::glue("{major}.{minor}") |>
    as.package_version()

  if (isTRUE(current_vrsn < min_vrsn)) {

    cli::cli_alert_warning(paste0(
      "Your version of {.pkg R} is out of date. Please update to version {.val {min_vrsn}} or above. The latest stable release is available at ",
      "{.url https://cloud.r-project.org/}.", pkg_mgr_hint("R")
    ))
  }

  if (update_min_vrsn && current_vrsn > min_vrsn) {

    brio::write_lines(text = current_vrsn,
                      path = path_min_vrsn)
  }

  invisible(current_vrsn)
}

`lvl_up_rstudio`

#' Level up RStudio
#'
#' Checks whether the currently running [RStudio](https://rstudio.com/products/rstudio/) version is >= a cached reference version. Intended to level up the 
#' RStudio version in use between multiple users of the same code (e.g. contributors to a specific R project).
#'
#' If the file `path_min_vrsn` exists, it is checked whether RStudio is running, and if so, whether its version number is greater than or equal to the version
#' number stored in that file. If this is not the case, an alert is displayed.
#' 
#' If `update_min_vrsn` is set to `TRUE` and the file `path_min_vrsn` doesn't exist or contains an RStudio version string that's lower than the currently
#' running version of RStudio, `path_min_vrsn` is overwritten with the currently running RStudio version string.
#'
#' Note that since **RStudio must be running for `lvl_up_rstudio()` to have any effect**, it can't be directly called in a (project-level)
#' [`.Rprofile`](https://support.rstudio.com/hc/en-us/articles/360047157094-Managing-R-with-Rprofile-Renviron-Rprofile-site-Renviron-site-rsession-conf-and-repos-conf)
#' startup script. Instead, the [`rstudio.sessionInit`](https://docs.rstudio.com/ide/server-pro/r_sessions/session_startup_scripts.html) hook can be used.
#' Example:
#' 
#' ```r
#' setHook(hookName = "rstudio.sessionInit",
#'         value = function(newSession) {
#'             if (newSession)
#'                 salim::lvl_up_rstudio(path_min_vrsn = ".RStudio_version",
#'                                       update_min_vrsn = TRUE)
#'         },
#'         action = "append")
#' ```
#'
#' @param path_min_vrsn Path to the cached RStudio version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently running RStudio version string *iff* the latter is higher than the
#'   former.
#'
#' @return Currently running RStudio version as a [numeric version][as.package_version], or `NULL` if RStudio is not running, invisibly.
#' @family dev_env
#' @export
lvl_up_rstudio <- function(path_min_vrsn,
                           update_min_vrsn = FALSE) {

  checkmate::assert_flag(update_min_vrsn)
  rlang::check_installed("rstudioapi",
                         reason = pal::reason_pkg_required())
  current_vrsn <- NULL

  # skip if RStudio is not running
  if (rstudioapi::isAvailable()) {

    if (fs::file_exists(path_min_vrsn)) {

      min_vrsn <-
        path_min_vrsn |>
        brio::read_lines(n = 1L) |>
        as.package_version()

    } else {
      min_vrsn <- as.package_version("0.0")
    }

    current_vrsn <-
      rstudioapi::versionInfo() |>
      purrr::chuck("version")

    if (isTRUE(current_vrsn < min_vrsn)) {

      cli::cli_alert_warning(paste0(
        "Your version of {.pkg RStudio} is out of date. Please update to version {.val {min_vrsn}} or above. The latest version is available at ",
        "{.url https://rstudio.com/products/rstudio/download/#download}.", pkg_mgr_hint("RStudio")
      ))
    }

    if (update_min_vrsn && current_vrsn > min_vrsn) {

      brio::write_lines(text = current_vrsn,
                        path = path_min_vrsn)
    }
  }

  invisible(current_vrsn)
}

`lvl_up_quarto`

#' Level up Quarto
#'
#' Checks whether the installed [Quarto](https://quarto.org/) version is >= a cached reference version. Intended to level up the Quarto version in use between
#' multiple users of the same code (e.g. contributors to a specific Quarto project).
#'
#' @param path_min_vrsn Path to the cached Quarto version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently installed Quarto version string *iff* the latter is higher than the
#'   former.
#'
#' @return Currently installed Quarto version as a [numeric version][numeric_version], invisibly.
#' @family dev_env
#' @export
lvl_up_quarto <- function(path_min_vrsn,
                          update_min_vrsn = FALSE) {

  checkmate::assert_flag(update_min_vrsn)
  rlang::check_installed("quarto",
                         reason = pal::reason_pkg_required())

  if (fs::file_exists(path_min_vrsn)) {

    min_vrsn <-
      path_min_vrsn |>
      brio::read_lines(n = 1L) |>
      as.package_version()

  } else {
    min_vrsn <- as.package_version("0.0")
  }

  current_vrsn <-
    quarto::quarto_path() |>
    system2(args = "--version",
            stdout = TRUE,
            stderr = TRUE) |>
    as.package_version()

  if (isTRUE(current_vrsn < min_vrsn)) {

    cli::cli_alert_warning(paste0(
      "Your version of {.pkg Quarto} is out of date. Please update to version {.val {min_vrsn}} or above. The latest stable release is available at ",
      "{.url https://quarto.org/docs/get-started/}.", pkg_mgr_hint("Quarto")
    ))
  }

  if (update_min_vrsn && current_vrsn > min_vrsn) {

    brio::write_lines(text = current_vrsn,
                      path = path_min_vrsn)
  }

  invisible(current_vrsn)
}

`update_rpkgs`

#' Update R packages from rpkg.dev
#'
#' Installs/updates \R packages from [rpkg.dev](https://gitlab.com/rpkg.dev) to the latest (development) version.
#'
#' @param pkgs R pkgs to be updated. A subset of:
#'   `r pal::fn_param_defaults(fn = "update_rpkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#' @param from_cran Whether or not to install `pkgs` from a [CRAN](https://en.wikipedia.org/wiki/R_package#Comprehensive_R_Archive_Network_(CRAN)) repository
#'   if possible. The repository URLs set in the [`repos`][options] \R option are used by default, with fallback to `https://cloud.r-project.org/`. If `FALSE`,
#'   the latest *development* versions are always installed, regardless of whether `pkgs` are available on CRAN or not.
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_rpkgs <- function(pkgs = c("pal",
                                  "pkgpins",
                                  "pkgpurl",
                                  "pkgsnip",
                                  "plotlee",
                                  "qstnr",
                                  "rstd",
                                  "swissmuni",
                                  "tocr",
                                  "yay"),
                         from_cran = FALSE) {

  rlang::check_installed("remotes",
                         reason = pal::reason_pkg_required())
  pkgs <- rlang::arg_match(pkgs,
                           multiple = TRUE)
  purrr::walk(pkgs,
              \(x) {

                if (pal::is_pkg_cran(x)) {
                  utils::install.packages(pkgs = x,
                                          repos = getOption("repos",
                                                            default = "https://cloud.r-project.org/"))
                } else {
                  remotes::install_gitlab(repo = paste0("rpkg.dev/", x), # nolint: paste_linter
                                          upgrade = FALSE)
                }
              })

  invisible(pkgs)
}

`update_salims_pkgs`

#' Update Salim B's R packages
#'
#' Installs/updates all of [Salim B's R packages](https://gitlab.com/salim_b/r/pkgs) to the latest (development) version.
#'
#' @inheritParams update_rpkgs
#' @param pkgs R pkgs to be updated. A subset of:
#'   `r pal::fn_param_defaults(fn = "update_salims_pkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_salims_pkgs <- function(pkgs = c("salim",
                                        "swissparty"),
                               from_cran = FALSE) {

  rlang::check_installed("remotes",
                         reason = pal::reason_pkg_required())
  pkgs <- rlang::arg_match(pkgs,
                           multiple = TRUE)
  purrr::walk(pkgs,
              \(x) {

                if (pal::is_pkg_cran(x)) {
                  utils::install.packages(pkgs = x,
                                          repos = getOption("repos",
                                                            default = "https://cloud.r-project.org/"))
                } else {
                  remotes::install_gitlab(repo = paste0("salim_b/r/pkgs/", x), # nolint: paste_linter
                                          upgrade = FALSE)
                }
              })

  invisible(pkgs)
}

`update_zdaarau_pkgs`

#' Update R packages from the Centre for Democracy Studies Aarau (ZDA)
#'
#' Installs/updates all of the [R packages from the Centre for Democracy Studies Aarau (ZDA)](https://gitlab.com/zdaarau/rpkgs) to the latest (development)
#' version.
#'
#' @inheritParams update_rpkgs
#' @param pkgs R pkgs to be updated. A subset of:
#'   `r pal::fn_param_defaults(fn = "update_zdaarau_pkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_zdaarau_pkgs <- function(pkgs = c("rdb.report",
                                         "fokus",
                                         "rdb",
                                         "swissevote"),
                                from_cran = FALSE) {

  rlang::check_installed("remotes",
                         reason = pal::reason_pkg_required())
  pkgs <- rlang::arg_match(pkgs,
                           multiple = TRUE)
  checkmate::assert_flag(from_cran)

  purrr::walk(pkgs,
              \(x) {

                if (from_cran && pal::is_pkg_cran(x)) {
                  utils::install.packages(pkgs = x,
                                          repos = getOption("repos",
                                                            default = "https://cloud.r-project.org/"))
                } else {
                  remotes::install_gitlab(repo = paste0("zdaarau/rpkgs/", x), # nolint: paste_linter
                                          upgrade = FALSE)
                }
              })

  invisible(pkgs)
}

salim-b/salim documentation built on April 12, 2024, 7:57 p.m.

rdrr.io home R language documentation Run R code online

CRAN packages Bioconductor packages R-Forge packages GitHub packages

Note that we can't provide technical support on individual packages. You should contact the package authors for that.

salim-b/salim A Wild Mix of Functions Serving Various Purposes

In salim-b/salim: A Wild Mix of Functions Serving Various Purposes

INTERNAL

Avoid R CMD check NOTES about undefined global objects

Functions

as_code_chunk_array

as_yaml_inline

pkg_mgr_hint

pkg_mgr_prose

EXPORTED

Spoken language

Multi-language

prettify_date

prettify_datetime

rank_nr

write_out_n

English

n_ify

German

definite_article_de

definite_article_de_declined

add_definite_article_de

decline_noun_de

Regular expression rules

regex_spelling_normalization

Pandoc

download_pandoc_binaries

pandoc_release_id_latest

pandoc_version_latest

pandoc_releases

pandoc_release_assets

pandoc_tpl