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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
# as.char.R: brief description of an object as a string e.g. "c(1,2)"
# this file also includes print_summary for matrices and data.frames
as.char <- function(object, maxlen=20)
{
check.integer.scalar(maxlen, min=1)
if(is.null(object))
"NULL"
else if(is.name(object))
paste.trunc(object, maxlen=maxlen) # e.g. "..3" for unforced dot args
else if(is.environment(object))
environment.as.char(object)
else if(is.call(object)) { # e.g. x is a call object in foo(x=1:3)
s <- strip.space.collapse(format(object))
if(nchar(s) > maxlen)
s <- paste0(substr(s, 1, maxlen), "...)")
s
}
else if(NCOL(object) == 1 && is.character(object))
paste.c(paste0("\"", object, "\""))
else if(NCOL(object) == 1 && is.logical(object))
paste.c(object)
else if(NCOL(object) == 1 && is.numeric(object)) {
# digits=4 is arb but seems about right, and zapsmall means more can
# be displayed in limited space if just one val is say 3.553e-15
paste.c(signif(zapsmall(object, digits=4), digits=4))
}
else if(length(dim(object)) == 2)
sprint("%s[%g,%g]", class(object)[1], NROW(object), NCOL(object))
else if(class(object)[1] == "list") # not is.list() because e.g. lm objects are lists
paste0("list(", paste.trunc(list.as.char(object), maxlen=maxlen+12), ")")
else if(inherits(object, "Date"))
paste0("Date:", paste.trunc(object, maxlen=maxlen+12))
else
paste0(class.as.char(object), ".object")
}
# compact description of an object's class
# typically quotify=TRUE for error messages (full class name with quotes),
# and quotify=FALSE for trace messages (just first field of class name, no quotes)
class.as.char <- function(object, quotify=FALSE)
{
if(quotify)
quotify(paste.trunc(class(object), collapse=",", maxlen=60))
else
class(object)[1]
}
# compact description of a list
# maxlen is max length of each list element (not of the entire list)
list.as.char <- function(object, maxlen=20)
{
stopifnot(is.list(object) || is.pairlist(object))
s <- ""
names <- names(object)
for(i in seq_along(object)) {
if(i != 1)
s <- sprint("%s, ", s)
name.ok <- length(names) >= i && !is.na(names[i]) && nzchar(names[i])
if(name.ok && names[i] == "...")
s <- sprint("%s...", s) # print dots as ... not as ...=pairlist.object
else {
if(name.ok)
s <- sprint("%s%s=", s, names(object)[i])
s <- sprint("%s%s", s, as.char(object[[i]], maxlen=maxlen))
}
}
s # one element character vector e.g "x=1, 2"
}
environment.as.char <- function(env, maxlen=60) # compact description
{
if(is.null(env)) # illegal, but we still want to format it
return("env(NULL)")
stopifnot(is.environment(env))
# format(env) returns "<environment: xxx>"
stripped.env <- gsub("<environment: |>", "", format(env)[1])
# if it's a standard environment return the environment's name
if(grepl("^namespace:|^R_[[:alnum:]]+Env", stripped.env))
stripped.env # something like "namespace:stats" or "R_GlobalEnv"
else # return the names of the objects in the environment
sprint("env(%s)",
paste.trunc(paste0(ls(env, all.names=TRUE), collapse=", "),
maxlen=maxlen))
}
# The main purpose of this routine is to summarize matrices and data.frames,
# but it will also (semi)gracefully handle any object that is passed to it.
#
# Note that this only does anything if trace >= 2.
#
# If x is a matrix or dataframe or similar, print first few rows and last row.
# If trace >= 4, then print all rows and cols, up to 1000 rows and 100 cols.
#
# the details argument:
# 0=don't print data, print the colnames truncated to one line of output
# 1=don't print data, print all colnames
# -1=like print data but don't prefix the output with spaces
# 2=print the data
print_summary <- function(x, xname=trunc.deparse(substitute(x)),
trace=2, msg="", prefix="", details=2)
{
check.numeric.scalar(trace)
if(trace < 2)
return()
if(is.null(x)) {
printf("%s: NULL\n", xname)
return()
}
if(length(x) == 0) {
printf("%s: length zero\n", xname)
return()
}
# try(data.frame(), silent=TRUE) is not actually silent
# for language objects, so handle them specially
if(is.language(x)) {
x$na.action <- NULL # don't want to print the na.action if there is one
s <- try(format(x))
max <- if(trace <= 2) 8 else 1000
if(length(s) > max) {
s <- s[1:max]
s[max] <- paste(s[max], "\n...")
}
s <- gsub("[ \t\n]", "", s) # remove white space
s <- gsub(",", ", ", s) # replace comma with comma space
s <- paste(s, collapse="\n ", sep="")
printf("%s%s%s:\n%s\n", prefix, xname, msg, s)
return()
}
if(is.list(x) && !is.data.frame(x)) { # data.frames are lists, hence must check both
if(details < 2 && trace < 4) {
printf("%s: list with elements %s\n", xname, quotify.trunc(paste(names(x))))
return()
}
printf("%s ", xname)
str(x)
return()
}
df <- try(my.data.frame(x, trace, stringsAsFactors=FALSE), silent=TRUE)
if(is.try.err(df)) { # be robust for whatever gets passed to this function
printf("print_summary: cannot convert class \"%s\" to a data.frame (%s)\n",
class(x)[1], cleantry(df))
printf("%s%s%s:\n", prefix, xname, msg)
if(length(dim(x)) == 2) { # it's a matrix or other 2D object?
if(trace >= 4) {
try(print_with_strings_quoted(x))
try(print(summary(x)))
} else {
try(print_with_strings_quoted(head(x)))
printf("...\n")
}
} else
try(print_with_strings_quoted(x))
return()
}
if(details < 2 && trace < 4) {
# don't print the data, just the dimensions and colnames
if(details != -1)
printf(" ")
printf("%s%s[%d,%d]%s ",
prefix, xname, nrow(df), ncol(df), msg)
print_colnames(x, full=details == 2, newline="")
if(NCOL(x) == 1 || NROW(x) == 1) # if a vector, print first few values
cat0(", and values ", # if double, print 4 significant digits
paste.trunc(if(is.double(x)) sprint("%.4g", x) else x,
collapse=", ", maxlen=32))
cat0("\n")
return()
}
colnames <- safe.colnames(x)
printf("%s%s[%d,%d]%s%s:\n",
prefix, xname, nrow(df), ncol(df), msg,
if(is.null(colnames)) " with no column names" else "")
df.short <- df
maxrows <- if(trace >= 4) 1000 else 5
if(maxrows < nrow(df)) {
df.short <- df[c(1:(maxrows-1), nrow(df)), , drop=FALSE]
if(is.null(rownames(df.short)))
rownames(df.short) <- c(1:(maxrows-1), nrow(df))
rownames(df.short)[maxrows-2+1] <- "..."
}
maxcols <- if(trace >= 4) 100 else 10
if(maxcols < ncol(df)) {
df.short[,maxcols] <- "..."
df.short <- df.short[, 1:maxcols, drop=FALSE]
if(!is.null(colnames))
colnames(df.short)[maxcols] <- "..."
}
try(print_with_strings_quoted(df.short))
is.fac <- sapply(df, is.factor)
if(is.null(colnames))
colnames(df) <- sprint("[,%d]", seq_len(NCOL(x)))
if(any(is.fac)) {
names <- paste0(colnames(df),
ifelse(sapply(df, is.ordered), "(ordered)", ""))
if(sum(is.fac) == 1) # only one fac, so enough space to print levels too
printf(" %s is a factor with levels: %s\n",
paste.trunc(names[is.fac]),
paste.trunc(levels(df[,is.fac])))
else
printf(" factors: %s\n", paste.trunc(names[is.fac]))
}
if(trace >= 4)
try(print(summary(df)))
}
print_colnames <- function(x, full=FALSE, newline="\n")
{
colnames <- safe.colnames(x)
if(is.null(colnames))
printf("with no column names%s", newline)
else {
colnames[which(colnames == "")] <- "\"\""
if(full) # full colnames (up to 1000 characters)
printf("with colname%s %s%s",
if(length(colnames(x)) > 1) "s" else "",
paste.trunc(colnames, maxlen=max(25, getOption("width")-20)),
newline)
else # short version of colnames
printf.wrap("with colname%s %s%s",
if(length(colnames(x)) > 1) "s" else "",
paste.trunc(colnames),
newline)
}
}
# Like print but puts quotes around strings.
# Useful for disambiguating strings from factors.
#
# "..." is not quoted because it is used as a
# "something was deleted" indicator in print_summary
print_with_strings_quoted <- function(x)
{
if(length(dim(x)) == 2)
for(j in seq_len(NCOL(x)))
if(is.character(x[,j]))
for(i in seq_along(x[,j]))
if(x[i,j] != "...")
x[i,j] <- paste0("\"", x[i,j], "\"")
print(x)
}
|
