R: классификация текстовой переменной

Question

У меня есть фрейм данных со строковой переменной, представляющей диагнозы заболеваний.Я хочу классифицировать диагнозы в соответствии с некоторыми правилами:

rules <- list(
  group1 = c('A012', 'A02', 'C30'),
  group2 = c('B01', 'B02')
)

Если поле диагностики содержит «A01», «A02» или «A03» (включая текст, содержащий эти шаблоны, например, «A0199»),затем дело следует поместить в группу 1 и т. д.

Мои данные выглядят так:

dat <- data.frame(
  ID = seq_len(10),
  diagnosis = c('A012', 'A01', 'B23', 'C43', 'B023', 'A99', 'A023', 'B012', 'B04', 'A07')
)

Метод, который я использовал, выглядит следующим образом:

# modify the rules so they work with grep    
rules <- lapply(rules, paste, collapse = '|')

# create a function that classifies an individual diagnosis
group <- function(y) {
      a <- sapply(rules, grepl, x = y)
      a <- names(a)[a]
      return(if (length(a) == 0) NA else a)
    }

# apply the function across the data frame
dat$group <- sapply(dat$diagnosis, group)

Кажется, это работает, но мой набор данных большой, и есть много правил, и он очень медленный!

Есть ли более быстрые способы, которыми я мог бы сделать это?

Answer 1

Если количество правил не слишком велико (OP говорит, что их всего 40), мы можем просто просмотреть правила и выполнить точное совпадение, используя stringi::stri_detect_fixed (что намного быстрее, чем с помощью регулярных выражений)

Сначала мы будем польстить rules

rules_dt <- list(rules = unlist(rules, use.names = FALSE), 
                 grp = rep(seq_len(length(rules)), lengths(rules))) 

Затем определим функцию

library(stringi)
f <- function(x) dat[stri_detect_fixed(dat$diagnosis, rules_dt$rules[x]), "group"] <<- rules_dt$grp[x]

Затем запустим ее по правилу

invisible(lapply(seq_len(length(rules_dt[[1]])), f))
dat
#    ID diagnosis group
# 1   1      A012     1
# 2   2       A02     1
# 3   3       B23    NA
# 4   4       C43    NA
# 5   5      B023     2
# 6   6       A99    NA
# 7   7      A023     1
# 8   8      B012     2
# 9   9       B04    NA
# 10 10       A07    NA

---

Тест : на. 5-миллиметровых строках и 10 группах по 10 на моем ноутбуке он работает около ~ 4 секунд

library(stringi)
n <- 10
N <- 5e5

set.seed(123)
rules <- setNames(replicate(n, 
                  stri_rand_strings(n = n, length = 4), simplify = FALSE), 
                  paste0("group", 1:n))

dat <- data.frame(
  ID = 1:N,
  diagnosis = stri_rand_strings(N, 4),
  stringsAsFactors = FALSE
)

system.time({
  rules_dt <- list(rules = unlist(rules, use.names = FALSE), 
                   grp = rep(seq_len(length(rules)), lengths(rules))) 
  invisible(lapply(seq_len(length(rules_dt[[1]])), f))
})

# user  system elapsed 
# 3.27    0.43    3.70

Answer 2

Просто для полноты я нашел лучшее решение, используя grep, который перебирает правила, а не строки.Я рассчитал решения ниже.Варианты stringi являются лучшими, но альтернативный подход grep намного лучше моего первоначального решения:

# rules and dataset

rules <- list(
  group1 = c('A012', 'A02', 'C30'),
  group2 = c('B01', 'B02'),
  group3 = c('C01', 'D03')
)

D <- 100000
diagnoses <- c('A012', 'A02', 'C30', 'B01', 'B02', 'C01', 'D03', 'X99', 'X100', 'XA99', 'A99', 'D99')

dat <- data.frame(
  ID = seq_len(D),
  diagnosis = sample(diagnoses, D, replace = T),
  stringsAsFactors = F
)

# initial approach

rules2 <- lapply(rules, paste, collapse = '|')

group <- function(y) {
  a <- sapply(rules2, grepl, x = y)
  a <- names(a)[a]
  return(if (length(a) == 0) NA else a)
}

ptm <- proc.time()
dat$group <- sapply(dat$diagnosis, group)
proc.time() - ptm

table(dat$group)

# alternative looping approach (across rules rather than cases)

dat$group <- NULL

ptm <- proc.time()

D <- sapply(rules2, grepl, dat$diagnosis)
dat$group <- ifelse(rowSums(D) == 0, NA, max.col(D))

proc.time() - ptm

table(dat2$group)

# stringi approach

dat$group <- NULL

library(stringi)
rules_dt <- list(rules = unlist(rules, use.names = FALSE), 
                 grp = rep(seq_len(length(rules)), lengths(rules)))

ptm <- proc.time()
lapply(1:length(rules_dt[[1]]), function(x) dat[stri_detect_fixed(dat$diagnosis, rules_dt$rules[x]), "group"] <<- rules_dt$grp[x])
proc.time() - ptm

table(dat$group)

Answer 3

Это немного lo-fi, я уверен, что есть гораздо более причудливые dplyr и data.table способы сделать это, но по крайней мере это довольно прозрачно.Аспект скорости вы должны будете оценить, но все это векторизовано, поэтому должно быть достаточно быстрым.

Сначала я создал несколько векторов правил.Начинается ли он с A, начинается ли с B, начинается ли с C, является ли второй символ 0, сколько символов существует и т. Д.
Затем я используюэти векторы для построения групповых векторов путем объединения векторов правил с использованием логических операторов.
Наконец, вектор group был построен на основе этих фактов, использующих, например, TRUE*2 == 2 и FALSE*3 == 0.0 поэтому будет возвращено, если диагноз не соответствует ни одной группе.Если диагноз подходит для более чем одной группы, он будет немного запутанным.

dat <- data.frame(
  ID = seq_len(10),
  diagnosis = c('A012', 'A02', 'B23', 'C43', 'B023', 
                'A99', 'A023', 'B012', 'B04', 'A07'),
  stringsAsFactors=FALSE  

)

dat <- within(dat, {
    A=grepl("^A", diagnosis)
    B=grepl("^B", diagnosis)
    C=grepl("^C", diagnosis)
    z=grepl("^.0+", diagnosis)
    n=nchar(diagnosis)

    gr1=(A & n > 3)
    gr2=(B & z)
    gr3=(C & !z)

    group=(gr1 + gr2*2 + gr3*3)
  }
  )