/
utils-format.r
93 lines (78 loc) · 2.22 KB
/
utils-format.r
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
#' Tools for describing matrices
#'
#' @param x a matrix to describe
#' @param n number of rows to show
#' @keywords internal
#' @examples
#' dim_desc(mtcars)
#' trunc_mat(mtcars)
#' @name dplyr-formatting
NULL
#' @export
#' @rdname dplyr-formatting
dim_desc <- function(x) {
d <- dim(x)
d2 <- format(d, big.mark = ",", justify = "none", trim = TRUE)
d2[is.na(d)] <- "??"
paste0("[", paste0(d2, collapse = " x "), "]")
}
#' @export
#' @rdname dplyr-formatting
trunc_mat <- function(x, n = NULL) {
rows <- nrow(x)
if (!is.na(rows) && rows == 0) return()
if (is.null(n)) {
if (is.na(rows) || rows > getOption("dplyr.print_max")) {
n <- getOption("dplyr.print_min")
} else {
n <- rows
}
}
df <- as.data.frame(head(x, n))
if (nrow(df) == 0) return()
mat <- format(df, justify = "left")
width <- getOption("width")
values <- c(format(rownames(mat))[[1]], unlist(mat[1, ]))
names <- c("", colnames(mat))
w <- pmax(nchar(values), nchar(names))
cumw <- cumsum(w + 1)
too_wide <- cumw[-1] > width
# Always display at least one column
if (all(too_wide)) {
too_wide[1] <- FALSE
df[[1]] <- substr(df[[1]], 1, width)
}
shrunk <- format(df[, !too_wide, drop = FALSE])
needs_dots <- is.na(rows) || 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)
}
print(shrunk)
if (any(too_wide)) {
vars <- colnames(mat)[too_wide]
types <- vapply(df[too_wide], type_sum, character(1))
var_types <- paste0(vars, " (", types, ")", collapse = ", ")
cat(wrap("Variables not shown: ", var_types), "\n", sep = "")
}
}
wrap <- function(..., indent = 0) {
x <- paste0(..., collapse = "")
wrapped <- strwrap(x, indent = indent, exdent = indent + 2,
width = getOption("width"))
paste0(wrapped, collapse = "\n")
}
ruler <- function() {
x <- seq_len(getOption("width"))
y <- ifelse(x %% 10 == 0, x %/% 10, ifelse(x %% 5 == 0, "+", "-"))
cat(y, "\n", sep = "")
cat(x %% 10, "\n", sep = "")
}
#' @export
print.BoolResult <- function(x, ...) {
cat(x)
if (!x) cat(": ", attr(x, "comment"), sep = "")
cat("\n")
}