R/Variables.R

In party: A Laboratory for Recursive Partytioning

# $Id: Variables.R 391 2008-08-29 16:05:23Z hothorn $

### factor handling
ff_trafo <- function(x) {
    ### temporarily define `na.pass' as na.action
    opt <- options()
    on.exit(options(opt))
    options(na.action = na.pass)
    if (nlevels(x) == 1) {
        warning("factors at only one level may lead to problems")
        mm <- matrix(1, nrow = length(x))
    } else {
        ### construct design matrix _without_ intercept
        mm <- model.matrix(~ x - 1)
    }
    colnames(mm) <- levels(x)  
    return(mm)
}

ptrafo <- function(data, numeric_trafo = id_trafo, factor_trafo = ff_trafo, 
    ordered_trafo = of_trafo, surv_trafo = logrank_trafo, var_trafo = NULL)

    trafo(data = data, numeric_trafo = numeric_trafo, factor_trafo =
          factor_trafo, ordered_trafo = ordered_trafo, 
          surv_trafo = surv_trafo, var_trafo = var_trafo)


initVariableFrame.df <- function(obj, trafo = ptrafo, scores = NULL, response = FALSE, ...) {

    if (is.null(trafo)) trafo <- ptrafo
    if (response) {
        RET <- new("ResponseFrame", nrow(obj), ncol(obj))
        tmp <- lapply(obj, function(x) {
            if (is.factor(x)) return(ff_trafo(x))
            ### FIXME
            if (inherits(x, "Surv")) return(logrank_trafo(x))
            return(x)
        })
        RET@predict_trafo <- as.matrix(as.data.frame(tmp))
        storage.mode(RET@predict_trafo) <- "double"
    } else {
        RET <- new("VariableFrame", nrow(obj), ncol(obj))
    }
    
    is_ordinal <- sapply(obj, is.ordered)
    is_nominal <- sapply(obj, is.factor) & !is_ordinal

    ### assign user-specified scores to variables in `obj'
    if (!is.null(scores)) {
        if (!is.list(scores) || is.null(names(scores)))
            stop(sQuote("scores"), " is not a named list")
        scores <- scores[names(scores) %in% colnames(obj)]
    }
    if (!is.null(scores)) {
        for (n in names(scores)) {
            if (!(is.factor(obj[[n]]) && is.ordered(obj[[n]])) || 
                nlevels(obj[[n]]) != length(scores[[n]]))
                stop("cannot assign scores to variable ", sQuote(n))
            if (any(order(scores[[n]]) != 1:length(scores[[n]])))
                stop("scores are not increasingly ordered")
            attr(obj[[n]], "scores") <- scores[[n]]
        }
    }

    RET@scores <- lapply(obj, function(x) {
        sc <- 0
        if (is.ordered(x)) {
            sc <- attr(x, "scores")
            if (is.null(sc)) sc <- 1:nlevels(x)
            storage.mode(sc) <- "double"
        }
        sc
    })

    ### transformations
    jt <- trafo(obj)

    ### for each variable
    xt <- vector(mode = "list", length = ncol(obj))
    for (i in 1:ncol(obj))
        xt[[i]] <- jt[,attr(jt, "assign") == i, drop = FALSE]
    rm(jt)

    ### ordering
    ordering <- lapply(obj, function(x) {
        if (is.factor(x) && !is.ordered(x)) return(NULL)
        if (inherits(x, "Surv")) return(NULL)
        if (is.ordered(x)) return(as.integer(order(as.numeric(x))))
        as.integer(order(x))
    })

    ### div.
    levels <- lapply(obj, function(x) if(is.factor(x)) levels(x))
    whichNA <- lapply(obj, function(x) which(is.na(x)))
    has_missings <- sapply(obj, function(x) any(is.na(x)))
    censored <- sapply(obj, function(x) inherits(x, "Surv"))

    ### some "handwork" 
    for (j in 1:ncol(obj)) {
        x <- obj[[j]]

        if (censored[j]) 
            ordering[[j]] <- as.integer(order(xt[[j]]))

        if (is.factor(x)) {
            if (is_ordinal[j]) {
                storage.mode(xt[[j]]) <- "double"
                ### R 2.5.0 does not allow to change the storage mode of factors
                class(obj[[j]]) <- "was_ordered"
                storage.mode(obj[[j]]) <- "double"
            } else {
                storage.mode(obj[[j]]) <- "integer"
            }
        } else {
            storage.mode(obj[[j]]) <- "double"
        }
        nas <- is.na(x)
        xt[[j]][nas, drop = FALSE] <- 0
    }            

    RET@transformations <- xt
    RET@is_nominal <- is_nominal
    RET@is_ordinal <- is_ordinal
    RET@is_censored <- censored
    RET@variables <- obj
    RET@levels <- levels
    RET@ordering <- ordering
    RET@has_missings <- has_missings
    RET@whichNA <- whichNA

    if (response) {
        RET@test_trafo <- as.matrix(as.data.frame(xt))
        storage.mode(RET@test_trafo) <- "double"
    }
    RET
}

