1#' Constructor for column data
2#'
3#' @description
4#' The `new_pillar_shaft()` constructor creates objects of the `"pillar_shaft"`
5#' class.
6#' This is a virtual or abstract class, you must specify the `class`
7#' argument.
8#' By convention, this should be a string that starts with `"pillar_shaft_"`.
9#' See `vignette("extending", package = "tibble")` for usage examples.
10#'
11#' This method accepts a vector of arbitrary length and is expected to return an S3 object with the following properties:
12#'
13#' - It has an attribute `"width"`
14#' - It can have an attribute `"min_width"`, if missing, `"width"` is used
15#' - It must implement a method `format(x, width, ...)` that can be called with any value between `min_width` and `width`
16#' - This method must return an object that inherits from `character` and has attributes `"align"` (with supported values `"left"`, `"right"`, and `"center"`) and `"width"`
17#'
18#' The function [new_pillar_shaft()] returns such an object, and also correctly formats `NA` values.
19#' In many cases, the implementation of `pillar_shaft.your_class_name()` will format the data as a character vector (using color for emphasis) and simply call `new_pillar_shaft()`.
20#' See `pillar:::pillar_shaft.numeric` for a code that allows changing the display depending on the available width.
21#'
22#' @param x An object
23#' @param ... Additional attributes.
24#' @param width The maximum column width.
25#' @param min_width The minimum allowed column width, `width` if omitted.
26#' @param class The name of the subclass.
27#' @param subclass Deprecated, pass the `class` argument instead.
28#' @name new_pillar_shaft
29#' @export
30new_pillar_shaft <- function(x, ..., width = NULL, min_width = width, class = NULL, subclass = NULL) {
31  if (!is.null(subclass)) {
32    deprecate_soft("1.4.0", "pillar::new_pillar_shaft(subclass = )", "new_pillar_shaft(class = )")
33    class <- subclass
34  }
35
36  stopifnot(is.character(class))
37  stopifnot(length(class) > 0)
38  stopifnot(is_bare_numeric(width, 1))
39
40  ret <- structure(
41    x,
42    ...,
43    class = c(class, "pillar_shaft")
44  )
45  ret <- set_width(ret, width)
46  ret <- set_min_width(ret, min_width)
47  ret
48}
49
50#' Column data
51#'
52#' Internal class for formatting the data for a column.
53#' `pillar_shaft()` is a coercion method that must be implemented
54#' for your data type to display it in a tibble.
55#'
56#' @param x A vector to format
57#' @inheritParams ellipsis::dots_used
58#' @export
59#' @examples
60#' pillar_shaft(1:3)
61#' pillar_shaft(1.5:3.5)
62#' pillar_shaft(NA)
63#' pillar_shaft(c(1:3, NA))
64pillar_shaft <- function(x, ...) {
65  "!!!!DEBUG pillar_shaft(`v(class(x))`)"
66
67  if (!missing(...)) {
68    check_dots_used(action = warn)
69  }
70
71  UseMethod("pillar_shaft")
72}
73
74#' @export
75pillar_shaft.pillar_empty_col <- function(x, ...) {
76  new_empty_shaft()
77}
78
79#' @param width Width for printing and formatting.
80#' @export
81#' @rdname pillar_shaft
82print.pillar_shaft <- function(x, width = NULL, ...) {
83  #' @description
84  #' This class comes with a default method for [print()] that calls [format()].
85  #' If `print()` is called without `width` argument, the natural width will be
86  #' used when calling `format()`.
87  #' Usually there's no need to implement this method for your subclass.
88  if (is.null(width)) width <- get_width(x)
89  print(format(x, width = width, ...))
90}
91
92#' @export
93#' @rdname pillar_shaft
94format.pillar_shaft <- function(x, width, ...) {
95  #' @description
96  #' Your subclass must implement `format()`, the default implementation just
97  #' raises an error.
98  #' Your `format()` method can assume a valid value for the `width` argument.
99  stop("Please implement a format() method for class ", class(x)[[1]], call. = FALSE)
100}
101
102# Methods -----------------------------------------------------------------
103
104#' @export
105#' @rdname pillar_shaft
106pillar_shaft.logical <- function(x, ...) {
107  out <- rep(NA, length(x))
108  out[x] <- "TRUE"
109  out[!x] <- "FALSE"
110
111  new_pillar_shaft_simple(out, width = 5, align = "left")
112}
113
114#' @export
115#' @rdname pillar_shaft
116#' @param sigfig
117#'   Deprecated, use [num()] or [set_num_opts()] on the data instead.
118pillar_shaft.numeric <- function(x, ..., sigfig = NULL) {
119  pillar_attr <- attr(x, "pillar", exact = TRUE)
120
121  if (is.null(pillar_attr) && !is.null(attr(x, "class", exact = TRUE))) {
122    ret <- format(x)
123    return(new_pillar_shaft_simple(ret, width = get_max_extent(ret), align = "left"))
124  }
125
126  data <- unclass(x)
127  scale <- pillar_attr$scale
128  if (!is.null(scale)) {
129    data <- data * scale
130  }
131
132  pillar_shaft_number(
133    data,
134    sigfig %||% pillar_attr$sigfig,
135    pillar_attr$digits,
136    pillar_attr$notation,
137    pillar_attr$fixed_exponent,
138    pillar_attr$extra_sigfig
139  )
140}
141
142pillar_shaft_number <- function(x, sigfig, digits, notation, fixed_exponent, extra_sigfig) {
143  if (!is.null(digits)) {
144    if (!is.numeric(digits) || length(digits) != 1) {
145      abort("`digits` must be a number.")
146    }
147  }
148  if (is.null(sigfig)) {
149    sigfig <- get_pillar_option_sigfig()
150  }
151
152  if (isTRUE(extra_sigfig)) {
153    sigfig <- sigfig + compute_extra_sigfig(x)
154  }
155
156  if (is.null(notation) || notation == "fit") {
157    dec <- split_decimal(x, sigfig = sigfig, digits = digits)
158    sci <- split_decimal(x, sigfig = sigfig, digits = digits, sci_mod = 1, fixed_exponent = fixed_exponent)
159
160    max_dec_width <- get_pillar_option_max_dec_width()
161    dec_width <- get_width(dec)
162    "!!!!!!DEBUG `v(dec_width)`"
163
164    if (dec_width > max_dec_width) {
165      dec <- NULL
166    }
167  } else if (notation == "dec") {
168    dec <- split_decimal(x, sigfig = sigfig, digits = digits)
169    sci <- NULL
170  } else if (notation == "sci") {
171    sci <- split_decimal(
172      x,
173      sigfig = sigfig, digits = digits,
174      sci_mod = 1,
175      fixed_exponent = fixed_exponent
176    )
177    dec <- NULL
178  } else if (notation == "eng") {
179    sci <- split_decimal(
180      x,
181      sigfig = sigfig, digits = digits, sci_mod = 3,
182      fixed_exponent = fixed_exponent
183    )
184    dec <- NULL
185  } else if (notation == "si") {
186    sci <- split_decimal(
187      x,
188      sigfig = sigfig, digits = digits, sci_mod = 3, si = TRUE,
189      fixed_exponent = fixed_exponent
190    )
191    dec <- NULL
192  } else {
193    abort(paste0('Internal error: `notation = "', notation, '".'))
194  }
195
196  ret <- list()
197  ret$dec <- dec
198  ret$sci <- sci
199
200  new_pillar_shaft(
201    ret,
202    width = get_width(ret$dec %||% ret$sci),
203    min_width = min(get_min_widths(ret)),
204    class = "pillar_shaft_decimal"
205  )
206}
207
208# registered in .onLoad()
209pillar_shaft.integer64 <- function(x, ..., sigfig = NULL) {
210  pillar_shaft_number(x, sigfig, digits = NULL, notation = NULL, fixed_exponent = NULL, extra_sigfig = NULL)
211}
212
213# registered in .onLoad()
214pillar_shaft.Surv <- function(x, ...) {
215  new_pillar_shaft_simple(format(x), align = "right")
216}
217
218# registered in .onLoad()
219pillar_shaft.Surv2 <- function(x, ...) {
220  new_pillar_shaft_simple(format(x), align = "right")
221}
222
223# registered in .onLoad()
224type_sum.Surv <- function(x) {
225  "Surv"
226}
227
228# registered in .onLoad()
229type_sum.Surv2 <- function(x) {
230  "Surv2"
231}
232
233#' @export
234#' @rdname pillar_shaft
235pillar_shaft.Date <- function(x, ...) {
236  x <- format(x, format = "%Y-%m-%d")
237
238  new_pillar_shaft_simple(x, width = 10, align = "left")
239}
240
241#' @export
242#' @rdname pillar_shaft
243pillar_shaft.POSIXt <- function(x, ...) {
244  width <- 19L
245  digits_secs <- getOption("digits.secs", 0L)
246  if (digits_secs > 0) {
247    width <- width + min(digits_secs, 6) + 1L
248  }
249
250  date <- format(x, format = "%Y-%m-%d")
251  time <- format(x, format = "%H:%M:%OS")
252
253  datetime <- paste0(date, " ", style_subtle(time))
254  datetime[is.na(x)] <- NA
255
256  new_pillar_shaft_simple(datetime, width = width, align = "left")
257}
258
259
260#' @export
261#' @rdname pillar_shaft
262#' @param min_width
263#'   Deprecated, use [char()] or [set_char_opts()] on the data instead.
264pillar_shaft.character <- function(x, ..., min_width = NULL) {
265  pillar_attr <- attr(x, "pillar", exact = TRUE)
266
267  min_chars <- min_width %||% pillar_attr$min_chars
268
269  x <- utf8::utf8_encode(x)
270  out <- x
271
272  # Add subtle quotes if necessary
273  needs_quotes <- which(is_ambiguous_string(x))
274  if (has_length(needs_quotes)) {
275    out[needs_quotes] <- gsub('"', '\\"', x[needs_quotes], fixed = TRUE)
276    out[!is.na(x)] <- paste0(style_subtle('"'), out[!is.na(x)], style_subtle('"'))
277    na_indent <- 1
278  } else {
279    na_indent <- 0
280  }
281
282  # determine width based on width of characters in the vector
283  if (is.null(min_chars)) {
284    min_chars <- get_pillar_option_min_chars()
285  }
286
287  pillar_shaft(new_vertical(out), ..., min_width = min_chars, na_indent = na_indent, shorten = pillar_attr$shorten)
288}
289
290#' @export
291#' @inheritParams new_pillar_shaft_simple
292#' @rdname pillar_shaft
293pillar_shaft.pillar_vertical <- function(x, ..., min_width = NULL, na_indent = 0L, shorten = NULL) {
294  min_width <- max(min_width, 3L)
295  width <- get_max_extent(x)
296
297  new_pillar_shaft_simple(
298    x,
299    width = width, align = "left", min_width = min(width, min_width),
300    na = pillar_na(use_brackets_if_no_color = TRUE),
301    na_indent = na_indent,
302    shorten = shorten
303  )
304}
305
306#' @export
307#' @rdname pillar_shaft
308pillar_shaft.list <- function(x, ...) {
309  out <- paste0("<", map_chr(x, obj_sum), ">")
310
311  width <- get_max_extent(out)
312
313  new_pillar_shaft_simple(style_list(out), width = width, align = "left", min_width = min(width, 3L))
314}
315
316#' @export
317#' @rdname pillar_shaft
318pillar_shaft.factor <- function(x, ...) {
319  pillar_shaft(as.character(x), ...)
320}
321
322#' @export
323#' @rdname pillar_shaft
324pillar_shaft.AsIs <- function(x, ...) {
325  pillar_shaft(remove_as_is_class(x))
326}
327
328#' @export
329#' @rdname pillar_shaft
330pillar_shaft.default <- function(x, ...) {
331  #' @details
332  #' The default method will currently format via [format()],
333  #' but you should not rely on this behavior.
334  pillar_shaft(new_vertical(format(x)), ...)
335}
336