File: reprex-undo.R

package info (click to toggle)
r-cran-reprex 0.3.0-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,424 kB
  • sloc: sh: 13; makefile: 2
file content (254 lines) | stat: -rw-r--r-- 8,355 bytes parent folder | download | duplicates (2)
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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
#' Un-render a reprex
#'
#' @description
#' Recover clean, runnable code from a reprex captured in the wild and write it
#' to user's clipboard. The code is also returned invisibly and optionally
#' written to file. Three different functions address various forms of
#' wild-caught reprex.
#'
#' @param input Character. If has length one and lacks a terminating newline,
#'   interpreted as the path to a file containing reprex code. Otherwise,
#'   assumed to hold reprex code as character vector. If not provided, the
#'   clipboard is consulted for input.
#' @param outfile Optional basename for output file. When `NULL`, no file is
#'   left behind. If `outfile = "foo"`, expect an output file in current working
#'   directory named `foo_clean.R`. If `outfile = NA`, expect on output file in
#'   a location and with basename derived from `input`, if a path, or in
#'   current working directory with basename derived from [tempfile()]
#'   otherwise.
#' @param comment regular expression that matches commented output lines
#' @param prompt character, the prompt at the start of R commands
#' @param continue character, the prompt for continuation lines
#' @return Character vector holding just the clean R code, invisibly
#' @name un-reprex
NULL

#' @describeIn un-reprex Attempts to reverse the effect of [reprex()]. When
#'   `venue = "r"`, this just becomes a wrapper around `reprex_clean()`.
#' @inheritParams reprex
#' @export
#' @examples
#' \dontrun{
#' ## a rendered reprex can be inverted, at least approximately
#' tmp_in <- file.path(tempdir(), "roundtrip-input")
#' x <- reprex({
#'   #' Some text
#'   #+ chunk-label-and-options-cannot-be-recovered, message = TRUE
#'   (x <- 1:4)
#'   #' More text
#'   y <- 2:5
#'   x + y
#' }, show = FALSE, advertise = FALSE, outfile = tmp_in)
#' tmp_out <- file.path(tempdir(), "roundtrip-output")
#' x <- reprex_invert(x, outfile = tmp_out)
#' x
#'
#' # clean up
#' file.remove(
#'   list.files(dirname(tmp_in), pattern = "roundtrip", full.names = TRUE)
#' )
#' }
reprex_invert <- function(input = NULL,
                          outfile = NULL,
                          venue = c("gh", "so", "ds", "r"),
                          comment = opt("#>")) {
  venue <- tolower(venue)
  venue <- match.arg(venue)
  venue <- ds_is_gh(venue)

  if (venue == "r") {
    return(reprex_clean(input, outfile = outfile, comment = comment))
  }

  reprex_undo(
    input,
    outfile = outfile,
    venue = venue,
    is_md = TRUE,
    comment = comment
  )
}

#' @describeIn un-reprex Assumes R code is top-level, possibly interleaved with
#'   commented output, e.g., a displayed reprex copied from GitHub or the direct
#'   output of `reprex(..., venue = "R")`. This function removes commented
#'   output.
#' @export
#' @examples
#' \dontrun{
#' ## a displayed reprex can be cleaned of commented output
#' tmp <- file.path(tempdir(), "commented-code")
#' x <- c(
#'   "## a regular comment, which is retained",
#'   "(x <- 1:4)",
#'   "#> [1] 1 2 3 4",
#'   "median(x)",
#'   "#> [1] 2.5"
#'   )
#' out <- reprex_clean(x, outfile = tmp)
#' out
#'
#' # clean up
#' file.remove(
#'   list.files(dirname(tmp), pattern = "commented-code", full.names = TRUE)
#' )
#'
#' ## round trip with reprex(..., venue = "R")
#' code_in <- c("x <- rnorm(2)", "min(x)")
#' res <- reprex(input = code_in, venue = "R", advertise = FALSE)
#' res
#' (code_out <- reprex_clean(res))
#' identical(code_in, code_out)
#' }
reprex_clean <- function(input = NULL,
                         outfile = NULL,
                         comment = opt("#>")) {
  reprex_undo(input, outfile = outfile, is_md = FALSE, comment = comment)
}

