Migliora la velocità di elaborazione del testo usando R e data.table

Question

Come utente relativamente inesperto del pacchetto data.table in R, ho cercato di elaborare una colonna di testo in un gran numero di colonne di indicatori, con un 1 in ciascuna colonna che indica che una particolare sottostringa è stata trovata all'interno della colonna di stringhe. Per esempio, io voglio elaborare questo:

ID  String 
1  a$b 
2  b$c 
3  c 

in questo:

ID  String  a  b  c 
1  a$b  1  1  0 
2  b$c  0  1  1 
3  c  0  0  1 

ho capito come fare il trattamento, ma ci vuole più tempo per l'esecuzione di quanto vorrei, e ho il sospetto che il mio codice è inefficiente. Di seguito è riportata una versione riproducibile del mio codice con dati fittizi. Si noti che nei dati reali sono presenti oltre 2000 sottostringhe da ricercare, ciascuna sottostringa ha una lunghezza di circa 30 caratteri e può contenere fino a qualche milione di righe. Se necessario, posso parallelizzare e lanciare molte risorse al problema, ma voglio ottimizzare il codice il più possibile. Ho provato a eseguire Rprof, che non suggeriva miglioramenti evidenti (per me).

set.seed(10) 
elements_list <- c(outer(letters, letters, FUN = paste, sep = "")) 
random_string <- function(min_length, max_length, separator) { 
    selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator) 
    return(selection) 
} 
dt <- data.table(id = c(1:1000), messy_string = "") 
dt[ , messy_string := random_string(2, 5, "$"), by = id] 
create_indicators <- function(search_list, searched_string) { 
    y <- rep(0, length(search_list)) 
    for(j in 1:length(search_list)) { 
     x <- regexpr(search_list[j], searched_string) 
     x <- x[1] 
     y[j] <- ifelse(x > 0, 1, 0) 
    } 
    return(y) 
} 
timer <- proc.time() 
indicators <- matrix(0, nrow = nrow(dt), ncol = length(elements_list)) 
for(n in 1:nrow(dt)) { 
    indicators[n, ] <- dt[n, create_indicators(elements_list, messy_string)] 
} 
indicators <- data.table(indicators) 
setnames(indicators, elements_list) 
dt <- cbind(dt, indicators) 
proc.time() - timer 

user system elapsed 
13.17 0.08 13.29 

EDIT

Grazie per le grandi risposte - tutte molto superiori al mio metodo. I risultati di alcuni test di velocità di seguito, con lievi modifiche a ciascuna funzione per utilizzare 0L e 1L nel mio codice, per memorizzare i risultati in tabelle separate per metodo e per standardizzare l'ordine. Questi sono i tempi trascorsi dai test a velocità singola (piuttosto che le mediane da molti test), ma le corse più lunghe richiedono tempo.

Number of rows in dt  2K  10K  50K  250K  1M 
OP      28.6 149.2 717.0 
eddi      5.1  24.6  144.8 1950.3 
RS      1.8  6.7  29.7 171.9  702.5 
Original GT    1.4  7.4  57.5 809.4 
Modified GT    0.7  3.9  18.1 115.2  473.9 
GT4      0.1  0.4  2.26 16.9  86.9 

Abbastanza chiaramente, la versione modificata dell'approccio di GeekTrader è la migliore. Sono ancora un po 'vago su cosa stia facendo ogni passo, ma posso esaminarlo a mio piacimento. Anche se un po 'fuori dai limiti della domanda originale, se qualcuno vuole spiegare quali metodi di GeekTrader e Ricardo Saporta stanno facendo in modo più efficiente, sarebbe apprezzato sia da me che probabilmente da chiunque visiti questa pagina in futuro. Sono particolarmente interessato a capire perché alcuni metodi scalano meglio di altri.

* EDIT # 2 ***

