R/updateObject.R

In BiocGenerics: S4 generic functions used in Bioconductor

### =========================================================================
### The updateObject() generic and related utilities
### -------------------------------------------------------------------------
###
### An "updateObject" default method + methods for some standard types are
### also provided.
###


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Utilities.
###

updateObjectFrom_errf <- function(..., verbose=FALSE) {
    function(err) {
        if (verbose)
            message(..., ":\n    ", conditionMessage(err),
                    "\n    trying next method...")
        NULL
    }
}

getObjectSlots <- function(object)  # object, rather than class defn, slots
{
    if (!is.object(object) || isVirtualClass(class(object)))
        return(NULL)
    value <- attributes(object)
    value$class <- NULL
    if (is(object, "vector")) {
        .Data <- as.vector(object)
        attr(.Data, "class") <- NULL
        attrNames <- c("comment", "dim", "dimnames",
                       "names", "row.names", "tsp")
        for (nm in names(value)[names(value) %in% attrNames])
            attr(.Data, nm) <- value[[nm]]
        value <- value[!names(value) %in% attrNames]
        value$.Data <- .Data
    }
    value
}

updateObjectFromSlots <- function(object, objclass=class(object),
                                  ..., verbose=FALSE)
{
    if (is(object, "environment")) {
        if (verbose)
            message("returning original object of class 'environment'")
        return(object)
    }
    classSlots <- slotNames(objclass)
    if (is.null(classSlots)) {
        if (verbose)
            message("definition of '", objclass, "' has no slots; ",
                    "returning original object")
        return(object)
    }
    if (verbose)
        message("updateObjectFromSlots(object = '", class(object),
                "' class = '", objclass, "')")
    objectSlots <- getObjectSlots(object)
    ## de-mangle and remove NULL
    nulls <- sapply(names(objectSlots),
                    function(slt) is.null(slot(object, slt)))
    objectSlots[nulls] <- NULL
    joint <- intersect(names(objectSlots), classSlots)
    toUpdate <- joint[joint!=".Data"]
    objectSlots[toUpdate] <- lapply(objectSlots[toUpdate],
                                    updateObject, ..., verbose=verbose)
    toDrop <- which(!names(objectSlots) %in% classSlots)
    if (length(toDrop) > 0L) {
        warning("dropping slot(s) '",
                paste(names(objectSlots)[toDrop], collapse="', '"),
                "' from object = '", class(object), "'")
        objectSlots <- objectSlots[-toDrop]
    }
    ## ad-hoc methods for creating new instances
    res <- NULL
    if (is.null(res)) {
        if (verbose)
            message("heuristic updateObjectFromSlots, method 1")
        res <- tryCatch({
                   do.call(new, c(objclass, objectSlots[joint]))
               }, error=updateObjectFrom_errf(
                      "'new(\"", objclass, "\", ...)' from slots failed",
                      verbose=verbose))
    }
    if (is.null(res)) {
        if (verbose)
            message("heuristic updateObjectFromSlots, method 2")
        res <- tryCatch({
                   obj <- do.call(new, list(objclass))
                   for (slt in joint)
                       slot(obj, slt) <- updateObject(objectSlots[[slt]],
                                                      ..., verbose=verbose)
                   obj
               }, error=updateObjectFrom_errf(
                      "failed to add slots to 'new(\"", objclass, "\", ...)'",
                      verbose=verbose))
    }
    if (is.null(res))
        stop("could not updateObject to class '", objclass, "'",
             "\nconsider defining an 'updateObject' method for class '",
             class(object), "'")
    res
}

getObjectFields <- function(object)
{
    value <- object$.refClassDef@fieldClasses
    for (field in names(value))
        value[[field]] <- object$field(field)
    value
}