#' @describeIn un-reprex Assumes R code lines start with a prompt and that
#'   printed output is top-level, e.g., what you'd get from copy/paste from the
#'   R Console. Removes lines of output and strips prompts from lines holding R
#'   commands.
#' @export
#' @examples
#' \dontrun{
#' ## rescue a reprex that was copied from a live R session
#' tmp <- file.path(tempdir(), "live-transcript")
#' x <- c(
#'   "> ## a regular comment, which is retained",
#'   "> (x <- 1:4)",
#'   "[1] 1 2 3 4",
#'   "> median(x)",
#'   "[1] 2.5"
#' )
#' out <- reprex_rescue(x, outfile = tmp)
#' out
#'
#' # clean up
#' file.remove(
#'   list.files(dirname(tmp),pattern = "live-transcript", full.names = TRUE)
#' )
#' }
reprex_rescue <- function(input = NULL,
                          outfile = NULL,
                          prompt = getOption("prompt"),
                          continue = getOption("continue")) {
  reprex_undo(
    input,
    outfile = outfile,
    is_md = FALSE,
    prompt = paste(escape_regex(prompt), escape_regex(continue), sep = "|")
  )
}

reprex_undo <- function(input = NULL,
                        outfile = NULL,
                        venue,
                        is_md = FALSE,
                        comment = NULL, prompt = NULL) {
  where <- locate_input(input)
  src <- switch(
    where,
    clipboard = ingest_clipboard(),
    path      = read_lines(input),
    input     = escape_newlines(sub("\n$", "", input)),
    NULL
  )
  comment <- arg_option(comment)

  outfile_given <- !is.null(outfile)
  infile <- if (where == "path") input else NULL
  if (outfile_given) {
    files <- make_filenames(make_filebase(outfile, infile), suffix = "clean")
    r_file <- files[["r_file"]]
    if (would_clobber(r_file)) {
      return(invisible())
    }
  }

  if (is_md) { ## reprex_invert
    flavor <- if (venue == "gh") "fenced" else "indented"
    x_out <- convert_md_to_r(
      src, comment = comment, flavor = flavor, drop_output = TRUE
    )
  } else if (is.null(prompt)) { ## reprex_clean
    x_out <- src[!grepl(comment, src)]
  } else { ## reprex_rescue
    regex <- paste0("^\\s*", prompt)
    x_out <- src[grepl(regex, src)]
    x_out <- sub(regex, "", x_out)
  }

  if (clipboard_available()) {
    clipr::write_clip(x_out)
    message("Clean code is on the clipboard.")
  }
  if (outfile_given) {
    writeLines(x_out, r_file)
    message("Writing clean code as R script:\n  * ", r_file)
  }
  invisible(x_out)
}

convert_md_to_r <- function(lines,
                            comment = "#>",
                            flavor = c("fenced", "indented"),
                            drop_output = FALSE) {
  flavor <- match.arg(flavor)
  classify_fun <- switch(flavor,
                         fenced = classify_fenced_lines,
                         indented = classify_indented_lines)
  lines_info <- classify_fun(lines, comment = comment)

  lines_out <- ifelse(lines_info == "prose" & nzchar(lines), prose(lines), lines)

  drop_classes <- c("bt", "so_header", if (drop_output) "output")
  lines_out <- lines_out[!lines_info %in% drop_classes]

  if (flavor == "indented") {
    lines_out <- sub("^    ", "", lines_out)
  }

  lines_out
}

## Classify lines in the presence of fenced code blocks.
## Specifically, blocks fenced by three backticks.
## This is true of the output from reprex(..., venue = "gh").
## Classifies each line like so:
##   * bt     = backticks
##   * code   = code inside a fenced block
##   * output = commented output inside a fenced block
##   * prose  = outside a fenced block
classify_fenced_lines <- function(x, comment = "^#>") {
  x_shift <- c("", utils::head(x, -1))
  cumulative_fences <- cumsum(grepl("^```", x_shift))
  wut <- ifelse(grepl("^```", x), "bt",
    ifelse(cumulative_fences %% 2 == 1, "code", "prose")
  )
  wut <- ifelse(wut == "code" & grepl(comment, x), "output", wut)
  wut
}

## Classify lines in the presence of indented code blocks.
## Specifically, blocks indented with 4 spaces.
## This is true of the output from reprex(..., venue = "so").
## https://stackoverflow.com/editing-help
## Classifies each line like so:
##   * code      = code inside an indented code block
##   * output    = commented output inside an indented code block
##   * prose     = outside an indented code block
##   * so_header = special html comment for so syntax highlighting
classify_indented_lines <- function(x, comment = "^#>") {
  comment <- sub("\\^", "^    ", comment)
  wut <- ifelse(grepl("^    ", x), "code", "prose")
  wut <- ifelse(wut == "code" & grepl(comment, x), "output", wut)

  so_special <- "<!-- language-all: lang-r -->"
  if (identical(x[1], so_special)) {
    wut[1] <- "so_header"
  }

  wut
}