ho provato a modificare la risposta di GeekTrader con questo commento, ma che sembra non funzionare. Ho apportato due lievi modifiche alla funzione GT3, a) ordinare le colonne, che aggiungono una piccola quantità di tempo, e b) sostituire 0 e 1 con 0L e 1L, il che accelera un po 'le cose. Chiama la funzione risultante GT4. Tabella sopra modificata per aggiungere tempi per GT4 a diverse dimensioni di tabella. Chiaramente il vincitore di un miglio, e ha il vantaggio aggiunto di essere intuitivo.

Answer 1

UPDATE: VERSIONE 3

Trovato ancora più veloce. Questa funzione è anche altamente efficiente in termini di memoria. La funzione precedente del motivo principale era lenta a causa della copia/assegnazione avvenuta all'interno del ciclo lapply e del valore rbinding del risultato.

Nella seguente versione, preassegniamo la matrice con le dimensioni appropriate e quindi cambiamo i valori alle coordinate appropriate, il che rende molto veloce rispetto alle altre versioni di ciclo.

funcGT3 <- function() { 
    #Get list of column names in result 
    resCol <- unique(dt[, unlist(strsplit(messy_string, split="\\$"))]) 

    #Get dimension of result 
    nresCol <- length(resCol) 
    nresRow <- nrow(dt) 

    #Create empty matrix with dimensions same as desired result 
    mat <- matrix(rep(0, nresRow * nresCol), nrow = nresRow, dimnames = list(as.character(1:nresRow), resCol)) 

    #split each messy_string by $ 
    ll <- strsplit(dt[,messy_string], split="\\$") 

    #Get coordinates of mat which we need to set to 1 
    coords <- do.call(rbind, lapply(1:length(ll), function(i) cbind(rep(i, length(ll[[i]])), ll[[i]]))) 

    #Set mat to 1 at appropriate coordinates 
    mat[coords] <- 1  

    #Bind the mat to original data.table 
    return(cbind(dt, mat)) 

} 


result <- funcGT3() #result for 1000 rows in dt 
result 
     ID messy_string zn tc sv db yx st ze qs wq oe cv ut is kh kk im le qg rq po wd kc un ft ye if zl zt wy et rg iu 
    1: 1 zn$tc$sv$db$yx 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
    2: 2 st$ze$qs$wq 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
    3: 3 oe$cv$ut$is 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
    4: 4 kh$kk$im$le$qg 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
    5: 5 rq$po$wd$kc 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 
    ---                              
996: 996 rp$cr$tb$sa 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
997: 997 cz$wy$rj$he 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 
998: 998  cl$rr$bm 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
999: 999 sx$hq$zy$zd 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 
1000: 1000 bw$cw$pw$rq 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 

Benchmark againt versione 2 suggerito da Ricardo (questo è per 250K righe in dati):

Unit: seconds 
expr  min  lq median  uq  max neval 
    GT2 104.68672 104.68672 104.68672 104.68672 104.68672  1 
    GT3 15.15321 15.15321 15.15321 15.15321 15.15321  1 

---

VERSIONE 1 seguito è la versione 1 di risposta suggerita

set.seed(10) 
elements_list <- c(outer(letters, letters, FUN = paste, sep = "")) 
random_string <- function(min_length, max_length, separator) { 
    selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator) 
    return(selection) 
} 
dt <- data.table(ID = c(1:1000), messy_string = "") 
dt[ , messy_string := random_string(2, 5, "$"), by = ID] 


myFunc <- function() { 
    ll <- strsplit(dt[,messy_string], split="\\$") 


    COLS <- do.call(rbind, 
        lapply(1:length(ll), 
         function(i) { 
          data.frame(
          ID= rep(i, length(ll[[i]])), 
          COL = ll[[i]], 
          VAL= rep(1, length(ll[[i]])) 
          ) 
          } 
         ) 
       ) 

    res <- as.data.table(tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length)) 
    dt <- cbind(dt, res) 
    for (j in names(dt)) 
    set(dt,which(is.na(dt[[j]])),j,0) 
    return(dt) 
} 


