Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #' Apply cutoff in CV
- #'
- #' Apply a cutoff learned on a cross-validated model (from cv.learn.fun)
- #'
- #' @param CVmodel
- #' Model from cv.learn.fun
- #' @param CVcutoffs
- #' Cutoffs from cv.learn.cutoff
- #' @param cutoff.whichdata
- #' The cutoff on which data it was learned
- #' @param whichdata
- #' On which data from CVmodel should the cutoffs be applied?
- #' @param cutofflabels
- #' How are the cutoffs named? (For 2 cutoffs: low, mid, high)
- #' It happens that in one step two cutoffs have the same value.
- #' The samples are then parted into "low" and "high"
- #' @param reference.cutofflabel
- #' The cutoff-label "in the middle" (For 2 cutoffs: mid)
- #' @param newname
- #' How should the new column be named which is concatenated to CVmodel
- #' @return
- #' @export
- #'
- #' @examples
- cv.apply.cutoff <- function(CVmodel
- ,CVcutoffs
- ,cutoff.whichdata = "trainResponseScaled"
- ,whichdata = "testResponseScaled"
- ,cutofflabels = c("low", "mid", "high")
- ,reference.cutofflabel = "mid"
- ,newname="testResponseScaledGroups"){
- if(any(names(CVmodel) != names(CVcutoffs[[cutoff.whichdata]]))){
- stop("Names from CVmodel and CVcutoffs[[cutoff.whichdata]] are not equal")
- }
- cutoffs <- CVcutoffs[[cutoff.whichdata]]
- for(CVstepX in names(CVmodel)){
- tmp.cutoffs <- cutoffs[[CVstepX]]$cutoff
- tmp.cutoff.ranges <- c(-Inf, sort(unique(tmp.cutoffs)), Inf)
- tmp.cutofflabels <- cutofflabels
- if(length(tmp.cutoff.ranges) < (length(tmp.cutoffs) + 2)){
- tmp.cutofflabels <- cutofflabels[c(1:(length(tmp.cutoff.ranges)-2), length(cutofflabels))]
- }
- tmp.data <- CVmodel[[CVstepX]][[whichdata]]
- if(!is.null(tmp.data)){
- tmp.testgroups <- cut( tmp.data, tmp.cutoff.ranges, labels = tmp.cutofflabels)
- if(!(length(tmp.cutoff.ranges) < (length(tmp.cutoffs) + 2))){
- tmp.testgroups <- relevel(tmp.testgroups, ref = reference.cutofflabel)
- }
- names(tmp.testgroups) <- names(tmp.data)
- }else{
- tmp.testgroups <- NULL
- }
- CVmodel[[CVstepX]][[newname]] <- tmp.testgroups
- }
- return(CVmodel)
- }
Add Comment
Please, Sign In to add comment