print.tbl_df() fixup

NAMESPACE

@@ -33,6 +33,7 @@ S3method(type_sum,data.frame)
 S3method(type_sum,default)
 S3method(type_sum,factor)
 S3method(type_sum,ordered)
+S3method(type_sum,tbl_df)
 export(add_row)
 export(as_data_frame)
 export(column_to_rownames)

R/tbl-df.r

@@ -11,10 +11,7 @@ as.data.frame.tbl_df <- function(x, row.names = NULL, optional = FALSE, ...) {
 #' @rdname formatting
 #' @export
 print.tbl_df <- function(x, ..., n = NULL, width = NULL) {
-  cat("Source: local data frame ", dim_desc(x), "\n", sep = "")
-  cat("\n")
   print(trunc_mat(x, n = n, width = width))
-
   invisible(x)
 }
 

R/type-sum.r

@@ -35,6 +35,8 @@ type_sum.POSIXt <- function(x) "time"
 #' @export
 type_sum.Date <- function(x) "date"
 #' @export
+type_sum.tbl_df <- function(x) "tibble"
+#' @export
 type_sum.data.frame <- function(x) class(x)[[1]]
 #' @export
 type_sum.default <- function(x) {
@@ -60,7 +62,9 @@ size_sum <- function(x) {
   if (!is_vector_s3(x)) return("")
 
   dim <- dim(x) %||% length(x)
-  paste0(" [", paste0(dim, collapse = ","), "]" )
+  format_dim <- vapply(dim, big_mark, character(1))
+  format_dim[is.na(dim)] <- "??"
+  paste0(" [", paste0(format_dim, collapse = " x "), "]" )
 }
 
 #' @export

R/utils-format.r

@@ -22,14 +22,6 @@
 #' @name formatting
 NULL
 
-dim_desc <- function(x) {
-  d <- dim(x)
-  d2 <- big_mark(d)
-  d2[is.na(d)] <- "??"
-
-  paste0("[", paste0(d2, collapse = " x "), "]")
-}
-
 #' @export
 #' @rdname formatting
 #' @importFrom stats setNames
@@ -46,31 +38,30 @@ trunc_mat <- function(x, n = NULL, width = NULL, n_extra = NULL) {
   n_extra <- n_extra %||% tibble_opt("max_extra_cols")
 
   df <- as.data.frame(head(x, n))
-  var_types <- vapply(df, type_sum, character(1))
-  var_names <- names(df)
-
   width <- tibble_width(width)
-  if (ncol(df) == 0 || nrow(df) == 0) {
-    shrunk <- list(table = NULL, extra = setNames(var_types, var_names))
-  } else {
-    shrunk <- shrink_mat(df, width, n_extra, var_names, var_types, rows, n,
-                         has_rownames(x))
-  }
 
-  return(structure(c(shrunk, list(width = width)), class = "trunc_mat"))
+  shrunk <- shrink_mat(df, width, rows, n, star = has_rownames(x))
+  trunc_info <- list(width = width, rows_total = rows, rows_min = nrow(df),
+                     n_extra = n_extra, summary = obj_sum(x))
+
+  structure(c(shrunk, trunc_info), class = "trunc_mat")
 }
 
 #' @importFrom stats setNames
-shrink_mat <- function(df, width, n_extra, var_names, var_types, rows, n, star) {
+shrink_mat <- function(df, width, rows, n, star) {
+  var_types <- vapply(df, type_sum, character(1))
+
+  if (ncol(df) == 0 || nrow(df) == 0) {
+    return(new_shrunk_mat(NULL, var_types))
+  }
+
   df <- remove_rownames(df)
 
   # Minimum width of each column is 5 "(int)", so we can make a quick first
   # pass
   max_cols <- floor(width / 5)
-  extra_wide <- seq_along(var_names) > max_cols
-  if (any(extra_wide)) {
-    df <- df[!extra_wide]
-  }
+  extra_wide <- (seq_along(df) > max_cols)
+  df[] <- df[!extra_wide]
 
   # List columns need special treatment because format can't be trusted
   classes <- paste0("<", vapply(df, type_sum, character(1)), ">")
@@ -111,64 +102,122 @@ shrink_mat <- function(df, width, n_extra, var_names, var_types, rows, n, star)
     rownames(shrunk)[[1]] <- "*"
   colnames(shrunk) <- colnames(df)[!too_wide]
 
-  needs_dots <- is.na(rows) || rows > n
+  if (is.na(rows))
+    needs_dots <- (nrow(df) >= n)
+  else
+    needs_dots <- (rows > n)
   if (needs_dots) {
     dot_width <- pmin(w[-1][!too_wide], 3)
     dots <- vapply(dot_width, function(i) paste(rep(".", i), collapse = ""),
       FUN.VALUE = character(1))
-    shrunk <- rbind(shrunk, ".." = dots)
-  }
-
-  if (any(extra_wide)) {
-    extra_wide[seq_along(too_wide)] <- too_wide
-    extra <- setNames(var_types[extra_wide], var_names[extra_wide])
+    rows_missing <- rows - n
   } else {
-    extra <- setNames(var_types[too_wide], var_names[too_wide])
+    rows_missing <- 0L
   }
 
-  if (length(extra) > n_extra) {
-    more <- paste0("and ", length(extra) - n_extra, " more")
-    extra <- c(extra[1:n_extra], setNames("...", more))
-  }
+  extra_wide[seq_along(too_wide)] <- too_wide
+  new_shrunk_mat(shrunk, var_types[extra_wide], rows_missing)
+}
 
-  list(table = shrunk, extra = extra)
+new_shrunk_mat <- function(table, extra, rows_missing = NULL) {
+  list(table = table, extra = extra, rows_missing = rows_missing)
 }
 
 #' @export
 print.trunc_mat <- function(x, ...) {
-  if (!is.null(x$table)) {
+  print_summary(x)
+  print_table(x)
+
+  extra <- format_extra(x)
+  if (length(extra) > 0) {
+    cat(wrap("... ", paste(extra, collapse = ", "), width = x$width), "\n",
+        sep = "")
+  }
+
+  invisible(x)
+}
+
+format_summary <- function(x) {
+  x$summary
+}
+
+print_summary <- function(x) {
+  cat("<", format_summary(x), ">\n", sep = "")
+}
+
+print_table <- function(x) {
+  if (!is.null(x$table))
     print(x$table)
+}
+
+format_extra <- function(x) {
+  extra_rows <- format_extra_rows(x)
+  extra_cols <- format_extra_cols(x)
+
+  extra <- c(extra_rows, extra_cols)
+  if (length(extra) >= 1) {
+    extra[[1]] <- paste0("with ", extra[[1]])
+    extra[-1] <- vapply(extra[-1], function(ex) paste0("and ", ex), character(1))
+  }
+  extra
+}
+
+format_extra_rows <- function(x) {
+  if (!is.null(x$table)) {
+    if (is.na(x$rows_missing)) {
+      "more rows"
+    } else if (x$rows_missing > 0) {
+      paste0(big_mark(x$rows_missing), " more rows")
+    }
+  } else if (is.na(x$rows_total)) {
+    paste0("at least ", x$rows_min, " rows total")
   }
+}
 
+format_extra_cols <- function(x) {
   if (length(x$extra) > 0) {
-    var_types <- paste0(names(x$extra), " <", x$extra, ">", collapse = ", ")
-    cat(wrap("Variables not shown: ", var_types, width = x$width),
-        ".\n", sep = "")
+    var_types <- paste0(names(x$extra), NBSP, "<", x$extra, ">")
+    if (x$n_extra > 0) {
+      if (x$n_extra < length(var_types)) {
+        var_types <- c(var_types[seq_len(x$n_extra)], "...")
+      }
+      vars <- paste0(": ", paste(var_types, collapse = ", "))
+    } else {
+      vars <- ""
+    }
+    paste0(length(x$extra), " ",
+           if (!identical(x$rows_total, 0L)) "more ",
+           "variables", vars)
   }
-  invisible()
 }
 
 #' knit_print method for trunc mat
 #' @keywords internal
 #' @export
 knit_print.trunc_mat <- function(x, options) {
+  summary <- format_summary(x)
+
   kable <- knitr::kable(x$table, row.names = FALSE)
 
-  if (length(x$extra) > 0) {
-    var_types <- paste0(names(x$extra), " <", x$extra, ">", collapse = ", ")
-    extra <- wrap("\n(_Variables not shown_: ", var_types, ")", width = x$width)
+  extra <- format_extra(x)
+
+  if (length(extra) > 0) {
+    extra <- wrap("(", paste(extra, collapse = ", "), ")", width = x$width)
   } else {
     extra <- "\n"
   }
 
-  res <- paste(c('', '', kable, '', extra), collapse = '\n')
+  res <- paste(c('', '', summary, '', kable, '', extra), collapse = '\n')
   knitr::asis_output(res, cacheable = TRUE)
 }
 
+NBSP <- "\U00A0"
+
 wrap <- function(..., indent = 0, width) {
   x <- paste0(..., collapse = "")
   wrapped <- strwrap(x, indent = indent, exdent = indent + 2,
     width = width)
+  wrapped <- gsub(NBSP, " ", wrapped)
 
   paste0(wrapped, collapse = "\n")
 }

README.md

@@ -15,8 +15,7 @@ You can create a tibble from an existing object with `as_data_frame()`:
 ``` r
 library(tibble)
 as_data_frame(iris)
-#> Source: local data frame [150 x 5]
-#> 
+#> <tibble [150 x 5]>
 #>    Sepal.Length Sepal.Width Petal.Length Petal.Width Species
 #>           <dbl>       <dbl>        <dbl>       <dbl>  <fctr>
 #> 1           5.1         3.5          1.4         0.2  setosa
@@ -29,7 +28,7 @@ as_data_frame(iris)
 #> 8           5.0         3.4          1.5         0.2  setosa
 #> 9           4.4         2.9          1.4         0.2  setosa
 #> 10          4.9         3.1          1.5         0.1  setosa
-#> ..          ...         ...          ...         ...     ...
+#> ... with 140 more rows
 ```
 
 This will work for reasonable inputs that are already data.frame, list, matrix, or table.
@@ -38,8 +37,7 @@ You can also create a new tibble from vectors that represent the columns with `d
 
 ``` r
 data_frame(x = 1:5, y = 1, z = x ^ 2 + y)
-#> Source: local data frame [5 x 3]
-#> 
+#> <tibble [5 x 3]>
 #>       x     y     z
 #>   <int> <dbl> <dbl>
 #> 1     1     1     2
@@ -59,8 +57,7 @@ frame_data(
   "a", 2,  3.6,
   "b", 1,  8.5
 )
-#> Source: local data frame [2 x 3]
-#> 
+#> <tibble [2 x 3]>
 #>       x     y     z
 #>   <chr> <dbl> <dbl>
 #> 1     a     2   3.6
@@ -84,8 +81,7 @@ Tibbles have a refined print method that shows only the first 10 rows, and all t
 ``` r
 library(nycflights13)
 flights
-#> Source: local data frame [336,776 x 19]
-#> 
+#> <tibble [336,776 x 19]>
 #>     year month   day dep_time sched_dep_time dep_delay arr_time
 #>    <int> <int> <int>    <int>          <int>     <dbl>    <int>
 #> 1   2013     1     1      517            515         2      830
@@ -98,10 +94,10 @@ flights
 #> 8   2013     1     1      557            600        -3      709
 #> 9   2013     1     1      557            600        -3      838
 #> 10  2013     1     1      558            600        -2      753
-#> ..   ...   ...   ...      ...            ...       ...      ...
-#> Variables not shown: sched_arr_time <int>, arr_delay <dbl>, carrier <chr>,
-#>   flight <int>, tailnum <chr>, origin <chr>, dest <chr>, air_time <dbl>,
-#>   distance <dbl>, hour <dbl>, minute <dbl>, time_hour <time>.
+#> ... with 336,766 more rows, and 12 more variables: sched_arr_time <int>,
+#>   arr_delay <dbl>, carrier <chr>, flight <int>, tailnum <chr>,
+#>   origin <chr>, dest <chr>, air_time <dbl>, distance <dbl>, hour <dbl>,
+#>   minute <dbl>, time_hour <time>
 ```
 
 Tibbles are strict about subsetting. If you try to access a variable that does not exist, you'll get an error:

tests/testthat/helper-unknown-rows.R

@@ -0,0 +1,21 @@
+as_unknown_rows <- function(x) {
+  x <- as_data_frame(x)
+  class(x) <- c("unknown_rows", class(x))
+  x
+}
+
+dim.unknown_rows <- function(x) {
+  c(NA_integer_, length(x))
+}
+
+registerS3method("dim", "unknown_rows", dim.unknown_rows)
+
+head.unknown_rows <- function(x, n) {
+  head(as.data.frame(x), n)
+}
+
+registerS3method("head", "unknown_rows", head.unknown_rows)
+
+type_sum.unknown_rows <- function(x) "unknown_rows"
+
+registerS3method("type_sum", "unknown_rows", type_sum.unknown_rows)

tests/testthat/output/trunc_mat/all--30.txt

@@ -1,10 +1,9 @@
-Source: local data frame [3 x 8]
-
+<tibble [3 x 8]>
       a     b     c     d
   <dbl> <int> <lgl> <chr>
 1   1.0     1  TRUE     a
 2   2.5     2 FALSE     b
 3    NA    NA    NA  <NA>
-Variables not shown: e
-  <fctr>, f <date>, g <time>,
-  h <list>.
+... with 4 more variables:
+  e <fctr>, f <date>,
+  g <time>, h <list>

tests/testthat/output/trunc_mat/all-1-30-0.txt

@@ -0,0 +1,6 @@
+<tibble [3 x 8]>
+      a     b     c     d
+  <dbl> <int> <lgl> <chr>
+1     1     1  TRUE     a
+... with 2 more rows, and 4
+  more variables

tests/testthat/output/trunc_mat/all-1-30-2.txt

@@ -1,7 +1,7 @@
-       a     b     c     d
-   <dbl> <int> <lgl> <chr>
-1      1     1  TRUE     a
-..   ...   ...   ...   ...
-Variables not shown: e
-  <fctr>, f <date>, and 2
-  more <...>.
+<tibble [3 x 8]>
+      a     b     c     d
+  <dbl> <int> <lgl> <chr>
+1     1     1  TRUE     a
+... with 2 more rows, and 4
+  more variables: e <fctr>,
+  f <date>, ...

tests/testthat/output/trunc_mat/all-knit-120.txt

@@ -1,5 +1,7 @@
 
 
+tibble [3 x 8]
+
 |a     |b     |c     |d     |e      |f          |g                   |h         |
 |:-----|:-----|:-----|:-----|:------|:----------|:-------------------|:---------|
 |<dbl> |<int> |<lgl> |<chr> |<fctr> |<date>     |<time>              |<list>    |

tests/testthat/output/trunc_mat/all-knit-60.txt

@@ -1,10 +1,12 @@
 
 
+tibble [3 x 8]
+
 |a     |b     |c     |d     |e      |f          |
 |:-----|:-----|:-----|:-----|:------|:----------|
 |<dbl> |<int> |<lgl> |<chr> |<fctr> |<date>     |
 |1.0   |1     |TRUE  |a     |a      |2015-12-10 |
 |2.5   |2     |FALSE |b     |b      |2015-12-11 |
 |NA    |NA    |NA    |<NA>  |NA     |NA         |
 
-(_Variables not shown_: g <time>, h <list>)
+(with 2 more variables: g <time>, h <list>)