https://github.com/cran/cutpointr
Raw File
Tip revision: 7e56c827a694247d212e9a0167a119f917e1f31b authored by Christian Thiele on 31 August 2018, 15:50:10 UTC
version 0.7.4
Tip revision: 7e56c82
predict.cutpointr.R
#' Predict using a cutpointr object
#'
#' Predictions are made on the \code{data.frame} in \code{newdata}
#' using either the variable name or by applying the same transformation to
#' the data as in \code{cutpointr}. The class of the output will be identical to the class
#' of the predictor.
#'
#' @param object a cutpointr object.
#' @param newdata a data.frame with a column that contains the predictor
#' variable.
#' @param cutpoint_nr if multiple optimal cutpoints were found this parameter
#' defines which one should be used for predictions. Can be a vector if
#' different cutpoint numbers are desired for different subgroups.
#' @param ... further arguments.
#' @examples
#' oc <- cutpointr(suicide, dsi, suicide)
#' ## Return in-sample predictions
#' predict(oc, newdata = data.frame(dsi = oc$data[[1]]$dsi))
#' @family main cutpointr functions
#' @export
predict.cutpointr <- function(object, newdata, cutpoint_nr = 1, ...) {
    if (!("data.frame" %in% class(newdata))) {
        stop("newdata should be a data.frame")
    }
    if (!(length(cutpoint_nr) == 1 | length(cutpoint_nr) == nrow(object))) {
        stop("Specify one cutpoint_nr or one cutpoint_nr per subgroup.")
    }
    predictor_name <- object$predictor[1]
    # The predictor may have been altered using NSE
    indep_var <- eval(parse(text = predictor_name), newdata, parent.frame())
    pos_class <- object$pos_class[1]
    neg_class <- object$neg_class[1]

    if (any(colnames(object) == "subgroup")) {
        grouping_name     <- unique(object$grouping)
        grouping_var_new  <- eval(parse(text = grouping_name), newdata, parent.frame())
        opt_cut_ind <- purrr::map_int(grouping_var_new, function(g) {
            which(object$subgroup == g)
        })
        if (length(cutpoint_nr) == 1) {
            optimal_cuts <- purrr::map_dbl(object$optimal_cutpoint, function(x) {
                x[cutpoint_nr]
            })
        } else {
            optimal_cuts <- purrr::map2(.x = 1:nrow(object),
                                        .y = cutpoint_nr,
                                        .f = function(i, nr) {
                optimal_cut <- object$optimal_cutpoint[[i]][nr]
                if (is.na(optimal_cut)) {
                    stop(paste("Cutpoint Nr.", nr, "in subgroup", i, "not found"))
                }
                return(optimal_cut)
            })
            optimal_cuts <- unlist(optimal_cuts)
        }
        optimal_cuts <- optimal_cuts[opt_cut_ind]
        if (object$direction[1] == ">=") {
            preds <- indep_var >= optimal_cuts
            preds <- ifel_pos_neg(preds, pos_class, neg_class)
        } else if (object$direction[1] == "<=") {
            preds <- indep_var <= optimal_cuts
            preds <- ifel_pos_neg(preds, pos_class, neg_class)
        }
    } else {
        optimal_cut <- object$optimal_cutpoint[[1]][cutpoint_nr]
        if (is.na(optimal_cut)) {
            stop(paste("Cutpoint Nr.", cutpoint_nr, "not found"))
        }
        if (object$direction[1] == ">=") {
            preds <- indep_var >= optimal_cut
            preds <- ifel_pos_neg(preds, pos_class, neg_class)
        } else if (object$direction[1] == "<=") {
            preds <- indep_var <= optimal_cut
            preds <- ifel_pos_neg(preds, pos_class, neg_class)
        }
    }
    return(preds)
}
back to top