Nothing
# The Relevel method
Relevel <- function (x, ...) UseMethod("Relevel")
# Utility to group a factor from a 2-column table;
# called from Relevel if second argument is a matrix or table
tRelevel <-
function( ff, # factor to be grouped
gg, # 2-column matrix or table with levels resp. grouping
xlevels = TRUE, # include also grouped levels not present in ff
nogroup = TRUE ) # levels of ff not grouped are tranferred (if FALSE set to NA)
{
if( any( wh <- ( apply( table( gg[,1], gg[,2] )>0, 1, sum )>1 ) ) )
stop( "\nFactor level", if(sum(wh)>1) "s", ": \n",
paste(names(wh)[wh],collapse=" / "),
"\nis grouped to more than one group.\n" )
if( any( is.na( match( unique(as.character(ff)),
unique(as.character(gg[,1])) ) ) ) )
cat( "Note: Some values of factor not among levels grouped.\n" )
if( any( wh <- ( apply( table( gg[,1], gg[,2] ), 1, sum )>1 ) ) )
warning( "Factor level", if(sum(wh)>1) "s", ": ",
paste(names(wh)[wh],collapse=" / "),
"\nappear more than once in the table of groupings." )
# indices and names of the original factor levels
ixff <- as.integer( ff )
chff <- as.character( ff )
# where they are in the translation table
ixg1 <- as.integer( factor( gg[,1], levels=levels(ff) ) )
# indices of the new levels in the translation table
ixg2 <- as.integer( g2 <- factor(gg[,2]) )
# remove unwanted NAs (levels in g[,1] not present in ff)
ixg2 <- ixg2[!is.na(ixg1)]
ixg1 <- ixg1[!is.na(ixg1)]
# where in ixg2 are the integers ixff - match(), choose those values
grff <- levels(g2)[ixg2[match(ixff,ixg1)]]
# transfer non-grouped levels of ff
if( nogroup ) grff[is.na(grff)] <- chff[is.na(grff)]
# a factor with the correct levels in the correct order
grff <- factor( grff, levels=union(levels(g2),levels(factor(grff))) )
# keep all levels from second column or not?
if( xlevels ) grff else factor(grff)
}
# The factor method is the default method
Relevel.default <-
Relevel.factor <-
function( x, ref, first = TRUE,
collapse = "+",
xlevels = TRUE,
nogroup = TRUE,
... )
{
# Function that collapses multiple sets of levels of a factor
#
# If ref is a 2-dim structure
if( is.matrix( ref) |
is.table( ref) |
is.array( ref) |
is.data.frame(ref) )
{
if( length(dim(ref)) !=2 ) stop("ref must be 2-dimensional\n")
if( dim(ref)[2] < 2 ) stop("ref must have at least 2 colums\n")
return( tRelevel( x, ref, xlevels, nogroup ) )
} else {
# Otherwise use the old version
#
if( !is.factor(x) )
{
argnam <- deparse( substitute(x) )
f <- factor( x )
cat( "WARNING: ", argnam,
"has been converted to a factor with levels:\n",
levels( f ) )
}
else
f <- x
# This is a copy of the relevel function from the base package:
#
relev <- function (x, ref, ...)
{
lev <- levels(x)
if ( is.character( ref ) )
ref <- match(ref, lev)
if ( any( is.na( ref ) ) )
stop( "any values in ref must be an existing level\n" )
nlev <- length( lev )
if ( any( ref < 1 ) || any( ref > nlev ) )
stop( paste( "ref=", paste( ref, collapse="," ),
": All elements must be in 1:", nlev, sep="" ) )
factor(x, levels = lev[c(ref, seq(along = lev)[-ref])])
}
# If called with a non-list argument assume reshuffling of levels
#
if( !is.list( ref ) )
fnew <- relev( f, ref )
# If called with a list collapse levels in each list element.
#
if( is.list( ref ) )
{
fnew <- f
newnames <- levels( f )
uninames <- character( length( ref ) )
for( s in 1:length(ref) )
if ( is.character( ref[[s]] ) ) ref[[s]] <- match( ref[[s]], levels(f) )
# Check for replicates in levels to be grouped
if( any( (tt<-table(unlist(ref))) > 1 ) )
stop("Factor level(s) ", levels( f )[as.numeric(names(tt)[tt>1])],
" has been allocated to more than one new level.")
for( s in 1:length(ref) )
{
uninames[s] <- if( is.null( names( ref ) ) )
{
paste( levels( f )[ref[[s]]], collapse=collapse )
}
else if( names( ref )[s]=="" )
{
paste( levels( f )[ref[[s]]], collapse=collapse )
}
else names( ref )[s]
newnames[ref[[s]]] <- rep( uninames[s], length( ref[[s]] ) )
}
levels( fnew ) <- newnames
if( !is.null( first ) )
{
if( !first ) fnew <- factor( fnew, c( levels( f )[-unlist( ref )], uninames ) )
if( first ) fnew <- factor( fnew, c( uninames, levels( f )[-unlist( ref )] ) )
}
}
# This is in order to merge levels with identical names
#
return( factor( fnew, levels=levels(fnew) ) )
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.