diff --git a/DESCRIPTION b/DESCRIPTION index b39c117..e17f32a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,6 +19,8 @@ Description: The website is a great resource of hex License: MIT + file LICENSE Encoding: UTF-8 Imports: + cli, + curl, ggplot2, graphics, grDevices, @@ -28,7 +30,6 @@ RoxygenNote: 7.2.3 URL: https://github.com/drmowinckels/colorhex BugReports: https://github.com/drmowinckels/colorhex/issues Suggests: - curl, spelling, scales Language: en-US diff --git a/R/api.R b/R/api.R index 98046d7..7c2f7c8 100644 --- a/R/api.R +++ b/R/api.R @@ -1,7 +1,16 @@ 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) - httr2::req_error(req, is_error = function(resp) FALSE) + 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){ @@ -11,3 +20,16 @@ colour_url <- function(full = TRUE){ 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 +} diff --git a/R/color.R b/R/color.R index 6b78aaa..0e43285 100644 --- a/R/color.R +++ b/R/color.R @@ -13,10 +13,14 @@ #' } get_popular_colors <- function(){ req <- httr2::request(colour_url()) + if(is.null(req)) + return(invisible(NULL)) req <- httr2::req_url_path_append( - req, + 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( @@ -56,33 +60,37 @@ get_random_color <- function(){ #' } get_color <- function(hex){ hex <- fix_hex(hex) - stopifnot(is_hex(hex)) req <- query_colorhex() + if(is.null(req)) + return(invisible(NULL)) + req <- httr2::req_url_path_append( - req, + req, "color", - gsub("#", "", hex)) - + gsub("^#", "", hex)) + + if(!status_ok(req)) + return(invisible(NULL)) + resp <- httr2::req_perform(req) resp <- httr2::resp_body_html(resp) tables <- rvest::html_nodes(resp, "table") - - prim <- rvest::html_table(tables[1], fill = TRUE)[[1]] - prim <- as.data.frame(t(prim)) + 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,] - + rows <- rvest::html_nodes(resp, 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_, @@ -91,13 +99,17 @@ get_color <- function(hex){ related = rows[22:length(rows)], palettes = get_pals(resp, "palettecontainerlist narrow") ) - + 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) } @@ -107,7 +119,7 @@ colorhex <- function(x){ "complementary", "analogous", "triadic", "shades", "tints", "related", "palettes")) - + structure( x, class = "colorhex" @@ -139,18 +151,18 @@ plot.colorhex <- function(x, "analogous", "shades", "tints", "related"), labels = TRUE, ...){ - + type <- match.arg(type, c("complementary", "triadic", "analogous", "shades", "tints", "related"), several.ok = TRUE) - + x <- lapply(type, function(y) if(y != "hex") c(x$hex, x[[y]]) else x[[y]]) names(x) <- type - + ncols <- length(type) nrows <- max(sapply(x, length))+.5 - + oldpar <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(oldpar)) graphics::par(mar = c(0, 0, 0, 0)) @@ -159,7 +171,7 @@ plot.colorhex <- function(x, type = "n", xlab = "", ylab = "", axes = FALSE ) - + for(i in 1:length(type)){ tmp <- x[[type[i]]] graphics::text(1, i, type[i], cex = 1, pos = 2) @@ -171,5 +183,5 @@ plot.colorhex <- function(x, } } } - + } diff --git a/R/palette.R b/R/palette.R index 4ccc908..79b0b7a 100644 --- a/R/palette.R +++ b/R/palette.R @@ -12,8 +12,12 @@ #' } get_latest_palettes <- function(){ req <- query_colorhex() + if(is.null(req)) + return(invisible(NULL)) req <- httr2::req_url_path_append( - req, "color-palettes/") + req, "color-palettes") + if(!status_ok(req)) + return(invisible(NULL)) resp <- httr2::req_perform(req) resp <- httr2::resp_body_html(resp) get_pals(resp) @@ -33,35 +37,19 @@ get_latest_palettes <- function(){ #' } get_popular_palettes <- function(){ req <- query_colorhex() + if(is.null(req)) + return(invisible(NULL)) req <- httr2::req_url_path_append( - req, + 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){ - req <- query_colorhex() - req <- httr2::req_url_path_append( - req, - "color-palette", - id) - 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 palettes from id #' #' Get palette information from www.color-hex.com @@ -113,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) diff --git a/R/utils.R b/R/utils.R index 4eef569..e34308e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -38,10 +38,13 @@ get_bkg_color <- function(x){ x <- sapply(x, function(x) x[2]) x <- gsub(';|\\\">|| ', '', x) - fix_hex(x) + sapply(x, fix_hex) } fix_hex <- function(x){ + if(!is_hex(x)){ + cli::cli_abort("'{x}' is not a valid hexidecimal colour.") + } indx <- ifelse(nchar(x) == 4, TRUE, FALSE) x[indx] <- paste0(x[indx], gsub("#", "", x[indx]))