Nothing
isUnknown <- function(x, unknown=NA, ...)
UseMethod("isUnknown")
isUnknown.default <- function(x, unknown=NA, ...)
{
if(is.list(unknown)) unknown <- unlist(unknown)
ret <- x %in% unknown
if(any(is.na(unknown))) ret <- ret | is.na(x)
ret
}
isUnknown.POSIXlt <- function(x, unknown=NA, ...)
{
## FIXME: codetools say
## isUnknown.POSIXlt: wrong number of arguments to as.character
if(is.list(unknown) && !inherits(x=unknown, what="POSIXlt")) {
unknown <- lapply(unknown, FUN=as.character, ...)
} else {
unknown <- as.character(x=unknown, ...)
}
if(is.list(x) && !inherits(x=x, what="POSIXlt")) {
x <- lapply(x, FUN=as.character, ...)
} else {
x <- as.character(x=x, ...)
}
isUnknown.default(x=as.character(x), unknown=as.character(unknown))
}
isUnknown.list <- function(x, unknown=NA, ...) {
unknown <- .unknownList(x=x, unknown=unknown)
x <- mapply(FUN="isUnknown", x=x, unknown=unknown, ..., SIMPLIFY=FALSE)
x
}
isUnknown.data.frame <- function(x, unknown=NA, ...)
{
x[] <- isUnknown.list(x, unknown=unknown, ...)
x
}
isUnknown.matrix <- function(x, unknown=NA, ...)
apply(X=x, MARGIN=ifelse(ncol(x) > nrow(x), 1, 2), FUN=isUnknown,
unknown=unknown)
unknownToNA <- function(x, unknown, warning=FALSE, ...)
UseMethod("unknownToNA")
unknownToNA.default <- function(x, unknown, warning=FALSE, ...)
{
if(warning) {
if(any(is.na(x)))
warning("'x' already has NA")
}
is.na(x) <- isUnknown(x=x, unknown=unknown)
x
}
unknownToNA.factor <- function(x, unknown, warning=FALSE, ...)
{
## could put this func into default method, but I need unlisted unknown
## for levels handling
if(warning) {
if(any(is.na(x)))
warning("'x' already has NA")
}
if(is.list(unknown)) unknown <- unlist(unknown)
## Levels handling - read help page on this
levs <- levels(x)
levs <- levs[!(levs %in% unknown)]
factor(x, levels=levs)
}
unknownToNA.list <- function(x, unknown, warning=FALSE, ...)
{
unknown <- .unknownList(x=x, unknown=unknown)
x <- mapply(FUN="unknownToNA", x=x, unknown=unknown, warning=warning,
SIMPLIFY=FALSE)
return(x)
}
unknownToNA.data.frame <- function(x, unknown, warning=FALSE, ...)
{
x[] <- unknownToNA.list(x=x, unknown=unknown, warning=warning)
x
}
NAToUnknown <- function(x, unknown, force=FALSE, call.=FALSE, ...)
UseMethod("NAToUnknown")
NAToUnknown.default <- function(x, unknown, force=FALSE, call.=FALSE, ...)
{
if(length(as.character(unknown)) != 1) # as.character allows also POSIXlt
stop("'unknown' must be a single value")
if(any(isUnknown(x, unknown=unknown)) && !force)
stop(sprintf("'x' already has value %s", dQuote(unknown)))
classX <- class(x)[1]
classUnk <- class(unknown)[1]
if(classX != classUnk) {
tmp <- c("integer", "numeric")
if(!(classX %in% tmp && classUnk %in% tmp)) {
warning(sprintf("'unknown' should be %s for %s 'x' - will try to coerce",
dQuote(classX), dQuote(classX)), call.=call.)
}
unknown <- do.call(paste("as.", classX, sep=""), args=list(unknown))
}
x[is.na(x)] <- unknown
x
}
NAToUnknown.factor <- function(x, unknown, force=FALSE, call.=FALSE, ...)
{
if(length(unknown) != 1)
stop("'unknown' must be a single value")
if(any(isUnknown(x, unknown=unknown))) {
if(!force) stop(sprintf("'x' already has level %s", dQuote(unknown)))
} else {
mapLevels(x) <- c(mapLevels(x, codes=FALSE),
mapLevels(as.character(unknown), codes=FALSE))
}
x[is.na(x)] <- unknown
if(!force)
warning(sprintf("new level is introduced: %s", unknown), call.=call.)
x
}
NAToUnknown.list <- function(x, unknown, force=FALSE, call.=FALSE, ...)
{
unknown <- .unknownList(x=x, unknown=unknown)
x <- mapply(FUN="NAToUnknown", x=x, unknown=unknown, force=force,
call.=call., SIMPLIFY=FALSE)
x
}
NAToUnknown.data.frame <- function(x, unknown, force=FALSE, call.=FALSE, ...)
{
x[] <- NAToUnknown.list(x=x, unknown=unknown, force=force, call.=call.)
x
}
.unknownList <- function(x, unknown)
{
## Setup
n <- length(x)
unkN <- length(unknown)
namesX <- names(x)
namesXNullTest <- is.null(namesX)
unkNames <- names(unknown)
unkNamesNullTest <- is.null(unkNames)
defInNames <- ".default" %in% unkNames
defInd <- unkNames %in% ".default"
def <- unknown[defInd]
if(defInNames) { # remove default
unkN <- unkN - 1
unkNames <- unkNames[!defInd]
unknown <- unknown[!defInd]
}
if(!namesXNullTest) { # check for nonexistent name
test <- !(unkNames %in% namesX)
if(any(test)) stop(sprintf("name(s) %s not in names of 'x'",
paste(sQuote(unkNames[test]), collapse=" ")))
}
## Recycle
if(unkN < n) {
if(unkNamesNullTest | defInNames) {
if(defInNames) { # handling .default
names(def) <- NULL
unknownDef <- rep(def, length=(n - unkN))
names(unknownDef) <- namesX[!(namesX %in% unkNames)]
unknown <- c(unknownDef, unknown)
} else {
unknownDef <- unknown
unknown <- rep(unknownDef, length=n)
}
} else {
stop("can not propely recycle named 'unknown'")
}
}
## Names
if(!namesXNullTest) { # no need if namesX NULL
if(unkNamesNullTest) { # missing unkNames
names(unknown) <- namesX
} else { # unkNames known
unknown <- unknown[match(namesX, names(unknown))]
}
}
unknown
}
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.