r - 使用ggplot的RDD图，过渡区域将线延伸到截止点

Question

考虑以下关于劳动力参与和年龄的数据框。在 65 岁时，我们有养老金资格年龄，我们对劳动力供应在养老金资格之前和之后的反应感兴趣。因此，我们还绘制了一个未考虑养老金资格年龄周围点的图表，因为它可能会引起一些噪音。

df<-data.frame( c(63, 63.5, 64, 64.5, 65, 65.5, 66, 66.5, 67), c(0.8, 0.7, 0.65, 0.5 , 0.5, 0.5, 0.15, 0.1 ,0))

colnames(df)<-c("age", "labor_force_participation")

df$pensionbreak<-cut(df$age,
                     breaks = c(-Inf, 64.4,65.5,Inf),
                     labels = c("prior pension", "transition area", "after pension"))

#Plot the graph without taking into account the transition area
p  + 
  geom_smooth(
    data = subset(df, pensionbreak != "transition area"),
    method = "lm", se = TRUE
  ) +
  xlab("age") + 
  ylab("fraction of males working") + 
  labs(color = "Retirement") + 
  theme_bw()

绘制此图时，我没有考虑过渡区域，但现在我想将绘图线延伸到截止点（即 65 岁）。更准确地说，我希望我的线条如下图所示。有谁知道我如何在 R 中做到这一点。我感谢任何帮助。

标签： rggplot2

Answer 1

您可以按以下方式进行操作 - 不是很优雅，但可以：)

require(tidyverse)
require(modelr)

# This is your subsetting
df_train <- df %>% filter(pensionbreak != "transition area")
df_predict <- tibble(age = 65, labor_force_participation = 0.5)

my_predictor <- function(x, pred, formula) {
  mod <- lm(formula, data = x)
  # This returns two types
  # type 1 is the predicted data
  # type 2 is the original data 
  bind_rows(pred, x) %>% 
    add_predictions(mod, var = "labor_force_participation") %>% 
    bind_rows(x, .id = "type")
}

# This applies the above function on your data - seperated by 
# the pensionbreak groups of data
dat <- df_train %>% 
  nest(data = c(age, labor_force_participation)) %>% 
  mutate(data_pred = map(data, my_predictor, df_predict, labor_force_participation ~ age)) %>% 
  unnest(data_pred) 

ggplot() +
  # Using type == 1 (predictions) for the line
  geom_line(data = dat %>% filter(type == 1),
            aes(x = age, y = labor_force_participation, col = pensionbreak),
            linetype = "dashed") +
  # Using type == 2 (original data) for the confidence area
  geom_smooth(data = dat %>% filter(type == 2),
              aes(x = age, y = labor_force_participation, col = pensionbreak),
              method = "lm") +
  xlab("age") + 
  ylab("fraction of males working") + 
  labs(color = "Retirement") + 
  theme_bw()