Merge branch 'f-#100-#101-output'. Fixes #100. Fixes #101.

- Computation of column width properly handles wide (e.g., Chinese) characters (#100).
- Add comment char `# ` for trailing metadata (#101).
- Restore full package coverage.

NAMESPACE

@@ -27,18 +27,18 @@ S3method(is_vector_s3,ordered)
 S3method(obj_sum,POSIXlt)
 S3method(obj_sum,default)
 S3method(obj_sum,list)
-S3method(obj_sum,tbl_df)
 S3method(print,tbl_df)
 S3method(print,trunc_mat)
 S3method(quote_n,character)
 S3method(quote_n,default)
+S3method(tbl_sum,default)
+S3method(tbl_sum,tbl_df)
 S3method(type_sum,Date)
 S3method(type_sum,POSIXt)
 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)
@@ -58,6 +58,7 @@ export(obj_sum)
 export(remove_rownames)
 export(repair_names)
 export(rownames_to_column)
+export(tbl_sum)
 export(tibble)
 export(trunc_mat)
 export(type_sum)

R/type-sum.r

@@ -1,10 +1,16 @@
 #' Provide a succinct summary of an object
 #'
+#' @description
 #' \code{type_sum} gives a brief summary of object type. Objects that commonly
 #' occur in a data frame should return a string with four or less characters.
+#'
 #' \code{obj_sum} also includes the size of the object if \code{is_s3_vector}
 #' is \code{TRUE}.
 #'
+#' \code{tbl_sum} gives a brief textual description of a table-like object,
+#' which should include the dimensions, the data source, and possible grouping
+#' (for dplyr).  The default implementation forwards to \code{obj_sum}
+#'
 #' @param x an object to summarise. Generally only methods of atomic vectors
 #'   and variants have been implemented.
 #' @keywords internal
@@ -32,11 +38,6 @@ obj_sum.POSIXlt <- function(x) {
   rep("POSIXlt", length(x))
 }
 
-#' @export
-obj_sum.tbl_df <- function(x) {
-  paste0("A tibble: ", dim_desc(x))
-}
-
 #' @export
 #' @rdname obj_sum
 type_sum <- function(x) UseMethod("type_sum")
@@ -50,8 +51,6 @@ 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) {
@@ -73,6 +72,18 @@ type_sum.default <- function(x) {
   }
 }
 
+#' @rdname obj_sum
+#' @export
+tbl_sum <- function(x) UseMethod("tbl_sum", x)
+
+#' @export
+tbl_sum.default <- function(x) obj_sum(x)
+
+#' @export
+tbl_sum.tbl_df <- function(x) {
+  paste0("A tibble: ", dim_desc(x))
+}
+
 dim_desc <- function(x) {
   dim <- dim(x) %||% length(x)
   format_dim <- vapply(dim, big_mark, character(1))

R/utils-format.r

@@ -42,7 +42,7 @@ trunc_mat <- function(x, n = NULL, width = NULL, n_extra = NULL) {
 
   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))
+                     n_extra = n_extra, summary = tbl_sum(x))
 
   structure(c(shrunk, trunc_info), class = "trunc_mat")
 }
