如何基于参考tibble为双列tibble新增匹配编号列

有一个问题困扰我许久，我确定存在可行解决方案但目前尚未找到实现思路。

目前我的代码中已生成如下结构的tibble：

id_tibble <- tibble(
  color = c("blue", "orange", "orange", "orange", "yellow", "black"),
  animals = c("elephant", "tiger", "leon", "leopard", "hawk", "hawk")
  )

我需要为该tibble新增color_num和animals_num两列，列值需从如下参考tibble中选取兼容的编号：

compatible_numbers <- tibble(
  key = c(rep(1, 8), rep(2, 8), rep(3, 8), rep(4, 8), rep(5, 8), rep(6, 8), rep(7, 8)),
  main = c(seq(2, 9), seq(13, 20), seq(25,32), seq(3, 18, by =2), c(4, 6:12), seq(7, 14), seq(5, 26, by = 3))
  )

编号分配规则如下：available_numbers为1到32范围内所有存在于compatible_numbers的key和main列中的编号池，将池内最小编号1分配给"blue"，再将key=1对应的main列首个可用兼容编号2分配给"elephant"，重复值可复用编号；编号被分配后即从available_numbers中移除，接下来选取剩余可用的最小编号3分配给"orange"，其对应main列的可用兼容编号25、26、27依次分配给"tiger"、"leon"、"leopard"，以此类推。

available_numbers <- seq_len(max(compatible_numbers))[seq_len(max(compatible_numbers)) %in% c(compatible_numbers$key, compatible_numbers$main)]

预期输出的tibble如下：

outcome_tibble <- tibble(
  color = c("blue", "orange", "orange", "orange", "yellow", "black"),
  animals = c("elephant", "tiger", "leon", "leopard", "hawk", "hawk"),
  color_num = c(1,3,3,3,4,6),
  animals_num = c(2,25, 26, 27, 5,5)
)

已实现方案 #

我参考@RonakShah分享的for循环逻辑，新增了多个if判断条件，适配了color和animals列存在重复值的场景，代码如下。如果有tidyverse版本的实现方案欢迎分享！

id_tibble$color_num <- NA
id_tibble$animals_num <- NA


for(i in 1:nrow(id_tibble)){
  if (i == 1){
    # 分配第一个可用编号
    id_tibble$color_num[i] <- available_numbers[1]
    all_num <- compatible_numbers$main[compatible_numbers$key == available_numbers[1]]
    # 仅保留可用范围内的编号
    all_num <- intersect(all_num, available_numbers)
    # 移除已分配的颜色编号
    available_numbers <- available_numbers[-1]
    # 分配第一个可用的兼容编号
    id_tibble$animals_num[i] <- all_num[1]
    # 移除已分配的动物编号
    available_numbers <- available_numbers[-1]
  } else{
    if(id_tibble$color[i] != id_tibble$color[i-1] && id_tibble$animals[i] != id_tibble$animals[i-1]){
      # 分配第一个可用编号
      id_tibble$color_num[i] <- available_numbers[1]
      all_num <- compatible_numbers$main[compatible_numbers$key == available_numbers[1]]
      # 仅保留可用范围内的编号
      all_num <- intersect(all_num, available_numbers)
      # 移除已分配的颜色编号
      available_numbers <- available_numbers[-1]
      # 分配第一个可用的兼容编号
      id_tibble$animals_num[i] <- all_num[1]
      # 移除已分配的动物编号
      available_numbers <- available_numbers[-which(available_numbers == all_num[1])]
    } else if(id_tibble$color[i] == id_tibble$color[i-1] && id_tibble$animals[i] != id_tibble$animals[i-1]){
      # 复用前一个颜色编号
      id_tibble$color_num[i] <- id_tibble$color_num[i-1]
      all_num <- compatible_numbers$main[compatible_numbers$key == id_tibble$color_num[i-1]]
      # 仅保留可用范围内的编号
      all_num <- intersect(all_num, available_numbers)
      # 分配第一个可用的兼容编号
      id_tibble$animals_num[i] <- all_num[1]
      # 移除已分配的动物编号
      available_numbers <- available_numbers[-which(available_numbers == all_num[1])]
    } else if(id_tibble$color[i] != id_tibble$color[i-1] && id_tibble$animals[i] == id_tibble$animals[i-1]){
      # 复用前一个动物编号
      id_tibble$animals_num[i] <- id_tibble$animals_num[i-1]
      all_num <- compatible_numbers$main[compatible_numbers$key == id_tibble$animals_num[i-1]]
      # 仅保留可用范围内的编号
      all_num <- intersect(all_num, available_numbers)
      # 分配第一个可用的兼容编号
      id_tibble$color_num[i] <- all_num[1]
      # 移除已分配的颜色编号
      available_numbers <- available_numbers[-which(available_numbers == all_num[1])]
    }
  }
}

内容的提问来源于stack exchange，提问作者anto