updateObjectFromFields <-
    function(object, objclass=class(object), ..., verbose=FALSE)
{
    if (verbose)
        message("updateObjectFromFields(object = '", class(object),
                "' objclass = '", objclass, "')")

    classFields <- names(getRefClass(objclass)$fields())
    if (is.null(classFields)) {
        if (verbose)
            message("definition of '", objclass, "' has no fields; ",
                    "regurning original object")
        return(object)
    }

    objectFields <- getObjectFields(object)

    toUpdate <- joint <- intersect(names(objectFields), classFields)
    objectFields[toUpdate] <-
        lapply(objectFields[toUpdate], updateObject, ..., verbose=verbose)
    toDrop <- which(!names(objectFields) %in% classFields)
    if (length(toDrop) > 0L) {
        warning("dropping fields(s) '",
                paste(names(objectFields)[toDrop], collapse="', '"),
                "' from object = '", class(object), "'")
        objectFields <- objectFields[-toDrop]
    }

        ## ad-hoc methods for creating new instances

    if (verbose)
        message("heuristic updateObjectFromFields, method 1")
    res <- tryCatch({
        do.call(new, c(objclass, objectFields[joint]))
    }, error = updateObjectFrom_errf(
           "'new(\"", objclass, "\", ...' from slots failed",
           verbose=verbose)
    )

    if (is.null(res))
        stop("could not updateObject to class '", objclass, "'",
             "\nconsider defining an 'updateObject' method for class '",
             class(object), "'")
    res
}


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### updateObject()
###

### TODO: Would be cleaner if 'check' was a formal argument.
setGeneric("updateObject", signature="object",
    function(object, ..., verbose=FALSE)
    {
        if (!isTRUEorFALSE(verbose))
            stop("'verbose' must be TRUE or FALSE")
        result <- standardGeneric("updateObject")
        check <- list(...)$check
        if (is.null(check)) {
            check <- TRUE
        } else if (!isTRUEorFALSE(check)) {
            stop("'check' must be TRUE or FALSE")
        }
        if (check) {
            if (verbose)
                message("[updateObject] Validating the updated object ... ",
                        appendLF=FALSE)
            validObject(result)
            if (verbose)
                message("OK")
        }
        result
    }
)

setMethod("updateObject", "ANY",
    function(object, ..., verbose=FALSE)
    {
        if (verbose)
            message("updateObject(object=\"ANY\") default for object ",
                    "of class '", class(object), "'")
        if (length(getObjectSlots(object)) > 0L &&
            !any(class(object) %in% c("data.frame")))
        {
            updateObjectFromSlots(object, ..., verbose=verbose)
        } else {
            object
        }
    }
)

setMethod("updateObject", "list",
    function(object, ..., verbose=FALSE)
    {
        if (verbose)
            message("updateObject(object = 'list')")
        if ("class" %in% names(attributes(object)))
            callNextMethod() # old-style S4
        else {
            result <- lapply(object, updateObject, ..., verbose=verbose)
            attributes(result) <- attributes(object)
            result
        }
    }
)

setMethod("updateObject", "environment",
    function(object, ..., verbose=FALSE)
    {
        if (verbose)
            message("updateObject(object = 'environment')")
        envLocked <- environmentIsLocked(object)
        if (verbose) {
            if (envLocked)
                warning("updateObject duplicating locked environment")
            else
                warning("updateObject modifying environment")
        }
        env <- if (envLocked) new.env() else object
        lapply(ls(object, all.names=TRUE),
               function(elt) {    # side-effect!
                   bindingLocked <- bindingIsLocked(elt, object)
                   if (!envLocked && bindingLocked)
                       stop("updateObject object = 'environment' ",
                            "cannot modify locked binding '", elt, "'")
                   else {
                       env[[elt]] <<- updateObject(object[[elt]],
                                                   ..., verbose=verbose)
                       if (bindingLocked) lockBinding(elt, env)
                   }
                   NULL
               })
        attributes(env) <- attributes(object)
        if (envLocked)
            lockEnvironment(env)
        env
    }
)

setMethod("updateObject", "formula",
    function(object, ..., verbose=FALSE)
{
    if (verbose)
        ## object@.Environment could be too general, e.g,. R_GlobalEnv
        message("updateObject(object = 'formula'); ignoring .Environment")
    object
})

setMethod("updateObject", "envRefClass",
    function(object, ..., verbose=FALSE)
{
    msg <- sprintf("updateObject(object= '%s')", class(object))
    if (verbose)
        message(msg)
    updateObjectFromFields(object, ..., verbose=verbose)
})