initVariableFrame.matrix <- function(obj, response = FALSE, ...) {

    if (response)
        return(initVariableFrame(as.data.frame(obj, ..., response = TRUE)))

    storage.mode(obj) <- "double"
    n <- nrow(obj)
    p <- ncol(obj)
    RET <- new("VariableFrame", n, p)
    is_ordinal <- rep(FALSE, p)
    is_nominal <- rep(FALSE, p)

    RET@scores <- vector(mode = "list", length = p)

    lobj <- vector(mode = "list", length = p)
    for (i in 1:p) lobj[[i]] <- obj[,i,drop = FALSE]
    obj <- lobj

    ### ordering
    ordering <- lapply(obj, function(x) {
        as.integer(order(x))
    })

    ### div.
    levels <- vector(mode = "list", length = p)
    whichNA <- lapply(obj, function(x) which(is.na(x)))
    has_missings <- sapply(obj, function(x) any(is.na(x)))
    censored <- rep(FALSE, p)

    RET@transformations <- obj
    RET@is_nominal <- is_nominal
    RET@is_ordinal <- is_ordinal
    RET@is_censored <- censored
    RET@variables <- RET@transformations
    RET@levels <- levels
    RET@ordering <- ordering
    RET@has_missings <- has_missings
    RET@whichNA <- whichNA

    RET
}

setGeneric(name = "initVariableFrame",
           def = function(obj, ...)
               standardGeneric("initVariableFrame")
)

setMethod("initVariableFrame", 
    signature = "data.frame",
    definition = initVariableFrame.df
)

setMethod("initVariableFrame", 
    signature = "matrix",
    definition = initVariableFrame.matrix
)

setGeneric(name = "response",
           def = function(object, ...)
               standardGeneric("response")
)

setMethod("response",
    signature = "BinaryTree",
    definition = function(object) object@responses@variables
)

get_variables <- function(x)
    x@variables

setGeneric(name = "LearningSample",
           def = function(object, ...)
               standardGeneric("LearningSample")
)

LearningSample.matrix <- function(object, response, ...) {

    new("LearningSample", inputs = inp <- initVariableFrame(object), 
        responses = initVariableFrame(as.data.frame(response), response = TRUE, ...),
        weights = rep(1, inp@nobs), nobs = inp@nobs,
        ninputs = inp@ninputs)
}

setMethod("LearningSample",
    signature = "matrix",
    definition = LearningSample.matrix
)

LearningSample.ModelEnv <- function(object, ...) {

    inp <- initVariableFrame(object@get("input"), ...)

    response <- object@get("response")

    if (any(is.na(response)))
        stop("missing values in response variable not allowed")

    resp <- initVariableFrame(response, ..., response = TRUE)

    RET <- new("LearningSampleFormula", inputs = inp, responses = resp,
               weights = rep(1, inp@nobs), nobs = inp@nobs,
               ninputs = inp@ninputs, menv = object)
    return(RET)
}

setMethod("LearningSample",
    signature = "ModelEnv",
    definition = LearningSample.ModelEnv
)

newinputs <- function(object, newdata = NULL) {

    if (is.null(newdata)) return(object@inputs)
    if (inherits(object, "LearningSampleFormula"))
        newdata <- object@menv@get("input", data = newdata)

    if (inherits(newdata, "VariableFrame"))
        return(newdata)
    if (inherits(newdata, "LearningSample"))
        return(newdata@inputs)

    return(initVariableFrame(newdata, trafo = ptrafo))
}