Mam ramkę danych z zmienną łańcuchową reprezentującą diagnozy chorób. Chcę sklasyfikować diagnozy zgodnie z niektórymi zasadami:

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

Jeśli pole diagnozowanie zawiera "A01", "A02" lub "A03" (w tym tekst zawierający te wzory, np. "A0199"), wówczas przypadek należy umieścić w grupie 1 i tak dalej.

Moje dane wyglądają tak:

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

Metoda, którą użyłem, wygląda tak:

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

Wydaje się, że działa, ale mój zestaw danych jest duży i jest mnóstwo zasad i jest niezwykle powolny!

Czy są szybsze sposoby, jakie mogłem to zrobić?

3
Dan Lewer 3 czerwiec 2018, 13:57

3 odpowiedzi

Najlepsza odpowiedź

Jeśli liczba zasad nie jest zbyt duży (OP mówi, że jest tylko 40), moglibyśmy przejechać przez zasady i wykonać dokładne dopasowanie przy użyciu stringi::stri_detect_fixed (co jest znacznie szybsze niż przy użyciu REGEX)

Po pierwsze, będziemy się bardziej płaskować rules

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

Następnie zdefiniuj funkcję

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

Następnie uruchom go na regułę

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

benchmark : na rzędach .5mm i 10 grup po 10 biegnie przez około ~ 4 sekund na moim laptopie

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
1
David Arenburg 3 czerwiec 2018, 14:28

Jest to trochę lo-fi, jestem pewien, że istnieje znacznie więcej fantazyjnych dplyr i data.table sposoby robienia tego, ale przynajmniej jest dość przejrzyste. Aspekt prędkości będziesz musiał ocenić, ale wszystko jest weklisze, więc powinno być dość szybkie.

To, co zrobiłem, był pierwszy zbudowany wektory wektory. Czy zaczyna się od A, czyni zaczyna się od B, czy to zaczyna się od C, jest drugim znakiem 0, ile jest znaków, itp.
. Następnie używam tych wektorów, aby zbudować wektory grupy, łącząc wektory reguł przy użyciu operatorów logicznych.
Wreszcie wektor group został zbudowany z tych korzystających z tego, że e.g {x5}} i FALSE*3 == 0. 0 zostanie zatem zwrócony, jeśli diagnoza pasuje bez grupy. Jeśli diagnoza pasuje do więcej niż jednej grupy, dostanie nieco mylące.

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)
  }
  )
1
AkselA 3 czerwiec 2018, 12:17

Właśnie na kompletność znalazłem również lepsze rozwiązanie przy użyciu grep, które pętle nad zasadami raczej rzędami. Poniżej wymieniałem rozwiązania. Opcje stringi są najlepsze, ale podejście alternatywne {x2}} jest znacznie lepsze niż moje oryginalne rozwiązanie:

# 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)
0
Dan Lewer 4 czerwiec 2018, 07:36