This script uses OpenAlex to download paper DOIs and associated topics.
rm(list=ls())
fsave <- function(x, file = NULL, location = "./data/processed/") {
ifelse(!dir.exists("data"), dir.create("data"), FALSE)
ifelse(!dir.exists("data/processed"), dir.create("data/processed"), FALSE)
if (is.null(file))
file = deparse(substitute(x))
datename <- substr(gsub("[:-]", "", Sys.time()), 1, 8)
totalname <- paste(location, file, "_", datename, ".rda", sep = "")
save(x, file = totalname) #need to fix if file is reloaded as input name, not as x.
}Load packages with groundhog, such that we can replicate.
library(groundhog)
packages_to_load <- c("readr", "dplyr", "openalexR",
"tidyr", "tidyverse", "tictoc",
"reshape", "data.table", "stringdist")
groundhog.library(packages_to_load, date = "2024-07-01")Load the publications from NARCIS and some data manipulation and bugfixes.
load("./data/processed/20240701df_pubs_topic.rda")
# how many papers?
print(paste0("Do we need to fetch ", nrow(x), " works from OpenAlex?"))
# how many papers with DOI?
print(paste0("No, we actually need to fetch ", nrow(x[!is.na(x$DOI), ]), " works from OpenAlex"))
# prep data such that we can fetch from AO
fetch <- x[!is.na(x$DOI), ]
#bugfixes, took me way too long to find out what was wrong...
fetch$DOI <- ifelse(fetch$DOI == "10.1016/j.jclinepi.2016.09,007", "10.1016/j.jclinepi.2016.09.007", fetch$DOI)
fetch$DOI <- ifelse(fetch$DOI == "10.1016/j.medengphy.2015.03,018", "10.1016/j.medengphy.2015.03.018", fetch$DOI)
#didn't do this before hand, should've done it
nrow(unique(fetch[, c("DOI")]))We will use DOI in part 1. Some checks before we attempt the entire fetch.
tic()
onethousand <- oa_fetch(
entity = "works",
doi = c(unlist(fetch[c(1:1000), c("DOI")])),
options = list(select = c("doi", "id", "counts_by_year", "publication_year", "title", "concepts", "topics")),
verbose = FALSE
)
toc()
# 2.2 seconds for 100
# 28 seconds for 1000
# scales pretty linearly? No reason not to.
# on the 1000 about 8 that weren't tracked, or <1%
print(object.size(onethousand), units="Mb")
rm(onethousand)
# Some expectation management
cat(paste0("We need about ", ((174000/1000)*28)/60," minutes to fetch the 174K DOIs. \nObject size will be about ", 9.6*174, " Mbs. \nExpectation is to have <1% missings."))And now the entire dataset of DOIs we have from NARCIS. I dropped authorships and some other columns that made the object unreasonably large. This object should be about 1.6Gb. And call polite, chunk it up and store it in lists.
# And now we attempt to get them all
# chunk them up for a loop
dois <- c(unlist(fetch[, c("DOI")]))
chunk_number <- 500
dois <- split(dois,
cut(seq_along(dois),
chunk_number,
labels = FALSE))
# list to store
works_from_dois <- list()
#load("/Users/u351132/surfdrive/Shared/DDDCovid_surf/data/processed/20240703df_oa_pubs.rda")
tic()
for (i in 1:length(dois)) {
works_from_dois[[i]] <- oa_fetch(
entity = "works",
doi = dois[[i]],
options = list(select = c("doi", "id", "counts_by_year", "publication_year", "title", "concepts", "topics")),
verbose = FALSE)
}
toc()Save the data that we fetch from OpenAlex.
# save data
fsave(works_from_dois, "df_oa_pubs.rda")
df <- bind_rows(works_from_dois)
fsave(df, "df_oa_pubs_df.rda")Now some crucial data manipulation. We first get topics from the DF we extract from OpenAlex. Then we drop those for which we don’t have any topics. We then attach DOIs and extract columns in which we’re interested. After that, we cast it into a dataframe, drop some columns, only keep the topic that loads best on the paper, keep unique papers, and cast it to a wide dataset.
# 117K unique dois out of 171K fetched dois
nrow(unique(df[,c("doi")]))
# get topics element from df
topics <- df[, c("topics", "doi")]
topics <- topics %>% unnest(topics)
tops <- topics[topics$i == 1, ] # get only the topic that loads heaviest on paper
tops <- data.table(tops) # set to data table
tops <- unique(tops) # keep unique papers
# by topic?
topic <- tops[tops$name == "topic", c("score", "display_name", "doi")]
topic <- topic %>% group_by(doi) %>% top_n(1, score)
# by subfield?
subfield <- tops[tops$name == "subfield", c("score", "display_name", "doi")]
subfield <- subfield %>% group_by(doi) %>% top_n(1, score)
# by field?
fields <- tops[tops$name == "field", c("score", "display_name", "doi")]
fields <- fields %>% group_by(doi) %>% top_n(1, score)
# by domain?
domains <- tops[tops$name == "domain", c("score", "display_name", "doi")]
domains <- domains %>% group_by(doi) %>% top_n(1, score)
# clunky, but it works, join them together
paper_fields <- left_join(domains[, c("display_name", "doi")], fields[, c("display_name", "doi")], by = c("doi" = "doi"))
names(paper_fields) <- c("domain", "doi", "field")
paper_fields <- left_join(paper_fields[, c("domain", "doi", "field")], subfield[, c("display_name", "doi")], by = c("doi" = "doi"))
colnames(paper_fields)[4] <- "subfield"
paper_fields <- left_join(paper_fields[, c("domain", "doi", "field", "subfield")], topic[, c("display_name", "doi")], by = c("doi" = "doi"))
colnames(paper_fields)[5] <- "topic"
paper_fields <- paper_fields[, c("doi", "domain", "field", "subfield", "topic")]
# did everything check out? No missings, exact number of unique cases
nrow(paper_fields[is.na("doi"), ])
nrow(paper_fields[is.na("domain"), ])
nrow(paper_fields[is.na("field"), ])
nrow(paper_fields[is.na("subfield"), ])
nrow(paper_fields[is.na("topic"), ])
nrow(unique(paper_fields))Now we want to know whether it worked
# did it work?
fcheck <- function(df1, df2, iter) {
x1 <- df1[iter,]
x2 <- unique(df2[df2$doi == as.character(df1[iter, c("doi")]), c("topics")] %>% unnest(topics))
x2 <- x2 %>% top_n(1, score)
x2 <- x2[x2$i == 1, c("name", "display_name")]
return(c(x2[1,2] == x1[1,5],
x2[2,2] == x1[1,4],
x2[3,2] == x1[1,3],
x2[4,2] == x1[1,2]))
}
fcheck(paper_fields, df, 8000)
fcheck(paper_fields, df, 25000)
# check! it worked, dataframe and curation I made corresponds with what we fetched from OASome data information. We have 206K papers from NARCIS. Of which 174K have a DOI. Of which we can fetch 171K papers from OpenAlex that have a topic load. Ultimately, these are 116K unique papers with a topic load.
#re-introduce the bugs such that we can match to our OA papers
paper_fields$doi <- ifelse(paper_fields$doi == "10.1016/j.jclinepi.2016.09.007", "10.1016/j.jclinepi.2016.09,007", paper_fields$doi)
paper_fields$doi <- ifelse(paper_fields$doi == "10.1016/j.medengphy.2015.03.018", "10.1016/j.medengphy.2015.03,018", paper_fields$doi)
# seperate data
colnames(paper_fields)[3] <- "fields"
fsave(paper_fields, "df_oa_paper_fields.rda")
# match to NARCIS
paper_fields$doi <- gsub("https://doi.org/", "", paper_fields$doi)
x <- left_join(x, paper_fields, by = c("DOI" = "doi"))
# so we have for 172K out of 206K papers domains and topics.
nrow(x[!is.na(x$domain), ])
# how many?
length(table(x$domain))
length(table(x$fields))
length(table(x$subfield))
fsave(x, "tempfields.rda")In part 2 we look up those works without DOI and match on title.
We first count the number of hits (such that we don’t download 100k results for a short title). We then download those with <51 hits. We then first consider those with similar publication years and then look for the title match with the nearest edit distances. If that edit distance is >.xx, we consider that lookup title the one we found and matched in OpenAlex.
# and titles, about 28K unique ones
fetch_titles <- x[is.na(x$DOI), ]
fetch_titles <- fetch_titles[, c("Titel_ori", "pub_year")]
nrow(fetch_titles)
fetch_titles <- data.frame(unique(fetch_titles))
fetch_titles$oa_lookup <- gsub('[[:punct:] ]+',' ', fetch_titles$Titel_ori)
fetch_titles$oa_lookup <- gsub("OR", "or", fetch_titles$oa_lookup) # OR is seen as an OR statement break the for loop below
# polite pool
polite <- "bas.hofstra@ru.nl"
# I first count the number of hits, such that we don't have to download MANY results per title
#count_per_title <- list()
tic()
for (i in 27375:nrow(fetch_titles)) {
count_per_title[[i]] <- oa_fetch(
entity = "works",
title.search = fetch_titles[i, c("oa_lookup")],
count_only = TRUE,
verbose = FALSE,
mailto = polite)
# we attach lookup title and pub year to use later
count_per_title[[i]] <- data.frame(count_per_title[[i]])
count_per_title[[i]]["oa_lookup"] <- fetch_titles[i, c("oa_lookup")]
count_per_title[[i]]["pub_year"] <- fetch_titles[i, c("pub_year")]
}
toc()
fsave(count_per_title, "count_per_title.rda")So now that we have our counts, we can download the actual metadata.
# once we have the count per lookup title, we download only those with less than 51 hits (i.e., 1 page of)
#works_from_titles <- list()
tic()
for (i in 1:length(count_per_title)) {
if(count_per_title[[i]]["count"] > 0 & count_per_title[[i]]["count"] <51){
works_from_titles[[i]] <- oa_fetch(
entity = "works",
title.search = count_per_title[[i]][, c("oa_lookup")],
options = list(select = c("doi", "id", "counts_by_year",
"publication_year", "title", "concepts",
"topics")),
verbose = FALSE,
mailto = polite)
# we attach lookup title and pub year
works_from_titles[[i]]["oa_lookup"] <- count_per_title[[i]][, c("oa_lookup")]
works_from_titles[[i]]["pub_year"] <- count_per_title[[i]][, c("pub_year")]
}
}
toc()
fsave(works_from_titles, "works_from_titles.rda")
#works_from_titles <- xNote that some title searched have multiple hits, so we first select those with equal pub years within lookup titles, after which we calculate an edit distance score. We keep the title combos (between OA titles and our lookup titles) with the lowest edit distance.
works_from_titles <- x
hit_from_title <- list()
for (i in 1:length(works_from_titles)) {
if(!is.null(works_from_titles[[i]])) {
hit_from_title[[i]] <- works_from_titles[[i]][, c("title", "publication_year", "topics", "oa_lookup", "pub_year")]
# if we don't do this, data blow up quite a bit
hit_from_title[[i]] <- hit_from_title[[i]][hit_from_title[[i]]$publication_year == hit_from_title[[i]]$pub_year,]
}
}
# bind rows, find title match closest (edit distance?) within lookup title
works_df <- bind_rows(hit_from_title)
works_df$ld <- stringdist(tolower(gsub('[[:punct:] ]+',' ', works_df$title)), tolower(works_df$oa_lookup), method = "lv")
# then choose lowest distance!
works_df2 <- works_df %>% group_by(oa_lookup) %>% top_n(-1, ld)
length(unique(works_df2$oa_lookup)) == nrow(works_df2)
#multiple lowest? sample
works_df2 <- works_df2 %>% group_by(oa_lookup) %>% slice_sample(n=1)
nrow(works_df2) == length(unique(works_df$oa_lookup))
#only keep those with edit distance <10, from eyeballing, pretty similar!
plot(density(works_df2$ld))
works_df2 <- works_df2[works_df2$ld < 10, ]
# 117K unique dois out of 171K fetched dois
# get topics element from df
topics <- works_df2[, c("topics", "oa_lookup")]
topics <- topics %>% unnest(topics)
tops <- topics[topics$i == 1, ] # get only the topic that loads heaviest on paper
tops <- data.table(tops) # set to data table
tops <- unique(tops) # keep unique papers
# by topic?
topic <- tops[tops$name == "topic", c("score", "display_name", "oa_lookup")]
topic <- topic %>% group_by(oa_lookup) %>% top_n(1, score)
# by subfield?
subfield <- tops[tops$name == "subfield", c("score", "display_name", "oa_lookup")]
subfield <- subfield %>% group_by(oa_lookup) %>% top_n(1, score)
# by field?
fields <- tops[tops$name == "field", c("score", "display_name", "oa_lookup")]
fields <- fields %>% group_by(oa_lookup) %>% top_n(1, score)
# by domain?
domains <- tops[tops$name == "domain", c("score", "display_name", "oa_lookup")]
domains <- domains %>% group_by(oa_lookup) %>% top_n(1, score)
# clunky, but it works, join them together
paper_fields <- left_join(domains[, c("display_name", "oa_lookup")], fields[, c("display_name", "oa_lookup")], by = c("oa_lookup" = "oa_lookup"))
names(paper_fields) <- c("domain", "oa_lookup", "field")
paper_fields <- left_join(paper_fields[, c("domain", "oa_lookup", "field")], subfield[, c("display_name", "oa_lookup")], by = c("oa_lookup" = "oa_lookup"))
colnames(paper_fields)[4] <- "subfield"
paper_fields <- left_join(paper_fields[, c("domain", "oa_lookup", "field", "subfield")], topic[, c("display_name", "oa_lookup")], by = c("oa_lookup" = "oa_lookup"))
colnames(paper_fields)[5] <- "topic"
paper_fields <- paper_fields[, c("oa_lookup", "domain", "field", "subfield", "topic")]
names(paper_fields) <- c("oa_lookup", "domain1", "field1", "subfield1", "topic1")
# did everything check out? No missings, exact number of unique cases
nrow(paper_fields[is.na("oa_lookup"), ])
nrow(paper_fields[is.na("domain1"), ])
nrow(paper_fields[is.na("field1"), ])
nrow(paper_fields[is.na("subfield1"), ])
nrow(paper_fields[is.na("topic1"), ])
nrow(unique(paper_fields))And match back to original data.
# same operations to get to the oa_lookup variable to match on
x$oa_lookup <- ifelse(is.na(x$DOI), gsub('[[:punct:] ]+',' ', x$Titel_ori), NA)
x$oa_lookup <- ifelse(!is.na(x$oa_lookup), gsub("OR", "or", x$oa_lookup), NA) # OR is seen as an OR statement break the for loop below
nrow(x[!is.na(x$oa_lookup), ])
x <- left_join(x, paper_fields, by = c("oa_lookup" = "oa_lookup"))
a <- nrow(x[!is.na(x$domain),])
x$domain <- ifelse(is.na(x$domain) & !is.na(x$domain1), x$domain1, x$domain)
b <- nrow(x[!is.na(x$domain),])
x$fields <- ifelse(is.na(x$fields) & !is.na(x$field1), x$field1, x$fields)
x$subfield <- ifelse(is.na(x$subfield) & !is.na(x$subfield1), x$subfield1, x$subfield)
x$topic <- ifelse(is.na(x$topic) & !is.na(x$topic1), x$topic1, x$topic)
a
b
b/nrow(x)fsave(x, "linked_pubs_oa_fields.rda")Copyright © 2024- Jochem Tolsma