跨行相乘和相加

Question

我有这个数据框：

color <- c("AKZ", "ZZA", "KAK")    
color_1 <- sample(color, 100, replace=TRUE, prob=c(0.4, 0.3, 0.3))
id = 1:100

sample_data = data.frame(id, color_1)


 id color_1
1  1     KAK
2  2     AKZ
3  3     KAK
4  4     KAK
5  5     AKZ
6  6     ZZA

假设有一个图例：

• K = 3
• A = 4
• Z = 6

我想向上面的数据框添加两列：

• sample_data$add_score ：例如 KAK = K + A + K = 3 + 4 + 3 = 10
• sample_data$multiply_score ：例如 KAK = K * A * K = 3 * 4 * 3 = 36

我想这样解决问题：

sample_data$first = substr(color_1,1,1)
sample_data$second = substr(color_1,2,2)
sample_data$third = substr(color_1,3,3)

sample_data$first_score = ifelse(sample_data$first == "K", 3, ifelse(sample_data$first == "A", 4, 6))
 
sample_data$second_score = ifelse(sample_data$second == "K", 3, ifelse(sample_data$second == "A", 4, 6))

sample_data$third_score = ifelse(sample_data$third == "K", 3, ifelse(sample_data$third == "A", 4, 6))

sample_data$add_score = sample_data$first_score + sample_data$second_score + sample_data$third_score

sample_data$multiply_score = sample_data$first_score * sample_data$second_score * sample_data$third_score

但我认为这种方式会如果“color_1”的长度较长，则需要很长时间。考虑到得分传奇，是否有更快的方法来做到这一点？

谢谢你！

Answer 1

这是一个方法。
主要技巧是将strsplit 分解为单个字符并将这些向量与图例相匹配。然后将匹配的数字相加或相乘。

set.seed(2022)
color <- c("AKZ", "ZZA", "KAK")    
color_1 <- sample(color, 100, replace=TRUE, prob=c(0.4, 0.3, 0.3))
id <- 1:100

sample_data = data.frame(id, color_1)

legend <- setNames(c(3, 4, 6), c("K", "A", "Z"))

add_mul <- function(x, l){
  add <- function(y, l){
    i <- match(y, names(l))
    sum(l[i])
  }
  mul <- function(y, l){
    i <- match(y, names(l))
    prod(l[i])
  }
  
  s <- strsplit(x, "")
  add_score <- sapply(s, add, l = l)
  mul_score <- sapply(s, mul, l = l)
  data.frame(add_score, mul_score)
}

sample_data <- cbind(sample_data, add_mul(sample_data$color_1, legend))
head(sample_data)
#>   id color_1 add_score mul_score
#> 1  1     ZZA        16       144
#> 2  2     KAK        10        36
#> 3  3     AKZ        13        72
#> 4  4     KAK        10        36
#> 5  5     AKZ        13        72
#> 6  6     KAK        10        36

^{由 reprex 软件包 (v2.0.1) 创建于 2022 年 3 月 10 日}

Answer 2

这是使用 tidyverse 的另一个选项。我使用 dplyr 中的 recode 根据 legend 将字母更改为数字。

library(tidyverse)

legend <- c(K = 3, A = 4, Z = 6)

sample_data %>%
  rowwise %>%
  mutate(code = list(recode(str_split(color_1, "", simplify = T), !!!legend)),
         add_score = sum(code),
         multiply_score = prod(code)) %>%
  select(-code)

输出

      id color_1 add_score multiply_score
   <int> <chr>       <dbl>          <dbl>
 1     1 AKZ            13             72
 2     2 AKZ            13             72
 3     3 KAK            10             36
 4     4 KAK            10             36
 5     5 AKZ            13             72
 6     6 AKZ            13             72
 7     7 KAK            10             36
 8     8 AKZ            13             72
 9     9 AKZ            13             72
10    10 AKZ            13             72
# … with 90 more rows

