1### LABELS
2###
3## We need a function that produces "nice" labels from any object mainly
4## for printing, but also for dimnames.  This function should do more
5## than as.character(), and less than format ...
6##
7## Normally, one uses LABELS() and adds extensions by writing methods
8## for LABEL().
9##
10## What we do in LABELS() is the following:
11##
12## 1. transform the given object to a list
13## 2. check names attribute; if any, use these as default
14## 3. for all components with empty name, use LABEL() to compute a
15##    "simple" representation
16## 4. optionally, truncate strings to specified length
17## 5. optionally, apply make.unique() to the result
18##
19## Generally, LABEL() uses format() if the argument is of length 1, and
20## creates a type specification otherwise.
21## Exception: we also accept "small" sets and pairs since they can well
22## be distinguished even if they are nested.  Currently, "small" means a
23## length of 5 which is sort of ad-hoc.
24
25LABELS <-
26function(x, max_width = NULL, dots = "...", unique = FALSE, limit = NULL, ...)
27{
28    x <- as.list(x)
29    l <- length(x)
30
31    ## recycle max_width and dots as needed
32    if (!is.null(max_width))
33        max_width <- rep_len(max_width, length.out = l)
34    dots <- rep_len(dots, length.out = l)
35
36    ## check existing labels
37    ret <- names(x)
38    if (is.null(ret))
39        ret <- rep.int("", l)
40
41    ## create a label for components without given one
42    empty <- is.na(ret) | (ret == "")
43    if (any(empty))
44        ret[empty] <- sapply(x[empty], LABEL, limit, ...)
45
46    ## check maximum width (max_width == NULL => unbounded)
47    if (!is.null(max_width)) {
48        too_long <- nchar(ret, "width") > max_width
49        if (any(too_long)) {
50            ret[too_long] <- strtrim(ret[too_long], max_width[too_long])
51
52            ## possibly add dots
53            if (!is.null(dots))
54                ret[too_long] <- paste0(ret[too_long], dots[too_long])
55          }
56    }
57
58    if (unique)
59      ret <- make.unique(ret)
60
61    ret
62}
63
64LABEL <-
65function(x, limit = NULL, ...)
66    UseMethod("LABEL")
67
68LABEL.default <-
69function(x, limit = NULL, ...)
70    paste0("<<", class(x)[1L], ">>")
71
72LABEL.matrix <-
73function(x, limit = NULL, ...)
74    sprintf("<<%ix%i matrix>>", nrow(x), ncol(x))
75
76LABEL.numeric <-
77LABEL.factor <-
78LABEL.integer <-
79LABEL.logical <-
80function(x, limit = NULL, ...) {
81    if (is.null(limit))
82        limit <- 2L
83    .format_or_class(x, limit, ...)
84}
85
86LABEL.character <-
87function(x, limit = NULL, quote = sets_options("quote"), ...) {
88    if (is.null(limit))
89        limit <- 2L
90    if (quote)
91        x <- ifelse(is.na(x), x, paste0("\"", x, "\""))
92    .format_or_class(x, limit, ...)
93}
94
95LABEL.list <-
96function(x, limit = NULL, ...) {
97    if (is.null(limit))
98        limit <- 1L
99    .format_or_class(x, limit, ...)
100}
101
102LABEL.set <-
103LABEL.gset <-
104LABEL.cset <-
105LABEL.tuple <-
106LABEL.interval <-
107function(x, limit = NULL, ...) {
108    if (is.null(limit))
109        limit <- 6L
110    .format_or_class(x, limit, ...)
111}
112
113.format_or_class <-
114function(x, limit, ...)
115{
116    l <- length.set(x)
117    if (l < limit) {
118        if (is.integer(x))
119            format(ifelse(is.na(x), x, paste0(x, "L")), ...)
120        else
121            format(x, ...)
122    } else
123        paste0("<<", class(x)[1L], "(", l, ")>>")
124}
125