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

@@ -2,43 +2,46 @@ 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)
 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)

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)
+}

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)
+{
+    ## <FIXME>
+    ## What if this fails?
+    ## Should say something like "Not a valid roman number ..."
+    ## </FIXME>
+    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
+}

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}

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}