1relabel <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
2    if(isS4(x)) {
3        m <- as.list(match.call(expand.dots=FALSE))
4        dots <- lapply(m$...,as.character)
5        m <- c(m[1:2],dots,m[-(1:3)])
6        m[[1]] <- as.name("relabel4")
7        #relabel4(x,...,gsub=gsub,fixed=fixed,warn=warn)
8        m <- as.call(m)
9        eval(m,parent.frame())
10    }
11    else UseMethod("relabel")
12}
13
14relabel.default <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
15    if(!is.null(attr(x,"labels"))) labels <- attr(x,"labels")
16    else labels <- names(x)
17    m <- match.call(expand.dots=FALSE)
18    subst <- sapply(m$...,as.character)
19    if(gsub){
20        for(i in 1:length(subst)){
21            labels <- gsub(names(subst[i]),subst[i],labels,fixed=fixed)
22        }
23    }
24    else {
25        i <- match(names(subst),labels)
26        if(any(is.na(i))) {
27            if(warn) warning("undefined label(s) selected")
28            if(any(!is.na(i)))
29                subst <- subst[!is.na(i)]
30            i <- i[!is.na(i)]
31        }
32        if(length(i))
33            labels[i] <- subst
34    }
35    if(!is.null(attr(x,"labels"))) attr(x,"labels") <- labels
36    else names(x) <- labels
37    return(x)
38}
39
40relabel.factor <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
41    m <- match.call(expand.dots=FALSE)
42    subst <- sapply(m$...,as.character)
43    labels <- levels(x)
44    if(gsub){
45        for(i in 1:length(subst)){
46            labels <- gsub(names(subst[i]),subst[i],labels,fixed=fixed)
47        }
48    }
49    else {
50        i <- match(names(subst),labels)
51        if(any(is.na(i))) {
52            if(warn) warning("undefined label(s) selected")
53            if(any(!is.na(i)))
54                subst <- subst[!is.na(i)]
55            i <- i[!is.na(i)]
56        }
57        if(length(i))
58            labels[i] <- subst
59    }
60    if(any(duplicated(labels)))
61        warning("Duplicate labels")
62    levels(x) <- labels
63    return(x)
64}
65
66relabel1 <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
67    m <- match.call(expand.dots=FALSE)
68    subst <- sapply(m$...,as.character)
69    if(gsub){
70        for(i in 1:length(subst)){
71            x <- gsub(names(subst[i]),subst[i],x,fixed=fixed)
72        }
73    }
74    else {
75        i <- match(names(subst),x)
76        if(any(is.na(i))) {
77            if(warn) warning("unused name(s) selected")
78            if(any(!is.na(i)))
79                subst <- subst[!is.na(i)]
80            i <- i[!is.na(i)]
81        }
82        if(length(i))
83            x[i] <- subst
84    }
85    return(x)
86}
87
88
89relabel.table <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
90
91  dn <- dimnames(x)
92  ndn <- names(dn)
93  dn <- lapply(dn,relabel1,...,gsub=gsub,fixed=fixed,warn=warn)
94  ndn <- relabel1(ndn,...,gsub=gsub,fixed=fixed,warn=warn)
95  names(dn) <- ndn
96  dimnames(x) <- dn
97  return(x)
98}
99
100
101relabel.ftable <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
102  attr(x,"row.vars") <- relabel1ft(attr(x,"row.vars"),...,gsub=gsub,fixed=fixed,warn=warn)
103  attr(x,"col.vars") <- relabel1ft(attr(x,"col.vars"),...,gsub=gsub,fixed=fixed,warn=warn)
104  return(x)
105}
106
107relabel1ft <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
108  n.x <- names(x)
109  if(length(n.x))
110    n.x <- relabel1(n.x,...,gsub=gsub,fixed=fixed,warn=warn)
111  x <- relabel1(x,...,gsub=gsub,fixed=fixed,warn=warn)
112  names(x) <- n.x
113  return(x)
114}
115
116relabel.ftable_matrix <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
117  attr(x,"row.vars") <- lapply(attr(x,"row.vars"),relabel1ft,...,gsub=gsub,fixed=fixed,warn=warn)
118  attr(x,"col.vars") <- lapply(attr(x,"col.vars"),relabel1ft,...,gsub=gsub,fixed=fixed,warn=warn)
119  return(x)
120}
121