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