@@ -83,10 +83,10 @@ shrink_mat <- function(df, width, rows, n, star) {
   # Column needs to be as wide as widest of name, values, and class
   w <- pmax(
     pmax(
-      nchar(encodeString(values)),
-      nchar(encodeString(names))
+      nchar_width(encodeString(values)),
+      nchar_width(encodeString(names))
     ),
-    nchar(encodeString(c("", classes)))
+    nchar_width(encodeString(c("", classes)))
   )
   cumw <- cumsum(w + 1)
 
@@ -127,27 +127,36 @@ new_shrunk_mat <- function(table, extra, rows_missing = NULL) {
 print.trunc_mat <- function(x, ...) {
   print_summary(x)
   print_table(x)
+  print_extra(x)
+  invisible(x)
+}
 
-  extra <- format_extra(x)
-  if (length(extra) > 0) {
-    cat(wrap("... ", collapse(extra), width = x$width), "\n",
-        sep = "")
+print_summary <- function(x) {
+  summary <- format_summary(x)
+  if (length(summary) > 0) {
+    print_comment(summary, width = x$width)
   }
+}
 
-  invisible(x)
+print_table <- function(x) {
+  if (!is.null(x$table)) {
+    print(x$table)
+  }
 }
 
-format_summary <- function(x) {
-  x$summary
+print_extra <- function(x) {
+  extra <- format_extra(x)
+  if (length(extra) > 0) {
+    print_comment("... ", collapse(extra), width = x$width)
+  }
 }
 
-print_summary <- function(x) {
-  cat("# ", wrap(format_summary(x), width = getOption("width")), "\n", sep = "")
+print_comment <- function(..., width) {
+  cat_line(wrap(..., prefix = "# ", width = min(width, getOption("width"))))
 }
 
-print_table <- function(x) {
-  if (!is.null(x$table))
-    print(x$table)
+format_summary <- function(x) {
+  x$summary
 }
 
 format_extra <- function(x) {
@@ -213,10 +222,11 @@ knit_print.trunc_mat <- function(x, options) {
 
 NBSP <- "\U00A0"
 
-wrap <- function(..., indent = 0, width) {
+wrap <- function(..., indent = 0, prefix = "", width) {
   x <- paste0(..., collapse = "")
   wrapped <- strwrap(x, indent = indent, exdent = indent + 2,
-    width = width)
+    width = max(width - nchar_width(prefix), 0))
+  wrapped <- paste0(prefix, wrapped)
   wrapped <- gsub(NBSP, " ", wrapped)
 
   paste0(wrapped, collapse = "\n")

R/utils.r

@@ -56,3 +56,11 @@ stopc <- function(...) {
 warningc <- function(...) {
   warning(..., call. = FALSE, domain = NA)
 }
+
+nchar_width <- function(x) {
+  nchar(x, type = "width")
+}
+
+cat_line <- function(...) {
+  cat(..., "\n", sep = "")
+}

tests/testthat/output/trunc_mat/POSIXlt-8-30.txt → tests/testthat/output/trunc_mat/POSIXlt-8-60.txt

@@ -9,4 +9,4 @@
 6 2016-01-01 12:35:02 <POSIXlt>
 7 2016-01-01 12:35:03 <POSIXlt>
 8 2016-01-01 12:35:04 <POSIXlt>
-... with 4 more rows
+# ... with 4 more rows

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

@@ -4,7 +4,7 @@
 1   1.0     1  TRUE     a
 2   2.5     2 FALSE     b
 3    NA    NA    NA  <NA>
-... with 5 more variables:
-  e <fctr>, f <date>,
-  g <time>, h <list>,
-  i <list>
+# ... with 5 more variables:
+#   e <fctr>, f <date>,
+#   g <time>, h <list>,
+#   i <list>

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

@@ -2,5 +2,5 @@
       a     b     c     d
   <dbl> <int> <lgl> <chr>
 1     1     1  TRUE     a
-... with 2 more rows, and 5
-  more variables
+# ... with 2 more rows, and 5
+#   more variables

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

@@ -2,6 +2,6 @@
       a     b     c     d
   <dbl> <int> <lgl> <chr>
 1     1     1  TRUE     a
-... with 2 more rows, and 5
-  more variables: e <fctr>,
-  f <date>, ...
+# ... with 2 more rows, and 5
+#   more variables: e <fctr>,
+#   f <date>, ...

tests/testthat/output/trunc_mat/iris--70.txt

@@ -11,4 +11,4 @@
 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
+# ... with 140 more rows

tests/testthat/output/trunc_mat/iris-3-5.txt

@@ -1,19 +1,23 @@
-# A tibble: 150 x 5
+# A
+#   tibble:
+#   150
+#   x
+#   5
   Sepal.Length
          <dbl>
 1          5.1
 2          4.9
 3          4.7
-...
-  with
-  147
-  more
-  rows,
-  and
-  4
-  more
-  variables:
-  Sepal.Width <dbl>,
-  Petal.Length <dbl>,
-  Petal.Width <dbl>,
-  Species <fctr>
+# ...
+#   with
+#   147
+#   more
+#   rows,
+#   and
+#   4
+#   more
+#   variables:
+#   Sepal.Width <dbl>,
+#   Petal.Length <dbl>,
+#   Petal.Width <dbl>,
+#   Species <fctr>

tests/testthat/output/trunc_mat/iris-5-30.txt

@@ -6,8 +6,8 @@
 3          4.7         3.2
 4          4.6         3.1
 5          5.0         3.6
-... with 145 more rows, and 3
-  more variables:
-  Petal.Length <dbl>,
-  Petal.Width <dbl>,
-  Species <fctr>
+# ... with 145 more rows, and
+#   3 more variables:
+#   Petal.Length <dbl>,
+#   Petal.Width <dbl>,
+#   Species <fctr>

tests/testthat/output/trunc_mat/iris_unk-10-70.txt

@@ -11,4 +11,4 @@
 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 more rows
+# ... with more rows

tests/testthat/output/trunc_mat/long-5-30.txt

@@ -6,4 +6,4 @@
 3     3
 4     4
 5     5
-... with 9,995 more rows
+# ... with 9,995 more rows

tests/testthat/output/trunc_mat/long_unk-5-30.txt

@@ -6,4 +6,4 @@
 3     3
 4     4
 5     5
-... with more rows
+# ... with more rows

tests/testthat/output/trunc_mat/mtcars-8-30.txt

@@ -9,8 +9,9 @@
 6  18.1     6 225.0   105
 7  14.3     8 360.0   245
 8  24.4     4 146.7    62
-... with 24 more rows, and 7
-  more variables: drat <dbl>,
-  wt <dbl>, qsec <dbl>,
-  vs <dbl>, am <dbl>,
-  gear <dbl>, carb <dbl>
+# ... with 24 more rows, and
+#   7 more variables:
+#   drat <dbl>, wt <dbl>,
+#   qsec <dbl>, vs <dbl>,
+#   am <dbl>, gear <dbl>,
+#   carb <dbl>

tests/testthat/output/trunc_mat/wide-8-60.txt

@@ -0,0 +1,6 @@
+# A tibble: 3 x 2
+  成交日期 合同录入日期
+     <int>        <int>
+1        1            4
+2        2            5
+3        3            6

tests/testthat/output/trunc_mat/zero-cols_unk-5-30.txt

@@ -1,3 +1,3 @@
 # A tibble: ?? x 0
-... with at least 5 rows
-  total
+# ... with at least 5 rows
+#   total

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

@@ -1,3 +1,3 @@
 # A tibble: 0 x 2
-... with 2 variables:
-  a <chr>, b <lgl>
+# ... with 2 variables:
+#   a <chr>, b <lgl>

tests/testthat/test-trunc-mat.R

@@ -83,5 +83,14 @@ test_that("trunc_mat for POSIXlt columns (#86)", {
 
   expect_output_file_rel(
     print(as_data_frame(df), n = 8L, width = 60L),
-    "trunc_mat/POSIXlt-8-30.txt")
+    "trunc_mat/POSIXlt-8-60.txt")
+})
+
+test_that("trunc_mat for wide-character columns (#100)", {
+  x <- c("成交日期", "合同录入日期")
+  df <- setNames(data_frame(1:3, 4:6), x)
+
+  expect_output_file_rel(
+    print(df, n = 8L, width = 60L),
+    "trunc_mat/wide-8-60.txt")
 })