R/termExtraction.R

In massimoaria/bibliometrix: Comprehensive Science Mapping Analysis

utils::globalVariables(c("SR", "text", "ngram"))
#' Term extraction tool from textual fields of a manuscript
#'
#' It extracts terms from a text field (abstract, title, author's keywords, etc.) of a bibliographic data frame.
#' @param M is a data frame obtained by the converting function \code{\link{convert2df}}.
#'        It is a data matrix with cases corresponding to articles and variables to Field Tag in the original WoS or SCOPUS file.
#' @param Field is a character object. It indicates the field tag of textual data :
#' \tabular{lll}{
#' \code{"TI"}\tab   \tab Manuscript title\cr
#' \code{"AB"}\tab   \tab Manuscript abstract\cr
#' \code{"ID"}\tab   \tab Manuscript keywords plus\cr
#' \code{"DE"}\tab   \tab Manuscript author's keywords}
#' The default is \code{Field = "TI"}.
#'
#' @param ngrams is an integer between 1 and 3. It indicates the type of n-gram to extract from texts.
#' An n-gram is a contiguous sequence of n terms. The function can extract n-grams composed by 1, 2, 3 or 4 terms. Default value is \code{ngrams=1}.
#' @param stemming is logical. If TRUE the Porter Stemming algorithm is applied to all extracted terms. The default is \code{stemming = FALSE}.
#' @param language is a character. It is the language of textual contents ("english", "german","italian","french","spanish"). The default is \code{language="english"}.
#' @param remove.numbers is logical. If TRUE all numbers are deleted from the documents before term extraction. The default is \code{remove.numbers = TRUE}.
#' @param remove.terms is a character vector. It contains a list of additional terms to delete from the corpus after term extraction. The default is \code{remove.terms = NULL}.
#' @param keep.terms is a character vector. It contains a list of compound words "formed by two or more terms" to keep in their original form in the term extraction process. The default is \code{keep.terms = NULL}.
#' @param synonyms is a character vector. Each element contains a list of synonyms, separated by ";",  that will be merged into a single term (the first word contained in the vector element). The default is \code{synonyms = NULL}.
#' @param verbose is logical. If TRUE the function prints the most frequent terms extracted from documents. The default is \code{verbose=TRUE}.
#' @return the bibliometric data frame with a new column containing terms about the field tag indicated in the argument \code{Field}.
#'
#'
#' @examples
#' # Example 1: Term extraction from titles
#'
#' data(scientometrics, package = "bibliometrixData")
#'
#' # vector of compound words
#' keep.terms <- c("co-citation analysis", "bibliographic coupling")
#'
#' # term extraction
#' scientometrics <- termExtraction(scientometrics,
#'   Field = "TI", ngrams = 1,
#'   remove.numbers = TRUE, remove.terms = NULL, keep.terms = keep.terms, verbose = TRUE
#' )
#'
#' # terms extracted from the first 10 titles
#' scientometrics$TI_TM[1:10]
#'
#'
#' # Example 2: Term extraction from abstracts
#'
#' data(scientometrics)
#'
#' # term extraction
#' scientometrics <- termExtraction(scientometrics,
#'   Field = "AB", ngrams = 2,
#'   stemming = TRUE, language = "english",
#'   remove.numbers = TRUE, remove.terms = NULL, keep.terms = NULL, verbose = TRUE
#' )
#'
#' # terms extracted from the first abstract
#' scientometrics$AB_TM[1]
#'
#' # Example 3: Term extraction from keywords with synonyms
#'
#' data(scientometrics)
#'
#' # vector of synonyms
#' synonyms <- c("citation; citation analysis", "h-index; index; impact factor")
#'
#' # term extraction
#' scientometrics <- termExtraction(scientometrics,
#'   Field = "ID", ngrams = 1,
#'   synonyms = synonyms, verbose = TRUE
#' )
#'
#' @seealso \code{\link{convert2df}} to import and convert an WoS or SCOPUS Export file in a bibliographic data frame.
#' @seealso \code{\link{biblioAnalysis}} function for bibliometric analysis
#'
#' @export



