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).
+
 * `levels.vctrs_vctr()` now returns `NULL` instead of failing (#1186, @krlmlr).
 
 * `vec_assert()` produces a more informative error when `size` is invalid

R/print-str.R

@@ -9,18 +9,26 @@
 #' @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_header(x, ...)
-  obj_print_data(x, ...)
-  obj_print_footer(x, ...)
+obj_print <- function(x, ..., max = NULL) {
+  max <- local_max_print(max)
+  obj_print_header_dispatch(x, ..., max = max)
+  obj_print_data_dispatch(x, ..., max = max)
+  obj_print_footer_dispatch(x, ..., max = max)
   invisible(x)
 }
 
 #' @export
 #' @rdname obj_print
-obj_print_header <- function(x, ...) {
+obj_print_header <- function(x, ..., max = NULL) {
+  max <- local_max_print(max)
+  return(obj_print_header_dispatch(x, ..., max = max))
+  UseMethod("obj_print_header")
+}
+obj_print_header_dispatch <- function(x, ..., max) {
   UseMethod("obj_print_header")
 }
 
@@ -32,32 +40,76 @@ obj_print_header.default <- function(x, ...) {
 
 #' @export
 #' @rdname obj_print
-obj_print_data <- function(x, ...) {
+obj_print_data <- function(x, ..., max) {
+  max <- local_max_print(max)
+  return(obj_print_data_dispatch(x, ..., max = max))
+  UseMethod("obj_print_data")
+}
+obj_print_data_dispatch <- function(x, ..., max) {
   UseMethod("obj_print_data")
 }
 
 #' @export
-obj_print_data.default <- function(x, ...) {
-  if (length(x) == 0)
+obj_print_data.default <- function(x, ..., max) {
+  if (!vec_is(x)) {
+    print(x, quote = FALSE)
     return(invisible(x))
+  }
+
+  if (vec_size(x) > max) {
+    x_max <- vec_slice(x, seq_len(max))
+  } else {
+    x_max <- x
+  }
+
+  if (vec_size(x_max) == 0) {
+    return(invisible(x))
+  }
 
-  out <- stats::setNames(format(x), names(x))
+  out <- stats::setNames(format(x_max), names(x_max))
   print(out, quote = FALSE)
 
   invisible(x)
 }
 
 #' @export
 #' @rdname obj_print
-obj_print_footer <- function(x, ...) {
+obj_print_footer <- function(x, ..., max = NULL) {
+  max <- local_max_print(max)
+  return(obj_print_footer_dispatch(x, ..., max = max))
+  UseMethod("obj_print_footer")
+}
+obj_print_footer_dispatch <- function(x, ..., max) {
   UseMethod("obj_print_footer")
 }
 
 #' @export
-obj_print_footer.default <- function(x, ...) {
+obj_print_footer.default <- function(x, ..., max = NULL) {
+  if (!vec_is(x)) {
+    return(invisible(x))
+  }
+
+  delta <- vec_size(x) - max
+  if (delta > 0) {
+    cat_line("... and ", big_mark(delta), " more")
+  }
   invisible(x)
 }
 
+local_max_print <- function(max, frame = parent.frame()) {
+  max_print <- getOption("max.print")
+  if (is.null(max)) {
+    return(max_print)
+  }
+
+  stopifnot(is_integerish(max, 1L, finite = TRUE), max >= 0)
+  if (max > max_print) {
+    # Avoid truncation in case we're forwarding to print()
+    local_options(max.print = max, .frame = frame)
+  }
+  max
+}
+
 
 # str ---------------------------------------------------------------------
 

R/type-list-of.R

@@ -101,11 +101,14 @@ vec_proxy.vctrs_list_of <- function(x, ...) {
 # Formatting --------------------------------------------------------------
 
 #' @export
-obj_print_data.vctrs_list_of <- function(x, ...) {
-  if (length(x) == 0)
-    return()
+obj_print_data.vctrs_list_of <- function(x, ..., max) {
+  out <- vec_data(x)
+  if (max < length(out)) {
+    out <- out[seq_len(max)]
+  }
 
-  print(vec_data(x))
+  print(out)
+  invisible(x)
 }
 
 #' @export

R/utils.R

@@ -284,3 +284,16 @@ 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
+}

tests/testthat/_snaps/print-str.md

@@ -29,3 +29,58 @@
       $ 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
+    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
+
+# 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
+    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
+    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,17 @@
       [1] 2 3
 
 
+---
+
+    Code
+      print(list_of(1, 2:3), max = 1)
+    Output
+      <list_of<double>[2]>
+      [[1]]
+      [1] 1
+
+      ... and 1 more
+
 ---
 
     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,7 @@ 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(print(list_of(1, 2:3), max = 1))
   expect_snapshot(tibble::tibble(x = list_of(1, 2:3)))
 })