create_indicators <- function(search_list, searched_string) { 
    y <- rep(0, length(search_list)) 
    for(j in 1:length(search_list)) { 
    x <- regexpr(search_list[j], searched_string) 
    x <- x[1] 
    y[j] <- ifelse(x > 0, 1, 0) 
    } 
    return(y) 
} 
OPFunc <- function() { 
indicators <- matrix(0, nrow = nrow(dt), ncol = length(elements_list)) 
for(n in 1:nrow(dt)) { 
    indicators[n, ] <- dt[n, create_indicators(elements_list, messy_string)] 
} 
indicators <- data.table(indicators) 
setnames(indicators, elements_list) 
dt <- cbind(dt, indicators) 
return(dt) 
} 



library(plyr) 
plyrFunc <- function() { 
    indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i) 
    dt[i, 
     data.frame(t(as.matrix(table(strsplit(messy_string, 
              split = "\\$"))))) 
     ])) 
    dt = cbind(dt, indicators) 
    #dt[is.na(dt)] = 0 #THIS DOESN'T WORK. USING FOLLOWING INSTEAD 

    for (j in names(dt)) 
    set(dt,which(is.na(dt[[j]])),j,0) 

    return(dt) 
} 

BE NCHMARK

system.time(res <- myFunc()) 
## user system elapsed 
## 1.01 0.00 1.01 

system.time(res2 <- OPFunc()) 
## user system elapsed 
## 21.58 0.00 21.61 

system.time(res3 <- plyrFunc()) 
## user system elapsed 
## 1.81 0.00 1.81 

---

VERSIONE 2: Consigliato da Ricardo

sto postando questo qui invece che nella mia risposta come il quadro è davvero @ di GeekTrader -Rick_

myFunc.modified <- function() { 
    ll <- strsplit(dt[,messy_string], split="\\$") 

    ## MODIFICATIONS: 
    # using `rbindlist` instead of `do.call(rbind..)` 
    COLS <- rbindlist(lapply(1:length(ll), 
          function(i) { 
          data.frame(
           ID= rep(i, length(ll[[i]])), 
           COL = ll[[i]], 
           VAL= rep(1, length(ll[[i]])), 
    # MODICIATION: Not coercing to factors        
           stringsAsFactors = FALSE 
           ) 
          } 
          ) 
        ) 

    # MODIFICATION: Preserve as matrix, the output of tapply 
    res2 <- tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length) 

    # FLATTEN into a data.table 
    resdt <- data.table(r=c(res2)) 

    # FIND & REPLACE NA's of single column 
    resdt[is.na(r), r:=0L] 

    # cbind with dt, a matrix, with the same attributes as `res2` 
    cbind(dt, 
      matrix(resdt[[1]], ncol=ncol(res2), byrow=FALSE, dimnames=dimnames(res2))) 
    } 


### Benchmarks: 

orig = quote({dt <- copy(masterDT); myFunc()}) 
modified = quote({dt <- copy(masterDT); myFunc.modified()}) 
microbenchmark(Modified = eval(modified), Orig = eval(orig), times=20L) 

# Unit: milliseconds 
#  expr  min  lq median  uq  max 
# 1 Modified 895.025 971.0117 1011.216 1189.599 2476.972 
# 2  Orig 1953.638 2009.1838 2106.412 2230.326 2356.802 

Answer 2

Ecco una versione ~ 10x più veloce utilizzando rbind.fill.

library(plyr) 
indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i) 
         dt[i, 
          data.frame(t(as.matrix(table(strsplit(messy_string, 
                   split = "\\$"))))) 
          ])) 
dt = cbind(dt, indicators) 

# dt[is.na(dt)] = 0 
# faster NA replace (thanks geektrader) 
for (j in names(dt)) 
    set(dt, which(is.na(dt[[j]])), j, 0L) 

Answer 3

