提升曲线被交换

Question

对于提升曲线 I 的示例运行

library(caret)
set.seed(1)
simulated <- data.frame(obs = factor(rep(letters[1:2], each = 100)),
                        perfect = sort(runif(200), decreasing = TRUE),
                        random = runif(200))
lift2 <- lift(obs ~ random + perfect, data = simulated)
xyplot(lift2, plot = "lift", auto.key = list(columns = 2))

并得到

作为结果。我希望图像可以水平交换 - 类似于

我做错了什么？

顺便说一句：这是一张提升图，而不是累积收益图。

更新：

我期待的剧情，现在用我自己的代码制作了

mylift <- caret::lift(Class ~ cforest_prob + perfect_prob + guess_prob, data = data_test)
ggplot(mylift$data) +
  geom_line(aes(CumTestedPct, lift, color = liftModelVar))

是

我注意到，data.frame mylift$data 包含以下列：

names(mylift$data)
 [1] "liftModelVar" "cuts"         "events"       "n"            "Sn"           "Sp"           "EventPct"    
 [8] "CumEventPct"  "lift"         "CumTestedPct"

所以我打印了下面的情节

ggplot(mylift$data) +
  geom_line(aes(cuts, lift, color = liftModelVar))

所以我猜不同的图只是检查升力的不同方法？我不知道有不同的提升图 - 我认为这是整个行业的标准化。

Answer 1

问题作者编辑，为后期读者：我接受这个答案的大部分原因是对这个答案的评论中的有益讨论。请考虑阅读讨论！

让我们重现图表并找到基线。让

cutoffs <- seq(0, 1, length = 1000)

成为我们的界限。现在主要计算由

完成

aux <- sapply(cutoffs, function(ct) {
  perf <- simulated$obs[simulated$perfect > ct]
  rand <- simulated$obs[simulated$random > ct]
  c(mean(perf == "a"), mean(rand == "a"))
})

我们检查截止向量并执行以下操作。以 perfect 为例。我们说每当 perfect > ct 时，我们将预测 "a"。然后 simulated$obs[simulated$perfect > ct] 是真实值，而 mean(perf == "a") 是给定截止值的准确度。 random.

也是如此

至于基线，它只是一个常数，由"a"在样本中的份额定义：

baseline <- mean(simulated$obs == "a")

绘制升力图时，我们将精度除以基线方法的精度，得到与基线曲线相同的图形：

plot(x = cutoffs, y = aux[1, ] / baseline, type = 'l', ylim = c(0, 2), xlab = "Cutoff", ylab = "Lift")
lines(x = cutoffs, y = aux[2, ] / baseline, col = 'blue')
abline(a = baseline / baseline, b = 0, col = 'magenta')

更新:

这里有一个例子，至少在手动绘制时，可以操纵 "expected" 类型的提升曲线并给出非唯一结果。

您的示例图来自 here，其中也包含以下数据：

#   contacted response
# 1      10000     6000
# 2      20000    10000
# 3      30000    13000
# 4      40000    15800
# 5      50000    17000
# 6      60000    18000
# 7      70000    18800
# 8      80000    19400
# 9      90000    19800
# 10    100000    20000

现在假设我们知道的不是这个进化，而是 10 个单独的块：

#    contacted response
# 1      10000     6000
# 2      10000     4000
# 3      10000     3000
# 4      10000     2800
# 5      10000     1200
# 6      10000     1000
# 7      10000      800
# 8      10000      600
# 9      10000      400
# 10     10000      200

在这种情况下，这取决于我们在 x 轴上放置“% Contacted”时如何对观察进行排序：

set.seed(1)
baseline <- sum(df$response) / sum(df$contacted) * cumsum(df$contacted)
lift1 <- cumsum(df$response)
lift2 <- cumsum(sample(df$response))
x <- 1:10 * 10

plot(x = x, y = lift1 / baseline, col = 'red', type = 'l', ylim = c(0, 3), xlab = "% Customers contacted", ylab = "Lift")
lines(x = x, y = lift2 / baseline, col = 'blue')
abline(a = baseline / baseline, b = 0, col = 'magenta')

提升曲线被交换

Lift curve is swapped

r

r-caret

更新：