Related
I have a dataset, let's call it "ORIGINALE", composed by several different rows for only two columns, the first called "DESCRIPTION" and the second "CODICE". The description column has the right information while the column codice, which is the key, is almost always empty, therefore I'm tryng to search for the corresponding codice in another dataset, let's call it "REFERENCE". I am using the column desciption, which is in natural language, and trying to match it with the description in the second dataset. I have to match word by word since there may be a different order of words, synonims or abbreviations. Then I calcolate the similarity score to keep only the best match and accept those above a certain score. Is there a way to improve it? I'm working with around 300000 rows and, even though I know is always going to take time, perhaps there could be a way to make it even just slightly faster.
ORIGINALE <- data.frame(DESCRIPTION = c("mr peter 123 rose street 3b LA"," 4c flower str jenny jane Chicago", "washington miss sarah 430f name strt"), CODICE = (NA, NA, NA))
REFERENE <- dataframe (DESCRIPTION = c("sarah brown name street 430f washington", "peter green 123 rose street 3b LA", "jenny jane flower street 4c Chicago"), CODICE = c("135tg67","aw56", "83776250"))
algoritmo <- function(ORIGINALE, REFERENCE) {
split1 <- strsplit(x$DESCRIPTION, " ")
split2 <- strsplit(y$DESCRIPTION, " ")
risultato <- vector()
distanza <- vector()
for(i in 1:NROW(split1)) {
best_dist <- -5
closest_match <- -5
for(j in 1:NROW(split2)) {
dist <- stringsim(as.character(split1[i]), as.character(split2[j]))
if (dist > best_dist) {
closest_match <- y$DESCRIPTION[j]
best_dist <- dist
}
}
distanza <- append(distanza, best_dist)
risultato <- append(risultato, closest_match)
}
confronto <<- tibble(x$DESCRIPTION, risultato, distanza)
}
match <- subset.data.frame(confronto, confronto$distanza >= "0.6")
missing <- subset.data.frame(confronto, confronto$distanza <"0.6")
The R tm (text mining) library can help here:
library(tm)
library(proxy) # for computing cosine similarity
library(data.table)
ORIGINALE = data.table(DESCRIPTION = c("mr peter 123 rose street 3b LA"," 4c flower str jenny jane Chicago", "washington miss sarah 430f name strt"), CODICE = c(NA, NA, NA))
REFERENCE = data.table(DESCRIPTION = c("sarah brown name street 430f washington", "peter green 123 rose street 3b LA", "jenny jane flower street 4c Chicago"), CODICE = c("135tg67","aw56", "83776250"))
# combine ORIGINALE and REFERENCE into one data.table
both = rbind(ORIGINALE,REFERENCE)
# create "doc_id" and "text" columns (required by tm)
both[,doc_id:=1:.N]
names(both)[1] = 'text'
# convert to tm corpus
corpus = SimpleCorpus(DataframeSource(both))
# convert to a tm document term matrix
dtm = DocumentTermMatrix(corpus)
# convert to a regular matrix
dtm = as.matrix(dtm)
# look at it (t() transpose for readability)
t(dtm)
Docs
Terms 1 2 3 4 5 6
123 1 0 0 0 1 0
peter 1 0 0 0 1 0
rose 1 0 0 0 1 0
street 1 0 0 1 1 1
chicago 0 1 0 0 0 1
flower 0 1 0 0 0 1
jane 0 1 0 0 0 1
jenny 0 1 0 0 0 1
str 0 1 0 0 0 0
430f 0 0 1 1 0 0
miss 0 0 1 0 0 0
name 0 0 1 1 0 0
sarah 0 0 1 1 0 0
strt 0 0 1 0 0 0
washington 0 0 1 1 0 0
brown 0 0 0 1 0 0
green 0 0 0 0 1 0
# compute similarity between each combination of documents 1:3 and documents 4:6
similarity = proxy::dist(dtm[1:3,], dtm[4:6,], method="cosine")
# result:
ORIGINALE REFERENCE document
document 4 5 6
1 0.7958759 0.1055728 0.7763932 <-- difference (smaller = more similar)
2 1.0000000 1.0000000 0.2000000
3 0.3333333 1.0000000 1.0000000
# make a table of which REFERENCE document is most similar
most_similar = rbindlist(
apply(
similarity,1,function(x){
data.table(i=which.min(x),distance=min(x))
}
)
)
# result:
i distance
1: 2 0.1055728
2: 3 0.2000000
3: 1 0.3333333
# rows 1, 2, 3 or rows of ORIGINALE; i: 2 3 1 are rows of REFERENCE
# add the results back to ORIGINALE
ORIGINALE1 = cbind(ORIGINALE,most_similar)
REFERENCE[,i:=1:.N]
ORIGINALE2 = merge(ORIGINALE1,REFERENCE,by='i',all.x=T,all.y=F)
# result:
i DESCRIPTION.x CODICE.x distance DESCRIPTION.y CODICE.y
1: 1 washington miss sarah 430f name strt NA 0.3333333 sarah brown name street 430f washington 135tg67
2: 2 mr peter 123 rose street 3b LA NA 0.1055728 peter green 123 rose street 3b LA aw56
3: 3 4c flower str jenny jane Chicago NA 0.2000000 jenny jane flower street 4c Chicago 83776250
# now the documents are in a different order than in ORIGINALE2.
# this is caused by merging by i (=REFERENCE document row).
# if order is important, then add these two lines around the merge line:
ORIGINALE1[,ORIGINALE_i:=1:.N]
ORIGINALE2 = merge(...
ORIGINALE2 = ORIGINALE2[order(ORIGINALE_i)]
Good question. for loops are slow in R:
for(i in 1:NROW(split1)) {
for(j in 1:NROW(split2)) {
For fast R, you need to vectorize your algorithm. I'm not that handy with data.frame anymore, so I'll use its successor, data.table.
library(data.table)
ORIGINALE = data.table(DESCRIPTION = c("mr peter 123 rose street 3b LA"," 4c flower str jenny jane Chicago", "washington miss sarah 430f name strt"), CODICE = c(NA, NA, NA))
REFERENCE = data.table(DESCRIPTION = c("sarah brown name street 430f washington", "peter green 123 rose street 3b LA", "jenny jane flower street 4c Chicago"), CODICE = c("135tg67","aw56", "83776250"))
# split DESCRIPTION to make tables that have one word per row
ORIGINALE_WORDS = ORIGINALE[,.(word=unlist(strsplit(DESCRIPTION,' ',fixed=T))),.(DESCRIPTION,CODICE)]
REFERENCE_WORDS = REFERENCE[,.(word=unlist(strsplit(DESCRIPTION,' ',fixed=T))),.(DESCRIPTION,CODICE)]
# remove empty words introduced by extra spaces in your DESCRIPTIONS
ORIGINALE_WORDS = ORIGINALE_WORDS[word!='']
REFERENCE_WORDS = REFERENCE_WORDS[word!='']
# merge the tables by word
merged = merge(ORIGINALE_WORDS,REFERENCE_WORDS,by='word',all=F,allow.cartesian=T)
# count matching words for each combination of ORIGINALE DESCRIPTION and REFERENCE DESCRIPTION and CODICE
counts = merged[,.N,.(DESCRIPTION.x,DESCRIPTION.y,CODICE.y)]
# keep only the highest N CODICE.y for each DESCRIPTION.x
topcounts = merged[order(-N)][!duplicated(DESCRIPTION.x)]
# merge the counts back to ORIGINALE
result = merge(ORIGINALE,topcounts,by.x='DESCRIPTION',by.y='DESCRIPTION.x',all.x=T,all.y=F)
Here is result:
DESCRIPTION CODICE DESCRIPTION.y CODICE.y N
1: 4c flower str jenny jane Chicago NA jenny jane flower street 4c Chicago 83776250 5
2: mr peter 123 rose street 3b LA NA peter green 123 rose street 3b LA aw56 6
3: washington miss sarah 430f name strt NA sarah brown name street 430f washington 135tg67 4
PS: There are more memory-efficient ways to do this, and this code could cause your machine to crash due to an out-of-memory error or go slowly due to needing virtual memory, but if not, it should be faster than the for loops.
What about :
library(stringdist)
library(dplyr)
library(tidyr)
data_o <- ORIGINALE %>% mutate(desc_o = DESCRIPTION) %>% select(desc_o)
data_r <- REFERENE %>% mutate(desc_r = DESCRIPTION) %>% select(desc_r)
data <- crossing(data_o,data_r)
data %>% mutate(dist= stringsim(as.character(desc_o),as.character(desc_r))) %>%
group_by(desc_o) %>%
filter(dist==max(dist))
desc_o desc_r dist
<chr> <chr> <dbl>
1 " 4c flower str jenny jane Chicago" jenny jane flower street 4c Chicago 0.486
2 "mr peter 123 rose street 3b LA" peter green 123 rose street 3b LA 0.758
3 "washington miss sarah 430f name strt" sarah brown name street 430f washington 0.385
I have a dataframe with a few columns, one of those columns is ranks, an integer between 1 and 20. I want to create another column that contains a bin value like "1-4", "5-10", "11-15", "16-20".
What is the most effective way to do this?
the data frame that I have looks like this(.csv format):
rank,name,info
1,steve,red
3,joe,blue
6,john,green
3,liz,yellow
15,jon,pink
and I want to add another column to the dataframe, so it would be like this:
rank,name,info,binValue
1,steve,red,"1-4"
3,joe,blue,"1-4"
6,john,green, "5-10"
3,liz,yellow,"1-4"
15,jon,pink,"11-15"
The way I am doing it now is not working, as I would like to keep the data.frame intact, and just add another column if the value of df$ranked is within a given range. thank you.
See ?cut and specify breaks (and maybe labels).
x$bins <- cut(x$rank, breaks=c(0,4,10,15), labels=c("1-4","5-10","10-15"))
x
# rank name info bins
# 1 1 steve red 1-4
# 2 3 joe blue 1-4
# 3 6 john green 5-10
# 4 3 liz yellow 1-4
# 5 15 jon pink 10-15
dat <- "rank,name,info
1,steve,red
3,joe,blue
6,john,green
3,liz,yellow
15,jon,pink"
x <- read.table(textConnection(dat), header=TRUE, sep=",", stringsAsFactors=FALSE)
x$bins <- cut(x$rank, breaks=seq(0, 20, 5), labels=c("1-5", "6-10", "11-15", "16-20"))
x
rank name info bins
1 1 steve red 1-5
2 3 joe blue 1-5
3 6 john green 6-10
4 3 liz yellow 1-5
5 15 jon pink 11-15
We can use smart_cut from package cutr :
# devtools::install_github("moodymudskipper/cutr")
library(cutr)
Using #Andrie's sample data:
x$bins <- smart_cut(x$rank,
c(1,5,11,16),
labels = ~paste0(.y[1],'-',.y[2]-1),
simplify = FALSE)
# rank name info bins
# 1 1 steve red 1-4
# 2 3 joe blue 1-4
# 3 6 john green 5-10
# 4 3 liz yellow 1-4
# 5 15 jon pink 11-15
more on cutr and smart_cut
I have a dataframe with a few columns, one of those columns is ranks, an integer between 1 and 20. I want to create another column that contains a bin value like "1-4", "5-10", "11-15", "16-20".
What is the most effective way to do this?
the data frame that I have looks like this(.csv format):
rank,name,info
1,steve,red
3,joe,blue
6,john,green
3,liz,yellow
15,jon,pink
and I want to add another column to the dataframe, so it would be like this:
rank,name,info,binValue
1,steve,red,"1-4"
3,joe,blue,"1-4"
6,john,green, "5-10"
3,liz,yellow,"1-4"
15,jon,pink,"11-15"
The way I am doing it now is not working, as I would like to keep the data.frame intact, and just add another column if the value of df$ranked is within a given range. thank you.
See ?cut and specify breaks (and maybe labels).
x$bins <- cut(x$rank, breaks=c(0,4,10,15), labels=c("1-4","5-10","10-15"))
x
# rank name info bins
# 1 1 steve red 1-4
# 2 3 joe blue 1-4
# 3 6 john green 5-10
# 4 3 liz yellow 1-4
# 5 15 jon pink 10-15
dat <- "rank,name,info
1,steve,red
3,joe,blue
6,john,green
3,liz,yellow
15,jon,pink"
x <- read.table(textConnection(dat), header=TRUE, sep=",", stringsAsFactors=FALSE)
x$bins <- cut(x$rank, breaks=seq(0, 20, 5), labels=c("1-5", "6-10", "11-15", "16-20"))
x
rank name info bins
1 1 steve red 1-5
2 3 joe blue 1-5
3 6 john green 6-10
4 3 liz yellow 1-5
5 15 jon pink 11-15
We can use smart_cut from package cutr :
# devtools::install_github("moodymudskipper/cutr")
library(cutr)
Using #Andrie's sample data:
x$bins <- smart_cut(x$rank,
c(1,5,11,16),
labels = ~paste0(.y[1],'-',.y[2]-1),
simplify = FALSE)
# rank name info bins
# 1 1 steve red 1-4
# 2 3 joe blue 1-4
# 3 6 john green 5-10
# 4 3 liz yellow 1-4
# 5 15 jon pink 11-15
more on cutr and smart_cut
In R, I can return the count results using the specific column names I am interested in as an array as below.
require("plyr")
bevs <- data.frame(cbind(name = c("Bill", "Llib"), drink = c("coffee", "tea", "cocoa", "water"), cost = seq(1:8)))
count(bevs, c("name", "drink"))
# produces
name drink freq
1 Bill cocoa 2
2 Bill coffee 2
3 Llib tea 2
4 Llib water 2
How can I get the count result of two specific column names in a matrix which has columns: all unique drinks, rows: all unique names and cells: freqs (like below)?
cocoa coffee tea water
Bill 2 2 0 0
Llib 0 0 2 2
P.S: Obviously, the solution does not need to use plyr.
You want a contingency table, which you can create using table:
table(bevs[, c("name", "drink")])
# drink
#name cocoa coffee tea water
# Bill 2 2 0 0
# Llib 0 0 2 2
I'm trying to make a cross tabulation in R, and having its output resemble as much as possible what I'd get in an Excel pivot table. So, given this code:
set.seed(2)
df<-data.frame("ministry"=paste("ministry ",sample(1:3,20,replace=T)),"department"=paste("department ",sample(1:3,20,replace=T)),"program"=paste("program ",sample(letters[1:20],20,replace=F)),"budget"=runif(20)*1e6)
library(tables)
library(dplyr)
arrange(df,ministry,department,program)
tabular(ministry*department~((Count=budget)+(Avg=(mean*budget))+(Total=(sum*budget))),data=df)
which yields:
Avg Total
ministry department Count budget budget
ministry 1 department 1 5 479871 2399356
department 2 1 770028 770028
department 3 1 184673 184673
ministry 2 department 1 2 170818 341637
department 2 1 183373 183373
department 3 3 415480 1246440
ministry 3 department 1 0 NaN 0 <---- LOOK HERE
department 2 5 680102 3400509
department 3 2 165118 330235
How do I get the output to hide the rows with zero frequencies?
I'm using tables::tabular but any other package is good for me (as long as there's a way, even indirect, of outputting to html). This is for generating HTML or Latex using R Markdown and displaying the table with my script's results as Excel would, or as in the example above in a pivot-table like form. But without the superfluous row.
Thanks!
Why not just use dplyr?
df %>%
group_by(ministry, department) %>%
summarise(count = n(),
avg_budget = mean(budget, na.rm = TRUE),
tot_budget = sum(budget, na.rm = TRUE))
ministry department count avg_budget tot_budget
1 ministry 1 department 1 5 479871.1 2399355.6
2 ministry 1 department 2 1 770027.9 770027.9
3 ministry 1 department 3 1 184673.5 184673.5
4 ministry 2 department 1 2 170818.3 341636.5
5 ministry 2 department 2 1 183373.2 183373.2
6 ministry 2 department 3 3 415479.9 1246439.7
7 ministry 3 department 2 5 680101.8 3400508.8
8 ministry 3 department 3 2 165117.6 330235.3
While I don't understand at all how the tabular object is made (since it says it's a list but seems to behaves like a data frame), you can select cells as usual, so
> results <-tabular(ministry*department~((Count=budget)+(Avg=(mean*budget))+(Total=(sum*budget))),data=df)
> results[results[,1]!=0,]
Avg Total
ministry department Count budget budget
ministry 1 department 1 5 479871 2399356
department 2 1 770028 770028
department 3 1 184673 184673
ministry 2 department 1 2 170818 341637
department 2 1 183373 183373
department 3 3 415480 1246440
ministry 3 department 2 5 680102 3400509
department 3 2 165118 330235
That's the solution.
I just found out the solution thanks to this user's reply on another question https://stackoverflow.com/users/516548/g-grothendieck