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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
relabel <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
if(isS4(x)) {
m <- as.list(match.call(expand.dots=FALSE))
dots <- lapply(m$...,as.character)
m <- c(m[1:2],dots,m[-(1:3)])
m[[1]] <- as.name("relabel4")
#relabel4(x,...,gsub=gsub,fixed=fixed,warn=warn)
m <- as.call(m)
eval(m,parent.frame())
}
else UseMethod("relabel")
}
relabel.default <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
if(!is.null(attr(x,"labels"))) labels <- attr(x,"labels")
else labels <- names(x)
m <- match.call(expand.dots=FALSE)
subst <- sapply(m$...,as.character)
if(gsub){
for(i in 1:length(subst)){
labels <- gsub(names(subst[i]),subst[i],labels,fixed=fixed)
}
}
else {
i <- match(names(subst),labels)
if(any(is.na(i))) {
if(warn) warning("undefined label(s) selected")
if(any(!is.na(i)))
subst <- subst[!is.na(i)]
i <- i[!is.na(i)]
}
if(length(i))
labels[i] <- subst
}
if(!is.null(attr(x,"labels"))) attr(x,"labels") <- labels
else names(x) <- labels
return(x)
}
relabel.factor <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
m <- match.call(expand.dots=FALSE)
subst <- sapply(m$...,as.character)
labels <- levels(x)
if(gsub){
for(i in 1:length(subst)){
labels <- gsub(names(subst[i]),subst[i],labels,fixed=fixed)
}
}
else {
i <- match(names(subst),labels)
if(any(is.na(i))) {
if(warn) warning("undefined label(s) selected")
if(any(!is.na(i)))
subst <- subst[!is.na(i)]
i <- i[!is.na(i)]
}
if(length(i))
labels[i] <- subst
}
if(any(duplicated(labels)))
warning("Duplicate labels")
levels(x) <- labels
return(x)
}
relabel1 <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
m <- match.call(expand.dots=FALSE)
subst <- sapply(m$...,as.character)
if(gsub){
for(i in 1:length(subst)){
x <- gsub(names(subst[i]),subst[i],x,fixed=fixed)
}
}
else {
i <- match(names(subst),x)
if(any(is.na(i))) {
if(warn) warning("unused name(s) selected")
if(any(!is.na(i)))
subst <- subst[!is.na(i)]
i <- i[!is.na(i)]
}
if(length(i))
x[i] <- subst
}
return(x)
}
relabel.table <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
dn <- dimnames(x)
ndn <- names(dn)
dn <- lapply(dn,relabel1,...,gsub=gsub,fixed=fixed,warn=warn)
ndn <- relabel1(ndn,...,gsub=gsub,fixed=fixed,warn=warn)
names(dn) <- ndn
dimnames(x) <- dn
return(x)
}
relabel.ftable <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
attr(x,"row.vars") <- relabel1ft(attr(x,"row.vars"),...,gsub=gsub,fixed=fixed,warn=warn)
attr(x,"col.vars") <- relabel1ft(attr(x,"col.vars"),...,gsub=gsub,fixed=fixed,warn=warn)
return(x)
}
relabel1ft <- function(x,...,gsub=FALSE,fixed=TRUE,warn=TRUE){
n.x <- names(x)
if(length(n.x))
n.x <- relabel1(n.x,...,gsub=gsub,fixed=fixed,warn=warn)
x <- relabel1(x,...,gsub=gsub,fixed=fixed,warn=warn)
names(x) <- n.x
return(x)
}
relabel.ftable_matrix <- function(x,...,gsub=FALSE,fixed=TRUE,warn=FALSE){
attr(x,"row.vars") <- lapply(attr(x,"row.vars"),relabel1ft,...,gsub=gsub,fixed=fixed,warn=warn)
attr(x,"col.vars") <- lapply(attr(x,"col.vars"),relabel1ft,...,gsub=gsub,fixed=fixed,warn=warn)
return(x)
}
|
