## makeLabel.R (2010-05-27)
## Label Management
## Copyright 2010 Emmanuel Paradis
## This file is part of the R-package `ape'.
## See the file ../COPYING for licensing issues.
makeLabel <- function(x, ...) UseMethod("makeLabel")
makeLabel.character <- function(x, len = 99, space = "_",
make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...)
{
x <- gsub("[[:space:]]", space, x)
if (illegal != "") {
illegal <- unlist(strsplit(illegal, NULL))
for (i in illegal) x <- gsub(i, "", x, fixed = TRUE)
}
if (quote) len <- len - 2
nc <- nchar(x) > len
if (any(nc)) x[nc] <- substr(x[nc], 1, len)
tab <- table(x)
if (all(tab == 1)) make.unique <- FALSE
if (make.unique) {
dup <- tab[which(tab > 1)]
nms <- names(dup)
for (i in 1:length(dup)) {
j <- which(x == nms[i])
end <- nchar(x[j][1])
## w: number of characters to be added as suffix
w <- floor(log10(dup[i])) + 1
suffix <- formatC(1:dup[i], width = w, flag = "0")
if (end + w > len) {
start <- end - w + 1
substr(x[j], start, end) <- suffix
} else x[j] <- paste(x[j], suffix, sep = "")
}
}
if (quote) x <- paste('"', x, '"', sep = "")
x
}
makeLabel.phylo <- function(x, tips = TRUE, nodes = TRUE, ...)
{
if (tips)
x$tip.label <- makeLabel.character(x$tip.label, ...)
if (!is.null(x$node.label) && nodes)
x$node.label <- makeLabel.character(x$node.label, ...)
x
}
makeLabel.multiPhylo <- function(x, tips = TRUE, nodes = TRUE, ...)
{
y <- attr(x, "TipLabel")
if (is.null(y)) {
for (i in 1:length(x))
x[[i]] <- makeLabel.phylo(x[[i]], tips = tips, nodes = nodes, ...)
} else {
attr(x, "TipLabel") <- makeLabel.character(y, ...)
}
x
}
makeLabel.DNAbin <- function(x, ...)
{
if (is.vector(x) || is.list(x))
names(x) <- makeLabel.character(names(x), ...)
else rownames(x) <- makeLabel.character(rownames(x), ...)
x
}
mixedFontLabel <-
function(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL,
always.upright = c("sp.", "spp.", "ssp."))
{
x <- list(...)
n <- length(x)
sep <- rep(sep, length.out = n - 1L)
if (!is.null(italic)) {
for (i in italic) {
y <- x[[i]]
s <- ! y %in% always.upright
y[s] <- paste("italic('", y[s], "')", sep = "")
x[[i]] <- y
}
}
if (!is.null(bold)) {
for (i in bold) {
y <- x[[i]]
s <- logical(length(y))
s[grep("^italic", y)] <- TRUE
y[s] <- sub("^italic", "bolditalic", y[s])
y[!s] <- paste("bold('", y[!s], "')", sep = "")
x[[i]] <- y
}
}
if (!is.null(parenthesis))
for (i in parenthesis)
x[[i]] <- paste("(", x[[i]], ")", sep = "")
res <- x[[1L]]
for (i in 2:n)
res <- paste(res, "*'", sep[i - 1L], "'*", x[[i]], sep = "")
parse(text = res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.