From ba30f3dc716effe22489bf88511bd1d60272f6de Mon Sep 17 00:00:00 2001 From: hornik Date: Fri, 29 Sep 2006 15:40:20 +0000 Subject: [PATCH] Add functionality for formatting itemize and enumerate lists, and manipulating integers as roman numerals. git-svn-id: https://svn.r-project.org/R/trunk@39546 00db46b3-68df-0310-9c12-caf00c1e9a41 --- src/library/utils/NAMESPACE | 40 +++++++------ src/library/utils/R/format.R | 64 ++++++++++++++++++++ src/library/utils/R/roman.R | 102 ++++++++++++++++++++++++++++++++ src/library/utils/man/format.Rd | 56 ++++++++++++++++++ src/library/utils/man/roman.Rd | 38 ++++++++++++ 5 files changed, 282 insertions(+), 18 deletions(-) create mode 100644 src/library/utils/R/format.R create mode 100644 src/library/utils/R/roman.R create mode 100644 src/library/utils/man/format.Rd create mode 100644 src/library/utils/man/roman.Rd diff --git a/src/library/utils/NAMESPACE b/src/library/utils/NAMESPACE index 18776256dfe..505a435c31d 100644 --- a/src/library/utils/NAMESPACE +++ b/src/library/utils/NAMESPACE @@ -2,36 +2,38 @@ export(.helpForCall, .tryHelp) export("?", CRAN.packages, Rprof,Rprofmem, RSiteSearch, URLdecode, URLencode, alarm, apropos, argsAnywhere, assignInNamespace, - as.person, as.personList, available.packages, browseEnv, - browseURL, bug.report, capture.output, checkCRAN, + as.roman, as.person, as.personList, available.packages, + browseEnv, browseURL, bug.report, capture.output, checkCRAN, chooseCRANmirror, citation, citEntry, citHeader, citFooter, close.socket, combn, compareVersion, contrib.url, data, data.entry, dataentry, de, de.ncols, de.restore, de.setup, debugger, demo, download.file, download.packages, dump.frames, edit, emacs, example, file_test, file.edit, find, fix, - fixInNamespace, flush.console, getAnywhere, getFromNamespace, - getS3method, glob2rx, head, head.matrix, help, help.search, - help.start, history, index.search, install.packages, - installed.packages, limitedLabels, loadhistory, - localeToCharset, ls.str, lsf.str, make.packages.html, - make.socket, menu, methods, mirror2html, modifyList, new.packages, - normalizePath, object.size, old.packages, package.contents, - package.skeleton, packageDescription, packageStatus, page, - person, personList, pico, prompt, promptData, promptPackage, - readCitationFile, readNEWS, read.DIF, read.fwf, read.fortran, - read.socket, recover, remove.packages, savehistory, - select.list, sessionInfo, setRepositories, stack, str, strOptions, - summaryRprof, tail, tail.matrix, timestamp, topicName, - toBibtex, toLatex, tracemem, untracemem, retracemem, unstack, - update.packageStatus, update.packages, upgrade, url.show, vi, - vignette, write.socket, wsbrowser, xedit, xemacs) + fixInNamespace, flush.console, formatOL, formatUL, getAnywhere, + getFromNamespace, getS3method, glob2rx, head, head.matrix, help, + help.search, help.start, history, index.search, install.packages, + installed.packages, limitedLabels, loadhistory, localeToCharset, + ls.str, lsf.str, make.packages.html, make.socket, menu, methods, + mirror2html, modifyList, new.packages, normalizePath, + object.size, old.packages, package.contents, package.skeleton, + packageDescription, packageStatus, page, person, personList, + pico, prompt, promptData, promptPackage, readCitationFile, + readNEWS, read.DIF, read.fwf, read.fortran, read.socket, recover, + remove.packages, savehistory, select.list, sessionInfo, + setRepositories, stack, str, strOptions, summaryRprof, tail, + tail.matrix, timestamp, topicName, toBibtex, toLatex, tracemem, + untracemem, retracemem, unstack, update.packageStatus, + update.packages, upgrade, url.show, vi, vignette, write.socket, + wsbrowser, xedit, xemacs) export(read.table, read.csv, read.csv2, read.delim, read.delim2, write.table, write.csv, write.csv2, count.fields, type.convert) S3method("[", getAnywhere) +S3method("[", roman) S3method(as.character, person) S3method(as.character, personList) +S3method(as.character, roman) S3method(as.person, default) S3method(as.personList, default) S3method(as.personList, person) @@ -39,6 +41,7 @@ S3method(edit, data.frame) S3method(edit, default) S3method(edit, matrix) S3method(edit, vignette) +S3method(format, roman) S3method(head, data.frame) S3method(head, default) S3method(head, "function") @@ -57,6 +60,7 @@ S3method(print, MethodsFunction) S3method(print, packageDescription) S3method(print, packageIQR) S3method(print, packageStatus) +S3method(print, roman) S3method(print, sessionInfo) S3method(print, socket) S3method(print, vignette) diff --git a/src/library/utils/R/format.R b/src/library/utils/R/format.R new file mode 100644 index 00000000000..94c7a2eb17c --- /dev/null +++ b/src/library/utils/R/format.R @@ -0,0 +1,64 @@ +formatUL <- +function(x, label = "*", offset = 0, + width = 0.9 * getOption("width")) +{ + if(length(x) == 0) + return(character()) + .format_rl_table(label, x, offset, width) +} + +formatOL <- +function(x, type = "arabic", offset = 0, start = 1, + width = 0.9 * getOption("width")) +{ + if(length(x) == 0) + return(character()) + type_tokens <- c("1", "A", "a", "I", "i") + type_full_names <- c("arabic", "Alph", "alph", "Roman", "roman") + type <- match.arg(type, c(type_tokens, type_full_names)) + if(nchar(type) > 1) + type <- type_tokens[match(type, type_full_names)] + len <- length(x) + labels <- seq.int(start[1], length = len) + upper <- labels[len] + if(type %in% c("A", "a")) { + if(upper > 26) + stop("too many list items (at most up to number 26)") + labels <- if(type == "A") + LETTERS[labels] + else + letters[labels] + } + else if(type %in% c("I", "i")) { + if(upper > 3899) + stop("too many list items (at most up to number 3899)") + labels <- as.character(as.roman(labels)) + if(type == "i") + labels <- tolower(labels) + } + .format_rl_table(sprintf("%s.", labels), x, offset, width) +} + +.format_rl_table <- +function(labels, x, offset = 0, width = 0.9 * getOption("width"), + sep = " ") +{ + ## Format a 2-column table with right-justified item labels and + ## left-justified text. Somewhat tricky because strwrap() eats up + ## leading whitespace ... + + .make_empty_string <- function(n) { + paste(rep.int(" ", n), collapse = "") + } + + labels <- format(labels, justify = "right") + len <- length(x) + delta <- nchar(labels[1], "width") + offset + x <- strwrap(x, width = width - delta - nchar(sep, "width"), + simplify = FALSE) + nlines <- cumsum(sapply(x, length)) + prefix <- rep.int(.make_empty_string(delta), nlines[len]) + prefix[1 + c(0, nlines[-len])] <- + paste(.make_empty_string(offset), labels, sep = "") + paste(prefix, unlist(x), sep = sep) +} diff --git a/src/library/utils/R/roman.R b/src/library/utils/R/roman.R new file mode 100644 index 00000000000..ad99046e988 --- /dev/null +++ b/src/library/utils/R/roman.R @@ -0,0 +1,102 @@ +as.roman <- +function(x) +{ + if(is.numeric(x)) + x <- as.integer(x) + else if(is.character(x)) { + ## Let's be nice: either strings that are *all* arabics, or + ## (hopefully, for the time being) all romans. + x <- if(all(regexpr("^[[:digit:]]+$", x) > -1)) + as.integer(x) + else + .roman2numeric(x) + } + else + stop("cannot coerce 'x' to roman") + x[(x <= 0 | x >= 3900)] <- NA + class(x) <- "roman" + x +} + +as.character.roman <- +function(x) + .numeric2roman(x) +format.roman <- +function(x, ...) + format(as.character(x)) +print.roman <- +function(x, ...) +{ + print(noquote(as.character(x))) + x +} +"[.roman" <- +function(x, i) +{ + cl <- oldClass(x) + y <- NextMethod("[") + oldClass(y) <- cl + y +} + +.numeric2roman <- +function(x) { + romans <- c("M", "CM", "D", "CD", "C", "XC", "L", "XL", "X", "IX", + "V", "IV", "I") + numbers <- c(1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1) + n2r <- function(z) { + y <- character() + for(i in seq_along(romans)) { + d <- numbers[i] + while(z >= d) { + z <- z - d + y <- c(y, romans[i]) + } + } + paste(y, collapse = "") + } + + out <- character(length(x)) + x <- as.integer(x) + ind <- is.na(x) | (x <= 0) | (x >= 3900) + out[ind] <- NA + if(any(!ind)) + out[!ind] <- sapply(x[!ind], n2r) + out +} + +.roman2numeric <- +function(x) +{ + ## + ## What if this fails? + ## Should say something like "Not a valid roman number ..." + ## + romans <- c("M", "CM", "D", "CD", "C", "XC", "L", "XL", "X", "IX", + "V", "IV", "I") + numbers <- c(1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1) + out <- integer(length(x)) + ind <- is.na(x) + out[ind] <- NA + if(any(!ind)) { + y <- toupper(x[!ind]) + y <- gsub("CM", "DCCCC", y) + y <- gsub("CD", "CCCC", y) + y <- gsub("XC", "LXXXX", y) + y <- gsub("XL", "XXXX", y) + y <- gsub("IX", "VIIII", y) + y <- gsub("IV", "IIII", y) + ok <- (regexpr("^M{,3}D?C{,4}L?X{,4}V?I{,4}$", y) > -1) + if(any(!ok)) { + warning(gettextf("Invalid roman numeral(s): %s", + paste(x[!ind][!ok], collapse = " "))) + out[!ind][!ok] <- NA + } + if(any(ok)) + out[!ind][ok] <- + sapply(strsplit(y[ok], ""), + function(z) + as.integer(sum(numbers[match(z, romans)]))) + } + out +} diff --git a/src/library/utils/man/format.Rd b/src/library/utils/man/format.Rd new file mode 100644 index 00000000000..9740262deed --- /dev/null +++ b/src/library/utils/man/format.Rd @@ -0,0 +1,56 @@ +\name{format} +\alias{formatUL} +\alias{formatOL} +\title{Format Unordered and Ordered Lists} +\description{ + Format unordered (itemize) and ordered (enumerate) lists. +} +\usage{ +formatUL(x, label = "*", offset = 0, + width = 0.9 * getOption("width")) +formatOL(x, type = "arabic", offset = 0, start = 1, + width = 0.9 * getOption("width")) +} +\arguments{ + \item{x}{a character vector of list items.} + \item{label}{a character string used for labelling the items.} + \item{offset}{a non-negative integer giving the offset (indentation) + of the list.} + \item{width}{a positive integer giving the target column for wrapping + lines in the output.} + \item{type}{a character string specifying the \dQuote{type} of the + labels in the ordered list. If \code{"arabic"} (default), arabic + numerals are used. For \code{"Alph"} or \code{"alph"}, single upper + or lower case letters are employed (in this case, the number of the + last item must not exceed 26. Finally, for \code{"Roman"} or + \code{"roman"}, the labels are given as upper or lower case roman + numerals (with the number of the last item maximally 3899). + \code{type} can be given as a unique abbreviation of the above, or + as one of the \acronym{HTML} style tokens \code{"1"} (arabic), + \code{"A"}/\code{"a"} (alphabetic), or \code{"I"}/\code{"i"} + (roman), respectively.} + \item{start}{a positive integer specifying the starting number of the + first item in an ordered list.} +} +\value{ + A character vector with the formatted entries. +} +\seealso{ + \code{\link{formatDL}} for formatting description lists. +} +\examples{ +## A simpler recipe. +x <- c("Mix dry ingredients thoroughly.", + "Pour in wet ingredients.", + "Mix for 10 minutes.", + "Bake for one hour at 300 degrees.") +## Format and output as an unordered list. +writeLines(formatUL(x)) +## Format and output as an ordered list. +writeLines(formatOL(x)) +## Ordered list using lower case roman numerals. +writeLines(formatOL(x, type = "i")) +## Ordered list using upper case letters and some offset. +writeLines(formatOL(x, type = "A", offset = 5)) +} +\keyword{print} diff --git a/src/library/utils/man/roman.Rd b/src/library/utils/man/roman.Rd new file mode 100644 index 00000000000..3e5766d1748 --- /dev/null +++ b/src/library/utils/man/roman.Rd @@ -0,0 +1,38 @@ +\name{roman} +\alias{as.roman} +\title{Roman Numerals} +\description{ + Manipulate integers as roman numerals. +} +\usage{ +as.roman(x) +} +\arguments{ + \item{x}{a numeric vector, or a character vector of arabic or roman + numerals.} +} +\details{ + \code{as.roman} creates objects of class \code{"roman"} which are + internally represented as integers, and have suitable methods for + printing, formatting, subsetting, and coercion to \code{character}. + + Only numbers between 1 and 3899 have a unique representation as roman + numbers. +} +\references{ + Wikipedia contributors (2006). Roman numerals. + Wikipedia, The Free Encyclopedia. + \url{http://en.wikipedia.org/w/index.php?title=Roman_numerals&oldid=78252134}. + Accessed September 29, 2006. +} +\examples{ +## First five roman 'numbers'. +(y <- as.roman(1 : 5)) +## Middle one. +y[3] +## Current year as a roman number. +(y <- as.roman(format(Sys.Date(), "\%Y"))) +## 10 years ago ... +y - 10 +} +\keyword{arith}