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