# split the `messy_string` and create a long table, keeping track of the id 
    DT2 <- setkey(DT[, list(val=unlist(strsplit(messy_string, "\\$"))), by=list(ID, messy_string)], "val") 

    # add the columns, initialize to 0 
    DT2[, c(elements_list) := 0L] 
    # warning expected, re:adding large ammount of columns 


    # iterate over each value in element_list, assigning 1's ass appropriate 
    for (el in elements_list) 
    DT2[el, c(el) := 1L] 

    # sum by ID 
    DT2[, lapply(.SD, sum), by=list(ID, messy_string), .SDcols=elements_list] 

Si noti che stiamo portando lungo la colonna messy_string dal momento che è più conveniente che lasciando alle spalle e poi join ing su ID per tornare indietro. Se non ne hai bisogno nell'output finale, basta cancellarlo sopra.

---

Benchmark:

creazione dei dati di esempio:

# sample data, using OP's exmple 
set.seed(10) 
N <- 1e6 # number of rows 
elements_list <- c(outer(letters, letters, FUN = paste, sep = "")) 
messy_string_vec <- random_string_fast(N, 2, 5, "$") # Create the messy strings in a single shot. 
masterDT <- data.table(ID = c(1:N), messy_string = messy_string_vec, key="ID") # create the data.table 

Nota a margine E 'molto più veloce di creare le stringhe casuali tutti in una volta e assegnare i risultati come un colonna singola piuttosto che chiamare la funzione N volte e assegnarle una a una a una.

# Faster way to create the `messy_string` 's 
    random_string_fast <- function(N, min_length, max_length, separator) { 
    ints <- seq(from=min_length, to=max_length) 
    replicate(N, paste(sample(elements_list, sample(ints)), collapse=separator)) 
    } 

a confronto quattro metodi:

• questa risposta - "DT.RS"
• @ risposta di Eddi - "Plyr.eddi"
• @ risposta di GeekTrader - DT.GT risposta
• GeekTrader di con alcune modifiche - DT.GT_Mod

Ecco la messa a punto:

library(data.table); library(plyr); library(microbenchmark) 

# data.table method - RS 
usingDT.RS <- quote({DT <- copy(masterDT); 
        DT2 <- setkey(DT[, list(val=unlist(strsplit(messy_string, "\\$"))), by=list(ID, messy_string)], "val"); DT2[, c(elements_list) := 0L] 
        for (el in elements_list) DT2[el, c(el) := 1L]; DT2[, lapply(.SD, sum), by=list(ID, messy_string), .SDcols=elements_list]}) 

# data.table method - GeekTrader 
usingDT.GT <- quote({dt <- copy(masterDT); myFunc()}) 

# data.table method - GeekTrader, modified by RS 
usingDT.GT_Mod <- quote({dt <- copy(masterDT); myFunc.modified()}) 

# ply method from below 
usingPlyr.eddi <- quote({dt <- copy(masterDT); indicators = do.call(rbind.fill, sapply(1:dim(dt)[1], function(i) dt[i, data.frame(t(as.matrix(table(strsplit(messy_string, split = "\\$"))))) ])); 
        dt = cbind(dt, indicators); dt[is.na(dt)] = 0; dt }) 

Ecco i risultati dei benchmark:

microbenchmark(usingDT.RS=eval(usingDT.RS), usingDT.GT=eval(usingDT.GT), usingDT.GT_Mod=eval(usingDT.GT_Mod), usingPlyr.eddi=eval(usingPlyr.eddi), times=5L) 


    On smaller data: 

    N = 600 
    Unit: milliseconds 
       expr  min  lq median  uq  max 
    1  usingDT.GT 1189.7549 1198.1481 1200.6731 1202.0972 1203.3683 
    2 usingDT.GT_Mod 581.7003 591.5219 625.7251 630.8144 650.6701 
    3  usingDT.RS 2586.0074 2602.7917 2637.5281 2819.9589 3517.4654 
    4 usingPlyr.eddi 2072.4093 2127.4891 2225.5588 2242.8481 2349.6086 


    N = 1,000 
    Unit: seconds 
     expr  min  lq median  uq  max 
    1 usingDT.GT 1.941012 2.053190 2.196100 2.472543 3.096096 
    2 usingDT.RS 3.107938 3.344764 3.903529 4.010292 4.724700 
    3 usingPlyr 3.297803 3.435105 3.625319 3.812862 4.118307 

    N = 2,500 
    Unit: seconds 
       expr  min  lq median  uq  max 
    1  usingDT.GT 4.711010 5.210061 5.291999 5.307689 7.118794 
    2 usingDT.GT_Mod 2.037558 2.092953 2.608662 2.638984 3.616596 
    3  usingDT.RS 5.253509 5.334890 6.474915 6.740323 7.275444 
    4 usingPlyr.eddi 7.842623 8.612201 9.142636 9.420615 11.102888 

    N = 5,000 
       expr  min  lq median  uq  max 
    1  usingDT.GT 8.900226 9.058337 9.233387 9.622531 10.839409 
    2 usingDT.GT_Mod 4.112934 4.293426 4.460745 4.584133 6.128176 
    3  usingDT.RS 8.076821 8.097081 8.404799 8.800878 9.580892 
    4 usingPlyr.eddi 13.260828 14.297614 14.523016 14.657193 16.698229 

    # dropping the slower two from the tests: 
    microbenchmark(usingDT.RS=eval(usingDT.RS), usingDT.GT=eval(usingDT.GT), usingDT.GT_Mod=eval(usingDT.GT_Mod), times=6L) 

    N = 10,000 
    Unit: seconds 
       expr  min  lq median  uq  max 
    1 usingDT.GT_Mod 8.426744 8.739659 8.750604 9.118382 9.848153 
    2  usingDT.RS 15.260702 15.564495 15.742855 16.024293 16.249556 

    N = 25,000 
    ... (still running) 

-----------------

funzioni utilizzate nei benchmark:

# original random string function 
    random_string <- function(min_length, max_length, separator) { 
     selection <- paste(sample(elements_list, ceiling(runif(1, min_length, max_length))), collapse = separator) 
     return(selection) 
    } 

    # GeekTrader's function 
    myFunc <- function() { 
    ll <- strsplit(dt[,messy_string], split="\\$") 


    COLS <- do.call(rbind, 
        lapply(1:length(ll), 
          function(i) { 
          data.frame(
           ID= rep(i, length(ll[[i]])), 
           COL = ll[[i]], 
           VAL= rep(1, length(ll[[i]])) 
           ) 
          } 
          ) 
        ) 

    res <- as.data.table(tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length)) 
    dt <- cbind(dt, res) 
    for (j in names(dt)) 
     set(dt,which(is.na(dt[[j]])),j,0) 
    return(dt) 
    } 


    # Improvements to @GeekTrader's `myFunc` -RS ' 
    myFunc.modified <- function() { 
    ll <- strsplit(dt[,messy_string], split="\\$") 

    ## MODIFICATIONS: 
    # using `rbindlist` instead of `do.call(rbind..)` 
    COLS <- rbindlist(lapply(1:length(ll), 
          function(i) { 
          data.frame(
           ID= rep(i, length(ll[[i]])), 
           COL = ll[[i]], 
           VAL= rep(1, length(ll[[i]])), 
    # MODICIATION: Not coercing to factors        
           stringsAsFactors = FALSE 
           ) 
          } 
          ) 
        ) 

    # MODIFICATION: Preserve as matrix, the output of tapply 
    res2 <- tapply(COLS$VAL, list(COLS$ID, COLS$COL), FUN = length) 

    # FLATTEN into a data.table 
    resdt <- data.table(r=c(res2)) 

    # FIND & REPLACE NA's of single column 
    resdt[is.na(r), r:=0L] 

    # cbind with dt, a matrix, with the same attributes as `res2` 
    cbind(dt, 
      matrix(resdt[[1]], ncol=ncol(res2), byrow=FALSE, dimnames=dimnames(res2))) 
    } 


    ### Benchmarks comparing the two versions of GeekTrader's function: 
    orig = quote({dt <- copy(masterDT); myFunc()}) 
    modified = quote({dt <- copy(masterDT); myFunc.modified()}) 
    microbenchmark(Modified = eval(modified), Orig = eval(orig), times=20L) 

    # Unit: milliseconds 
    #  expr  min  lq median  uq  max 
    # 1 Modified 895.025 971.0117 1011.216 1189.599 2476.972 
    # 2  Orig 1953.638 2009.1838 2106.412 2230.326 2356.802 

