obj_print*() gain max argument

NEWS.md

@@ -1,5 +1,10 @@
 # vctrs (development version)
 
+* `obj_print()`, `obj_print_header()`, `obj_print_data()` and
+  `obj_print_footer()` gain `max` argument that controls the maximum number
+  of items to print. By default, `getOption("max.print")` is consulted
+  (#1355, @krlmlr).
+
 * `"select"` and `"relocate"` have been added as valid subscript actions to
   support tidyselect and dplyr (#1596).
 

R/print-str.R

@@ -6,15 +6,55 @@
 #' the `_header()`, `_data()` or `_footer()` components individually. The
 #' default methods are built on top of `format()`.
 #'
+#' @details
+#' If you are implementing `obj_print_header()`, `obj_print_data()` or
+#' `obj_print_footer()`, your method can assume that the `max` argument
+#' is a scalar integer that accurately describes the maximum number of items
+#' to print, and that `getOption("max.print")` is set to at least that value.
+#'
+#' All methods receive `x` unchanged when called from `obj_print()`.
+#' `obj_print_data()` should print only the first `max` elements.
+#'
 #' @param x A vector
 #' @param ... Additional arguments passed on to methods. See [print()] and
 #'   [str()] for commonly used options
+#' @param max The maximum number of items to print, defaults to
+#'   `getOption("print.max")`.
 #' @keywords internal
 #' @export
-obj_print <- function(x, ...) {
+obj_print <- function(x, ..., max = NULL) {
+  if (!vec_is(x)) {
+    delta <- 0
+    x_max <- x
+  } else {
+    max <- local_max_print(max)
+    delta <- vec_size(x) - max
+
+    if (vec_size(x) > max) {
+      x_max <- vec_slice(x, seq_len(max))
+    } else {
+      x_max <- x
+    }
+  }
+
   obj_print_header(x, ...)
-  obj_print_data(x, ...)
+  obj_print_data(x_max, ...)
   obj_print_footer(x, ...)
+
+  if (delta > 0) {
+    max_print <- attr(max, "max_print")
+    if (is.null(max_print)) {
+      max_print <- getOption("max.print")
+    }
+
+    cat_line("... and ", big_mark(delta), " more")
+    if (max < max_print) {
+      cat_line("Set `max` to a larger value to show all items.")
+    } else {
+      cat_line("Set `options(max.print = )` to a larger value to show all items.")
+    }
+  }
+
   invisible(x)
 }
 
@@ -38,8 +78,14 @@ obj_print_data <- function(x, ...) {
 
 #' @export
 obj_print_data.default <- function(x, ...) {
-  if (length(x) == 0)
+  if (!vec_is(x)) {
+    print(x, quote = FALSE)
     return(invisible(x))
+  }
+
+  if (vec_size(x) == 0) {
+    return(invisible(x))
+  }
 
   out <- stats::setNames(format(x), names(x))
   print(out, quote = FALSE)
@@ -58,6 +104,23 @@ obj_print_footer.default <- function(x, ...) {
   invisible(x)
 }
 
+local_max_print <- function(max, frame = parent.frame()) {
+  max_print <- getOption("max.print")
+  if (is.null(max)) {
+    max <- max_print
+  }
+
+  stopifnot(is_integerish(max, 1L, finite = TRUE), max >= 0, max < 2147483648)
+  max <- as.integer(max)
+
+  if (max > max_print) {
+    # Avoid truncation in case we're forwarding to print()
+    local_options(max.print = max, .frame = frame)
+  }
+
+  structure(max, max_print = max_print)
+}
+
 
 # str ---------------------------------------------------------------------
 

R/utils.R

@@ -314,6 +314,19 @@ named <- function(x) {
   x
 }
 
+# Copied from pillar.
+#
+# Function for the thousand separator, returns "," unless it's used for the
+# decimal point, in which case returns "."
+big_mark <- function(x) {
+  # The thousand separator,
+  # "," unless it's used for the decimal point, in which case "."
+  mark <- if (identical(getOption("OutDec"), ",")) "." else ","
+  ret <- formatC(x, big.mark = mark, format = "d", preserve.width = "individual")
+  ret[is.na(x)] <- "??"
+  ret
+}
+
 browser <- function(...,
                     skipCalls = 0,
                     frame = parent.frame()) {

tests/testthat/_snaps/print-str.md

@@ -29,3 +29,62 @@
       $ carb: num  4 4 1 1 2 1 4 2 2 4 ...
       @ row.names: chr [1:32] "Mazda RX4" "Mazda RX4 Wag" "Datsun 710" "Hornet 4 Drive" ...
 
+# max argument (#1355)
+
+    Code
+      x <- vctrs::new_vctr(letters)
+      print(x, max = 5)
+    Output
+      <vctrs_vctr[26]>
+      [1] a b c d e
+      ... and 21 more
+      Set `max` to a larger value to show all items.
+    Code
+      print(x, max = 30)
+    Output
+      <vctrs_vctr[26]>
+       [1] a b c d e f g h i j k l m n o p q r s t u v w x y z
+
+# small max.print option (#1355)
+
+    Code
+      x <- vctrs::new_vctr(letters)
+      print(x)
+    Output
+      <vctrs_vctr[26]>
+      [1] a b c d e
+      ... and 21 more
+      Set `options(max.print = )` to a larger value to show all items.
+
+# large max.print option (#1355)
+
+    Code
+      x <- vctrs::new_vctr(letters)
+      print(x)
+    Output
+      <vctrs_vctr[26]>
+       [1] a b c d e f g h i j k l m n o p q r s t u v w x y z
+
+# both max argument and max.print option (#1355)
+
+    Code
+      x <- vctrs::new_vctr(letters)
+      print(x, max = 5)
+    Output
+      <vctrs_vctr[26]>
+      [1] a b c d e
+      ... and 21 more
+      Set `max` to a larger value to show all items.
+    Code
+      print(x, max = 20)
+    Output
+      <vctrs_vctr[26]>
+       [1] a b c d e f g h i j k l m n o p q r s t
+      ... and 6 more
+      Set `options(max.print = )` to a larger value to show all items.
+    Code
+      print(x, max = 30)
+    Output
+      <vctrs_vctr[26]>
+       [1] a b c d e f g h i j k l m n o p q r s t u v w x y z
+

tests/testthat/_snaps/type-list-of.md

@@ -11,6 +11,34 @@
       [1] 2 3
 
 
+---
+
+    Code
+      list_of(.ptype = integer())
+    Output
+      <list_of<integer>[0]>
+
+---
+
+    Code
+      print(list_of(1, 2:3), max = 1)
+    Output
+      <list_of<double>[2]>
+      [[1]]
+      [1] 1
+
+      ... and 1 more
+      Set `max` to a larger value to show all items.
+
+---
+
+    Code
+      print(list_of(1, 2:3), max = 0)
+    Output
+      <list_of<double>[2]>
+      ... and 2 more
+      Set `max` to a larger value to show all items.
+
 ---
 
     Code

tests/testthat/test-print-str.R

@@ -5,3 +5,38 @@ test_that("show attributes", {
 
   expect_snapshot(obj_str(mtcars))
 })
+
+test_that("max argument (#1355)", {
+  expect_snapshot({
+    x <- vctrs::new_vctr(letters)
+    print(x, max = 5)
+    print(x, max = 30)
+  })
+})
+
+test_that("small max.print option (#1355)", {
+  local_options(max.print = 5)
+  expect_snapshot({
+    x <- vctrs::new_vctr(letters)
+    print(x)
+  })
+})
+
+test_that("large max.print option (#1355)", {
+  local_options(max.print = 30)
+  expect_snapshot({
+    x <- vctrs::new_vctr(letters)
+    print(x)
+  })
+})
+
+test_that("both max argument and max.print option (#1355)", {
+  local_options(max.print = 10)
+
+  expect_snapshot({
+    x <- vctrs::new_vctr(letters)
+    print(x, max = 5)
+    print(x, max = 20)
+    print(x, max = 30)
+  })
+})

tests/testthat/test-type-list-of.R

@@ -41,6 +41,9 @@ test_that("is_list_of as expected", {
 test_that("print method gives human friendly output", {
   skip_on_cran() # Depends on tibble
   expect_snapshot(list_of(1, 2:3))
+  expect_snapshot(list_of(.ptype = integer()))
+  expect_snapshot(print(list_of(1, 2:3), max = 1))
+  expect_snapshot(print(list_of(1, 2:3), max = 0))
   expect_snapshot(tibble::tibble(x = list_of(1, 2:3)))
 })