Question

通常，我想对包含一些因子变量的数据集运行交叉验证，并且在运行一段时间后，交叉验证例程失败并显示错误：factor x has new levels Y。

例如，使用包boot：

library(boot)
d <- data.frame(x=c('A', 'A', 'B', 'B', 'C', 'C'), y=c(1, 2, 3, 4, 5, 6))
m <- glm(y ~ x, data=d)
m.cv <- cv.glm(d, m, K=2) # Sometimes succeeds
m.cv <- cv.glm(d, m, K=2)
# Error in model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels) : 
#   factor x has new levels B

更新：这是一个玩具示例。对于较大的数据集也会出现同样的问题，其中有多个级别C，但 training 分区中没有一个出现。

包caret中的函数createDataPartition函数对结果变量执行分层抽样并正确警告：

此外，对于'createDataPartition'，非常小的班级大小（＆lt; = 3），这些班级可能不会出现在训练和测试数据中。

有两种解决方案可供考虑：

首先，通过首先选择每个factor level的一个随机样本，从最稀有的类（按频率）开始，然后贪婪地满足下一个稀有类等来创建数据的子集。然后在数据集的其余部分上使用createDataPartition并合并结果以创建包含所有levels的新列车数据集。
使用createDataPartitions并进行拒绝抽样。

到目前为止，由于数据大小的原因，选项 2 对我有用，但我不禁认为必须有一个比推出一个更好的解决方案。

理想情况下，如果无法创建此类分区，我会想要一个正常工作的解决方案，并且提前失败。

有没有一个基本的理论上的原因，为什么包不提供这个？他们是否提供它而我因为盲点而无法发现它们？有没有更好的方法来进行这种分层抽样？

如果我要在stats.stackoverflow.com上提出这个问题，请发表评论。

更新：

这就是我的手推出解决方案（2）的样子：

get.cv.idx <- function(train.data, folds, factor.cols = NA) {

    if (is.na(factor.cols)) {
        all.cols        <- colnames(train.data)
        factor.cols     <- all.cols[laply(llply(train.data[1, ], class), function (x) 'factor' %in% x)]
    }

    n                   <- nrow(train.data)
    test.n              <- floor(1 / folds * n)

    cond.met            <- FALSE
    n.tries             <- 0

    while (!cond.met) {
        n.tries         <- n.tries + 1
        test.idx        <- sample(nrow(train.data), test.n)
        train.idx       <- setdiff(1:nrow(train.data), test.idx)

        cond.met        <- TRUE

        for(factor.col in factor.cols) {
            train.levels <- train.data[ train.idx, factor.col ]
            test.levels  <- train.data[ test.idx , factor.col ]
            if (length(unique(train.levels)) < length(unique(test.levels))) {
                cat('Factor level: ', factor.col, ' violated constraint, retrying.\n')
                cond.met <- FALSE
            }
        }
    }

    cat('Done in ', n.tries, ' trie(s).\n')

    list( train.idx = train.idx
        , test.idx  = test.idx
        )
}

Answer 1

每个人都同意确保有最佳解决方案。但就个人而言，我只需try cv.glm电话，直到它使用while。

m.cv<- try(cv.glm(d, m, K=2)) #First try
class(m.cv) #Sometimes error, sometimes list
while ( inherits(m.cv, "try-error") ) {
m.cv<- try(cv.glm(d, m, K=2))
}
class(m.cv) #always list

我在data.fame中尝试了100,000行，只需要几秒钟。

library(boot)
n <-100000
d <- data.frame(x=c(rep('A',n), rep('B', n), 'C', 'C'), y=1:(n*2+2))
m <- glm(y ~ x, data=d)

m.cv<- try(cv.glm(d, m, K=2))
class(m.cv) #Sometimes error, sometimes list
while ( inherits(m.cv, "try-error") ) {
m.cv<- try(cv.glm(d, m, K=2))
}
class(m.cv) #always list

Answer 2

当我打电话回溯时，我得到了这个：

> traceback()
9: stop(sprintf(ngettext(length(m), "factor %s has new level %s", 
       "factor %s has new levels %s"), nm, paste(nxl[m], collapse = ", ")), 
       domain = NA)
8: model.frame.default(Terms, newdata, na.action = na.action, xlev = object$xlevels)
7: model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels)
6: predict.lm(object, newdata, se.fit, scale = 1, type = ifelse(type == 
       "link", "response", type), terms = terms, na.action = na.action)
5: predict.glm(d.glm, data[j.out, , drop = FALSE], type = "response")
4: predict(d.glm, data[j.out, , drop = FALSE], type = "response")
3: mean((y - yhat)^2)
2: cost(glm.y[j.out], predict(d.glm, data[j.out, , drop = FALSE], 
       type = "response"))