termExtraction <- function(M, Field = "TI", ngrams = 1, stemming = FALSE, language = "english", remove.numbers = TRUE, remove.terms = NULL, keep.terms = NULL, synonyms = NULL, verbose = TRUE) {
  # ngrams imposed = 1 for keywords
  if (Field %in% c("ID", "DE")) {
    ngrams <- 1
  }

  # load stopwords
  data("stopwords", envir = environment())
  data("stop_words", envir = environment(), package = "tidytext")
  stop_words <- stop_words %>% as.data.frame()

  if (ngrams == 2) {
    remove.terms <- c(remove.terms, stopwords$bigrams)
  }

  switch(language,
    english = {
      stopwords <- (stop_words$word)
    },
    italian = {
      stopwords <- stopwords$it
    },
    german = {
      stopwords <- stopwords$de
    },
    french = {
      stopwords <- stopwords$fr
    },
    spanish = {
      stopwords <- stopwords$es
    }
  )
  stopwords <- tolower(stopwords)

  # remove all special characters (except "-" becoming "_")
  TERMS <- M %>%
    select(SR, !!Field)

  names(TERMS) <- c("SR", "text")

  TERMS$text <- gsub(" - ", " ", TERMS$text)

  # save original multi-words keywords
  if (Field %in% c("ID", "DE")) {
    listTerms <- strsplit(TERMS$text, ";")
    TERMS$text <- unlist(lapply(listTerms, function(l) {
      l <- gsub("-", "__", trimES(trimws(l)))
      l <- tolower(paste(gsub(" ", "_", l), sep = "", collapse = ";"))
    }))
  } else {
    TERMS <- TERMS %>%
      mutate(
        text = tolower(gsub("[^[:alnum:][:blank:]\\-]", "", text)),
        text = gsub("-", "__", text)
      )
  }


  # remove numbers
  if (remove.numbers == TRUE) {
    TERMS <- TERMS %>%
      mutate(text = gsub("[[:digit:]]", "", text))
  }

  # keep terms in the vector keep.terms
  if (length(keep.terms) > 0 & is.character(keep.terms)) {
    keep.terms <- tolower(keep.terms)
    if (Field %in% c("DE", "ID")) {
      kt <- gsub(" ", "_", keep.terms)
      kt <- gsub("-", "__", keep.terms)
    } else {
      kt <- gsub("-", "__", keep.terms)
    }
    for (i in 1:length(keep.terms)) {
      TERMS <- TERMS %>%
        mutate(text = gsub(keep.terms[i], kt[i], text))
    }
  }

  if (is.null(remove.terms)) remove.terms <- ""

  TERMS <- extractNgrams(
    text = TERMS, Var = "text", nword = ngrams,
    stopwords = stopwords, custom_stopwords = tolower(remove.terms),
    stemming = stemming, language = language, synonyms = synonyms, Field = Field
  )

  TERMS <- TERMS %>%
    dplyr::filter(!(ngram %in% paste(rep("NA", ngrams), sep = "", collapse = " "))) %>%
    group_by(SR) %>%
    summarize(text = paste(ngram, collapse = ";"))

  # assign the vector to the bibliographic data frame
  col_name <- paste(Field, "_TM", sep = "")
  M <- M[!names(M) %in% col_name]

  M <- TERMS %>%
    right_join(M, by = "SR")
  names(M)[which(names(M) %in% "text")] <- col_name


  # display results
  if (verbose == TRUE) {
    s <- tableTag(M, col_name)

    if (length(s > 25)) {
      print(s[1:25])
    } else {
      print(s)
    }
  }

  class(M) <- c("bibliometrixDB", "data.frame")
  row.names(M) <- M$SR
  return(M)
}

extractNgrams <- function(text, Var, nword, stopwords, custom_stopwords, stemming, language, synonyms, Field) {
  # text is data frame containing the corpus data text = M %>% select(.data$SR,.data$AB)
  # Var is a string indicating the column name. I.e. Var = "AB"
  # nword is a integer vector indicating the ngrams to extract. I.e. nword = c(2,3)

  stopwords <- c(
    stopwords, "elsevier", "springer", "wiley", "mdpi", "emerald", "originalityvalue", "designmethodologyapproach",
    "-", " -", "-present", "-based", "-literature", "-matter"
  )
  custom_stopngrams <- c(
    custom_stopwords, "rights reserved", "john wiley", "john wiley sons", "science bv", "mdpi basel",
    "mdpi licensee", "emerald publishing", "taylor francis", "paper proposes",
    "we proposes", "paper aims", "articles published", "study aims", "research limitationsimplications"
  )
  ngram <- NULL

  # ngrams <- text %>%
  #   drop_na(any_of(Var)) %>%
  #   unnest_tokens(ngram, !!Var, token = "ngrams", n = nword) %>%
  #   separate(.data$ngram, paste("word",1:nword,sep=""), sep = " ")
  ngrams <- text %>%
    drop_na(any_of(Var)) %>%
    unnest_tokens(ngram, !!Var, token = "ngrams", n = nword)
  ind <- which(substr(ngrams$ngram, 1, 2) %in% "__")
  ngrams$ngram[ind] <- trimws(substr(ngrams$ngram[ind], 3, nchar(ngrams$ngram[ind])))

  ngrams <- ngrams %>%
    separate(ngram, paste("word", 1:nword, sep = ""), sep = " ")



  ## come back to the original multiword format
  ngrams <- ngrams %>%
    mutate_at(paste("word", seq(1, nword), sep = ""), ~ gsub("__", "-", .)) %>%
    mutate_at(paste("word", seq(1, nword), sep = ""), ~ gsub("_", " ", .))
  ##

  ngrams <- ngrams %>% dplyr::filter(if_all(starts_with("word"), ~ !.x %in% stopwords))

  if (isTRUE(stemming)) {
    ngrams <- ngrams %>%
      mutate(across(paste("word", 1:nword, sep = ""), ~ SnowballC::wordStem(.x, language = language)))
  }
  # filter(if_all(starts_with("word"), ~ !str_detect(.x, "\\d"))) %>%
  ngrams <- ngrams %>%
    unite(ngram, paste("word", 1:nword, sep = ""), sep = " ") %>%
    dplyr::filter(!ngram %in% custom_stopngrams) %>%
    mutate(ngram = toupper(ngram))

  # Merge synonyms in the vector synonyms
  if (length(synonyms) > 0 & is.character(synonyms)) {
    s <- strsplit(toupper(synonyms), ";")
    snew <- trimws(unlist(lapply(s, function(l) l[1])))
    sold <- (lapply(s, function(l) {
      l <- trimws(l[-1])
      # l <- paste("(?<![[^[:alnum:]]|[[:alnum:]]])",l,sep="")  ### string to make an exact matching
    }))

    for (i in 1:length(s)) {
      ngrams$ngram[ngrams$ngram %in% unlist(sold[[i]])] <- snew[i]
    }
  }

  return(ngrams)
}