Procházet zdrojové kódy

pre-CRAN flight check

0.6.0
boB Rudis před 5 roky
rodič
revize
34c15bb3f0
V databázi nebyl nalezen žádný známý klíč pro tento podpis GPG Key ID: 1D7529BE14E2BBA9
  1. 55
      R/docker-splash.r
  2. 90
      R/utils-safely.R
  3. 3
      man/install_splash.Rd
  4. 2
      man/start_splash.Rd

55
R/docker-splash.r

@ -2,6 +2,7 @@
#'
#' @md
#' @param tag Splash Docker image tag to install
#' @return a `docker_image` object or `NULL` if an error occurred.
#' @export
#' @family splash_docker_helpers
#' @examples \dontrun{
@ -10,8 +11,22 @@
#' stop_splash(splash_container)
#' }
install_splash <- function(tag="latest") {
docker <- stevedore::docker_client()
res <- docker$image$pull("scrapinghub/splash", tag=tag, stream=stdout())
tryCatch(
docker$image$pull("scrapinghub/splash", tag=tag, stream=stdout()),
error = function(e) {
message("Error pulling image from DockerHub.\n", e)
return(NULL)
},
interrupt = function(e) {
stop("Terminated by user", call. = FALSE)
}
) -> res
invisible(res)
}
#' Start a Splash server Docker container
@ -33,7 +48,7 @@ install_splash <- function(tag="latest") {
#' Defaults to `FALSE`.
#' @param ... passed on to Splash instance launch parameters
#' @family splash_docker_helpers
#' @return `stevedor` container object
#' @return `stevedore` container object
#' @export
#' @examples \dontrun{
#' install_splash()
@ -44,15 +59,24 @@ start_splash <- function(tag="latest", container_name = "splashr", remove=FALSE,
docker <- stevedore::docker_client()
docker$container$run(
image = sprintf("scrapinghub/splash:%s", tag),
name = container_name,
ports = c("5023:5023", "8051:8051", "8050:8050"),
detach = TRUE,
rm = remove,
tty = TRUE,
"--disable-browser-caches",
...
tryCatch(
docker$container$run(
image = sprintf("scrapinghub/splash:%s", tag),
name = container_name,
ports = c("5023:5023", "8051:8051", "8050:8050"),
detach = TRUE,
rm = remove,
tty = TRUE,
"--disable-browser-caches",
...
),
error = function(e) {
message("Error pulling image from DockerHub.")
return(NULL)
},
interrupt = function(e) {
stop("Terminated by user", call. = FALSE)
}
) -> splash_inst
invisible(splash_inst)
@ -73,8 +97,10 @@ start_splash <- function(tag="latest", container_name = "splashr", remove=FALSE,
#' stop_splash(splash_container)
#' }
stop_splash <- function(splash_container) {
splash_container$stop()
splash_container$remove()
if (inherits(splash_container, "stevedore_object")) {
splash_container$stop()
splash_container$remove()
}
invisible(NULL)
}
@ -90,7 +116,9 @@ stop_splash <- function(splash_container) {
killall_splash <- function() {
docker <- stevedore::docker_client()
x <- docker$container$list(all=TRUE)
for (i in 1:nrow(x)) {
if (grepl("bin/splash", x$command[i])) {
message(sprintf("Pruning: %s...", x$id[i]))
@ -101,6 +129,7 @@ killall_splash <- function() {
}
}
}
}

90
R/utils-safely.R

@ -0,0 +1,90 @@
# Less cool counterparts to purrr's side-effect capture-rs
#
# Most of the helper functions are 100% from output.R in purrr repo
#
# @param quiet Hide errors (`TRUE`, the default), or display them
# as they occur?
# @param otherwise Default value to use when an error occurs.
#
# @return `safely`: wrapped function instead returns a list with
# components `result` and `error`. One value is always `NULL`.
#
# `quietly`: wrapped function instead returns a list with components
# `result`, `output`, `messages` and `warnings`.
#
# `possibly`: wrapped function uses a default value (`otherwise`)
# whenever an error occurs.
safely <- function(.f, otherwise = NULL, quiet = TRUE) {
function(...) capture_error(.f(...), otherwise, quiet)
}
quietly <- function(.f) {
function(...) capture_output(.f(...))
}
possibly <- function(.f, otherwise, quiet = TRUE) {
force(otherwise)
function(...) {
tryCatch(.f(...),
error = function(e) {
if (!quiet)
message("Error: ", e$message)
otherwise
},
interrupt = function(e) {
stop("Terminated by user", call. = FALSE)
}
)
}
}
capture_error <- function(code, otherwise = NULL, quiet = TRUE) {
tryCatch(
list(result = code, error = NULL),
error = function(e) {
if (!quiet)
message("Error: ", e$message)
list(result = otherwise, error = e)
},
interrupt = function(e) {
stop("Terminated by user", call. = FALSE)
}
)
}
capture_output <- function(code) {
warnings <- character()
wHandler <- function(w) {
warnings <<- c(warnings, w$message)
invokeRestart("muffleWarning")
}
messages <- character()
mHandler <- function(m) {
messages <<- c(messages, m$message)
invokeRestart("muffleMessage")
}
temp <- file()
sink(temp)
on.exit({
sink()
close(temp)
})
result <- withCallingHandlers(
code,
warning = wHandler,
message = mHandler
)
output <- paste0(readLines(temp, warn = FALSE), collapse = "\n")
list(
result = result,
output = output,
warnings = warnings,
messages = messages
)
}

3
man/install_splash.Rd

@ -9,6 +9,9 @@ install_splash(tag = "latest")
\arguments{
\item{tag}{Splash Docker image tag to install}
}
\value{
a \code{docker_image} object or \code{NULL} if an error occurred.
}
\description{
Retrieve the Docker image for Splash
}

2
man/start_splash.Rd

@ -18,7 +18,7 @@ Defaults to `FALSE`.}
\item{...}{passed on to Splash instance launch parameters}
}
\value{
`stevedor` container object
`stevedore` container object
}
\description{
If using this in an automation context, you should consider adding a

Načítá se…
Zrušit
Uložit