1: cv.glm(d, m, K = 2)

查看cv.glm函数给出：

> cv.glm
function (data, glmfit, cost = function(y, yhat) mean((y - yhat)^2), 
    K = n) 
{
    call <- match.call()
    if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) 
        runif(1)
    seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
    n <- nrow(data)
    out <- NULL
    if ((K > n) || (K <= 1)) 
        stop("'K' outside allowable range")
    K.o <- K
    K <- round(K)
    kvals <- unique(round(n/(1L:floor(n/2))))
    temp <- abs(kvals - K)
    if (!any(temp == 0)) 
        K <- kvals[temp == min(temp)][1L]
    if (K != K.o) 
        warning(gettextf("'K' has been set to %f", K), domain = NA)
    f <- ceiling(n/K)
    s <- sample0(rep(1L:K, f), n)
    n.s <- table(s)
    glm.y <- glmfit$y
    cost.0 <- cost(glm.y, fitted(glmfit))
    ms <- max(s)
    CV <- 0
    Call <- glmfit$call
    for (i in seq_len(ms)) {
        j.out <- seq_len(n)[(s == i)]
        j.in <- seq_len(n)[(s != i)]
        Call$data <- data[j.in, , drop = FALSE]
        d.glm <- eval.parent(Call)
        p.alpha <- n.s[i]/n
        cost.i <- cost(glm.y[j.out], predict(d.glm, data[j.out, 
            , drop = FALSE], type = "response"))
        CV <- CV + p.alpha * cost.i
        cost.0 <- cost.0 - p.alpha * cost(glm.y, predict(d.glm, 
            data, type = "response"))
    }
    list(call = call, K = K, delta = as.numeric(c(CV, CV + cost.0)), 
        seed = seed)
}

似乎问题与极小的样本量和分类效果（值“A”，“B”和“C”）有关。你正在使用2个效果来装入glm：“B：A”和“C：A”。在每个CV迭代中，您从样本数据集引导并适合新模型d.glm。给定大小，保证自举数据得到一次或多次迭代，其中值“C”未被采样，因此错误来自于来自训练数据的自举模型的拟合概率，其中验证数据具有在训练数据中未观察到x的“C”水平。

Frank Harrell（通常在stats.stackexchange.com上）在回归建模策略中写道，当样本量很小和/或某些细胞计数在分类数据分析中很小时，人们应该支持分割样本验证。奇点（正如你在这里看到的）是我认为这是真的很多原因之一。

鉴于此处的样本量较小，您应该考虑一些拆分样本交叉验证替代方案，如置换测试或参数化引导程序。另一个重要的考虑因素是您认为基于模型的推理不正确的原因。正如图基所说的自举，他想把它称为霰弹枪。只要你愿意重新组装这些碎片，它就会让任何问题摆脱困境。

Answer 3

网络上似乎没有很多简单的解决方案，因此我得出的结论很容易归纳为所需的多种因素。它使用预装的软件包和Caret，但是如果您确实想要的话，可以只使用base R。

要在有多个因素时使用交叉验证，请遵循两步过程。将因子转换为数值，然后将它们相乘。将此新变量用作分层采样函数中的目标变量。创建折叠后，请确保将其删除或将其排除在训练范围之外。

如果y是您的DV，而x是一个因数，则：

#Simulated factors (which are conveniently distributed for the example)
dataset <-data.frame(x=as.factor(rep(c(1,10),1000)),y=as.factor(rep(c(1,2,3,4),250)[sample(1000)]))

#Convert the factors to numerics and multiply together in new variable
dataset$cv.variable <-as.numeric(levels(dataset$x))[dataset$x]*as.numeric(levels(dataset$y))[dataset$y]


prop.table(table(dataset$y)) #One way to view distribution of levels
ftable(dataset$x,dataset$y)  #A full table of all x and y combinations

folds <- caret::createFolds(dataset$cv.variable,k=10) 
testIndexes <- folds[[k]]
testData <- as.data.frame(dataset[testIndexes, ])
trainData <- as.data.frame(dataset[-testIndexes, ])

prop.table(table(testData$y)) 
ftable(testData$x,testData$y) #evaluate distribution

应该会产生接近平衡的结果。

注意：在现实生活中，如果您的样本缺乏必要的独特因素组合，那么您的问题将很难克服，甚至可能无法解决。您可以在创建折叠之前将某些级别从考虑中删除，也可以采用某种过度采样。

R：对具有因子的数据集进行交叉验证

3 个答案: