reemplazar - gsub r

Extrayendo información de la primera coincidencia aproximada de una cadena de texto en R(y sumando el número total de coincidencias)

Question

Tengo problemas para sumar coincidencias aproximadas de cadenas de texto, así como para extraer información de la cadena que se emparejó primero en el tiempo.

Tengo datos que se ven así:

text<-c("THEN it goes West","AT it falls East","it goes West", "it falls East", "AT it goes West")
date<-c(2008,2009,2003,2006,2011)
ID<-c(1,2,3,4,5)
data<-cbind(text,date,ID)
data<-as.data.frame(data)

Observe que las últimas cadenas de texto tienen mayúsculas "THEN" y "AT" agregadas a las cadenas de texto anteriores.

Me gustaría una tabla que se vea así:

     ID  Sum Originaltext     Originaldate
[1,] "4" "3" "it goes West"      "2003"      
[2,] "2" "2" "it falls East"     "2006" 

Esto incluye:

El número de ID correspondiente al texto con la fecha más temprana (el texto "original" del que se derivaron los otros). Sumas de todas las coincidencias aproximadas para cada una. El texto correspondiente a la fecha más temprana. Y la fecha del texto correspondiente con la fecha más temprana.

Tengo decenas de millones de casos, por lo que tengo problemas para automatizar el proceso.

Ejecuto Windows 7 y tengo acceso a servidores de computación rápida.

IDEAS

#order them backwards in time
data<-data[order(data$date, decreasing = TRUE),]

#find the strings with the latest date

pattern<-"AT|THEN"

k <- vector("list", length(data$text))

 for (j in 1:length(data$text)){
     k[[j]]<- grep(pattern,data$text[[j]], ignore.case=FALSE)
}

k<-subset(data$text, k==1)

k<-unique(k)

#this is a problem, because case nos. 1 and 5 are still in the dataset, but they derive from the same tweet. 

Desde aquí, puedo usar "agrep", pero no estoy seguro de en qué contexto. ¡Cualquier ayuda sería muy apreciada!

NOTA: Si bien las tres respuestas a continuación responden a mi pregunta de la forma en que originalmente la hice, no he mencionado que mis casos de texto varían incluso sin las palabras "AT" y "THEN". De hecho, la mayoría de ellos no coinciden exactamente. Debería haber puesto esto en la pregunta original. Sin embargo, todavía me encantaría una respuesta.

¡Gracias!

Answer 1

Voy a darte una solución base, pero realmente creo que este es un gran problema para la base y el paquete data.table es lo que se necesita (pero no sé cómo usar data.table muy bien:

dat <- data[order(data$date), ]
Trim <- function (x) gsub("^//s+|//s+$", "", x)
dat$text2 <- Trim(gsub("AT|THEN", "", dat$text))
dat2 <- split(dat, dat$text2)
FUN <- function(x) {
    c(ID = x[1, 3], Sum = nrow(x), Original.Text = as.character(x[1, 1]), 
        Original.Date = as.character(x[1, 2]))
}

data.frame(do.call(rbind, lapply(dat2, FUN)), row.names = NULL)

Realmente no sé qué tan cerca está cada cadena de texto, así que tal vez mi coincidencia exacta no sea apropiada, pero si ese es el caso, use agrep para desarrollar una nueva variable. Lo siento por la falta de anotaciones pero estoy presionada por el tiempo y creo que data.table es más apropiado de todos modos.

EDITAR: Sigo pensando que data.table es mejor y debería estar afuera, pero que correr en paralelo es inteligente. Estás en una máquina con Windows, así que esto funcionaría para usar varios núcleos de una computadora:

dat <- data[order(data$date), ]
Trim <- function (x) gsub("^//s+|//s+$", "", x)
dat$text2 <- Trim(gsub("AT|THEN", "", dat$text))
dat2 <- split(dat, dat$text2)
FUN <- function(x) {
    c(ID = x[1, 3], Sum = nrow(x), Original.Text = as.character(x[1, 1]), 
        Original.Date = as.character(x[1, 2]))
}

library(parallel)
detectCores()  #make sure you have > 1 core

cl <- makeCluster(mc <- getOption("cl.cores", detectCores()))
clusterExport(cl=cl, varlist=c("FUN", "dat2"), envir=environment())
x <- parLapply(cl, dat2, FUN)
stopCluster(cl)  #stop the cluster
data.frame(do.call(rbind, x), row.names = NULL)

Answer 2

plyr puede ser demasiado lento dado el número de registros que mencionas, pero aquí hay una solución para ti:

library(stringr)
data$original_text <- data$text
data$text[grep("^THEN", data$text)] <- str_trim(str_sub(data$text[grep("^THEN", data$text)],6))
data$text[grep("^AT", data$text)] <- str_trim(str_sub(data$text[grep("^AT", data$text)],4))

result <- ddply(data, .(text), function(x) {
     sum <- nrow(x)
     x <- x[which(x$date==min(x$date)),]
    return(data.frame(id=unique(x$ID), Sum = sum, Originaltext = unique(x$original_text), Originaldate = unique(x$date)))
    })

> result[, -1]
  id Sum  Originaltext Originaldate
1  4   2 it falls East         2006
2  3   3  it goes West         2003

Si tiene acceso a una máquina multinúcleo (4 o más núcleos), aquí hay una solución HPC

library(multicore)
library(stringr)
data$original_text <- data$text
data$text[grep("^THEN", data$text)] <- str_trim(str_sub(data$text[grep("^THEN", data$text)],6))
data$text[grep("^AT", data$text)] <- str_trim(str_sub(data$text[grep("^AT", data$text)],4))

fux <- function(foo) {
     sum <- nrow(x)
     x <- x[which(x$date==min(x$date)),]
    return(data.frame(id=unique(x$ID), Sum = sum, Originaltext = unique(x$original_text), Originaldate = unique(x$date)))
}

x <- split(data, data$text)
result <- mclapply(x, fux, mc.cores = 4, mc.preschedule = TRUE)

Answer 3

Una solución data.table que evita stringr . Estoy seguro de que esto podría mejorarse

Tratar con datos de texto

# make the factor columns character
.data <- lapply(data, function(x) if(is.factor(x)) {as.character(x)} else { x})
library(data.table)
DT <- as.data.table(.data)


DT[, original_text := text]
# using `%like% which is an easy data.table wrapper for grepl
DT[text %like% "^THEN", text := substr(text, 6, nchar(text))]
DT[text %like% "^AT", text :=  substr(text, 4, nchar(text))]

# or avoiding the two vector scans and replacing in one fell swoop
DT[,text := gsub(''(^THEN )|(^AT )'', '''', text)]

DT[, c(sum=.N, .SD[which.min(date)]) ,by=text]

usando niveles de factor (podría ser más rápido)

# assuming that text is a factor
DTF <- as.data.table(data) 
DTF[, original_text := text]
levels_text <- DTF[, levels(text)]
new_levels <- gsub(''(^THEN )|(^AT )'', x= levels_text ,'''')
# reset the levels
setattr(DTF[[''text'']], ''levels'', new_levels)
# coerce to character and do the same count / min date
DTF[, c(sum=.N, .SD[which.min(date)]) ,by=list(text = as.character(text))]