匹配不同级别的角色并生成分数

Question

我有两个测试组的结果（每组测试相同的样本），我想评估两组结果之间的异同。我想在两组结果之间对不同级别的匹配进行评分，从 1 到 4。对于每个样本，都有由“+”分隔的成对结果。如果两个结果相同，我希望得分为 1，如果它们匹配但对于一个或另一个基因不明确（用“/”表示），则得分为 2，得分 3 = 如果第 1 组的结果不明确，但组2 是明确的，但他们共享一个基因，得分 4 = 如果第 2 组的结果不明确，但第 1 组是明确的，但他们共享一个基因，得分 0 = 不匹配，即两个组的结果不共享任何基因顺序。

Group1                            Group2                             Match
Y*01:01+Y*01:01                   Y*01:01+Y*01:01                    1
Y*01:03+Y*01:01                   Y*01:01+Y*01:03                    1
Y*01:01:02+Y*01:01:01             Y*01:01:02+Y*01:01:01              1
Y*01:01/Y*01:02+Y*01:01           Y*01:01/Y*01:02+Y*01:01            2
Y*01:01/Y*01:02+Y*01:01/Y*01:02   Y*01:01/Y*01:02+Y*01:01/Y*01:02    2
Y*01:01/Y*01:02+Y*01:01           Y*01:02+Y*01:01                    3
Y*01:03+Y*01:01                   Y*01:03/Y*01:06+Y*01:01            4
Y*01:01+Y*01:02                   Y*01:03+Y*01:04                    0
Y*01:01/Y*01:02+Y*01:01/Y*01:02   Y*01:03/Y*01:04+Y*01:06/Y*01:06    0

我尝试了以下公式，但它给出了匹配的总体“真”分数，不匹配的“假”。我不知道如何调整它以生成不同级别的匹配

 df = as.data.frame(mapply(function(x,y) all(x==y),   
 lapply(strsplit(df$`group1`, "[+]"), sort), 
 lapply(strsplit(df$`group2`, "[+]"), sort)))

Answer 1

可能有一种方法可以更好地对其进行矢量化，但如果您可以接受逐行执行，那么这里有一个建议。 （如果您要处理“大量”数据，这对您来说可能会很慢。）（数据如下。）（编辑编辑以处理添加的比较。）

gene_compare <- function(a,b) {
  sa <- sort(strsplit(a, "[+]")[[1]])
  sb <- sort(strsplit(b, "[+]")[[1]])
  if (all(sa == sb)) {
    if (any(grepl("/", c(a,b)))) return(2L) else return(1L)
  } else if (all(mapply(function(m,n) any(m == n), strsplit(sa, "/"), sb))) return(3L)
  else if (all(mapply(function(m,n) any(m == n), sa, strsplit(sb, "/")))) return(4L)
  else if (any(sa == sb)) return(5L)
  else return(0L)
}

mapply(gene_compare, dat$Group1, dat$Group2, USE.NAMES=FALSE)
#  [1] 1 1 1 2 2 3 4 0 0 5

如果你使用/更喜欢tidyverse 动词：

dat %>%
  mutate(Match2 = purrr::map2(Group1, Group2, gene_compare))
#                             Group1                          Group2 Match Match2
# 1                  Y*01:01+Y*01:01                 Y*01:01+Y*01:01     1      1
# 2                  Y*01:03+Y*01:01                 Y*01:01+Y*01:03     1      1
# 3            Y*01:01:02+Y*01:01:01           Y*01:01:02+Y*01:01:01     1      1
# 4          Y*01:01/Y*01:02+Y*01:01         Y*01:01/Y*01:02+Y*01:01     2      2
# 5  Y*01:01/Y*01:02+Y*01:01/Y*01:02 Y*01:01/Y*01:02+Y*01:01/Y*01:02     2      2
# 6          Y*01:01/Y*01:02+Y*01:01                 Y*01:02+Y*01:01     3      3
# 7                  Y*01:03+Y*01:01         Y*01:03/Y*01:06+Y*01:01     4      4
# 8                  Y*01:01+Y*01:02                 Y*01:03+Y*01:04     0      0
# 9  Y*01:01/Y*01:02+Y*01:01/Y*01:02 Y*01:03/Y*01:04+Y*01:06/Y*01:06     0      0
# 10           Y*02:01:01+Y*02:01:01           Y*02:01:01+Y*02:01:50     5      5
# >

性能冲击有两种形式：逐行操作；并嵌套（重复）mapply 调用。

---

数据：

dat <- read.table(header=TRUE, stringsAsFactors=FALSE, text='
Group1                            Group2                             Match
Y*01:01+Y*01:01                   Y*01:01+Y*01:01                    1
Y*01:03+Y*01:01                   Y*01:01+Y*01:03                    1
Y*01:01:02+Y*01:01:01             Y*01:01:02+Y*01:01:01              1
Y*01:01/Y*01:02+Y*01:01           Y*01:01/Y*01:02+Y*01:01            2
Y*01:01/Y*01:02+Y*01:01/Y*01:02   Y*01:01/Y*01:02+Y*01:01/Y*01:02    2
Y*01:01/Y*01:02+Y*01:01           Y*01:02+Y*01:01                    3
Y*01:03+Y*01:01                   Y*01:03/Y*01:06+Y*01:01            4
Y*01:01+Y*01:02                   Y*01:03+Y*01:04                    0
Y*01:01/Y*01:02+Y*01:01/Y*01:02   Y*01:03/Y*01:04+Y*01:06/Y*01:06    0
Y*02:01:01+Y*02:01:01             Y*02:01:01+Y*02:01:50              5')