Something went wrong. Try again.
Scripts to use scopus API to download economics journals and articles metadata + use of Elsevier API for full-text
Something went wrong. Try again.
34 kB · 872 lines
R
at master
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873#: Extraction function ---------------------------#' Extract full‑text paragraphs and section titles from Elsevier XML#'#' Read an Elsevier XML file, verify it contains a FULL‑TEXT article, and#' extract paragraph, section title and note paragraph nodes while removing#' inline footnotes and superscript cross‑references.#'#' This function is a thin wrapper around xml2 parsing utilities. It attempts#' to read a single XML file, checks the document type using the configured#' namespace object (`ns`) and the ".//xocs:item-weight" tag, and if the type#' is "FULL-TEXT" returns the extracted nodes for downstream text processing.#'#' @param xml_file Character scalar. Filename of the XML file to process,#' relative to `xml_dir`.#' @param xml_dir Character scalar. Directory containing the XML files.#' Defaults to the value of `xml_path` (expected to exist in the calling#' environment).#'#' @details#' The function:#' - reads the XML file with xml2::read_xml(),#' - checks the document type via ".//xocs:item-weight" and only proceeds for#' documents labelled "FULL-TEXT",#' - selects nodes matching ".//ce:para", ".//ce:section-title" and#' ".//ce:note-para" using the `ns` namespace,#' - removes inline footnote nodes and cross-reference nodes that contain#' superscript markers (so returned paragraph text is cleaner).#'#' The function handles read errors gracefully and returns NULL on error or#' when the document is not of type "FULL-TEXT".#'#' @return An xml2::xml_nodeset of the selected nodes (paragraphs, section#' titles, note paragraphs) with inline footnotes and certain cross‑refs#' removed. Returns NULL if the file cannot be read or if the document type#' is not "FULL-TEXT".#'#' @note#' - This function relies on a named list `ns` (XML namespaces) to be present#' in the environment where it is called. Ensure `ns` is defined and#' contains the prefixes used in the XPath expressions (e.g. "ce", "xocs").#' - Informational and error messages are emitted via cli functions.#'#' @examples#' # Assuming xml_path and ns are defined in your environment:#' # xml_path <- "data/xml"#' # ns <- c(ce = "http://...", xocs = "http://...")#' extract_elsevier_fulltext("example_article.xml", xml_dir)#'#' @seealso xml2::read_xml, xml2::xml_find_all, xml2::xml_remove#' @export#@param xml_file filename (character) relative to `xml_path`#@param xml_dir directory containing xml files (default: xml_path)extract_elsevier_fulltext <- function(xml_file, xml_dir = xml_path) { file_path <- file.path(xml_dir, xml_file)
# Handle file read errors gracefully xml_data <- tryCatch( read_xml(file_path), error = function(e) { cli_alert_danger("Failed to read XML: {xml_file} — {conditionMessage(e)}") return(NULL) } ) if (is.null(xml_data)) { return(NULL) }
#* Check document type — we only want FULL-TEXT articles type_xml <- xml_text(xml_find_all(xml_data, ".//xocs:item-weight", ns = ns)) if (length(type_xml) == 0) { type_xml <- NA_character_ }
if (!identical(type_xml, "FULL-TEXT")) { #cli_alert_warning("Skipping file: {xml_file} (type: {type_xml})") return(NULL) }
#cli_alert_info("Processing file: {xml_file} of type {type_xml}")
#*Extract paragraphs and section titles (and note-paragraphs) paras_and_titles <- xml_find_all( xml_data, ".//ce:para | .//ce:section-title | .//ce:note-para", # note-para extract just the content of the footnote ns = ns )
# Remove inline footnote nodes (so the paragraph text is cleaner) xml_remove(xml_find_all(paras_and_titles, ".//ce:footnote")) xml_remove(xml_find_all( paras_and_titles, ".//ce:cross-ref[.//ce:sup]", # this is for removing the superscript reference numbers in paragraphs ns = ns ))
# Build a small table with node text, node name and node order extracted_data <- data.table( xml_text = xml_text(paras_and_titles, trim = TRUE), xml_name = xml_name(paras_and_titles), xml_node_id = seq_len(length(paras_and_titles)), file_name = xml_file )
# Return extracted rows (may be zero rows) if (nrow(extracted_data) == 0) { cli_alert_warning("No paragraphs or sections found in {xml_file}") return(NULL) } return(extracted_data)}
#' Retrieve the journals from the Elsevier Serial Title API#'#' Fetch a single page of journals (serial) metadata for a given subject area from#' the Elsevier Serial Title API. This function performs a small number of#' retry attempts on transient errors. It expects the variables \code{subject_code}#' and \code{api_key} to be available in the calling environment (or to be set#' in the global environment) and uses \pkg{httr}, \pkg{jsonlite} and \pkg{glue}#' to perform the request and parse the response.#'#' @param start_index integer. Offset for the page to request (0-based).#' @param page_size integer. Number of items to request per page.#' @param max_attempts integer. Maximum number of attempts to try the request#' before giving up. Defaults to \code{3L}.#'#' @details#' The function builds a request URL of the form#' \code{https://api.elsevier.com/content/serial/title?subj={subject_code}&count={page_size}&start={start_index}}#' and sends the request with the header \code{X-ELS-APIKey = api_key}. On HTTP#' 200 responses the JSON body is parsed and the \code{entry} element of the#' \code{serial-metadata-response} is returned. If the API returns no entries#' (NULL or length 0) an empty list is returned to indicate that no more results#' are available. On repeated failures (after \code{max_attempts}) the function#' returns \code{NULL} to indicate an error.#'#' The function prints a short message on each failed attempt and performs a#' short sleep between retries (sleep grows linearly with the attempt count).#'#' @return#' - A list of parsed entry objects on success (as returned by#' \code{jsonlite::fromJSON} for the \code{entry} field).#' - An empty list when the API returns no entries (indicates completion).#' - \code{NULL} when all retry attempts fail (indicates an error).#'#' @examples#' \dontrun{#' # Ensure api_key and subject_code are set in your environment#' api_key <- Sys.getenv("ELSEVIER_API_KEY")#' subject_code <- "MED" # example subject code#'#' # Fetch first page of journals#' entries <- fetch_serial_page(start_index = 0L, page_size = 25L)#' if (is.null(entries)) {#' stop("Failed to fetch journal data from Elsevier API")#' } else if (length(entries) == 0L) {#' message("No journal entries returned (no more results)")#' } else {#' # process `entries`#' }#' }#'#' @seealso \pkg{httr}, \pkg{jsonlite}, \pkg{glue}#' @keywords api journals elsevier retry#' @exportfetch_serial_page <- function(start_index, page_size, max_attempts = 3L) { attempt <- 1L while (attempt <= max_attempts) { url <- glue::glue( "https://api.elsevier.com/content/serial/title?subj={subject_code}&count={page_size}&start={start_index}" ) res <- tryCatch( httr::GET(url, httr::add_headers("X-ELS-APIKey" = api_key)), error = function(e) NULL )
if (!is.null(res) && httr::status_code(res) == 200L) { body <- httr::content(res, as = "text", encoding = "UTF-8") parsed <- jsonlite::fromJSON(body, simplifyVector = TRUE) entries <- parsed$`serial-metadata-response`$entry # entries may be NULL or length 0 when there are no more results if (is.null(entries) || length(entries) == 0L) { return(list()) # return empty list to indicate completion } return(entries) } else { message(glue::glue( "Attempt {attempt} failed for start={start_index}. Retrying..." )) attempt <- attempt + 1L Sys.sleep(1 * attempt) } } # If we reach here all attempts failed -> return NULL to indicate error NULL}
#' Fetch a Scopus API page with retries#'#' Perform an HTTP GET request to the provided Scopus/Elsevier API URL, parse the#' JSON response and return it as an R list. The function will retry the request#' up to \code{attempts} times on failure, waiting one second between attempts.#'#' @param request_url character(1). Full URL to call (including query parameters).#' @param attempts integer(1). Number of retries to attempt before giving up.#' Defaults to \code{max_attempts} (expected to be defined in the calling#' environment).#'#' @return A parsed JSON list (as returned by \code{jsonlite::fromJSON}) when a#' successful HTTP 200 response is received, or \code{NULL} if all attempts#' fail.#'#' @details#' The function issues an HTTP GET request using \code{httr::GET} and sets the#' \code{X-ELS-APIKey} header from the \code{api_key} object (expected to be#' available in the calling environment). It requests JSON via the#' \code{Accept: application/json} header. On a successful response (HTTP status#' 200), the response body is read and parsed with \code{jsonlite::fromJSON}.#' On error or non-200 status codes the function will retry up to#' \code{attempts} times, sleeping one second between retries. If all retries#' fail the function returns \code{NULL}.#'#' @note#' - The function depends on \code{api_key} and (optionally) \code{max_attempts}#' being defined in the environment where it is called.#' - Network errors are caught and trigger retries.#'#' @examples#' \dontrun{#' # prepare environment#' api_key <- Sys.getenv("SCOPUS_API_KEY")#' max_attempts <- 3L#'#' url <- "https://api.elsevier.com/content/search/scopus?query=TITLE(ml)"#' res <- fetch_scopus_page(url, attempts = max_attempts)#' if (!is.null(res)) {#' # inspect parsed JSON#' str(res)#' }#' }#'#' @seealso \code{\link[httr]{GET}}, \code{\link[httr]{add_headers}},#' \code{\link[jsonlite]{fromJSON}}#' @exportfetch_scopus_page <- function(request_url, attempts = max_attempts) { attempt <- 1L while (attempt <= attempts) { resp <- tryCatch( httr::GET( request_url, httr::add_headers("X-ELS-APIKey" = api_key), httr::accept("application/json") ), error = function(e) NULL )
if (!is.null(resp) && httr::status_code(resp) == 200L) { body <- content(resp, as = "text", encoding = "UTF-8") content_json <- fromJSON(body, simplifyVector = TRUE) return(content_json) }
# brief wait and retry attempt <- attempt + 1L Sys.sleep(1) } NULL}
#' Fetch and save full-text XML from Elsevier (Scopus/DOI) for a single file#'#' Fetch the article XML from the Elsevier API using either a DOI (preferred)#' or a Scopus ID and save the returned XML to disk. The function looks up#' the DOI and Scopus ID for the given filename in the global `elsevier_articles`#' table, constructs an API request, performs an HTTP GET, and writes the#' returned XML to a path under the specified `path` directory.#'#' This function is intended to be used as a helper for batch retrieval of#' full-text (XML) records. It logs progress and warnings using the#' \pkg{cli} package and returns invisibly.#'#' @param file character(1). The filename (relative name) that identifies the#' article record in `elsevier_articles`#' @param path character(1). The directory path where the XML file should be#' saved.#'#' @details#' - The function queries `elsevier_articles` (a data.frame or data.table expected#' to contain at least the columns `file_name`, `prism_doi` and#' `dc_identifier`) to obtain the DOI (`prism_doi`) and Scopus ID#' (`dc_identifier`) for the supplied `file`.#' - If a DOI is present, the request is made against the DOI endpoint:#' "https://api.elsevier.com/content/article/doi/<DOI>". Otherwise the#' Scopus ID endpoint is used:#' "https://api.elsevier.com/content/article/scopus_id/<SCOPUS_ID>".#' - The function requires a valid API key stored in the global `api_key`#' variable. The request sets the "Accept" header to "text/xml" and uses a#' 20 second timeout.#' - On HTTP status 200 the response body (text, UTF-8) is written to the#' file path constructed as file.path(xml_data_path, file). On other status#' codes a warning is emitted. Any unexpected errors during the request are#' captured and reported via a warning.#'#' @return Invisibly returns NULL. The primary effect is the creation (or#' overwrite) of a file containing the retrieved XML if the request#' succeeds.#'#' @note#' - This function depends on the side-effect globals:#' `elsevier_articles`, and `api_key`. Ensure these are defined and valid before#' calling.#' - The function currently does not throttle requests automatically; a#' small delay (e.g. Sys.sleep(0.5)) between calls may be appropriate to#' respect API rate limits (a commented delay is present in the original#' implementation).#'#' @references#' Elsevier/Scopus APIs — see https://dev.elsevier.com for API details and#' usage limits.#'#' @examples#' \dontrun{#' # Precondition: api_key and all_articles must be set.#' # all_articles should contain columns: file_name, prism_doi, dc_identifier.#' fetch_and_save_fulltext("article_001.xml", "path/to/save")#' }#'#' @keywords IO API HTTP XML Elsevier#' @importFrom httr GET add_headers timeout content status_code#' @importFrom glue glue#' @importFrom utils writeLines URLencode#' @importFrom cli cli_alert_info cli_alert_warning#' @exportfetch_and_save_fulltext <- function(file, path) { # Construct file path where the XML will be stored file_path <- file.path(path, file)
# Look up DOI and Scopus ID for the given filename (may be NA) doi <- unique(elsevier_articles[file_name == file, ]$prism_doi) scopus_id <- unique(elsevier_articles[file_name == file, ]$scopus_id)
# Build URL: prefer DOI when available, else use Scopus ID if (is.na(doi)) { cli::cli_alert_info(glue( "No DOI found for {scopus_id}, using Scopus ID instead." )) url <- paste0( "https://api.elsevier.com/content/article/scopus_id/", URLencode(scopus_id) ) } else { url <- paste0( "https://api.elsevier.com/content/article/doi/", URLencode(doi) ) }
# Attempt the HTTP GET request and save on success tryCatch( { response <- GET( url, add_headers("X-ELS-APIKey" = api_key, "Accept" = "text/xml"), timeout(20) )
if (status_code(response) == 200) { writeLines(content(response, "text", encoding = "UTF-8"), file_path) cli::cli_alert_success(glue::glue("Saved: {scopus_id}")) } else { cli::cli_alert_warning(glue::glue( "Failed: {scopus_id} - status {status_code(response)}" )) }
# Sys.sleep(0.5) # Add delay to respect API }, error = function(e) { warning(glue::glue("Error with DOI {scopus_id}: {e$message}")) } ) invisible(NULL)}
#' Normalize sentinel values to NA in selected data.table columns#'#' Convert selected columns to character and replace common sentinel values#' (e.g. "[NULL]", "NULL", "<NA>", empty string, single space, "0") with#' NA. The function operates by reference on a data.table and returns the#' modified data.table invisibly.#'#' @param dt data.table. A data.table which will be modified in-place.#' @param cols character. A character vector of column names in `dt` to#' normalize. Columns that are not present are silently skipped.#'#' @details#' The function first checks that `dt` is a data.table. For each column named#' in `cols` that exists in `dt` the column is coerced to character and any#' values equal to the sentinel set are replaced with `NA_character_`.#' Common sentinel values handled are: `"[NULL]"`, `"NULL"`, `"<NA>"`, `""`,#' `" "`, and `"0"`.#'#' This is useful when importing heterogeneous datasets that use sentinel#' strings to indicate missingness. Because conversion is performed by#' reference the original data.table is modified; the function returns the#' same data.table invisibly.#'#' @return The input data.table, invisibly, after modification (columns coerced#' to character and sentinel values replaced with `NA_character_`).#'#' @examples#' library(data.table)#' dt <- data.table(a = c("NULL", "x", "[NULL]"), b = c("<NA>", " ", "y"))#' normalize_sentinels_to_na(dt, c("a", "b"))#' dt#'#' @exportnormalize_sentinels_to_na <- function(dt, cols) { values_to_na <- c("[NULL]", "NULL", "<NA>", "", " ", "0")
if (!data.table::is.data.table(dt)) { stop("`dt` must be a data.table") } for (col_name in cols) { if (!col_name %in% names(dt)) { next } # ensure column is character, then replace sentinel values with NA dt[, (col_name) := as.character(.SD[[1]]), .SDcols = col_name] dt[get(col_name) %in% values_to_na, (col_name) := NA_character_] } invisible(dt)}
#' Perform deterministic record matching between two datasets#'#' @title Deterministic record matching (exact-key)#' @description#' Perform deterministic (exact-key) record matching between two data.tables#' (referred to as "left" and "right") using one or more matching variables.#' The function builds a composite key by pasting the provided matching#' variables (order matters), joins the two datasets on that key to produce#' left <-> right id pairs, and returns a per-left-id table of match results#' and summary statistics for the chosen matching strategy.#'#' @param dt_left data.table#' Left-side dataset to be matched. Expected to contain the identifier column#' specified by `id_left_col` and all variables named in `matching_variable`.#' @param dt_right data.table#' Right-side dataset to be matched. Expected to contain the identifier column#' specified by `id_right_col` and all variables named in `matching_variable`.#' @param matching_variable character vector#' One or more column names used to form the deterministic matching key. The#' values are pasted together (in the provided order) to form the composite key.#' Default: c("title_cleaned", "year").#' @param match_suffix character#' Suffix used to name strategy-specific output columns (e.g. "match_1").#' Default: "match_1".#' @param id_left_col character#' Name of the identifier column in `dt_left` (required).#' @param id_right_col character#' Name of the identifier column in `dt_right` (required).#' @param normalize_sentinels logical#' Whether to normalize common sentinel values to NA in the matching, based on#' the `matching_variable` columns, before performing the matching. Use#' `normalize_sentinels_to_na`. Default: FALSE.#'#' @details#' - Rows with NA in any `matching_variable` are omitted before matching.#' - A composite key named "paste_match" is created by pasting the#' `matching_variable` columns together for both datasets; matches are exact#' string matches on that key.#' - The function preserves the original input tables and operates on copies.#' - Output column names are constructed from `match_suffix` and identifier#' names:#' - Strategy-specific right id column: paste0(id_right_col, "_", match_suffix)#' - Per-row indicator that a right match was found: paste0("is_", match_suffix, "_true")#' - Strategy-level matched share: paste0("share_matching_", match_suffix) (percent)#' - Strategy-level duplication rate: paste0("duplication_rate", match_suffix) (percent;#' note: no underscore to preserve original script behavior)#' - Informational messages about percent matched and duplication rate are emitted#' via cli::cli_alert_info().#'#' @return data.table#' A data.table with one row per left-side id (column name given by#' `id_left_col`) and the following columns (names vary with `match_suffix`#' and id column names):#' - strategy-specific right id column (e.g. "id_wos_match_1")#' - binary indicator for whether this left record had a right match#' (e.g. "is_match_1_true"; 1 = matched, 0 = not matched)#' - strategy-level metrics repeated for every row:#' - share of left records matched by this strategy (percent)#' - duplication rate for this strategy (percent)#'#' @examples#' \dontrun{#' library(data.table)#'#' # Minimal example data.tables#' left_dt <- data.table(id_jstor = 1:3,#' title_cleaned = c("a", "b", "c"),#' year = c(2000, 2001, 2002))#' right_dt <- data.table(id_wos = c("A","B"),#' title_cleaned = c("a","b"),#' year = c(2000,2001))#'#' # Run deterministic matching on title_cleaned and year#' res <- perform_record_matching(#' dt_left = left_dt,#' dt_right = right_dt,#' matching_variable = c("title_cleaned", "year"),#' match_suffix = "match_1",#' id_left_col = "id_jstor",#' id_right_col = "id_wos",#' normalize_sentinels = FALSE#' )#' print(res)#' }
#' @seealso#' For fuzzy/probabilistic matching approaches consider packages such as#' stringdist or RecordLinkage.#'#' @export
perform_record_matching <- function( dt_left, dt_right, matching_variable = c("title_cleaned", "year"), match_suffix = "match_1", id_left_col, id_right_col, normalize_sentinels = FALSE) { # Input checks if (missing(dt_left) || !is.data.table(dt_left)) { stop("dt_left must be provided and be a data.table.") } if (missing(dt_right) || !is.data.table(dt_right)) { stop("dt_right must be provided and be a data.table.") } if (missing(id_left_col) || !(id_left_col %in% names(dt_left))) { stop("Provide a valid id_left_col present in dt_left.") } if (missing(id_right_col) || !(id_right_col %in% names(dt_right))) { stop("Provide a valid id_right_col present in dt_right.") } if (any(!(matching_variable %in% names(dt_left)))) { stop("All matching_variable names must exist in dt_left.") } if (any(!(matching_variable %in% names(dt_right)))) { stop("All matching_variable names must exist in dt_right.") }
# Prepare minimal copies and drop rows missing any matching variable left_prep <- copy(dt_left[, .SD, .SDcols = c(id_left_col, matching_variable)]) right_prep <- copy(dt_right[, .SD, .SDcols = c(id_right_col, matching_variable) ])
# Normalize sentinels to NA if requested, to make sure they don't interfere with matching if (normalize_sentinels) { normalize_sentinels_to_na(left_prep, matching_variable) normalize_sentinels_to_na(right_prep, matching_variable) }
left_prep <- na.omit(left_prep, cols = matching_variable) right_prep <- na.omit(right_prep, cols = matching_variable)
# Build composite key left_prep[, paste_match := do.call(paste, .SD), .SDcols = matching_variable] right_prep[, paste_match := do.call(paste, .SD), .SDcols = matching_variable]
# Keep unique id/key pairs left_unique <- unique(left_prep[, .SD, .SDcols = c(id_left_col, "paste_match") ]) right_unique <- unique(right_prep[, .SD, .SDcols = c(id_right_col, "paste_match") ])
# Create matched pairs (allowing a left id to map to multiple right ids) matched_pairs <- merge( left_unique, right_unique, by = "paste_match", all.x = TRUE, allow.cartesian = TRUE )
# Ensure we always have a per-left-id output: merge matched right ids back into original left table left_with_matches <- merge( dt_left, matched_pairs[, .SD, .SDcols = c(id_left_col, id_right_col)], by = id_left_col, all.x = TRUE )
# Build output table with one row per left id (keeps original left rows) output_stat_dt <- left_with_matches[, .SD, .SDcols = c(id_left_col, id_right_col) ]
# Names for strategy-specific columns id_match_col_name <- paste0(id_right_col, "_", match_suffix) match_check_col_name <- paste0("is_", match_suffix, "_true") id_stat_col_name <- paste0("share_matching_", match_suffix) duplication_rate_stat_col_name <- paste0("duplication_rate", match_suffix) # preserved no underscore
# Indicator: 1 if a right id found, else 0 output_stat_dt[, (match_check_col_name) := as.integer(!is.na(get(id_right_col))) ]
# Share matched: percent of left rows with at least one right match output_stat_dt[, (id_stat_col_name) := sum(get(match_check_col_name)) / .N * 100 ]
# Duplication rate: percent of left ids that match to more than one distinct right id if (nrow(matched_pairs) == 0L) { dup_rate <- 0 } else { left_match_counts <- matched_pairs[, .N, by = id_left_col] n_left_with_duplicates <- left_match_counts[N > 1, .N] n_left_total <- uniqueN(matched_pairs[[id_left_col]]) # If no left keys were matched at all, define duplication as 0 dup_rate <- if (n_left_total == 0L) { 0 } else { round(n_left_with_duplicates / n_left_total * 100, 2) } } output_stat_dt[, (duplication_rate_stat_col_name) := dup_rate]
# Create strategy-specific right-id column and drop the generic right id output_stat_dt[, (id_match_col_name) := get(id_right_col)] output_stat_dt[, (id_right_col) := NULL]
# Informational messages cli::cli_alert_info( glue::glue( "{match_suffix}: matched {round(output_stat_dt[[id_stat_col_name]][1], 2)}% of {id_left_col} records" ) ) cli::cli_alert_info( glue::glue( "{match_suffix}: duplication rate {round(output_stat_dt[[duplication_rate_stat_col_name]][1], 2)}%" ) )
# Return per-left-id table with the strategy-specific columns return(output_stat_dt[])}
#' Find near-duplicate text pairs between two data.tables#'#' Compute string distances between text fields from two data.tables after#' restricting comparisons to matching groups (e.g. same journal, year, etc.).#' The function returns pairwise matches (one row per pair) including the raw#' string distance and, optionally, a normalized distance (distance divided by#' the maximum length of the two strings). The inputs are copied and never#' modified in-place.#'#' @param data_dt_1 data.table. First input table containing the text to compare.#' @param data_dt_2 data.table. Second input table containing the text to compare.#' @param text_column character(1). Name of the text column present in both#' tables. Default: "text".#' @param grouping_columns character vector or NULL. Column names used to#' group/match rows between the two tables before computing distances. Only#' columns present in both tables will be used; if no common grouping columns#' remain, the function stops with an error.#' @param id_col_1 character(1). Name of the identifier column in data_dt_1 to#' include in the output. If the named column does not exist, a sequential#' integer id is created for data_dt_1. Default: "id".#' @param id_col_2 character(1). Name of the identifier column in data_dt_2 to#' include in the output. If the named column does not exist, a sequential#' integer id is created for data_dt_2. Default: "id".#' @param distance_method character(1). Distance metric passed to#' stringdist::stringdist (e.g. "osa", "lv", "dl", "hamming", etc.). Default:#' "osa".#' @param normalize logical(1). If TRUE, a \code{normalized_distance} column is#' added equal to \code{distance / max(nchar(text1), nchar(text2))}. If both#' strings are empty the normalized distance will be NA. Default: TRUE.#' @param keep_one_to_one logical(1). If TRUE, any id from either table that#' participates in more than one pair is removed from the result (keeps only#' strict one-to-one matches). Default: TRUE.#'#' @details#' - The function performs an inner merge (cartesian allowed) between#' \code{data_dt_1} and \code{data_dt_2} on the selected \code{grouping_columns}.#' Only rows that share the same values for all grouping columns are compared.#' - Text columns are internally renamed to \code{text1} and \code{text2} for#' computation; returned results include those columns alongside the id and#' grouping columns.#' - If no candidate pairs exist after grouping, the function calls#' \code{cli::cli_alert_info("No titles to compare found.")} and returns#' \code{invisible(NULL)}.#' - Inputs are copied with \code{data.table::copy()} so the originals are not#' modified.#'#' @return A data.table (or NULL if no pairs) with one row per compared pair.#' Typical columns (if present) are:#' - the two id columns (named according to \code{id_col_1} and \code{id_col_2}),#' - the chosen \code{grouping_columns},#' - \code{text1} and \code{text2} (the text values compared),#' - \code{distance} (numeric; raw string distance from \code{stringdist}),#' - \code{normalized_distance} (numeric; present when \code{normalize = TRUE}).#' The result is ordered ascending by \code{normalized_distance} (if present)#' or by \code{distance} otherwise.#'#' @note#' - The function depends on the data.table and stringdist packages and uses#' cartesian joins to generate all cross-group pairs before distance#' calculation. For very large groups this can produce many pairwise#' comparisons and use substantial memory/time.#' - The \code{distance_method} argument is forwarded directly to#' \code{stringdist::stringdist}; consult that function's documentation for#' available methods and their behaviour.#'#' @examples#' if (requireNamespace("data.table", quietly = TRUE)) {#' library(data.table)#' dt1 <- data.table(id = 1:3, journal = c("A", "A", "B"),#' text = c("hello world", "foo bar", "lorem"))#' dt2 <- data.table(id = 10:12, journal = c("A", "A", "B"),#' text = c("helo world", "foobar", "ipsum"))#' # Compare only within the same journal#' res <- find_duplicates(dt1, dt2, text_column = "text", grouping_columns = "journal")#' print(res)#' }#'#' @exportfind_duplicated_text <- function( data_dt_1, data_dt_2, text_column = "text", grouping_columns = NULL, id_col_1 = "id", id_col_2 = "id", distance_method = "osa", normalize = TRUE, keep_one_to_one = TRUE) { # Validate inputs stopifnot(is.data.table(data_dt_1), is.data.table(data_dt_2)) grouping_columns <- intersect( grouping_columns, intersect(names(data_dt_1), names(data_dt_2)) ) if (length(grouping_columns) == 0) { stop("No common grouping columns found between the two tables.") } if ( !text_column %in% names(data_dt_1) || !text_column %in% names(data_dt_2) ) { stop("text_column must exist in both data tables.") } # Prepare temporary copies to avoid modifying originals dt1 <- copy(data_dt_1) dt2 <- copy(data_dt_2)
# Ensure id columns exist setnames(dt1, old = id_col_1, new = "id_1", skip_absent = TRUE) if (!"id_1" %in% names(dt1)) { dt1[, id_1 := seq_len(.N)] } setnames(dt2, old = id_col_2, new = "id_2", skip_absent = TRUE) if (!"id_2" %in% names(dt2)) { dt2[, id_2 := seq_len(.N)] }
# keep only necessary columns dt1 <- dt1[, .SD, .SDcols = c("id_1", grouping_columns, text_column)] dt2 <- dt2[, .SD, .SDcols = c("id_2", grouping_columns, text_column)]
# Merge on grouping columns to restrict comparisons merged <- merge( dt1, dt2, by = grouping_columns, suffixes = c("_1", "_2"), all = FALSE, allow.cartesian = TRUE )
# If no pairs, return empty table with expected cols if (nrow(merged) == 0L) { cli_alert_info("No titles to compare found.") return(invisible(NULL)) }
# Extract texts (account for suffixing) txt1_name <- paste0(text_column, "_1") txt2_name <- paste0(text_column, "_2") setnames(merged, c(txt1_name, txt2_name), c("text1", "text2"))
# Compute distances merged[, distance := stringdist::stringdist(text1, text2, method = distance_method) ]
# Normalized distance (by max length); NA if both empty if (normalize) { merged[, normalized_distance := { l1 <- nchar(text1) l2 <- nchar(text2) denom <- pmax(l1, l2) denom[denom == 0] <- NA_real_ distance / denom } ] }
# Remove rows with at least one NA in any grouping column merged <- na.omit(merged, cols = grouping_columns)
# Optionally keep only one-to-one matches (remove ids with multiple matches) if (keep_one_to_one) { dup1 <- merged[, .N, by = "id_1"][N > 1, id_1] dup2 <- merged[, .N, by = "id_2"][N > 1, id_2] if (length(dup1) || length(dup2)) { merged <- merged[!id_1 %in% dup1 & !id_2 %in% dup2] } }
# Keep and order relevant columns cols_keep <- c( "id_1", "id_2", grouping_columns, "text1", "text2", "distance" ) if (normalize) { cols_keep <- c(cols_keep, "normalized_distance") } cols_keep <- intersect(cols_keep, names(merged)) merged <- merged[, .SD, .SDcols = cols_keep]
# Give back original id column names setnames(merged, old = "id_1", new = id_col_1, skip_absent = TRUE) setnames(merged, old = "id_2", new = id_col_2, skip_absent = TRUE)
if (normalize) { merged <- merged[order(normalized_distance), ] } else { merged <- merged[order(distance), ] }
return(merged)}
normalize_title <- function(x) { x |> stringr::str_replace_all("&#x([0-9A-Fa-f]+);", function(m) { intToUtf8(strtoi(stringr::str_extract(m, "[0-9A-Fa-f]+"), base = 16L)) }) |> stringr::str_replace_all("\\s*&\\s*", " and ") |> stringr::str_to_lower() |> stringi::stri_trans_general("Latin-ASCII") |> stringr::str_remove("^the\\s+") |> stringr::str_remove_all("[[:punct:]]") |> stringr::str_squish()}