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 \code{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 \code{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 \code{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 \code{x}.
79#' @param stop Ending index or indices, recycled to match the length
80#'   of \code{x}.
81#' @return Character vector of the same length as \code{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 \code{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 \code{first}
144#'   and \code{last}.
145#' @param first Starting index or indices, recycled to match the length
146#'   of \code{x}.
147#' @param last Ending index or indices, recycled to match the length
148#'   of \code{x}.
149#' @return Character vector of the same length as \code{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 \code{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 \code{fixed = TRUE}) to use
196#'   for splitting.  If empty matches occur, in particular if \code{split} has
197#'   zero characters, \code{x} is split into single characters.
198#' @param ... Extra arguments are passed to \code{base::strsplit}.
199#' @return A list of the same length as \code{x}, the \eqn{i}-th element of
200#'   which contains the vector of splits of \code{x[i]}. ANSI styles are
201#'   retained.
202#'
203#' @family ANSI string operations
204#' @export
205#' @examples
206#' str <- red("I am red---") %+%
207#'   green("and I am green-") %+%
208#'   underline("I underlined")
209#'
210#' cat(str, "\n")
211#'
212#' # split at dashes, keep color
213#' cat(col_strsplit(str, "[-]+")[[1]], sep = "\n")
214#' strsplit(strip_style(str), "[-]+")
215#'
216#' # split to characters, keep color
217#' cat(col_strsplit(str, "")[[1]], "\n", sep = " ")
218#' strsplit(strip_style(str), "")
219
220col_strsplit <- function(x, split, ...) {
221  split <- try(as.character(split), silent=TRUE)
222  if(inherits(split, "try-error") || !is.character(split) || length(split) > 1L)
223    stop("`split` must be character of length <= 1, or must coerce to that")
224  if(!length(split)) split <- ""
225  plain <- strip_style(x)
226  splits <- re_table(split, plain, ...)
227  chunks <- non_matching(splits, plain, empty = TRUE)
228  # silently recycle `split`; doesn't matter currently since we don't support
229  # split longer than 1, but might in future
230  split.r <- rep(split, length.out=length(x))
231  # Drop empty chunks to align with `substr` behavior
232  chunks <- lapply(
233    seq_along(chunks),
234    function(i) {
235      y <- chunks[[i]]
236      # empty split means drop empty first match
237      if(nrow(y) && !nzchar(split.r[[i]]) && !head(y, 1L)[, "length"]) {
238        y <- y[-1L, , drop=FALSE]
239      }
240      # drop empty last matches
241      if(nrow(y) && !tail(y, 1L)[, "length"]) y[-nrow(y), , drop=FALSE] else y
242    }
243  )
244  zero.chunks <- !vapply(chunks, nrow, integer(1L))
245  # Pull out zero chunks from colored string b/c col_substring won't work
246  # with them
247  res <- vector("list", length(chunks))
248  res[zero.chunks] <- list(character(0L))
249  res[!zero.chunks] <- mapply(
250    chunks[!zero.chunks], x[!zero.chunks], SIMPLIFY = FALSE,
251    FUN = function(tab, xx) col_substring(xx, tab[, "start"], tab[, "end"])
252  )
253  res
254}
255