R/salim.gen.R

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

# DO NOT EDIT THIS FILE BY HAND! Instead edit the R Markdown source file `Rmd/salim.Rmd` and run `pkgpurl::purl_rmd()`.
# See `README.md#r-markdown-format` for more information on the literate programming approach used applying the R Markdown format.

# salim: A Wild Mix of Functions Serving Various Purposes
# Copyright (C) 2025 Salim Brüggemann
# 
# This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the Free
# Software Foundation, either version 3 of the License, or any later version.
# 
# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
# 
# You should have received a copy of the GNU Affero General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.

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

pkg_mgr_hint <- function(software = names(pkg_mgr_software)) {
  
  software <- rlang::arg_match(software)
  
  result <- ""
  
  if (checkmate::test_os(os = "mac")) {
    result %<>% paste0(pkg_mgr_prose(software = software,
                                     pkg_mgrs = "brew"))
    
  } else if (checkmate::test_os(os = "windows")) {
    result %<>% paste0(pkg_mgr_prose(software = software,
                                     pkg_mgrs = c("scoop", "choco")))
  }
  
  result
}

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 ", ., "."),
              ~ "")
}

this_pkg <- utils::packageName()

#' Phrase date(time)s
#'
#' Formats date(time)s as strings according to the specified `format`s and `locale`, applying some typographic tweaks. A convenience wrapper around
#' [stringi::stri_datetime_format()].
#'
#' @inheritParams stringi::stri_datetime_format
#' @param x Date(s) or datetime(s) to format. A [date][base::Date], [datetime][base::DateTimeClasses], factor or character vector.
#' @param format Format string(s) defining how to phrase `x`. Possible values include
#'   `r c("date", "time") |> purrr::map(\(x) paste(x, c("short", "medium", "long", "full"), sep = "_")) |> unlist() |> pal::as_md_vals() |> pal::enum_str()`.
#'   See [stringi::stri_datetime_format()] for details.
#'
#' @return A character vector of the same length as `x`.
#' @family spoken
#' @export
#'
#' @examples
#' salim::phrase_datetime("2020-02-20")
#' 
#' salim::phrase_datetime(x = as.POSIXct(0L),
#'                        format = c("date_full",
#'                                   "time_full"),
#'                        locale = "de-CH")
#'
#' # note that character input is internally converted to a datetime using `as.POSIXct()` with the
#' # default `format` which ignores possible time components:
#' salim::phrase_datetime(x = "2020-02-20T13:13:13Z",
#'                        format = c("date_full",
#'                                   "time_full"))
#' 
#' # hence it's recommended to directly provide input as datetimes:
#' salim::phrase_datetime(x = clock::date_time_parse_RFC_3339("2020-02-20T13:13:13Z"),
#'                        format = c("date_full",
#'                                   "time_full"))
phrase_datetime <- function(x,
                            format = "date_long",
                            locale = funky::config_val("locale")) {
  
  result <- stringi::stri_datetime_format(time = x,
                                          format = format,
                                          locale = locale)
  
  # use non-break space to sep day from month
  ix_date <- startsWith(format, "date_")
  
  if (length(ix_date) > 0L) {
    result[ix_date] %<>% pal::when(startsWith(locale, "en") ~ stringr::str_replace(string = .[ix_date],
                                                                                   pattern = "(\\w+)\\s+(\\d+)",
                                                                                   replacement = "\\1\u00a0\\2"),
                                   startsWith(locale, "de") ~ stringr::str_replace(string = .[ix_date],
                                                                                   pattern = "(\\d+\\.)\\s+",
                                                                                   replacement = "\\1\u00a0"),
                                   startsWith(locale, "fr") ~ stringr::str_replace(string = .[ix_date],
                                                                                   pattern = "(\\d+)\\s+",
                                                                                   replacement = "\\1\u00a0"),
                                   ~ .)
  }
  
  result
}

#' 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 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
}

#' 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"))
}

#' 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"))
  }
}

#' 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 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 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 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"

