1
2## Create a mapping between the string and its style-less version.
3## This is useful to work with the colored string.
4
5#' @importFrom utils tail
6
7map_to_ansi <- function(x, text = NULL) {
8
9  if (is.null(text)) {
10    text <- non_matching(re_table(ansi_regex, x), x, empty=TRUE)
11  }
12
13  map <- lapply(
14    text,
15    function(text) {
16      cbind(
17        pos = cumsum(c(1, text[, "length"], Inf)),
18        offset = c(text[, "start"] - 1, tail(text[, "end"], 1), NA)
19      )
20    })
21
22  function(pos) {
23    pos <- rep(pos, length.out = length(map))
24    mapply(pos, map, FUN = function(pos, table) {
25      if (pos < 1) {
26        pos
27      } else {
28        slot <- which(pos < table[, "pos"])[1] - 1
29        table[slot, "offset"] + pos - table[slot, "pos"] + 1
30      }
31    })
32  }
33}
34
35
36#' Count number of characters in an ANSI colored string
37#'
38#' This is a color-aware counterpart of [base::nchar()],
39#' which does not do well, since it also counts the ANSI control
40#' characters.
41#'
42#' @param x Character vector, potentially ANSO styled, or a vector to be
43#'   coarced to character.
44#' @param ... Additional arguments, passed on to `base::nchar()`
45#'   after removing ANSI escape sequences.
46#' @return Numeric vector, the length of the strings in the character
47#'   vector.
48#'
49#' @family ANSI string operations
50#' @export
51#' @examples
52#' str <- paste(
53#'   red("red"),
54#'   "default",
55#'   green("green")
56#' )
57#'
58#' cat(str, "\n")
59#' nchar(str)
60#' col_nchar(str)
61#' nchar(strip_style(str))
62
63col_nchar <- function(x, ...) {
64  base::nchar(strip_style(x), ...)
65}
66
67
68#' Substring(s) of an ANSI colored string
69#'
70#' This is a color-aware counterpart of [base::substr()].
71#' It works exactly like the original, but keeps the colors
72#' in the substrings. The ANSI escape sequences are ignored when
73#' calculating the positions within the string.
74#'
75#' @param x Character vector, potentially ANSI styled, or a vector to
76#'   coarced to character.
77#' @param start Starting index or indices, recycled to match the length
78#'   of `x`.
79#' @param stop Ending index or indices, recycled to match the length
80#'   of `x`.
81#' @return Character vector of the same length as `x`, containing
82#'   the requested substrings. ANSI styles are retained.
83#'
84#' @family ANSI string operations
85#' @export
86#' @examples
87#' str <- paste(
88#'   red("red"),
89#'   "default",
90#'   green("green")
91#' )
92#'
93#' cat(str, "\n")
94#' cat(col_substr(str, 1, 5), "\n")
95#' cat(col_substr(str, 1, 15), "\n")
96#' cat(col_substr(str, 3, 7), "\n")
97#'
98#' substr(strip_style(str), 1, 5)
99#' substr(strip_style(str), 1, 15)
100#' substr(strip_style(str), 3, 7)
101#'
102#' str2 <- "another " %+%
103#'   red("multi-", sep = "", underline("style")) %+%
104#'   " text"
105#'
106#' cat(str2, "\n")
107#' cat(col_substr(c(str, str2), c(3,5), c(7, 18)), sep = "\n")
108#' substr(strip_style(c(str, str2)), c(3,5), c(7, 18))
109
110col_substr <- function(x, start, stop) {
111  if(!is.character(x)) x <- as.character(x)
112  if(!length(x)) return(x)
113  start <- as.integer(start)
114  stop <- as.integer(stop)
115  if(!length(start) || !length(stop))
116    stop("invalid substring arguments")
117  if(anyNA(start) || anyNA(stop))
118    stop("non-numeric substring arguments not supported")
119  ansi <- re_table(ansi_regex, x)
120  text <- non_matching(ansi, x, empty=TRUE)
121  mapper <- map_to_ansi(x, text = text)
122  nstart <- mapper(start)
123  nstop  <- mapper(stop)
124
125  bef <- base::substr(x, 1, nstart - 1)
126  aft <- base::substr(x, nstop + 1, base::nchar(x))
127  ansi_bef <- vapply(regmatches(bef, gregexpr(ansi_regex, bef)),
128                     paste, collapse = "", FUN.VALUE = "")
129  ansi_aft <- vapply(regmatches(aft, gregexpr(ansi_regex, aft)),
130                     paste, collapse = "", FUN.VALUE = "")
131
132  paste(sep = "", ansi_bef, base::substr(x, nstart, nstop), ansi_aft)
133}
134
135#' Substring(s) of an ANSI colored string
136#'
137#' This is the color-aware counterpart of [base::substring()].
138#' It works exactly like the original, but keeps the colors in the
139#' substrings. The ANSI escape sequences are ignored when
140#' calculating the positions within the string.
141#'
142#' @param text Character vector, potentially ANSI styled, or a vector to
143#'   coarced to character. It is recycled to the longest of `first`
144#'   and `last`.
145#' @param first Starting index or indices, recycled to match the length
146#'   of `x`.
147#' @param last Ending index or indices, recycled to match the length
148#'   of `x`.
149#' @return Character vector of the same length as `x`, containing
150#'   the requested substrings. ANSI styles are retained.
151#'
152#' @family ANSI string operations
153#' @export
154#' @examples
155#' str <- paste(
156#'   red("red"),
157#'   "default",
158#'   green("green")
159#' )
160#'
161#' cat(str, "\n")
162#' cat(col_substring(str, 1, 5), "\n")
163#' cat(col_substring(str, 1, 15), "\n")
164#' cat(col_substring(str, 3, 7), "\n")
165#'
166#' substring(strip_style(str), 1, 5)
167#' substring(strip_style(str), 1, 15)
168#' substring(strip_style(str), 3, 7)
169#'
170#' str2 <- "another " %+%
171#'   red("multi-", sep = "", underline("style")) %+%
172#'   " text"
173#'
174#' cat(str2, "\n")
175#' cat(col_substring(str2, c(3,5), c(7, 18)), sep = "\n")
176#' substring(strip_style(str2), c(3,5), c(7, 18))
177
178col_substring <- function(text, first, last = 1000000L) {
179  if (!is.character(text)) text <- as.character(text)
180  n <- max(lt <- length(text), length(first), length(last))
181  if (lt && lt < n) text <- rep_len(text, length.out = n)
182  col_substr(text, as.integer(first), as.integer(last))
183}
184
185
186#' Split an ANSI colored string
187#'
188#' This is the color-aware counterpart of [base::strsplit()].
189#' It works almost exactly like the original, but keeps the colors in the
190#' substrings.
191#'
192#' @param x Character vector, potentially ANSI styled, or a vector to
193#'   coarced to character.
194#' @param split Character vector of length 1 (or object which can be coerced to
195#'   such) containing regular expression(s) (unless `fixed = TRUE`) to use
196#'   for splitting.  If empty matches occur, in particular if `split` has
197#'   zero characters, `x` is split into single characters.
198#' @param ... Extra arguments are passed to `base::strsplit()`.
199#' @return A list of the same length as `x`, the \eqn{i}-th element of
200#'   which contains the vector of splits of `x[i]`. ANSI styles are
201#'   retained.
202#'
203#' @family ANSI string operations
204#' @export
205#' @importFrom utils head
206#' @examples
207#' str <- red("I am red---") %+%
208#'   green("and I am green-") %+%
209#'   underline("I underlined")
210#'
211#' cat(str, "\n")
212#'
213#' # split at dashes, keep color
214#' cat(col_strsplit(str, "[-]+")[[1]], sep = "\n")
215#' strsplit(strip_style(str), "[-]+")
216#'
217#' # split to characters, keep color
218#' cat(col_strsplit(str, "")[[1]], "\n", sep = " ")
219#' strsplit(strip_style(str), "")
220
221col_strsplit <- function(x, split, ...) {
222  split <- try(as.character(split), silent=TRUE)
223  if(inherits(split, "try-error") || !is.character(split) || length(split) > 1L)
224    stop("`split` must be character of length <= 1, or must coerce to that")
225  if(!length(split)) split <- ""
226  plain <- strip_style(x)
227  splits <- re_table(split, plain, ...)
228  chunks <- non_matching(splits, plain, empty = TRUE)
229  # silently recycle `split`; doesn't matter currently since we don't support
230  # split longer than 1, but might in future
231  split.r <- rep(split, length.out=length(x))
232  # Drop empty chunks to align with `substr` behavior
233  chunks <- lapply(
234    seq_along(chunks),
235    function(i) {
236      y <- chunks[[i]]
237      # empty split means drop empty first match
238      if(nrow(y) && !nzchar(split.r[[i]]) && !head(y, 1L)[, "length"]) {
239        y <- y[-1L, , drop=FALSE]
240      }
241      # drop empty last matches
242      if(nrow(y) && !tail(y, 1L)[, "length"]) y[-nrow(y), , drop=FALSE] else y
243    }
244  )
245  zero.chunks <- !vapply(chunks, nrow, integer(1L))
246  # Pull out zero chunks from colored string b/c col_substring won't work
247  # with them
248  res <- vector("list", length(chunks))
249  res[zero.chunks] <- list(character(0L))
250  res[!zero.chunks] <- mapply(
251    chunks[!zero.chunks], x[!zero.chunks], SIMPLIFY = FALSE,
252    FUN = function(tab, xx) col_substring(xx, tab[, "start"], tab[, "end"])
253  )
254  res
255}
256
257#' Align an ANSI colored string
258#'
259#' @param text The character vector to align.
260#' @param width Width of the field to align in.
261#' @param align Whether to align `"left"`, `"center"` or `"right"`.
262#' @param type Passed on to [col_nchar()] and there to [nchar()]
263#' @return The aligned character vector.
264#'
265#' @family ANSI string operations
266#' @export
267#' @examples
268#' col_align(red("foobar"), 20, "left")
269#' col_align(red("foobar"), 20, "center")
270#' col_align(red("foobar"), 20, "right")
271
272col_align <- function(text, width = getOption("width"),
273                      align = c("left", "center", "right"),
274                      type = "width") {
275
276  align <- match.arg(align)
277  nc <- col_nchar(text, type = type)
278
279  if (!length(text)) return(text)
280
281  if (align == "left") {
282    paste0(text, make_space(width - nc))
283
284  } else if (align == "center") {
285    paste0(make_space(ceiling((width - nc) / 2)),
286           text,
287           make_space(floor((width - nc) / 2)))
288
289  } else {
290    paste0(make_space(width - nc), text)
291  }
292}
293
294make_space <- function(num, filling = " ") {
295  num <- pmax(0, num)
296  res <- strrep(filling, num)
297  Encoding(res) <- Encoding(filling)
298  res
299}
300
301strrep <- function (x, times) {
302  x = as.character(x)
303  if (length(x) == 0L) return(x)
304
305  mapply(
306    function(x, times) {
307      if (is.na(x) || is.na(times)) {
308        NA_character_
309      } else if (times <= 0L) {
310        ""
311      } else {
312        paste0(rep(x, times), collapse = "")
313      }
314    },
315    x, times,
316    USE.NAMES = FALSE
317  )
318}
319