inst/biblioshiny/biblioShot.R

In bibliometrix: Comprehensive Science Mapping Analysis

# Acknowledgment
# This function is based on the source code of the webshot2 package. 
# We would like to acknowledge and express our gratitude to the authors 
# and contributors of webshot2 for their valuable work in developing tools 
# for web content capture. 
#
# In this implementation, we have adapted and modified parts of the original 
# webshot2 code to address an issue where PNG files were being generated as 
# empty images when used on Windows systems. Our modifications aim to improve 
# compatibility and ensure reliable output across different platforms.
#
# Reference:
# webshot2 package: https://github.com/rstudio/webshot2

biblioShot <- function(
  url = NULL,
  file = "biblioShot.png",
  vwidth = 992,
  vheight = 744,
  selector = NULL,
  cliprect = NULL,
  expand = NULL,
  delay = 0.2,
  zoom = 1,
  useragent = NULL,
  max_concurrent = getOption("biblioShot.concurrent", default = 6),
  verbose = FALSE
) {

  if (length(url) == 0) {
    stop("Need url.")
  }

  url <- vapply(url,
    function(x) {
      if (!is_url(x)) {
        file_url(x)
      } else {
        x
      }
    },
    character(1)
  )

  if (!is.null(cliprect) && !is.list(cliprect)) cliprect <- list(cliprect)
  if (!is.null(selector) && !is.list(selector)) selector <- list(selector)
  if (!is.null(expand)   && !is.list(expand))   expand   <- list(expand)

  if (is.null(selector)) {
    selector <- "html"
  }

  if (length(url) > 1 && length(file) == 1) {
    file <- vapply(1:length(url), FUN.VALUE = character(1), function(i) {
      replacement <- sprintf("%03d.\\1", i)
      gsub("\\.(.{3,4})$", replacement, file)
    })
  }

  args_all <- list(
    url       = url,
    file      = file,
    vwidth    = vwidth,
    vheight   = vheight,
    selector  = selector,
    cliprect  = cliprect,
    expand    = expand,
    delay     = delay,
    zoom      = zoom,
    useragent = useragent,
    verbose = verbose
  )

  n_urls <- length(url)
  args_all <- mapply(args_all, names(args_all),
    FUN = function(arg, name) {
      if (length(arg) == 0) {
        return(vector(mode = "list", n_urls))
      } else if (length(arg) == 1) {
        return(rep(arg, n_urls))
      } else if (length(arg) == n_urls) {
        return(arg)
      } else {
        stop("Argument `", name, "` should be NULL, length 1, or same length as `url`.")
      }
    },
    SIMPLIFY = FALSE
  )

  args_all <- long_to_wide(args_all)

  cm <- default_chromote_object()

  # A list of promises for the screenshots
  res <- lapply(args_all,
    function(args) {
      new_session_screenshot(cm,
        args$url, args$file, args$vwidth, args$vheight, args$selector,
        args$cliprect, args$expand, args$delay, args$zoom, args$useragent,
        verbose
      )
    }
  )

  p <- promises::promise_all(.list = res)
  res <- cm$wait_for(p)
  res <- structure(unlist(res), class = "webshot")
  res
}


new_session_screenshot <- function(
  chromote,
  url,
  file,
  vwidth,
  vheight,
  selector,
  cliprect,
  expand,
  delay,
  zoom,
  useragent,
  verbose = FALSE
) {

  filetype <- tolower(tools::file_ext(file))
  if (filetype != "png" && filetype != "pdf") {
    stop("File extension must be 'png' or 'pdf'")
  }

  if (is.null(selector)) {
    selector <- "html"
  }

  if (is.character(cliprect)) {
    if (cliprect == "viewport") {
      cliprect <- c(0, 0, vwidth, vheight)
    } else {
      stop("Invalid value for cliprect: ", cliprect)
    }
  } else {
    if (!is.null(cliprect) && !(is.numeric(cliprect) && length(cliprect) == 4)) {
      stop("`cliprect` must be a vector with four numbers, or a list of such vectors")
    }
  }

  s <- NULL

  p <- chromote$new_session(wait_ = FALSE,
      width = vwidth,
      height = vheight
    )$
    then(function(session) {
      s <<- session

      if (!is.null(useragent)) {
        s$Network$setUserAgentOverride(userAgent = useragent)
      }
      res <- s$Page$loadEventFired(wait_ = FALSE)
      s$Page$navigate(url, wait_ = FALSE)
      res
    })$
    then(function(value) {
      if (delay > 0) {
        promises::promise(function(resolve, reject) {
          later::later(
            function() {
              resolve(value)
            },
            delay
          )
        })
      } else {
        value
      }
    })$
    then(function(value) {
      if (filetype == "png") {
        s$screenshot(
          filename = file, selector = selector, cliprect = cliprect,
          expand = expand, scale = zoom,
          show = FALSE, wait_ = FALSE
        )

      } else if (filetype == "pdf") {
        s$screenshot_pdf(filename = file, wait_ = FALSE)
      }
    })$
    then(function(value) {
      if (verbose) message(url, " screenshot completed")
      normalizePath(value)
    })$
    finally(function() {
      s$close()
    })

  p
}

is_url <- function(x) {
  grepl("^[a-zA-Z]+://", x)
}

# Given the path to a file, return a file:// URL.
file_url <- function(filename) {
  if (is_windows()) {
    paste0("file://", normalizePath(filename, mustWork = TRUE))
  } else {
    enc2utf8(paste0("file:///", normalizePath(filename, winslash = "/", mustWork = TRUE)))
  }
}

is_windows <- function() .Platform$OS.type == "windows"

is_mac <- function() Sys.info()[["sysname"]] == "Darwin"

is_linux <- function() Sys.info()[["sysname"]] == "Linux"

long_to_wide <- function(x) {
  if (length(x) == 0)
    return(x)

  lapply(seq_along(x[[1]]), function(n) {
    lapply(stats::setNames(names(x), names(x)), function(name) {
      x[[name]][[n]]
    })
  })
}