#' Download Pandoc release
#'
#' Downloads the [assets][pandoc_release_assets] and extracts the executable program binaries for Linux, macOS and Windows of the specified Pandoc release.
#'
#' @inheritParams pandoc_release_assets
#' @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`.
#'
#' @return `path` invisibly.
#' @family pandoc
#' @seealso GitHub release functions: [yay::gh_releases()], [yay::gh_release_latest()]
#' @export
download_pandoc_binaries <- function(release_id = yay::gh_release_latest(owner = "jgm",
                                                                         name = "pandoc")$id,
                                     os = c("linux", "macos", "windows"),
                                     path = "bin/",
                                     overwrite = TRUE) {
  rlang::check_installed("yay",
                         reason = pal::reason_pkg_required())
  rlang::check_installed("waldo",
                         reason = pal::reason_pkg_required())
  checkmate::assert_subset(os,
                           choices = eval(formals()$os),
                           empty.ok = FALSE)
  checkmate::assert_path_for_output(path,
                                    overwrite = TRUE)
  checkmate::assert_flag(overwrite)
  
  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)
}

#' 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 identifier of the desired Pandoc release. Use
#'   [`yay::gh_releases(owner = "jgm", name = "pandoc")`][yay::gh_releases] to determine the release identifier of a specific Pandoc version number. An
#'   integer scalar.
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @seealso GitHub release functions: [yay::gh_releases()], [yay::gh_release_latest()]
#' @export
pandoc_release_assets <- function(release_id = yay::gh_release_latest(owner = "jgm",
                                                                      name = "pandoc")$id) {
  rlang::check_installed("yay",
                         reason = pal::reason_pkg_required())
  rlang::check_installed("gh",
                         reason = pal::reason_pkg_required())
  checkmate::assert_count(release_id,
                          positive = TRUE)
  
  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()
}

#' 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::http_get_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::http_get_cached(url = glue::glue("https://gitlab.com/salim_b/pandoc/templates/-/raw/main/{tpl}?ref_type=heads&inline=false")) |>
      httr2::resp_body_string())
}

#' Set common ggplot2 geom defaults
#'
#' Sets common ggplot2 geom default settings (currently only font `family`). Convenience wrapper around [ggplot2::update_geom_defaults()].
#'
#' Note that `ggplot2_geom_defaults()` must be invoked *before* plots are created to have any effect.
#'
#' @param family Font family to use in text geoms.
#'
#' @return `NULL`, invisibly.
#' @family plot_theme
#' @export
ggplot2_geom_defaults <- function(family) {
  
  rlang::check_installed("ggplot2",
                         reason = pal::reason_pkg_required())
  
  ggplot2::update_geom_defaults(geom = "text",
                                new = list(family = family))
  
  if (pal::is_pkg_installed(pkg = "ggrepel")) {
    ggplot2::update_geom_defaults(geom = ggrepel::GeomTextRepel,
                                  new = list(family = family))
  }
}

