fail gracefully on server fail (#4)

* fail gracefully if not conecting to server

* strip xml2

* dont use ping, use dontrun

* update check action

* add cran comments2

* bump version

* update news

* fix readme urls

* examples on interactive

* reduce example

* use httr2, fail gracefully

* dont error on httr fail,

.Rbuildignore

@@ -5,3 +5,4 @@
 ^\.github$
 ^cran-comments\.md$
 ^CRAN-RELEASE$
+^CRAN-SUBMISSION$

.github/workflows/R-CMD-check.yaml

@@ -5,38 +5,22 @@ on:
     branches: [main, master]
   pull_request:
     branches: [main, master]
+  schedule:
+    - cron: '00 1 * * 1'
 
 name: R-CMD-check
 
 jobs:
   R-CMD-check:
-    runs-on: ${{ matrix.config.os }}
-
-    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
-
-    strategy:
-      fail-fast: false
-      matrix:
-        config:
-          - {os: macos-latest,   r: 'release'}
-          - {os: windows-latest, r: 'release'}
-          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
-          - {os: ubuntu-latest,   r: 'release'}
-          - {os: ubuntu-latest,   r: 'oldrel-1'}
-
+    runs-on: ubuntu-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
       R_KEEP_PKG_SOURCE: yes
-
     steps:
       - uses: actions/checkout@v3
 
-      - uses: r-lib/actions/setup-pandoc@v2
-
       - uses: r-lib/actions/setup-r@v2
         with:
-          r-version: ${{ matrix.config.r }}
-          http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
       - uses: r-lib/actions/setup-r-dependencies@v2
@@ -45,5 +29,3 @@ jobs:
           needs: check
 
       - uses: r-lib/actions/check-r-package@v2
-        with:
-          upload-snapshots: true

CRAN-SUBMISSION

@@ -0,0 +1,4 @@
+Version: 0.1.4
+Date: 2023-09-07 19:55:56 UTC
+SHA:
+    d0cf9e1372771e89b74a37c0ea69e75934b91d26

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: colorhex
 Type: Package
 Title: Colors and Palettes from Color-Hex
-Version: 0.1.2
+Version: 0.1.4
 Authors@R: c(
             person("Athanasia Mo", "Mowinckel", 
                     email = "a.m.mowinckel@psykologi.uio.no", 
@@ -19,14 +19,16 @@ Description: The website <https://www.color-hex.com> is a great resource of hex
 License: MIT + file LICENSE
 Encoding: UTF-8
 Imports: 
-    rvest,
-    xml2,
-    grDevices,
+    cli,
+    curl,
+    ggplot2,
     graphics,
-    ggplot2
-RoxygenNote: 7.1.1
-URL: https://github.com/Athanasiamo/colorhex
-BugReports: https://github.com/Athanasiamo/colorhex/issues
+    grDevices,
+    httr2,
+    rvest
+RoxygenNote: 7.2.3
+URL: https://github.com/drmowinckels/colorhex
+BugReports: https://github.com/drmowinckels/colorhex/issues
 Suggests: 
     spelling,
     scales

NEWS.md

@@ -1,3 +1,7 @@
+
+# colorhex 0.1.4
+- fixes failure of build if server is unresponsive
+
 # colorhex 0.1.1
 - cran submission
 

R/api.R

@@ -0,0 +1,35 @@
+query_colorhex <- function(){
+  if(!curl::has_internet()){
+    cli::cli_alert_warning("Not connected to internet.")
+    return(invisible(NULL))
+  }
+  req <- httr2::request(colour_url())
+  req <- httr2::req_retry(req,
+                          backoff = ~ 10,
+                          is_transient = ~ httr2::resp_status(.x) > 400)
+  req <- httr2::req_error(req,
+                   is_error = function(resp) FALSE,
+                   body = error_body)
+  req
+}
+
+colour_url <- function(full = TRUE){
+  url <- "www.color-hex.com"
+  if(!full)
+    return(url)
+  paste0("https://", url, "/")
+}
+
+error_body <- function(resp) {
+  httr2::resp_body_json(resp)$error
+}
+
+status_ok <- function(req){
+  test <- httr2::req_perform(req)
+  if(httr2::resp_status(test) > 400 ){
+    cli::cli_alert_warning("Cannot connect to service.")
+    cli::cli_inform(httr2::resp_status_desc(test))
+    return(FALSE)
+  }
+  TRUE
+}

R/color.R

@@ -8,13 +8,24 @@
 #' @export
 #'
 #' @examples
+#' if(curl::has_internet()){
 #' get_popular_colors()
+#' }
 get_popular_colors <- function(){
-  url <- paste0(colour_url(), "popular-colors.php")
-  resp <- xml2::read_html(url)
-
-  cols <- rvest::html_nodes(resp,
-                            xpath = '//*[@class="colordva"]')
+  req <- httr2::request(colour_url())
+  if(is.null(req))
+    return(invisible(NULL))
+  req <- httr2::req_url_path_append(
+    req,
+    "popular-colors.php")
+  if(!status_ok(req))
+    return(invisible(NULL))
+
+  resp <- httr2::req_perform(req)
+  resp <- httr2::resp_body_html(resp)
+  cols <- rvest::html_nodes(
+    resp,
+    xpath = '//*[@class="colordva"]')
   cols <- as.character(cols)
   get_bkg_color(cols)
 }
@@ -33,10 +44,6 @@ get_random_color <- function(){
                  maxColorValue = 255)
 }
 
-randcol <- function(){
-  sample(1:255, 1)
-}
-
 #' Get color information
 #'
 #' Get color information from www.color-hex.com
@@ -48,19 +55,28 @@ randcol <- function(){
 #' @export
 #'
 #' @examples
+#' if(curl::has_internet()){
 #' get_color("#470f0f")
-#' get_color("#f2f2f2")
+#' }
 get_color <- function(hex){
   hex <- fix_hex(hex)
-  stopifnot(is_hex(hex))
+  req <- query_colorhex()
+  if(is.null(req))
+    return(invisible(NULL))
 
-  url <- paste0(colour_url(), "color/", gsub("#", "", hex))
+  req <- httr2::req_url_path_append(
+    req,
+    "color",
+    gsub("^#", "", hex))
 
-  resp <- xml2::read_html(url)
-  tables <- rvest::html_nodes(resp, "table")
+  if(!status_ok(req))
+    return(invisible(NULL))
 
-  prim <- rvest::html_table(tables[1], fill = TRUE)[[1]]
-  prim <- as.data.frame(t(prim))
+  resp <- httr2::req_perform(req)
+  resp <- httr2::resp_body_html(resp)
+  tables <- rvest::html_nodes(resp, "table")
+  tables <- lapply(tables, rvest::html_table, fill = TRUE)
+  prim <- as.data.frame(t(tables[[1]]))
   names(prim) <- as.character(unlist(prim[1,]))
   row.names(prim) <- NULL
   prim <- prim[-1,]
@@ -69,12 +85,12 @@ get_color <- function(hex){
                             xpath = '//*[@class="colordvconline"]')
   rows <- rvest::html_text(rows)
   rows <- gsub(" \n", "", rows)
-  rows <- fix_hex(rows)
+  rows <- sapply(rows, fix_hex)
 
   ret <- list(
     hex = hex,
     space = prim,
-    base = rvest::html_table(tables[2], fill = TRUE)[[1]],
+    base = tables[[2]],
     triadic = NA_character_,
     analogous = NA_character_,
     complementary = NA_character_,
@@ -85,9 +101,13 @@ get_color <- function(hex){
   )
 
   if(length(tables) > 2){
-    ret$triadic = fix_hex(chartable(tables[3]))
-    ret$analogous = fix_hex(chartable(tables[4]))
-    ret$complementary = fix_hex(chartable(tables[5]))
+    ex <- lapply(3:5, function(x){
+      j <- unique(unlist(tables[[x]]))
+      sapply(j[j!=""], fix_hex)
+    })
+    ret$triadic = ex[[1]]
+    ret$analogous = ex[[2]]
+    ret$complementary = ex[[3]]
   }
 
   colorhex(ret)

R/palette.R

@@ -7,45 +7,49 @@
 #' @export
 #'
 #' @examples
+#' if(curl::has_internet()){
 #' get_latest_palettes()
+#' }
 get_latest_palettes <- function(){
-  url <- paste0(colour_url(), "color-palettes/")
-  resp <- xml2::read_html(url)
+  req <- query_colorhex()
+  if(is.null(req))
+    return(invisible(NULL))
+  req <- httr2::req_url_path_append(
+    req, "color-palettes")
+  if(!status_ok(req))
+    return(invisible(NULL))
+  resp <- httr2::req_perform(req)
+  resp <- httr2::resp_body_html(resp)
   get_pals(resp)
 }
 
 #' Get most popular palettes
 #'
 #' Retrieve the palettes most users have
-#' checked as favourites from www.color-hex.com
+#' checked as favorites from www.color-hex.com
 #'
 #' @return data.frame with name, id and colours
 #' @export
 #'
 #' @examples
+#' if(curl::has_internet()){
 #' get_popular_palettes()
+#' }
 get_popular_palettes <- function(){
-  url <- paste0(colour_url(), "color-palettes/popular.php")
-  resp <- xml2::read_html(url)
+  req <- query_colorhex()
+  if(is.null(req))
+    return(invisible(NULL))
+  req <- httr2::req_url_path_append(
+    req,
+    "color-palettes",
+    "popular.php")
+  if(!status_ok(req))
+    return(invisible(NULL))
+  resp <- httr2::req_perform(req)
+  resp <- httr2::resp_body_html(resp)
   get_pals(resp)
 }
 
-get_pal <- function(id){
-  url <- paste0(colour_url(), "color-palette/", id)
-  resp <- xml2::read_html(url)
-
-  tables <- rvest::html_nodes(resp, "table")
-  tables <- rvest::html_table(tables[1], fill = TRUE)[[1]]
-
-
-  palettehex(
-    gsub(" Color Palette", "",
-         rvest::html_text(rvest::html_nodes(resp, "h1"))),
-    id,
-    list(tables[,2])
-  )
-}
-
 #' Get palettes from id
 #'
 #' Get palette information from www.color-hex.com
@@ -57,11 +61,13 @@ get_pal <- function(id){
 #' @export
 #'
 #' @examples
+#' if(curl::has_internet()){
 #' get_palette(103107)
 #'
 #' # Lookup multiple palettes
 #' id <- c(103161, 103107)
 #' get_palette(id)
+#' }
 get_palette <- function(id){
   x <- lapply(id, get_pal)
   do.call(rbind, x)
@@ -95,6 +101,31 @@ plot.palettehex <- function(x, ...){
 }
 
 # helpers ----
+
+get_pal <- function(id){
+  req <- query_colorhex()
+  if(is.null(req))
+    return(invisible(NULL))
+  req <- httr2::req_url_path_append(
+    req,
+    "color-palette",
+    id)
+  if(!status_ok(req))
+    return(invisible(NULL))
+  resp <- httr2::req_perform(req)
+  resp <- httr2::resp_body_html(resp)
+
+  tables <- rvest::html_nodes(resp, "table")
+  tables <- rvest::html_table(tables[1], fill = TRUE)[[1]]
+
+  palettehex(
+    gsub(" Color Palette", "",
+         rvest::html_text(rvest::html_nodes(resp, "h1"))),
+    id,
+    list(tables[,2])
+  )
+}
+
 get_pals <- function(resp, class = "palettecontainerlist"){
   path <- paste0('//*[@class="',class, '"]')
   pal <- rvest::html_nodes(resp, xpath = path)

R/scale_colorhex.R

@@ -18,6 +18,7 @@
 #' @name scale-colorhex
 #' @return a ggplot2-proto
 #' @examples
+#' if(curl::has_internet()){
 #' library(ggplot2)
 #'
 #' x <- get_color("#008080")
@@ -41,6 +42,7 @@
 #' ggplot(mtcars, aes(mpg, disp, colour = factor(cyl))) +
 #'    geom_point() +
 #'    scale_color_colorhex_d(x, "shades")
+#'  }
 NULL
 #> NULL
 

R/scale_palettehex.R

@@ -17,6 +17,7 @@
 #' @name scale-palettehex
 #' @return ggplot2-proto
 #' @examples
+#' if(curl::has_internet()){
 #' library(ggplot2)
 #'
 #' x <- get_popular_palettes()
@@ -36,6 +37,7 @@
 #' ggplot(mtcars, aes(mpg, disp, colour = factor(cyl))) +
 #'    geom_point() +
 #'    scale_color_palettehex_d(x, 1872)
+#' }
 NULL
 #> NULL