File: reprex_document.R

package info (click to toggle)
r-cran-reprex 1.0.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 1,584 kB
  • sloc: sh: 13; makefile: 2
file content (193 lines) | stat: -rw-r--r-- 6,211 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
#' reprex output format
#'
#' @description
#' This is an R Markdown output format designed specifically for making
#' "reprexes", typically created via the [reprex()] function, which ultimately
#' renders the document with [reprex_render()]. It is a heavily modified version
#' of [rmarkdown::md_document()]. The arguments have different spheres of
#' influence:
#'   * `venue` potentially affects input preparation and [reprex_render()].
#'   * Add content to the primary input, prior to rendering:
#'     - `advertise`
#'     - `session_info`
#'     - `std_out_err` (also consulted by [reprex_render()])
#'   * Influence knitr package or chunk options:
#'     - `style`
#'     - `comment`
#'     - `tidyverse_quiet`
#'   * `html_preview` is only consulted by [reprex_render()], but it is a formal
#'     argument of `reprex_document()` so that it can be included in the YAML
#'     frontmatter.
#'
#' RStudio users can create new R Markdown documents with the
#' `reprex_document()` format using built-in templates. Do
#' *File > New File > R Markdown ... > From Template* and choose one of:
#'   * reprex (minimal)
#'   * reprex (lots of features)
#'
#' Both include `knit: reprex::reprex_render` in the YAML, which causes the
#' RStudio "Knit" button to use `reprex_render()`. If you render these documents
#' yourself, you should do same.
#'
#' @inheritParams reprex
#' @inheritParams rmarkdown::md_document
#' @return An R Markdown output format to pass to [rmarkdown::render()].
#' @export
#' @examples
#' reprex_document()
reprex_document <- function(venue = c("gh", "r", "rtf", "html", "slack", "so", "ds"),

                            advertise       = NULL,
                            session_info    = opt(FALSE),
                            style           = opt(FALSE),
                            comment         = opt("#>"),
                            tidyverse_quiet = opt(TRUE),
                            std_out_err     = opt(FALSE),
                            pandoc_args = NULL,
                            # must exist, so that it is tolerated in the YAML
                            html_preview) {
  venue <- tolower(venue)
  venue <- match.arg(venue)
  venue <- normalize_venue(venue)

  advertise       <- set_advertise(advertise, venue)
  session_info    <- arg_option(session_info)
  style           <- arg_option(style)
  style           <- style_requires_styler(style)
  # html_preview is actually an input for for reprex_render()
  comment         <- arg_option(comment)
  tidyverse_quiet <- arg_option(tidyverse_quiet)
  std_out_err     <- arg_option(std_out_err)

  stopifnot(is_toggle(advertise), is_toggle(session_info), is_toggle(style))
  stopifnot(is.character(comment))
  stopifnot(is_toggle(tidyverse_quiet), is_toggle(std_out_err))

  opts_chunk <- list(
    # fixed defaults
    collapse = TRUE, error = TRUE,
    # explicitly exposed for user configuration
    comment = comment,
    R.options = list(
      tidyverse.quiet = tidyverse_quiet,
      tidymodels.quiet = tidyverse_quiet
    )
  )
  if (isTRUE(style)) {
    opts_chunk[["tidy"]] <- "styler"
  }
  opts_knit <- list(
    upload.fun = switch(
      venue,
      r = identity,
      knitr::imgur_upload
    )
  )

  pandoc_args <- c(
    pandoc_args,
    if (rmarkdown::pandoc_available()) {
      if (rmarkdown::pandoc_version() < "1.16") "--no-wrap" else "--wrap=preserve"
    }
  )

  pre_knit <- NULL
  if (isTRUE(std_out_err) || isTRUE(advertise) || isTRUE(session_info)) {
    pre_knit <- function(input, ...) {

      # I don't know why the pre_knit hook operates on the **original** input
      # instead of the to-be-knitted (post-spinning) input, but I need to
      # operate on the latter. So I brute force the correct path.
      # This is a no-op if input starts as `.Rmd`.
      knit_input <- sub("[.]R$", ".spin.Rmd", input)
      input_lines <- read_lines(knit_input)

      if (isTRUE(advertise)) {
        input_lines <- c(input_lines, "", ad(venue))
      }

      if (isTRUE(std_out_err)) {
        input_lines <- c(
          input_lines, "", std_out_err_stub(input, venue %in% c("gh", "html"))
        )
      }

      if (isTRUE(session_info)) {
        input_lines <- c(
          input_lines, "", si(details = venue %in% c("gh", "html"))
        )
      }

      write_lines(input_lines, knit_input)
    }
  }

  format <- rmarkdown::output_format(
    knitr = rmarkdown::knitr_options(
      opts_knit = opts_knit,
      opts_chunk = opts_chunk
    ),
    pandoc = rmarkdown::pandoc_options(
      to = "commonmark",
      from = rmarkdown::from_rmarkdown(implicit_figures = FALSE),
      ext = ".md",
      args = pandoc_args
    ),
    clean_supporting = FALSE,
    pre_knit = pre_knit,
    base_format = rmarkdown::md_document()
  )
  format
}

std_out_err_stub <- function(input, details = FALSE) {
  txt <- backtick(std_file(input))
  if (details) {
    c(
      "<details style=\"margin-bottom:10px;\">",
      "<summary>Standard output and standard error</summary>",
      txt,
      "</details>"
    )
  } else {
    c("#### Standard output and error", txt)
  }
}

ad <- function(venue) {
  if (venue %in% c("gh", "ds", "so", "html")) {
    return(glue::glue('
      <sup>Created on `r Sys.Date()` by the \\
      [reprex package](https://reprex.tidyverse.org) \\
      (v`r utils::packageVersion("reprex")`)</sup>'))
  }
  # what's left? venues "r", "rtf", "slack"
  glue::glue('
    Created on `r Sys.Date()` by the reprex package \\
    v`r utils::packageVersion("reprex")` https://reprex.tidyverse.org')
}

# TO RECONSIDER: once I am convinced that so == gh, I can eliminate the
# `details` argument of `si()`. Empirically, there seems to be no downside
# on SO when we embed session info in the html tags that are favorable for
# GitHub. They apparently are ignored.
si <- function(details = FALSE) {
  txt <- r_chunk(session_info_string())
  if (details) {
    txt <- c(
      "<details style=\"margin-bottom:10px;\">",
      "<summary>Session info</summary>",
      txt,
      "</details>"
    )
  }
  txt
}

session_info_string <- function() {
  if (rlang::is_installed("sessioninfo")) {
    "sessioninfo::session_info()"
  } else {
    "sessionInfo()"
  }
}