Подбор персонажей на разных уровнях и получение очков

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

Может быть, есть способ лучше векторизовать его, но если вы можете согласиться делать это построчно, вот предложение. (Если вы имеете дело с «большими» объемами данных, это может быть медленным для вас.) (Данные приведены ниже.) ( Изменить ed, чтобы иметь дело с добавленным сравнением.)

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')