R/time.R

In httping: 'Ping' 'URLs' to Time 'Requests'

#' Ping a url to time the request
#'
#' @export
#'
#' @param .request A \pkg{httr} response object
#' @param count integer, Number of requests to do.
#' @param delay integer, Seconds to delay successive calls by. Default:
#' 0.5 seconds.
#' @param flood logical; If `TRUE`, no delay between requests. If `FALSE`,
#' delay by 0.5
#' second.
#' @param verbose logical; If `TRUE`, print progress.
#' @param ... Further args passed on to functions in \pkg{httr}
#' @examples \dontrun{
#' GET("https://mockbin.com/request") %>% time()
#' GET("https://api.github.com") %>% time()
#' GET("http://google.com") %>% time()
#' }

time <- function(
  .request,
  count = 10,
  delay = 0.5,
  flood = FALSE,
  verbose = TRUE,
  ...
) {
  stopifnot(is(.request, "response"))
  if (flood) {
    delay <- 0
  } else {
    stopifnot(is(as.numeric(delay), "numeric"))
  }
  if (verbose) {
    cat(
      sprintf(
        "%s kb - %s code:%s time(ms):%s",
        get_kb(.request),
        .request$url,
        .request$status_code,
        .request$times[["total"]] * 1000
      ),
      sep = "\n"
    )
  }
  if (count < 2) {
    stop("count parameter must be greater than 1", call. = FALSE)
  }
  if (count > 1) {
    count_ <- count - 1
  }
  reps <- replicate(
    count_,
    rerequest_(.request, delay, verbose),
    simplify = FALSE
  )
  all <- do.call(c, list(list(.request), reps))
  times <- pluck(all, "times")
  nmz <- names(times[[1]])
  avgs <- setNames(
    lapply(nmz, function(z) {
      tt <- pluck(times, z, double(1))
      setNames(
        sapply(list(min, max, mean), function(x) calc(tt, x)),
        c("min", "max", "mean")
      )
    }),
    nmz
  )
  structure(
    list(times = times, averages = avgs, request = .request),
    count = count,
    delay = delay,
    class = "http_time"
  )
}

calc <- function(x, fxn) format(fxn(x * 1000, na.rm = TRUE), scientific = FALSE)

rerequest_ <- function(x, delay, verbose = TRUE) {
  Sys.sleep(delay)
  tmp <- rerequest(x)
  if (verbose) {
    cat(
      sprintf(
        "%s kb - %s code:%s time(ms):%s",
        get_kb(tmp),
        tmp$url,
        tmp$status_code,
        tmp$times[["total"]] * 1000
      ),
      sep = "\n"
    )
  }
  return(tmp)
}

get_kb <- function(x) (lobstr::obj_size(x) / 1000)[[1]]

#' @export
print.http_time <- function(x, ...) {
  cat("<http time>", sep = "\n")
  cat(paste0("  Avg. min (ms):  ", x$averages[['total']][['min']]), sep = "\n")
  cat(paste0("  Avg. max (ms):  ", x$averages[['total']][['max']]), sep = "\n")
  cat(paste0("  Avg. mean (ms): ", x$averages[['total']][['mean']]), sep = "\n")
}

#' @export
summary.http_time <- function(object, ...) {
  cat("<http time, averages (min max mean)>", sep = "\n")
  cat(
    paste0("  Total (s):           ", p0(object$averages[['total']])),
    sep = "\n"
  )
  cat(
    paste0("  Tedirect (s):        ", p0(object$averages[['redirect']])),
    sep = "\n"
  )
  cat(
    paste0("  Namelookup time (s): ", p0(object$averages[['namelookup']])),
    sep = "\n"
  )
  cat(
    paste0("  Connect (s):         ", p0(object$averages[['connect']])),
    sep = "\n"
  )
  cat(
    paste0("  Pretransfer (s):     ", p0(object$averages[['pretransfer']])),
    sep = "\n"
  )
  cat(
    paste0("  Starttransfer (s):   ", p0(object$averages[['starttransfer']])),
    sep = "\n"
  )
}

p0 <- function(x) paste0(x, collapse = " ")