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