Answer 4

Ecco un approccio utilizzando rapply e table. Sono sicuro che ci sarebbe stato un approccio leggermente più veloce rispetto all'utilizzo di tavolo qui, ma è ancora un po 'più veloce rispetto al myfunc.Modified da @ricardo; s risposta

# a copy with enough column pointers available 
dtr <- alloc.col(copy(dt) ,1000L) 

rapplyFun <- function(){ 
ll <- strsplit(dtr[, messy_string], '\\$') 
Vals <- rapply(ll, classes = 'character', f= table, how = 'replace') 
Names <- unique(rapply(Vals, names)) 

dtr[, (Names) := 0L] 
for(ii in seq_along(Vals)){ 
    for(jj in names(Vals[[ii]])){ 
    set(dtr, i = ii, j = jj, value =Vals[[ii]][jj]) 
    } 
} 
} 


microbenchmark(myFunc.modified(), rapplyFun(),times=5) 
Unit: milliseconds 
#    expr  min  lq median  uq  max neval 
# myFunc.modified() 395.1719 396.8706 399.3218 400.6353 401.1700  5 
# rapplyFun()  308.9103 309.5763 309.9368 310.2971 310.3463  5 

Answer 5

Ecco un'altra soluzione, che costruisce un oggetto matrice sparsa invece di quello che hai Questo elimina un sacco di tempo e memoria.

Produce ordinato risultati e anche con la conversione in data.table è più veloce di GT3 con 0L e 1L e senza riordino (questo potrebbe essere perché io uso un metodo diverso per arrivare alle coordinate necessarie - non sono andato attraverso la GT3 algo), tuttavia se non lo converti e lo mantieni come una matrice sparsa è circa 10-20 volte più veloce di GT3 (e ha un ingombro di memoria molto più piccolo).

library(Matrix) 

strings = strsplit(dt$messy_string, split = "$", fixed = TRUE) 
element.map = data.table(el = elements_list, n = seq_along(elements_list), key = "el") 

tmp = data.table(n = seq_along(strings), each = unlist(lapply(strings, length))) 

rows = tmp[, rep(n, each = each), by = n][, V1] 
cols = element.map[J(unlist(strings))][,n] 

dt.sparse = sparseMatrix(rows, cols, x = 1, 
         dims = c(max(rows), length(elements_list))) 

# optional, should be avoided until absolutely necessary 
dt = cbind(dt, as.data.table(as.matrix(dt.sparse))) 
setnames(dt, c('id', 'messy_string', elements_list)) 

L'idea è quella di dividere in stringhe, quindi utilizzare un data.table come oggetto mappa per mappare ogni stringa nella posizione colonna corretta. Da lì in poi è solo questione di capire correttamente le righe e riempire la matrice.

Answer 6

Ecco un approccio un po 'più recente, utilizzando cSplit_e() dal pacchetto splitstackshape.

library(splitstackshape) 
cSplit_e(dt, split.col = "String", sep = "$", type = "character", 
     mode = "binary", fixed = TRUE, fill = 0) 
# ID String String_a String_b String_c 
#1 1 a$b  1  1  0 
#2 2 b$c  0  1  1 
#3 3  c  0  0  1