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