1###  These are function that are designed to compatibility with S-plus
2###  for R internationalization.  They are named with a prefix of
3###  "Splus".
4###
5###  These functions contain representations of sprintf, gettext,
6###  gettextf, and ngettext
7
8
9if(!exists("sprintf")) sprintf <- function(fmt, ...) {
10  ldots <- list(...)
11
12  text <- vector("character")
13  vars <- vector("character")
14  i <- 1; j <- 1;
15  temp <- fmt
16  while (nchar(temp)) {
17    ne <- regexpr('(?<!%)%[^%]*?[dixXfeEgGs]', temp, perl=TRUE)
18    if( ne < 0 ) {
19      text[i] <- gsub('%%', '%', temp)
20      temp <- ""
21    } else {
22      text[i] <- gsub('%%', '%', substr(temp, 0, ne-1))
23      i <- i + 1
24      vars[j] <- substr(temp, ne+1, ne+attr(ne, "match.length")-1)
25      j <- j + 1
26      temp <- substr(temp, ne+attr(ne, "match.length"), nchar(temp))
27    }
28  }
29
30  output <- NULL
31  j <- 1
32  for( i in 1:(length(text) - 1)) {
33    output <- paste(output, text[i], sep='')
34    if(regexpr('^\\d+\\$', vars[i], perl=TRUE) > 0){
35      arg <- sub('^(\\d+)\\$.*$', '\\1', vars[i], perl=TRUE)
36      if(arg > 0 && arg < length(ldots)) {
37        val <- as.integer(arg)
38      }
39      else
40        stop("Error")
41    }
42    else {
43      val <- j
44      j <- j + 1
45    }
46    output <- paste(output, ldots[[val]], sep='')
47  }
48  return(paste(output, text[length(text)], sep=''))
49}
50
51if(!exists("gettext")) gettext <- function(..., domain=NULL)
52    return(unlist(list(...)))
53
54
55if(!exists("gettextf")) gettextf <- function(fmt, ..., domain=NULL) {
56  return(sprintf(fmt, ...))
57}
58
59if(!exists("ngettext")) ngettext <- function(n, msg1, msg2, domain = NULL) {
60  if(n == 1)
61    return(msg1)
62  return(msg2)
63}
64