R中的条带变量

Question

对于以下代码：

x <- data.frame(year = c(1730, 1860, 1941, 2011))

century_bands <- data.frame(min_year = c(1700, 1800, 1900, 2000),
                            max_year = c(1799, 1899, 1999, 2099),
                            century_name = c("18th", "19th", "20th", "21st"))

对于 x 中的每个值，我想使用 century_bands 中的信息计算出它所属的世纪的名称。我无法想象这很难实现，但我无法弄清楚。有人可以帮忙吗？有没有办法使用 dplyr 包（我用得很多）或者其他一些技术？

这只是现实生活中的一个非常简单的例子，在这种情况下，乐队并没有整齐地排列 100 年的步长 - 因此，任何基于将年份除以 100 等的快捷方式都不会奏效。

谢谢。

Answer 1

利用 fuzzyjoin 的一个选项可能是：

fuzzy_left_join(x, century_bands, 
                by = c("year" = "min_year",
                       "year" = "max_year"),
                match_fun = list(`>=`, `<=`)) 

  year min_year max_year century_name
1 1730     1700     1799         18th
2 1860     1800     1899         19th
3 1941     1900     1999         20th
4 2011     2000     2099         21st

Answer 2

由于 max_year 列似乎是多余的，您也可以轻松地做到：

century_bands[colSums(sapply(x$year, function(x) `>=`(x, century_bands$min_year))), 3]
# [1] "18th" "19th" "20th" "21st"

Answer 3

这里有一些方法。

1) sqldf 在 SQL 中，可以在复杂条件下进行连接。如果 year 大于或等于下限且小于或等于上限，则使用 between 的语法匹配。对于特定年份，如果没有匹配项，左连接将导致使用 NA（尽管问题示例中不会出现这种情况）。

library(sqldf)
sqldf("select year, century_name from x
  left join century_bands on year between min_year and max_year")
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

2) findInterval 此方法仅使用基数 R。对于其第一个参数的每个组件 findInterval returns 第二个参数中值的数量小于或等于它。假定第二个参数按升序排序。 findInterval 返回的数字可用于索引 century_name。 findInterval 往往效率很高。

transform(x, year_name = 
  with(century_bands, century_name[findInterval(year, min_year)]))
##   year year_name
## 1 1730      18th
## 2 1860      19th
## 3 1941      20th
## 4 2011      21st

尽管问题中不会出现这种情况，但如果 year 可能在所有频段之外，那么我们可以在不更改代码的情况下通过向与 century_bands 关联的 century_bands 添加额外的行来扩展它=26=] 的 NA 否则我们可以扩展 findInterval liek this:

FindInterval <- function(x, vec, upper) {
  ifelse(x < vec[1] | x > upper, NA, findInterval(x, vec))
}
transform(x, year_name = 
  with(century_bands, century_name[FindInterval(year, min_year, max(max_year))]))

如果仍然使用 dplyr，我们可以将 transform 替换为 mutate；否则，使用 transform 消除了这种依赖性。

3) sapply 另一种基础解决方案是

Match <- function(x) with(century_bands, century_name[x >= min_year & x <= max_year])
transform(x, century_name = sapply(year, Match))
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

如果所有年份都在范围内，这应该足够了。问题示例中就是这种情况，但如果不能保证这一点，则像这样扩展 Match：

Match <- function(x) {
  Name <- with(century_bands, century_name[x >= min_year & x <= max_year])
  if (length(Name)) Name else NA
}

4) cut 这个基本解决方案类似于 findInterval 但它 returns NA 如果 year 不在任何波段内.

transform(x, year_name = with(century_bands, century_name[
    cut(year, c(min_year, max(max_year)), label = FALSE, include.lowest = TRUE)
]))

5) car::recode 此函数允许按如下方式重新编码值。

library(car)

recodes <- 
  "1700:1799='18th'; 1800:1899='19th'; 1900:1999='20th'; 2000:2099='21st'; else=NA"
transform(x, year_name = recode(year, recodes))
##   year year_name
## 1 1730      18th
## 2 1860      19th
## 3 1941      20th
## 4 2011      21st

为了避免对 recodes 字符串进行硬编码，它可以像这样从 century_bands 派生出来

recodes <- with(century_bands, 
  paste(sprintf("%d:%d='%s'", min_year, max_year, century_name), collapse = ";")
)
recodes <- paste0(recodes, "; else=NA")

6) expand bands 我们可以将 bands 扩展到单独的年份，在这种情况下我们可以简单地进行匹配。 century_name.

中不匹配任何波段的年份会导致 NA

century_bands2 <- with(century_bands, 
  stack(setNames(Map(seq, min_year, max_year), century_name)))
transform(x, century_name = with(century_bands2, ind[match(year, values)]))
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

6a) 一个 tidyverse 的变体在很大程度上是这样的：

library(dplyr)
library(purrr)
library(tibble)
library(tidyr)

century_bands2 <- century_bands %>%
  { set_names(map2(.$min_year, .$max_year, seq), .$century_name) %>%
    as_tibble %>%
    pivot_longer(everything(), names_to = "century_name", values_to = "year")
  }

x %>% left_join(century_bands2, by = "year")
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

7) case_when。我们可以将波段定义硬编码为 case_when:

library(dplyr)

x %>% mutate(century_name = case_when(
    year %in% 1700:1799 ~ "18th",
    year %in% 1800:1899 ~ "19th",
    year %in% 1900:1999 ~ "20th",
    year %in% 2000:2099 ~ "21st",
    TRUE ~ NA_character_))
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

7a) 用 case_when 表示的另一种方式是：

x %>% mutate(century_name = case_when(
    year < 1700 ~ NA_character_,
    year < 1800 ~ "18th",
    year < 1900 ~ "19th",
    year < 2000 ~ "20th",
    year < 2100 ~ "21st",
    TRUE ~ NA_character_))
##   year century_name
## 1 1730         18th
## 2 1860         19th
## 3 1941         20th
## 4 2011         21st

R中的条带变量

Banding Variable in R

r

dplyr

fuzzyjoin