R/makeLabel.R

   1 ## makeLabel.R (2010-05-27)
   2
   3 ##   Label Management
   4
   5 ## Copyright 2010 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 makeLabel <- function(x, ...) UseMethod("makeLabel")
  11
  12 makeLabel.character <- function(x, len = 99, space = "_",
  13           make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...)
  14 {
  15     x <- gsub("[[:space:]]", space, x)
  16     if (illegal != "") {
  17         illegal <- unlist(strsplit(illegal, NULL))
  18         for (i in illegal) x <- gsub(i, "", x, fixed = TRUE)
  19     }
  20     if (quote) len <- len - 2
  21     nc <- nchar(x) > len
  22     if (any(nc)) x[nc] <- substr(x[nc], 1, len)
  23     tab <- table(x)
  24     if (all(tab == 1)) make.unique <- FALSE
  25     if (make.unique) {
  26         dup <- tab[which(tab > 1)]
  27         nms <- names(dup)
  28         for (i in 1:length(dup)) {
  29             j <- which(x == nms[i])
  30             end <- nchar(x[j][1])
  31             ## w: number of characters to be added as suffix
  32             w <- floor(log10(dup[i])) + 1
  33             suffix <- formatC(1:dup[i], width = w, flag = "0")
  34             if (end + w > len) {
  35                 start <- end - w + 1
  36                 substr(x[j], start, end) <- suffix
  37             } else x[j] <- paste(x[j], suffix, sep = "")
  38         }
  39     }
  40     if (quote) x <- paste('"', x, '"', sep = "")
  41     x
  42 }
  43
  44 makeLabel.phylo <- function(x, tips = TRUE, nodes = TRUE, ...)
  45 {
  46     if (tips)
  47         x$tip.label <- makeLabel.character(x$tip.label, ...)
  48     if (!is.null(x$node.label) && nodes)
  49         x$node.label <- makeLabel.character(x$node.label, ...)
  50     x
  51 }
  52
  53 makeLabel.multiPhylo <- function(x, tips = TRUE, nodes = TRUE, ...)
  54 {
  55     y <- attr(x, "TipLabel")
  56     if (is.null(y)) {
  57         for (i in 1:length(x))
  58             x[[i]] <- makeLabel.phylo(x[[i]], tips = tips, nodes = nodes, ...)
  59     } else {
  60         attr(x, "TipLabel") <- makeLabel.character(y, ...)
  61     }
  62     x
  63 }
  64
  65 makeLabel.DNAbin <- function(x, ...)
  66 {
  67     if (is.vector(x) || is.list(x))
  68         names(x) <- makeLabel.character(names(x), ...)
  69     else rownames(x) <- makeLabel.character(rownames(x), ...)
  70     x
  71 }
  72
  73 mixedFontLabel <-
  74     function(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL,
  75              always.upright = c("sp.", "spp.", "ssp."))
  76 {
  77     x <- list(...)
  78     n <- length(x)
  79     sep <- rep(sep, length.out = n - 1L)
  80
  81     if (!is.null(italic)) {
  82         for (i in italic) {
  83             y <- x[[i]]
  84             s <- ! y %in% always.upright
  85             y[s] <- paste("italic('", y[s], "')", sep = "")
  86             x[[i]] <- y
  87         }
  88     }
  89
  90     if (!is.null(bold)) {
  91         for (i in bold) {
  92             y <- x[[i]]
  93             s <- logical(length(y))
  94             s[grep("^italic", y)] <- TRUE
  95             y[s] <- sub("^italic", "bolditalic", y[s])
  96             y[!s] <- paste("bold('", y[!s], "')", sep = "")
  97             x[[i]] <- y
  98         }
  99     }
 100
 101     if (!is.null(parenthesis))
 102         for (i in parenthesis)
 103             x[[i]] <- paste("(", x[[i]], ")", sep = "")
 104
 105     res <- x[[1L]]
 106     for (i in 2:n)
 107         res <- paste(res, "*'", sep[i - 1L], "'*", x[[i]], sep = "")
 108     parse(text = res)
 109 }