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