Browse Source

removed purrr/dplyr deps & cran preflight check

master
boB Rudis 6 years ago
parent
commit
629ff8b96a
No known key found for this signature in database GPG Key ID: 1D7529BE14E2BBA9
  1. 4
      DESCRIPTION
  2. 6
      NAMESPACE
  3. 2
      NEWS.md
  4. 90
      R/a-utils-safely.R
  5. 3
      R/longurl-package.r
  6. 42
      R/longurl.r
  7. 5
      man/expand_urls.Rd

4
DESCRIPTION

@ -21,7 +21,5 @@ LazyData: true
Suggests:
testthat
Imports:
httr,
dplyr,
purrr
httr
RoxygenNote: 6.0.1.9000

6
NAMESPACE

@ -1,10 +1,4 @@
# Generated by roxygen2: do not edit by hand
export(expand_urls)
import(dplyr)
import(httr)
importFrom(purrr,map)
importFrom(purrr,map_chr)
importFrom(purrr,map_df)
importFrom(purrr,map_lgl)
importFrom(purrr,safely)

2
NEWS.md

@ -1,6 +1,8 @@
# longurl 0.3.2
* Ensure input is character before processing. (@JohnCoene, #4)
* Removed dplyr & purrr deps
* As a result of ^^ also removed progress bar
# longurl 0.3.1

90
R/a-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
R/longurl-package.r

@ -3,6 +3,5 @@
#' @name longurl
#' @docType package
#' @author Bob Rudis (bob@@rud.is)
#' @import httr dplyr
#' @importFrom purrr safely map map_df map_chr map_lgl
#' @import httr
NULL

42
R/longurl.r

@ -1,5 +1,5 @@
s_HEAD <- purrr::safely(httr::HEAD)
s_STATUS <- purrr::safely(httr::warn_for_status)
s_HEAD <- safely(httr::HEAD)
s_STATUS <- safely(httr::warn_for_status)
#' Expand a vector of (short) URLs using
#'
@ -12,8 +12,7 @@ s_STATUS <- purrr::safely(httr::warn_for_status)
#' @param agent user agent to use (some sites switchup content based on user agents).
#' Defaults to "`longurl-r-package`".
#' @param seconds number of seconds to wait for a response until giving up. Cannot be <1ms.
#' @param .progress display a progress bar (generally only useful in
#' interactive sesions)
#' @param .progress kept for legacy functionality but ignored
#' @return a tibble/data frame with the orignial URLs in `orig_url`, expanded URLs in
#' `expanded_url` and the HTTP `status_code` of the expanded URL. Completely
#' invalid URLs result in a `NA` value for `expanded_url` & `status_code`.
@ -28,31 +27,46 @@ expand_urls <- function(urls_to_expand,
warn = TRUE,
agent = "longurl-r-package",
seconds = 5,
.progress = interactive()) {
if (.progress) pb <- progress_estimated(length(urls_to_expand))
.progress = FALSE) {
urls_to_expand <- as.character(urls_to_expand)
purrr::map_df(urls_to_expand, function(x) {
if (.progress) pb$tick()$print()
lapply(urls_to_expand, function(x) {
res <- s_HEAD(x, httr::user_agent(agent), httr::timeout(seconds))
if (is.null(res$result)) {
warning(sprintf("Invalid URL: [%s]", x))
data_frame(orig_url = x, expanded_url = NA, status_code = NA)
data.frame(
orig_url = x,
expanded_url = NA_character_,
status_code = NA_character_,
stringsAsFactors = FALSE
)
} else {
sres <- s_STATUS(res$result)
if (is.null(sres$result)) {
warning("httr::warn_for_status() on HEAD request result")
data_frame(orig_url = x, expanded_url = NA, status_code = NA)
data.frame(
orig_url = x,
expanded_url = NA_character_,
status_code = NA_character_,
stringsAsFactors = FALSE
)
} else {
data_frame(orig_url = x, expanded_url = res$result$url, status_code = res$result$status_code)
data.frame(
orig_url = x,
expanded_url = res$result$url,
status_code = res$result$status_code,
stringsAsFactors = FALSE
)
}
}
})
}) -> xlst
xdf <- do.call(rbind.data.frame, xlst)
class(xdf) <- c("tbl_df", "tbl", "data.frame")
xdf
}

5
man/expand_urls.Rd

@ -5,7 +5,7 @@
\title{Expand a vector of (short) URLs using}
\usage{
expand_urls(urls_to_expand, warn = TRUE, agent = "longurl-r-package",
seconds = 5, .progress = interactive())
seconds = 5, .progress = FALSE)
}
\arguments{
\item{urls_to_expand}{character vector of URLs}
@ -17,8 +17,7 @@ Defaults to "\code{longurl-r-package}".}
\item{seconds}{number of seconds to wait for a response until giving up. Cannot be <1ms.}
\item{.progress}{display a progress bar (generally only useful in
interactive sesions)}
\item{.progress}{kept for legacy functionality but ignored}
}
\value{
a tibble/data frame with the orignial URLs in \code{orig_url}, expanded URLs in

Loading…
Cancel
Save