数据

set.seed(103)
color <- c("AKZ", "ZZA", "KAK")    
color_1 <- sample(color, 100, replace=TRUE, prob=c(0.4, 0.3, 0.3))
id = 1:100

sample_data = data.frame(id, color_1)

基准

看起来 Rui Barradas 的解决方案是迄今为止最快的答案。

Answer 3

我们可以使用stri_replace_all_regex与算术运算符一起将您的color_1替换为整数。

在这里，我将您的值存储到向量 color_1_convert 中。我们可以将其用作 stri_replace_all_regex 中的输入，以便更好地管理值。

library(dplyr)
library(stringi)

color_1_convert <- c("K" = "3", "A" = "4", "Z" = "6")

sample_data %>%
  group_by(id) %>%
  mutate(add_score = eval(parse(text = gsub("\\+$", "", stri_replace_all_regex(color_1, names(color_1_convert), paste0(color_1_convert, "+"), vectorize_all = F)))),
         multiply_score = eval(parse(text = gsub("\\*$", "", stri_replace_all_regex(color_1, names(color_1_convert), paste0(color_1_convert, "*"), vectorize_all = F)))))

# A tibble: 100 × 4
# Groups:   id [100]
      id color_1 add_score multiply_score
   <int> <chr>       <dbl>          <dbl>
 1     1 KAK            10             36
 2     2 ZZA            16            144
 3     3 AKZ            13             72
 4     4 ZZA            16            144
 5     5 AKZ            13             72
 6     6 AKZ            13             72
 7     7 AKZ            13             72
 8     8 KAK            10             36
 9     9 ZZA            16            144
10    10 AKZ            13             72
# … with 90 more rows

Answer 4

这是一种基于 tidyr::separate_rows() 和分组 dplyr::summarize() 的方法：

library(tidyverse)
set.seed(1)

legend <- c(K = 3, A = 4, Z = 6)

sample_data %>%
  mutate(decoded = color_1) %>%
  separate_rows(decoded, sep = "(?!^)") %>%
  mutate(decoded = legend[decoded]) %>%
  group_by(id, color_1) %>%
  summarize(
    add_score = sum(decoded),
    multiply_score = prod(decoded), 
    .groups = "drop"
  )

输出：

# A tibble: 100 x 4
      id color_1 add_score multiply_score
   <int> <chr>       <dbl>          <dbl>
 1     1 AKZ            13             72
 2     2 AKZ            13             72
 3     3 KAK            10             36
 4     4 ZZA            16            144
 5     5 AKZ            13             72
 6     6 ZZA            16            144
 7     7 ZZA            16            144
 8     8 KAK            10             36
 9     9 KAK            10             36
10    10 AKZ            13             72
# ... with 90 more rows

Answer 5

还有另一种选择，使用一些针对速度进行优化的库，stringi 用于字符串操作，Rfast 用于矩阵运算。请注意，当数据中存在任何 NA 值时，matrixStats 使用起来比 Rfast 更安全。

set.seed(2022)
color <- c("AKZ", "ZZA", "KAK")    
color_1 <- sample(color, 100, replace=TRUE, prob=c(0.4, 0.3, 0.3))
id = 1:100
sample_data = data.frame(id, color_1)

m <- strsplit(sample_data[["color_1"]], "") |>
  unlist(use.names = F) |>
  stringi::stri_replace_all_regex(
    c("K", "A", "Z"),
    c("3", "4", "6"), vectorize_all = F) |>
  as.integer() |>
  matrix(ncol = 3, byrow = T)
sample_data$add_score <- Rfast::rowsums(m)
sample_data$mul_score <- Rfast::rowprods(m)

head(sample_data)
  id color_1 add_score mul_score
1  1     ZZA        16       144
2  2     KAK        10        36
3  3     AKZ        13        72
4  4     KAK        10        36
5  5     AKZ        13        72
6  6     KAK        10        36