#' Apply common theme to ggplot2 chart
#'
#' Applies common [theming][ggplot2::theme] to a [ggplot2][ggplot2::ggplot2-package] chart. It's based on [ggplot2::theme_minimal()].
#'
#' @inheritParams ggplot2::theme_minimal
#' @inheritParams ggplot2::theme
#' @param axis.title.x,axis.title.y Labels of axes ([ggplot2::element_text()]). Specify all axes' labels (`axis.title`), labels by plane (using `axis.title.x`
#'   or `axis.title.y`), or individually for each axis (using `axis.title.x.bottom`, `axis.title.x.top`, `axis.title.y.left`, `axis.title.y.right`).
#'   `axis.title.*.*` inherits from `axis.title.*` which inherits from `axis.title`, which in turn inherits from `text`.
#' @param axis.text Tick labels along axes ([ggplot2::element_text()]). Specify all axis tick labels (`axis.text`), tick labels by plane (using `axis.text.x` or
#'   `axis.text.y`), or individually for each axis (using `axis.text.x.bottom`, `axis.text.x.top`, `axis.text.y.left`, `axis.text.y.right`). `axis.text.*.*`
#'   inherits from `axis.text.*` which inherits from `axis.text`, which in turn inherits from `text`.
#' @param legend.spacing Spacing between legends (`unit`). `legend.spacing.x` & `legend.spacing.y` inherit from `legend.spacing` or can be specified separately.
#' @param ... Further arguments passed on to [ggplot2::theme()].
#'
#' @return An object of class [`theme`][ggplot2::theme].
#' @family plot_theme
#' @export
#'
#' @examples
#' sysfonts::font_add_google(name = "Alegreya Sans")
#' showtext::showtext_auto()
#'
#' ggplot2::ggplot(data = mtcars,
#'                 mapping = ggplot2::aes(x = mpg,
#'                                        y = cyl)) +
#'   ggplot2::geom_point() +
#'   salim::ggplot2_theme(base_size = 12)
# nolint start: object_name_linter.
ggplot2_theme <- function(base_size = 11L,
                          base_family = funky::config_val("font_family_body"),
                          base_line_size = base_size / 22L,
                          base_rect_size = base_size / 22L,
                          axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 20L, r = 0L, b = 0L, l = 0L),
                                                               inherit.blank = TRUE),
                          axis.title.y = ggplot2::element_text(margin = ggplot2::margin(t = 0L, r = 20L, b = 0L, l = 0L),
                                                               inherit.blank = TRUE),
                          axis.text = ggplot2::element_text(color = "#000",
                                                            inherit.blank = TRUE),
                          legend.box.margin = ggplot2::margin(),
                          legend.box.spacing = ggplot2::element_blank(),
                          legend.margin = ggplot2::margin(),
                          legend.position = "bottom",
                          legend.spacing = grid::unit(x = 0.0,
                                                      units = "npc"),
                          plot.margin = ggplot2::margin(),
                          ...) {
  
  rlang::check_installed("ggplot2",
                         reason = pal::reason_pkg_required())
  
  ggplot2::theme_minimal(base_size = base_size,
                         base_family = base_family,
                         base_line_size = base_line_size,
                         base_rect_size = base_rect_size) +
    ggplot2::theme(axis.title.x = axis.title.x,
                   axis.title.y = axis.title.y,
                   axis.text = axis.text,
                   legend.box.margin = legend.box.margin,
                   legend.box.spacing = legend.box.spacing,
                   legend.margin = legend.margin,
                   legend.position = legend.position,
                   legend.spacing = legend.spacing,
                   plot.margin = plot.margin,
                   ...)
}
# nolint end

#' Add common HTML-specific theme to ggplot2 chart
#'
#' Dynamically adds common HTML-specific [theming][ggplot2::theme] to a [ggplot2][ggplot2::ggplot2-package] chart. It depends on the current [knitr output
#' format][knitr::pandoc_to] whether the additional HTML-specific theming is actually added or not.
#'
#' Note that `ggplot2_theme_html()` must be evaluated *during* [knitting][knitr::knit] to work properly.
#'
#' @param .color_text Text color to use for all text elements ([ggplot2::element_text()]) when the knitr output format [is HTML][knitr::is_html_output()].
#' @param .color_bg Background color to use when the knitr output format [is HTML][knitr::is_html_output()].
#' @param .color_grid Grid color to use when the knitr output format [is HTML][knitr::is_html_output()].
#' @param ... Further arguments passed on to [ggplot2::theme()] when the knitr output format [is HTML][knitr::is_html_output()].
#'
#' @return An object of class [`theme`][ggplot2::theme].
#' @family plot_theme
#' @export
#'
#' @examples
#' sysfonts::font_add_google(name = "Alegreya Sans")
#' showtext::showtext_auto()
#'
#' ggplot2::ggplot(data = mtcars,
#'                 mapping = ggplot2::aes(x = mpg,
#'                                        y = cyl)) +
#'   ggplot2::geom_point() +
#'   salim::ggplot2_theme() +
#'   salim::ggplot2_theme_html()
ggplot2_theme_html <- function(.color_text = funky::config_val("plot_color_body"),
                               .color_bg = funky::config_val("plot_color_bg"),
                               .color_grid = funky::config_val("plot_color_grid"),
                               ...) {
  
  checkmate::assert_string(.color_text)
  checkmate::assert_string(.color_bg)
  checkmate::assert_string(.color_grid)
  rlang::check_installed("ggplot2",
                         reason = pal::reason_pkg_required())
  rlang::check_installed("knitr",
                         reason = pal::reason_pkg_required())
  
  result <- ggplot2::theme()
  
  if (knitr::is_html_output()) {
    
    result <- result + ggplot2::theme(line = ggplot2::element_line(color = .color_text,
                                                                   inherit.blank = TRUE),
                                      rect = ggplot2::element_rect(color = .color_text,
                                                                   inherit.blank = TRUE),
                                      text = ggplot2::element_text(color = .color_text,
                                                                   inherit.blank = TRUE),
                                      axis.text = ggplot2::element_text(color = .color_text,
                                                                        inherit.blank = TRUE),
                                      legend.background     = ggplot2::element_rect(fill = .color_bg,
                                                                                    color = NA_character_),
                                      legend.box.background = ggplot2::element_rect(fill = .color_bg,
                                                                                    color = NA_character_),
                                      legend.key            = ggplot2::element_rect(fill = .color_bg,
                                                                                    color = NA_character_),
                                      panel.background      = ggplot2::element_rect(fill = .color_bg,
                                                                                    color = NA_character_),
                                      panel.grid            = ggplot2::element_line(color = .color_grid),
                                      plot.background       = ggplot2::element_rect(fill = .color_bg,
                                                                                    color = NA_character_),
                                      ...)
  }
  
  result
}

