我正在拟合一个模型来分析数据和预测。如果newdata
中的predict.lm()
包含模型未知的单个因子级别,则predict.lm()
的所有都会失败并返回错误。
是否有一种很好的方法让predict.lm()
返回模型知道的那些因子水平的预测值和未知因子水平的NA,而不仅仅是错误?
示例代码:
foo <- data.frame(response=rnorm(3),predictor=as.factor(c("A","B","C")))
model <- lm(response~predictor,foo)
foo.new <- data.frame(predictor=as.factor(c("A","B","C","D")))
predict(model,newdata=foo.new)
我希望最后一个命令返回对应于因子级别“A”,“B”和“C”以及对应于未知级别“D”的NA
的三个“真实”预测。
答案 0 :(得分:29)
您必须在进行任何计算之前删除额外的级别,例如:
> id <- which(!(foo.new$predictor %in% levels(foo$predictor)))
> foo.new$predictor[id] <- NA
> predict(model,newdata=foo.new)
1 2 3 4
-0.1676941 -0.6454521 0.4524391 NA
这是一种更通用的方法,它会将原始数据中未出现的所有级别设置为NA。正如Hadley在评论中提到的那样,他们可以选择在predict()
函数中包含它,但它们没有
如果你查看计算本身,为什么你必须这样做变得很明显。在内部,预测计算如下:
model.matrix(~predictor,data=foo) %*% coef(model)
[,1]
1 -0.1676941
2 -0.6454521
3 0.4524391
在底部你有两个模型矩阵。您看到foo.new
的列有一个额外的列,因此您不能再使用矩阵计算。如果您要使用新数据集进行建模,您还可以获得一个不同的模型,即为额外级别添加额外虚拟变量的模型。
> model.matrix(~predictor,data=foo)
(Intercept) predictorB predictorC
1 1 0 0
2 1 1 0
3 1 0 1
attr(,"assign")
[1] 0 1 1
attr(,"contrasts")
attr(,"contrasts")$predictor
[1] "contr.treatment"
> model.matrix(~predictor,data=foo.new)
(Intercept) predictorB predictorC predictorD
1 1 0 0 0
2 1 1 0 0
3 1 0 1 0
4 1 0 0 1
attr(,"assign")
[1] 0 1 1 1
attr(,"contrasts")
attr(,"contrasts")$predictor
[1] "contr.treatment"
您不仅可以从模型矩阵中删除最后一列,因为即使您这样做,其他级别仍会受到影响。级别A
的代码将为(0,0)。对于B
,这是(1,0),对于C
这个(0,1)......对于D
,它再次是(0,0)!所以你的模型假设A
和D
是相同的水平,如果它会天真地删除最后一个虚拟变量。
在更理论的部分:可以在没有所有级别的情况下构建模型。现在,正如我之前尝试解释的那样,该模型仅对构建模型时使用的级别有效。如果您遇到新级别,则必须构建新模型以包含额外信息。如果您不这样做,您唯一能做的就是从数据集中删除额外的级别。但是,你基本上会丢失其中包含的所有信息,因此通常不被视为良好做法。
答案 1 :(得分:6)
通过MorgenBall整理和扩展功能。它现在也在sperrorest中实现。
NA
。 test_data
中是否存在因子变量,如果存在则返回原始data.frame lm
,glm
,也适用于glmmPQL
注意:此处显示的功能可能会随着时间的推移而改变(改善)。
#' @title remove_missing_levels
#' @description Accounts for missing factor levels present only in test data
#' but not in train data by setting values to NA
#'
#' @import magrittr
#' @importFrom gdata unmatrix
#' @importFrom stringr str_split
#'
#' @param fit fitted model on training data
#'
#' @param test_data data to make predictions for
#'
#' @return data.frame with matching factor levels to fitted model
#'
#' @keywords internal
#'
#' @export
remove_missing_levels <- function(fit, test_data) {
# https://stackoverflow.com/a/39495480/4185785
# drop empty factor levels in test data
test_data %>%
droplevels() %>%
as.data.frame() -> test_data
# 'fit' object structure of 'lm' and 'glmmPQL' is different so we need to
# account for it
if (any(class(fit) == "glmmPQL")) {
# Obtain factor predictors in the model and their levels
factors <- (gsub("[-^0-9]|as.factor|\\(|\\)", "",
names(unlist(fit$contrasts))))
# do nothing if no factors are present
if (length(factors) == 0) {
return(test_data)
}
map(fit$contrasts, function(x) names(unmatrix(x))) %>%
unlist() -> factor_levels
factor_levels %>% str_split(":", simplify = TRUE) %>%
extract(, 1) -> factor_levels
model_factors <- as.data.frame(cbind(factors, factor_levels))
} else {
# Obtain factor predictors in the model and their levels
factors <- (gsub("[-^0-9]|as.factor|\\(|\\)", "",
names(unlist(fit$xlevels))))
# do nothing if no factors are present
if (length(factors) == 0) {
return(test_data)
}
factor_levels <- unname(unlist(fit$xlevels))
model_factors <- as.data.frame(cbind(factors, factor_levels))
}
# Select column names in test data that are factor predictors in
# trained model
predictors <- names(test_data[names(test_data) %in% factors])
# For each factor predictor in your data, if the level is not in the model,
# set the value to NA
for (i in 1:length(predictors)) {
found <- test_data[, predictors[i]] %in% model_factors[
model_factors$factors == predictors[i], ]$factor_levels
if (any(!found)) {
# track which variable
var <- predictors[i]
# set to NA
test_data[!found, predictors[i]] <- NA
# drop empty factor levels in test data
test_data %>%
droplevels() -> test_data
# issue warning to console
message(sprintf(paste0("Setting missing levels in '%s', only present",
" in test data but missing in train data,",
" to 'NA'."),
var))
}
}
return(test_data)
}
我们可以将此函数应用于问题中的示例,如下所示:
predict(model,newdata=remove_missing_levels (fit=model, test_data=foo.new))
在尝试改进此功能的同时,我发现像lm
,glm
等SL学习方法需要相同的水平和训练方法。如果删除了级别,则ML学习方法(svm
,randomForest
)会失败。这些方法需要火车和火车的所有级别。测试。
一般的解决方案很难实现,因为每个拟合的模型都有不同的存储因子级别组件的方式(fit$xlevels
为lm
而fit$contrasts
为glmmPQL
。至少它在lm
相关模型中似乎是一致的。
答案 2 :(得分:5)
如果你想在创建lm模型之后但在调用预测之前处理数据中缺少的级别(假设我们事先并不确切知道哪些级别可能会丢失),这里是我建立的功能来设置所有级别不在NA的模型中 - 预测也会给NA,然后你可以使用另一种方法来预测这些值。
对象将是lm(...,data = trainData)的lm输出
数据将是您要为
创建预测的数据框missingLevelsToNA<-function(object,data){
#Obtain factor predictors in the model and their levels ------------------
factors<-(gsub("[-^0-9]|as.factor|\\(|\\)", "",names(unlist(object$xlevels))))
factorLevels<-unname(unlist(object$xlevels))
modelFactors<-as.data.frame(cbind(factors,factorLevels))
#Select column names in your data that are factor predictors in your model -----
predictors<-names(data[names(data) %in% factors])
#For each factor predictor in your data if the level is not in the model set the value to NA --------------
for (i in 1:length(predictors)){
found<-data[,predictors[i]] %in% modelFactors[modelFactors$factors==predictors[i],]$factorLevels
if (any(!found)) data[!found,predictors[i]]<-NA
}
data
}
答案 3 :(得分:2)
听起来你可能喜欢随机效果。看看glmer(lme4包)之类的东西。使用贝叶斯模型,当估计它们时几乎没有信息可用时,您将获得接近0的效果。但是,请注意,您必须自己进行预测,而不是使用predict()。
或者,您可以简单地为要包含在模型中的级别创建虚拟变量,例如:星期一的变量0/1,星期二的变量0,星期三的变量等等。如果它包含全0,则星期日将自动从模型中删除。但是在其他数据的星期日列中有一个1将不会使预测步骤失败。它只是假设星期日的影响是其他日子的平均值(可能是也可能不是)。
答案 4 :(得分:2)
线性/逻辑回归的一个假设是很少或没有多重共线性;因此,如果预测变量理想地彼此独立,则模型不需要查看所有可能的因子水平。新因子水平(D)是新的预测因子,并且可以设置为NA而不影响剩余因子A,B,C的预测能力。这就是模型仍然能够进行预测的原因。但是添加新级别D会抛弃预期的架构。这就是整个问题。设置NA修复了。
答案 5 :(得分:1)
如果您在调用lme4
时设置了标记allow.new.levels=TRUE
,predict
包将处理新级别。
示例:如果您的星期几因子位于变量dow
和分类结果b_fail
中,则可以运行
M0 <- lmer(b_fail ~ x + (1 | dow), data=df.your.data, family=binomial(link='logit'))
M0.preds <- predict(M0, df.new.data, allow.new.levels=TRUE)
这是随机效应逻辑回归的一个例子。当然,您可以执行常规回归...或大多数GLM模型。如果你想进入贝叶斯路径,请看看格尔曼&amp; amp;希尔的优秀书籍和Stan基础设施。
答案 6 :(得分:0)
用于拆分测试的快捷方法是将稀有值重新编码为“其他”。这是一个实现:
rare_to_other <- function(x, fault_factor = 1e6) {
# dirty dealing with rare levels:
# recode small cells as "other" before splitting to train/test,
# assuring that lopsided split occurs with prob < 1/fault_factor
# (N.b. not fully kosher, but useful for quick and dirty exploratory).
if (is.factor(x) | is.character(x)) {
min.cell.size = log(fault_factor, 2) + 1
xfreq <- sort(table(x), dec = T)
rare_levels <- names(which(xfreq < min.cell.size))
if (length(rare_levels) == length(unique(x))) {
warning("all levels are rare and recorded as other. make sure this is desirable")
}
if (length(rare_levels) > 0) {
message("recoding rare levels")
if (is.factor(x)) {
altx <- as.character(x)
altx[altx %in% rare_levels] <- "other"
x <- as.factor(altx)
return(x)
} else {
# is.character(x)
x[x %in% rare_levels] <- "other"
return(x)
}
} else {
message("no rare levels encountered")
return(x)
}
} else {
message("x is neither a factor nor a character, doing nothing")
return(x)
}
}
例如,使用data.table,调用将类似于:
dt[, (xcols) := mclapply(.SD, rare_to_other), .SDcol = xcols] # recode rare levels as other
其中xcols
是colnames(dt)
的任意子集。