pkgsnip.Rmd

---
editor_options:
  chunk_output_type: console
---

# EXPORTED

## R Markdown file snippets

For now, only R Markdown file snippets are included. But this can easily be extended to other file formats in the future.

### `ls_file_snips`

```{r}
#' List all available R Markdown file snippets
#' 
#' Lists all of the R Markdown snippets shipped with this package, together with the paths where they're located on the filesystem.
#'
#' @return `r return_lbl("tibble")`
#' @family rmdsnips
#' @export
ls_file_snips <- function() {
  
  fs::path_package("snippets/",
                   package = utils::packageName()) |>
    fs::dir_ls(recurse = TRUE,
               type = "file") |>
    tibble::tibble(path = _) |>
    dplyr::mutate(id = fs::path_file(path),
                  .before = 1L)
}
```

### `snip_path`

```{r}
#' Get R Markdown snippet file path
#'
#' Returns the file path to an R Markdown snippet shipped with this package.
#'
#' The snippets can be used anywhere R Markdown input is supported. For example, you can use them as input to knitr's
#' [`child` document option](https://yihui.org/knitr/options/#child-documents):
#'
#' ````rmd
#' ```{r, child = pkgsnip::snip_path("pkg-instl-dev-gitlab.Rmd")}
#' ```
#' ````
#'
#' Or you can use them in roxygen2's [`@includeRmd` tag](https://roxygen2.r-lib.org/articles/rd.html#including-external--rmd-md-files):
#'
#' ```r
#' #' @includeRmd `r pkgsnip::snip_path("pkg-instl-dev-gitlab.Rmd")`
#' ```
#'
#' @param id Snippet identifier. One of
#'   `r ls_file_snips()$id |> pal::as_md_val_list()`
#'
#' @return `r return_lbl("path")`
#' @family rmdsnips
#' @export
snip_path <- function(id = ls_file_snips()$id) {
  
  id <- rlang::arg_match(id)
  
  fs::path_package(package = utils::packageName(),
                   "snippets",
                   id) |>
    fs::path_real()
}
```

## Markdown snippets

### `data_md_snips`

```{r}
#' Markdown snippets
#'
#' A [tibble][tibble::tbl_df] with all Markdown snippets together with their `id`. The latter can be fed to [pkgsnip::md_snip()].
#'
#' @format `r return_lbl("tibble_cols", cols = colnames(data_md_snips))`
#' @family mdsnips
#' @export
#'
#' @examples
#' pkgsnip::data_md_snips
"data_md_snips"
```

### `md_snip`

```{r}
#' Get predefined Markdown snippet
#'
#' Returns a predefined Markdown snippet.
#'
#' Currently, the following Markdown snippets are available:
#'
#' ```{r, echo = FALSE}
#' data_md_snips |>
#'   add_args_col() |>
#'   dplyr::select(-value) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#'
#' @inheritParams roxy_lbl
#' @param id Snippet identifier. One of `r pal::fn_param_defaults(param = "id", fn = md_snip) |> pal::wrap_chr("\x60") |> cli::ansi_collapse(last = " or ")`.
#' @param ... Further named arguments used to tailor the snippet to your needs. Not all snippets require additional arguments, see [`data_md_snips`] for an
#'   overview. If a required argument is not explicitly provided, it is searched for in the [parent frames][parent.frame].
#'
#' @return A character scalar.
#' @family mdsnips
#' @export
#'
#' @examples
#' pkgsnip::md_snip(id = "rstudio_addin") |> cat()
#'
#' # certain snips require additional args
#' pkgsnip::md_snip(id = "funky_config",
#'                  pkg = "foo") |>
#'   cat()
md_snip <- function(id = data_md_snips$id,
                    env = parent.frame(),
                    ...) {
  
  id <- rlang::arg_match(id)
  
  data_md_snips |>
    dplyr::filter(id == !!id) %$%
    value |>
    glue::glue(.envir = env,
               ... = ...)
}
```

## roxygen2 labels

### `data_roxy_lbls`

```{r}
#' roxygen2 tag labels
#'
#' A [tibble][tibble::tbl_df] with all Markdown snippets together with their `type` and `id`. The latter can be fed to [pkgsnip::md_snip()].
#'
#' @format `r return_lbl("tibble_cols", cols = colnames(data_md_snips))`
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::data_roxy_lbls
"data_roxy_lbls"
```

### `roxy_lbls`

```{r}
#' Get a table of all available roxygen2 tag labels
#'
#' Returns a [tibble][tibble::tbl_df] listing all parameter labels included in this package, together with their `id` which can be provided as the `id`
#' argument of [pkgsnip::roxy_lbl()], [pkgsnip::param_lbl()], [pkgsnip::return_lbl()], etc.
#'
#' Currently, the following roxygen2 tag labels are available:
#'
#' ```{r, echo = FALSE}
#' data_roxy_lbls |>
#'   add_args_col() |>
#'   dplyr::select(-value) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#'
#' @param type The label type to return label values for. One of `r c("default", roxy_tags_lbl) |> pal::as_md_vals() |> cli::ansi_collapse(last = " or ")`.
#'
#' @return `r return_lbl("tibble")`
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::roxy_lbls(type = "title")
roxy_lbls <- function(type = "default") {
  
  type <- rlang::arg_match(arg = type,
                           values = c("default", roxy_tags_lbl))
  data_roxy_lbls |>
    dplyr::filter(type %in% c("default", !!type)) |>
    dplyr::group_by(id) |>
    dplyr::group_modify(\(d, k) if (nrow(d) == 1L) d else d |> dplyr::filter(type != "default")) |> # nolint: pipe_continuation_linter.
    dplyr::ungroup()
}
```

### `roxy_lbl`

```{r}
#' Get predefined roxygen2 tag label
#'
#' Returns a predefined label intended to be used to document functions using [roxygen2][roxygen2::roxygen2]
#' [tags](https://roxygen2.r-lib.org/articles/rd.html#functions).
#'
#' The labels can be inserted using [inline \R code](https://roxygen2.r-lib.org/articles/reuse.html#inline-code) as follows:
#'
#' ```r
#' #' @param start_date `r pkgsnip::roxy_lbl("start_date", type = "param")`
#' #' @return `r pkgsnip::roxy_lbl("tibble", type = "return")`
#' ```
#'
#' Note that the above only works in [roxygen2 7.1.0+](https://www.tidyverse.org/blog/2020/03/roxygen2-7-1-0/).
#' 
#' @param id Label identifier. See [pkgsnip::roxy_lbls()] for possible values.
#' @param type The label type to return the label value for. One of `r c("default", roxy_tags_lbl) |> pal::as_md_vals() |> cli::ansi_collapse(last = " or ")`.
#' @param as_sentence Whether or not to format the resulting string as a full sentence, i.e. with the first letter capitalized and a period at the end.
#' @param env Environment in which inline code is to be evaluated, e.g. [base::parent.frame()], [base::new.env()], or [base::globalenv()].
#' @param ... Further named arguments used to tailor the label to your needs. Not all labels require additional arguments, see [pkgsnip::roxy_lbls()] for an
#'   overview. If a required argument is not explicitly provided, it is searched for in the [parent frames][base::parent.frame].
#'
#' @return `r pkgsnip::return_lbl("glue_chr")`
#' @keywords internal
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::roxy_lbl(id = "cli_markup_support")
#'
#' # some labels take additional arguments
#' pkgsnip::roxy_lbl(id = "opt_global_max_cache_age",
#'                   global_max_cache_age = "6h",
#'                   pkg = "foo")
#'
#' # note that the `pkg` argument always defaults to the current package
#' # (none if run from the global environment)
#' pkgsnip::roxy_lbl(id = "opt_global_max_cache_age",
#'                   global_max_cache_age = "6h")
roxy_lbl <- function(id = roxy_lbls()$id,
                     type = "default",
                     as_sentence = TRUE,
                     env = parent.frame(),
                     ...) {
  
  id <- rlang::arg_match(id)
  checkmate::assert_flag(as_sentence)
  
  # add additional user-supplied to `env`
  env <- rlang::new_environment(parent = env)
  rlang::env_bind(.env = env,
                  !!!list(...))
  result <-
    roxy_lbls(type = type) |>
    dplyr::filter(id == !!id) |>
    _$value |>
    cli::format_inline(.envir = env)
  
  if (as_sentence) {
    
    result %<>%
      stringr::str_replace(pattern = "(?<=^[^\\{\\w]{0,999})[a-zA-Z]",
                           replacement = toupper) %>%
      stringr::str_replace(pattern = "\\.?$",
                           replacement = ".")
  }
  
  glue::as_glue(result)
}
```

### `description_lbl`

```{r}
#' Get predefined `@description` label
#'
#' Returns a predefined label intended to be used as a function's description using [roxygen2][roxygen2::roxygen2]'s
#' [`@description`](https://roxygen2.r-lib.org/reference/tags-rd.html) tag. Shorthand for [roxy_lbl(type = "description")][roxy_lbl].
#'
#' A label can be inserted using [inline \R code](https://roxygen2.r-lib.org/articles/reuse.html#inline-code) as follows:
#'
#' ```r
#' #' @description `r pkgsnip::description_lbl("ID")`
#' ```
#' Note that the above only works in [roxygen2 7.1.0+](https://www.tidyverse.org/blog/2020/03/roxygen2-7-1-0/).
#'
#' Currently, the following `@description` labels are available:
#'
#' ```{r, echo = FALSE}
#' roxy_lbls(type = "description") |>
#'   add_args_col() |>
#'   dplyr::select(-c(type, value)) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#' 
#' @inheritParams return_lbl
#'
#' @inherit roxy_lbl return
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::description_lbl(id = "dyn_dots_support")
#'
#' # some labels take additional arguments
#' pkgsnip::description_lbl(id = "opt_global_max_cache_age",
#'                          global_max_cache_age = "6h",
#'                          pkg = "foo")
#'
#' # note that the `pkg` argument always defaults to the current package
#' # (none if run from the global environment)
#' pkgsnip::description_lbl(id = "opt_global_max_cache_age",
#'                          global_max_cache_age = "6h")
description_lbl <- function(id = roxy_lbls(type = "description")$id,
                            ...) {
  
  id <- rlang::arg_match(id)
  
  roxy_lbl(id = id,
           type = "description",
           ... = ...)
}
```

### `param_lbl`

```{r}
#' Get predefined `@param` label
#'
#' Returns a predefined label intended to be used to document a function parameter using [roxygen2][roxygen2::roxygen2]'s
#' [`@param`](https://roxygen2.r-lib.org/articles/rd.html#functions) tag. Shorthand for [roxy_lbl(type = "param")][roxy_lbl].
#'
#' A label can be inserted using [inline \R code](https://roxygen2.r-lib.org/articles/reuse.html#inline-code) as follows:
#'
#' ```r
#' #' @param PARAM_NAME `r pkgsnip::param_lbl("ID")`
#' ```
#' Note that the above only works in [roxygen2 7.1.0+](https://www.tidyverse.org/blog/2020/03/roxygen2-7-1-0/).
#'
#' Currently, the following parameter labels are available:
#'
#' ```{r, echo = FALSE}
#' roxy_lbls(type = "param") |>
#'   add_args_col() |>
#'   dplyr::select(-c(type, value)) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#' 
#' @inheritParams return_lbl
#'
#' @inherit roxy_lbl return
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::param_lbl(id = "eol")
#'
#' # some labels take additional arguments
#' pkgsnip::param_lbl(id = "http_method",
#'                    one_of = c("GET", "POST"))
param_lbl <- function(id = roxy_lbls(type = "param")$id,
                      ...) {
  
  id <- rlang::arg_match(id)
  
  roxy_lbl(id = id,
           type = "param",
           ... = ...)
}
```

### `return_lbl`

```{r}
#' Get predefined `@return` label
#'
#' Returns a predefined label intended to be used to document function return values using [roxygen2][roxygen2::roxygen2]'s
#' [`@return`](https://roxygen2.r-lib.org/articles/rd.html#functions) tag. Shorthand for [roxy_lbl(type = "return")][roxy_lbl].
#'
#' A label can be inserted using [inline \R code](https://roxygen2.r-lib.org/articles/reuse.html#inline-code) as follows:
#'
#' ```r
#' #' @return `r pkgsnip::return_lbl("ID")`
#' ```
#' Note that the above only works in [roxygen2 7.1.0+](https://www.tidyverse.org/blog/2020/03/roxygen2-7-1-0/).
#'
#' Currently, the following return labels are available:
#'
#' ```{r, echo = FALSE}
#' roxy_lbls(type = "return") |>
#'   add_args_col() |>
#'   dplyr::select(-c(type, value)) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#' 
#' @inheritParams roxy_lbl
#' @param ... Further named arguments passed on to [pkgsnip::roxy_lbl()].
#'
#' @inherit roxy_lbl return
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::return_lbl(id = "dyn_dots_support")
#'
#' # some labels take additional arguments
#' pkgsnip::return_lbl(id = "funky_config",
#'                     pkg = "foo")
#'
#' # note that the `pkg` argument always defaults to the current package
#' # (none if run from the global environment)
#' pkgsnip::return_lbl(id = "funky_config")
return_lbl <- function(id = roxy_lbls(type = "return")$id,
                       ...) {
  
  id <- rlang::arg_match(id)
  
  roxy_lbl(id = id,
           type = "return",
           ... = ...)
}
```

### `title_lbl`

```{r}
#' Get predefined `@title` label
#'
#' Returns a predefined label intended to be used to document a function's title using [roxygen2][roxygen2::roxygen2]'s
#' [`@title`](https://roxygen2.r-lib.org/reference/tags-rd.html) tag. Shorthand for [roxy_lbl(type = "title")][roxy_lbl].
#'
#' A label can be inserted using [inline \R code](https://roxygen2.r-lib.org/articles/reuse.html#inline-code) as follows:
#'
#' ```r
#' #' @title `r pkgsnip::title_lbl("ID")`
#' ```
#' Note that the above only works in [roxygen2 7.1.0+](https://www.tidyverse.org/blog/2020/03/roxygen2-7-1-0/).
#'
#' Currently, the following `@title` labels are available:
#'
#' ```{r, echo = FALSE}
#' roxy_lbls(type = "title") |>
#'   add_args_col() |>
#'   dplyr::select(-c(type, value)) |>
#'   backtickify_cols() |>
#'   pal::pipe_table()
#' ```
#'
#' `r hint_arg_pkg`
#' 
#' @inheritParams roxy_lbl
#'
#' @inherit roxy_lbl return
#' @family roxylbl
#' @export
#'
#' @examples
#' # some labels take additional arguments
#' pkgsnip::title_lbl(id = "funky_config",
#'                    pkg = "foo")
#'
#' # note that the `pkg` argument always defaults to the current package
#' # (none if run from the global environment)
#' pkgsnip::title_lbl(id = "funky_config")
title_lbl <- function(id = roxy_lbls(type = "title")$id,
                      as_sentence = FALSE,
                      ...) {
  
  id <- rlang::arg_match(id)
  
  roxy_lbl(id = id,
           type = "title",
           as_sentence = as_sentence,
           ... = ...)
}
```

### `data_types`

```{r}
#' Type hints
#'
#' A [tibble][tibble::tbl_df] with all \R object type hints together with their `id`. The latter can be fed to [pkgsnip::type()].
#'
#' @format `r return_lbl("tibble_cols", cols = colnames(data_types))`
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::data_types
"data_types"
```

### `type`

NOTES

-   Only native R scalars are intended to support the `length` arg (their constructors like `logical()` literally feature a `length` arg).

```{r}
#' Get predefined type hint
#'
#' Returns a predefined \R object type hint intended to be used to document a function parameter's type.
#'
#' @param id Type identifier. One of `r data_types$id |> pal::as_md_vals() |> cli::ansi_collapse(last = " or ")`
#' @param length Length of the \R object to be documented. Omitted if `NULL`.
#' @param add_cr Whether or not to suffix the returned string with an [Rd line break
#'   (`\cr`)](https://rstudio.github.io/r-manuals/r-exts/Writing-R-documentation-files.html#sectioning).
#'
#' @return `r pkgsnip::return_lbl("glue_chr")`
#' @family roxylbl
#' @export
#'
#' @examples
#' pkgsnip::type(id = "lgl",
#'               length = 3L)
#'
#' pkgsnip::type(id = "pg_conn")
type <- function(id = data_types$id,
                 length = NULL,
                 add_cr = TRUE) {
  
  id <- rlang::arg_match(id)
  checkmate::assert_int(length,
                        null.ok = TRUE)
  checkmate::assert_flag(add_cr)
  
  result <- data_types |> dplyr::filter(id == !!id)
  
  if (!result$is_scalar && !is.null(length)) {
    cli::cli_abort("The {.val {id}} type hint does not support the {.arg length} argument.")
  }
  
  result <- glue::glue(result$value,
                       length = length,
                       .null = "")
  if (add_cr) {
    result %<>% paste0("\\cr")
  }
  
  result
}
```

## Common abbreviations

### `abbrs`

```{r}
#' Commonly used abbreviations in \R code
#' 
#' Returns a [tibble][tibble::tbl_df] listing an opinionated set of abbreviations commonly used when writing \R code. It can be used as a reference, for
#' example, to check availability/consistency when considering using some abbreviation in a function or argument name.
#'
#' To avoid the list getting excessively long and redundant, **the main focus is on verbs and nouns**. Adjectives and adverbs are only listed in column
#' `full_expression` when there's not already a verb or noun with the same root word listed for a particular `abbreviation`. That means that e.g. the
#' abbreviation "seq" could also stand for the full expressions "sequential" or "sequentially", despite the fact that it is not explicitly listed but merely the
#' verb/noun "sequence" is.
#'
#' # Motivation
#'
#' To quote [Leon Bambrick](https://twitter.com/secretGeek/status/7269997868):
#' 
#' *"There are 2 hard problems in computer science: cache invalidation, **naming things**, and off-by-1 errors."*
#' 
#' @param unnest Whether to unnest the `full_expression` column and return the data in long format. If `FALSE`, a "nested" list column `full_expressions` will
#'   be returned, meaning the values in column `abbreviation` will be unique.
#' @return `r return_lbl("tibble")`
#' @export
#'
#' @examples
#' pkgsnip::abbrs(unnest = TRUE) |> print(n = Inf)
abbrs <- function(unnest = FALSE) {
  
  checkmate::assert_flag(unnest)
  
  if (unnest) {
    data_abbrs %<>% tidyr::unnest_longer(col = full_expressions,
                                         values_to = "full_expression")
  }
  
  data_abbrs
}
```

# INTERNAL

## Avoid `R CMD check` notes about undefined global objects used in magrittr pipes

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

```{r}
utils::globalVariables(names = c(".",
                                 "full_expressions",
                                 "id",
                                 "path",
                                 "type",
                                 "value"))
```

## Constants

### `hint_*`

```{r}
hint_arg_pkg <- paste0("Note that the `pkg` argument defaults to the name of the package from which this function is called (`NULL` if not run within a ",
                       "package environment).")
```

## Functions

### `add_args_col`

```{r}
add_args_col <- function(data) {
  
  from_cols <- "value"
  
  from_col <-
    colnames(data) |>
    match(from_cols) %>%
    magrittr::extract(!is.na(.)) %>%
    {from_cols[.]} |> # nolint
    pal::when(length(.) == 0L ~ cli::cli_abort("No `from_col` could be determined!"),
              length(.) > 1L ~ cli::cli_abort("Multiple `from_col` candidates found:", cli::ansi_collapse(pal::as_md_vals(.))),
              ~ .)
  
  data |> dplyr::mutate(arguments =
                          stringr::str_extract_all(string = !!as.symbol(from_col),
                                                   pattern = "(?<=\\{)[^\\{\\?][^\\{]*?(?=\\})") |>
                          purrr::map_chr(\(x) {
                            
                            if (length(x) == 0L) {
                              return("")
                            }
                            
                            result <-
                              x |>
                              stringr::str_trim() |>
                              purrr::map_chr(\(el) {
                                ## return early if multi-statement expr since `extract_syms()` (the underlying `str2lang()`, actually) below only works with
                                ## single statements
                                if (stringr::str_detect(as.character(el), stringr::fixed(";"))) {
                                  return(NA_character_)
                                }
                                
                                extract_syms(el) |>
                                  stringr::str_subset("^\\w+$") |>
                                  unique() |>
                                  as.list() |>
                                  # NOTE: rush job
                                  dplyr::last() |>
                                  pal::when(length(.) > 1L ~ .[2L],
                                            ~ .)
                              }) %>%
                              magrittr::extract(!is.na(.)) |>
                              unique() |>
                              pal::when(length(.) == 0L ~ "",
                                        ~ pal::wrap_chr(.,
                                                        wrap = "`") |>
                                          cli::ansi_collapse(sep2 = ", ",
                                                             last = sep2))
                          }))
}
```

### `backtickify_cols`

```{r}
backtickify_cols <- function(data,
                             cols = tidyselect::any_of(c("id", "path"))) {
  
  dplyr::mutate(.data = data,
                dplyr::across({{ cols }},
                              \(x) purrr::map_chr(x,
                                                  \(y) pal::md_verb(as.symbol(y),
                                                                    .backtick = FALSE))))
}
```

### `extract_syms`

Recursively extract symbol names from an R code string using `str2lang()`. Hackish.

```{r}
extract_syms <- function(x) {
  
  result <-
    str2lang(x) |>
    as.character() |>
    setdiff(y = ls(name = "package:base")) |>
    stringr::str_subset("^(\\w+::\\w+(\\(\\))?|\\W+)$",
                        negate = TRUE)
  
  if (length(result) > 1L || stringr::str_detect(result, "\\(.+\\)")) {
    
    result %<>%
      purrr::map(extract_syms) %>%
      purrr::list_c(ptype = character())
  }
  
  result
}
```