Рассчитайте расстояние Левенштейна / Хэмминга, сгруппировав переменную

Question

Я пытаюсь вычислить точность ответа участников (столбец MEM_Response) на основе правильного ответа (столбцы MEM_Correct).Переменная группировки будет идентификатором участника (в данном случае столбец SERIAL -> 15 случаев на участника).

dput(example)
structure(list(MEM_Correct = c("ZLHK", "RZKX", "DGWL", "BCJSP", 
"WRKTJ", "CHBXS", "HNDCWX", "SWVNDT", "WLDGPB", "DSHRKBV", "HCXLZWB", 
"HDNBVZC", "BCRHKVDM", "RVTBWKFS", "NWHVZFLD", "ZLHK", "RZKX", 
"DGWL", "BCJSP", "WRKTJ", "CHBXS", "HNDCWX", "SWVNDT", "WLDGPB", 
"DSHRKBV", "HCXLZWB", "HDNBVZC", "BCRHKVDM", "RVTBWKFS", "NWHVZFLD"
), MEM_Response = c("ZLHK", "RZKX", "DGWL", "BCJSP", "WRKLTJ", 
"CHBXS", "HNDCWX", "SWVDTN", "WLDGPB", "DSHRKBV", "HCXLZWB", 
"HDNBVZC", "BCRHKVDM", "RVTBWKFS", "NWHVZFLD", "ZLHK", "RZKX", 
"DGWL", "BCJSB", "WRKTJ", "CHBXA", "HDNDWX", "SWVNDT", "WLGPBD", 
"DSHKRBV", "WLGJHKK", "HDBNVZC", "BCHRKVBM", "RVGBKSNM", "NWHVZWHJ"
), SERIAL = c("4444", "4444", "4444", "4444", "4444", "4444", 
"4444", "4444", "4444", "4444", "4444", "4444", "4444", "4444", 
"4444", "5555", "5555", "5555", "5555", "5555", "5555", "5555", 
"5555", "5555", "5555", "5555", "5555", "5555", "5555", "5555"
)), row.names = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 11L, 
12L, 13L, 14L, 15L, 17L, 18L, 19L, 20L, 21L, 22L, 23L, 24L, 25L, 
26L, 27L, 28L, 29L, 30L, 31L), class = "data.frame")

Я пытался вычислить точность (т. Е. Расстояние между правильным и фактическим ответом), используя несколько методов, но я пока не получил удовлетворительного результата.

Использование stringdist для расстояния Хэмминга и Левенштейна:

Левенштейна:

example$MEM_Lev = stringdist(example$MEM_Correct, example$MEM_Response, method = c("lv"))

Хемминга:

example$MEM_Ham = stringdist(example$MEM_Correct, example$MEM_Response, method = c("hamming"))

Проблема: у меня есть Хеммингарасстояние для каждого случая, но как мне рассчитать точность для каждого участника, в конечном итоге получив диапазон от 0 до 1 (то есть от 0 до 100% точности)?Проблема с расстоянием Хэмминга также состоит в том, что случаи различной длины (см. Строку 5: WRKTJ против WRKLTJ ) дают inf.Так что мне, вероятно, было бы лучше использовать расстояние Левенштейна, верно?

Затем я попробовал функцию with() для расстояния Левенштейна:

with(example, levenshteinSim(example$MEM_Correct, example$MEM_Response))

На этот раз значения лежат между0 и 1, что на шаг вперед, я думаю.Возьмем снова строку 5: WRKTJ (5 букв) и WRKLTJ (6 букв) отличаются тем, что последний имеет дополнительный «L» прямо посередине.Таким образом, 1 единичное редактирование (в этом случае удаление) будет необходимо для соответствия с правильным ответом.Его значение Левенштейна 0,8333 соответствует 5/6 правильному (хотя правильное значение имеет только 5). Использую ли я правильную функцию расстояния?

И, наконец, мой последний вопрос:

Как мне сопоставить / рассчитать среднюю точность для каждого участника?У меня есть еще один df со всеми участниками, Я хочу объединить выходные данные примера средства для человека с кадром данных, где 1 строка = 1 участник.

Надеюсь, это имеет смысл - если нетЯ могу попытаться включить больше информации.Пожалуйста, не стесняйтесь предлагать другие методы, если вы считаете, что я не использую правильный подход.

Заранее спасибо!

Answer 1

То, как вы хотите определить «точность», является методологическим решением, которое должно приниматься вами, в литературе могут быть некоторые ссылки, но вот одно из предложений.

example$lv.dist <- stringdist(example[,1], example[,2], method="lv")
head(example)
#   MEM_Correct MEM_Response SERIAL lv.dist
# 1        ZLHK         ZLHK   4444       0
# 2        RZKX         RZKX   4444       0
# 3        DGWL         DGWL   4444       0
# 4       BCJSP        BCJSP   4444       0
# 5       WRKTJ       WRKLTJ   4444       1
# 6       CHBXS        CHBXS   4444       0

aggregate(lv.dist ~ SERIAL, example, mean)
#   SERIAL  lv.dist
# 1   4444 0.200000
# 2   5555 1.866667

aggregate(lv.dist ~ SERIAL, example, function(x) round(mean(100/(1+x)), 2))
#   SERIAL lv.dist
# 1   4444   92.22
# 2   5555   54.17

# Using stringsim()
example$lv.sim <- stringsim(example[,1], example[,2], method="lv")

(agg <- aggregate(lv.sim ~ SERIAL, example, function(x) round(mean(x)*100, 2)))
#   SERIAL lv.sim
# 1   4444  96.67
# 2   5555  73.25

# Merging two data.frames is easy as long as they have a have a 
# column in common (SERIAL in this case)    
participants <- data.frame(age=7:9, SERIAL=c(5555, 4444, 1234))

merge(participants, agg)
#   SERIAL age lv.sim
# 1   4444   9  96.67
# 2   5555   8  73.25

merge(participants, agg, all=TRUE)
#   SERIAL age lv.sim
# 1   1234   9     NA
# 2   4444   8  96.67
# 3   5555   7  73.25