从R中一个文本串的第一近似匹配拉信息（和求和匹配的总数）

Question

遇到麻烦求和文本字符串的近似匹配，以及从被匹配的字符串中提取信息 第一及时。

我看起来像这样的数据：

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) 

注意最新的文本字符串都大写的“THEN”和“AT”添加到先前的文本字符串。

我想一个表，看起来像这样：

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

这包括：

与最早的日期文本相应的ID号（“原始”文字，其他人源自）。 总计所有大致匹配的每个。 文本与最早的日期对应。 和日期与最早的日期相对应的文本。

我有几千万的情况下，所以我有麻烦自动化过程。

我运行Windows 7，并有机会获得快速计算服务器。

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. 

从这里，我可以用 “AGREP”，但我不知道在什么情况下。任何帮助将不胜感激！

注意：当三个答案下面就回答我的问题，我原来问的方式，我没有提到，我的文字的情况确实有所不同，即使没有的话“AT”和“THEN”。事实上，他们中的大多数并不完全匹配。我应该把它放在原来的问题中。但是，我仍然喜欢答案。

谢谢！

Answer 1

甲data.table溶液避免stringr。我相信这可以改善

处理采用因子水平文本数据

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

（可能会更快）

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

Answer 2

我要给你一个基础解决方案，但我真的认为这是基地的一个大问题和data.table包所需要的（但我不知道如何使用data.table非常好：

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) 

我真的不知道每个文本字符串是如何接近，所以也许我的精确匹配是不恰当的，但如果是这样的话使用agrep开发一个新的变量。对不起，我没有注释的，但我赶时间，我觉得data.table是比较合适的呢

编辑：我仍然认为大ta.table更好，应该走出门外，但可能并行运行很聪明。你是在Windows机器上那么这将工作用计算机的多个内核：

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 3

plyr可能太慢给予你提到的记录数，但这里是你的解决方案：

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 

如果有权访问多核机（4个或更多核），然后在这里是一个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)