#' Apply common layout to Plotly chart
#'
#' Applies common [layout][plotly::layout] configuration to a [Plotly][plotly::plot_ly] chart.
#'
#' @inheritParams plotlee::simplify_trace_ids
#' @param font [Global font](https://plotly.com/r/reference/layout/#layout-font). Fonts used in traces and other layout components inherit from the global font.
#' @param paper_bgcolor [Background color of the paper](https://plotly.com/r/reference/layout/#layout-paper_bgcolor) where the graph is drawn.
#' @param plot_bgcolor [Background color of the plotting area](https://plotly.com/r/reference/layout/#layout-plot_bgcolor) in-between x and y axes.
#' @param xaxis [X-axis configuration](https://plotly.com/r/reference/layout/#layout-xaxis).
#' @param yaxis [Y-axis configuration](https://plotly.com/r/reference/layout/#layout-yaxis).
#' @param ... Further [layout configuration](https://plotly.com/r/reference/layout/) arguments.
#'
#' @return `r pkgsnip::return_lbl("plotly_obj")`
#' @family plot_theme
#' @export
#'
#' @examples
#' plotly::plot_ly(data = mtcars,
#'                 type = "bar",
#'                 x = ~mpg) |>
#'   salim::plotly_layout(font = list(color = funky::config_val(key = "plot_color_body",
#'                                                              pkg = "salim")))
plotly_layout <- function(p,
                          font = list(color = funky::config_val("plot_color_body"),
                                      family = funky::config_val("font_family_body")),
                          paper_bgcolor = funky::config_val("plot_color_bg"),
                          plot_bgcolor  = paper_bgcolor,
                          xaxis = list(gridcolor = funky::config_val("plot_color_grid")),
                          yaxis = list(gridcolor = funky::config_val("plot_color_grid")),
                          ...) {
  
  rlang::check_installed("plotly",
                         reason = pal::reason_pkg_required())
  plotly::layout(p = p,
                 font = font,
                 paper_bgcolor = paper_bgcolor,
                 plot_bgcolor  = plot_bgcolor,
                 xaxis = xaxis,
                 yaxis = yaxis,
                 ...)
}

#' 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)
}

#' 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://posit.co/download/rstudio-desktop/}.", 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)
}

#' 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 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("gitlab",
                                  "nocodb",
                                  "pal",
                                  "pkgdown.tpl",
                                  "pkgpins",
                                  "pkgpurl",
                                  "pkgsnip",
                                  "plotlee",
                                  "qstnr",
                                  "quappo",
                                  "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 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 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)
}