Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Vectorize functions #3

Merged
merged 4 commits into from
Jan 22, 2024
Merged
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
Vectorize resmush_url()
dieghernan committed Jan 22, 2024
commit abfbbf6c634303e77abcd7833e74c0a6c879bb68
3 changes: 3 additions & 0 deletions .Rbuildignore
Original file line number Diff line number Diff line change
@@ -19,3 +19,6 @@
^data-raw$
^docs$
^dev$
^resmush\.Rcheck$
^resmush.*\.tar\.gz$
^resmush.*\.tgz$
25 changes: 14 additions & 11 deletions R/resmush_file.R
Original file line number Diff line number Diff line change
@@ -6,27 +6,30 @@
#' **Note that** the default parameters of the function `outfile = file`
#' **overwrites** the local file. See **Examples**.
#'
#' @param file Path or paths to a local file. **reSmush** can optimize the
#' @param file Path or paths to local files. **reSmush** can optimize the
#' following image files:
#' * `png`
#' * `jpg`
#' * `gif`
#' * `bmp`
#' * `tif`
#' @param outfile Path or paths where the optimized file would be store in
#' @param outfile Path or paths where the optimized files would be store in
#' your disk. By default, it would override the file specified in `file`. It
#' should be of the same length than `file` parameter.
#' @param qlty Only affects `jpg` files. Integer between 0 and 100 indicating
#' the optimization level. For optimal results use vales above 90.
#' @param verbose Logical. If `TRUE` displays a summary of the results.
#' @param exif_preserve Logical. Should be the
#' [Exif](https://en.wikipedia.org/wiki/Exif) information removed as well?
#' @param exif_preserve Logical. Should the
#' [Exif](https://en.wikipedia.org/wiki/Exif) information (if any) deleted?
#' Default is to remove (i.e. `exif_preserve = FALSE`).
#' @return
#' Writes on disk the optimized file if the API call is successful.
#' In any case, a (invisibly) data frame with a summary of the process is
#' returned as well.
#'
#' If any value of the vector `outfile` is duplicated, `resmush_file()` would
#' rename the output with a suffix `_1. _2`, etc.
#'
#' @seealso
#' [reSmush.it API](https://resmush.it/api) docs.
#'
@@ -73,19 +76,19 @@ resmush_file <- function(file, outfile = file, qlty = 92, verbose = FALSE,
l2 <- length(outfile)

if (l1 != l2) {
cli::cli_abort(
paste0(
"Lengths of {.arg file} and {.arg outfile}",
"should be the same ",
"({l1} vs. {l2})"
)
)
cli::cli_abort(paste0(
"Lengths of {.arg file} and {.arg outfile}",
"should be the same ({l1} vs. {l2})"
))
}


# Once checked call single
iter <- seq_len(l1)

# Make unique paths
outfile <- make_unique_paths(outfile)

res_vector <- lapply(iter, function(x) {
df <- resmush_file_single(
file[x], outfile[x],
70 changes: 59 additions & 11 deletions R/resmush_url.R
Original file line number Diff line number Diff line change
@@ -4,23 +4,28 @@
#' Optimize and download an online image using the
#' [reSmush.it API](https://resmush.it/).
#'
#' @param url url to a hosted file. **reSmush** can optimize the
#' following image files:
#' @param url url or a vector of urls pointing to hosted image files.
#' **reSmush** can optimize the following image files:
#' * `png`
#' * `jpg`
#' * `gif`
#' * `bmp`
#' * `tif`
#' @param outfile Path where the optimized file would be store in your disk. By
#' default, a temporary file (see [tempfile()]) with the same [basename()] than
#' the file provided in url would be created.
#' @param outfile Path or paths where the optimized files would be store in
#' your disk. By default, temporary files (see [tempfile()]) with the same
#' [basename()] than the file provided in `url` would be created. It should be
#' of the same length than `url` parameter.
#' @inheritParams resmush_file
#'
#' @return
#' Writes on disk the optimized file if the API call is successful.
#' In any case, a (invisibly) data frame with a summary of the process is
#' returned as well.
#'
#' If any value of the vector `outfile` is duplicated, `resmush_url()` would
#' rename the output with a suffix `_1. _2`, etc.
#'
#'
#' @seealso
#' [reSmush.it API](https://resmush.it/api) docs.
#'
@@ -36,20 +41,63 @@
#' base_url <- "https://raw.githubusercontent.com/dieghernan/resmush/main/inst/"
#'
#' png_url <- paste0(base_url, "/extimg/example.png")
#' resmush_url(png_url)
#'
#' # Silently returns a data frame
#' png_res <- resmush_url(png_url)
#' png_res
#'
#' # Use with jpg and parameters
#' # Several urls
#' jpg_url <- paste0(base_url, "/extimg/example.jpg")
#'
#' # Silently returns a data frame
#'
#' summary <- resmush_url(c(png_url, jpg_url))
#'
#' # Returns an (invisible) data frame with a summary of the process
#' summary
#'
#' # Use with jpg and parameters
#' resmush_url(jpg_url, verbose = TRUE)
#' resmush_url(jpg_url, verbose = TRUE, qlty = 10)
#' }
resmush_url <- function(url, outfile = file.path(tempdir(), basename(url)),
qlty = 92, verbose = FALSE, exif_preserve = FALSE) {
# High level function for vectors

# Check lengths
l1 <- length(url)
l2 <- length(outfile)

if (l1 != l2) {
cli::cli_abort(paste0(
"Lengths of {.arg url} and {.arg outfile}",
"should be the same ({l1} vs. {l2})"
))
}


# Once checked call single
iter <- seq_len(l1)

# Make unique paths
outfile <- make_unique_paths(outfile)

res_vector <- lapply(iter, function(x) {
df <- resmush_url_single(
url[x], outfile[x],
qlty, verbose, exif_preserve
)
df
})

# Bind and output
df_end <- do.call("rbind", res_vector)

return(invisible(df_end))
}



resmush_url_single <- function(url,
outfile = file.path(tempdir(), basename(url)),
qlty = 92, verbose = FALSE,
exif_preserve = FALSE) {
# Master table with results
res <- data.frame(
src_img = url, dest_img = NA, src_size = NA,
55 changes: 55 additions & 0 deletions R/utils.R
Original file line number Diff line number Diff line change
@@ -5,6 +5,61 @@ make_object_size <- function(x) {
x
}

# Handle names
make_unique_paths <- function(x, res) {
dir_file <- dirname(x)
base_names <- basename(x)

res <- character(length = length(base_names))
iter <- seq_len(length(base_names))


for (i in iter) {
this_file <- base_names[i]

if (!this_file %in% res) {
res[i] <- this_file
next
}
newname <- name_sans_ext(this_file)
ext <- my_file_ext(this_file)

for (j in seq(1, 100)) {
f <- paste0(newname, "_", j, ext)
if (!f %in% res) {
res[i] <- f
break
}
}
}

file.path(dir_file, res)
}

name_sans_ext <- function(x) {
sans_ext <- vapply(x, FUN = function(y) {
name_parts <- unlist(strsplit(y, ".", fixed = TRUE))

paste0(name_parts[-length(name_parts)], collapse = ".")
}, FUN.VALUE = character(1))

unname(sans_ext)
}



my_file_ext <- function(x) {
ext_only <- vapply(x, FUN = function(y) {
name_parts <- unlist(strsplit(y, ".", fixed = TRUE))

paste0(".", name_parts[length(name_parts)])
}, FUN.VALUE = character(1))

unname(ext_only)
}



# Utils for testing
load_inst_to_temp <- function(file) {
f <- system.file(paste0("extimg/", file), package = "resmush")
2 changes: 1 addition & 1 deletion codemeta.json
Original file line number Diff line number Diff line change
@@ -107,7 +107,7 @@
},
"SystemRequirements": null
},
"fileSize": "449.964KB",
"fileSize": "457.461KB",
"releaseNotes": "https://github.com/dieghernan/resmush/blob/master/NEWS.md",
"readme": "https://github.com/dieghernan/resmush/blob/main/README.md",
"contIntegration": ["https://github.com/dieghernan/resmush/actions/workflows/check-full.yaml", "https://app.codecov.io/gh/dieghernan/resmush"],
11 changes: 7 additions & 4 deletions man/resmush_file.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

33 changes: 20 additions & 13 deletions man/resmush_url.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

8 changes: 8 additions & 0 deletions tests/testthat/_snaps/remush_url.md
Original file line number Diff line number Diff line change
@@ -73,3 +73,11 @@
notes
1 403: Unauthorized extension. Allowed are : JPG, PNG, GIF, BMP, TIFF, WEBP

# Test errors in lengths

Code
dm <- resmush_url(two_input, several_outputs)
Condition
Error in `resmush_url()`:
! Lengths of `url` and `outfile`should be the same (2 vs. 3)

151 changes: 151 additions & 0 deletions tests/testthat/test-remush_url.R
Original file line number Diff line number Diff line change
@@ -178,3 +178,154 @@ test_that("Test qlty par with jpg", {

expect_lt(out2s, outs)
})



test_that("Test errors in lengths", {
skip_on_cran()

png_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.png"
)

jpg_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.jpg"
)

two_input <- c(png_url, jpg_url)
several_outputs <- LETTERS[1:3]

expect_snapshot(
dm <- resmush_url(two_input, several_outputs),
error = TRUE
)
})

test_that("Test full vectors without outfile", {
skip_on_cran()
skip_if_offline()

# No url
turl <- "https://dieghernan.github.io/aaabbbccc.png"


# Not valid
notval <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/README.md"
)

png_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.png"
)

jpg_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.jpg"
)

all_in <- c(png_url, notval, jpg_url, turl)

expect_message(
dm <- resmush_url(all_in),
"API Error"
)

expect_equal(nrow(dm), 4)
expect_equal(dm$src_img, all_in)

is.na(dm$dest_img)
expect_equal(is.na(dm$dest_img), c(FALSE, TRUE, FALSE, TRUE))
})


test_that("Test full vectors with outfile", {
skip_on_cran()
skip_if_offline()

# No url
turl <- "https://dieghernan.github.io/aaabbbccc.png"


# Not valid
notval <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/README.md"
)

png_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.png"
)

jpg_url <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.jpg"
)

all_in <- c(png_url, notval, jpg_url, turl)

all_outs <- c(
tempfile(fileext = ".png"),
tempfile(fileext = ".png"),
tempfile(fileext = ".jpg"),
tempfile(fileext = ".png")
)

expect_length(unique(all_outs), 4)

expect_message(
dm <- resmush_url(all_in, all_outs),
"API Error"
)

expect_equal(nrow(dm), 4)
expect_equal(dm$src_img, all_in)
expect_equal(dm$dest_img, c(all_outs[1], NA, all_outs[3], NA))

expect_true(all(file.exists(all_outs[c(1, 3)])))
})


test_that("Handle duplicate names", {
skip_on_cran()
skip_if_offline()

png_url_single <- paste0(
"https://raw.githubusercontent.com/",
"dieghernan/resmush/main/inst/",
"extimg/example.png"
)

png_url <- rep(png_url_single, 2)

outs <- file.path(tempdir(), basename(png_url))

if (any(file.exists(outs))) unlink(outs, force = TRUE)

expect_false(file.exists(outs[1]))

# But should be renamed as
renamed <- file.path(tempdir(), "example_1.png")
if (any(file.exists(renamed))) unlink(renamed, force = TRUE)
expect_false(file.exists(renamed))

# Call
expect_silent(dm <- resmush_url(png_url, outs))

# Check that now exists
expect_true(file.exists(renamed))

expect_equal(nrow(dm), 2)
expect_equal(dm$src_img, png_url)
expect_equal(dm$dest_img, c(outs[1], renamed))
})
26 changes: 26 additions & 0 deletions tests/testthat/test-resmush_file.R
Original file line number Diff line number Diff line change
@@ -262,3 +262,29 @@ test_that("Test full vectors with outfile", {

expect_true(all(file.exists(all_outs[c(1, 3)])))
})


test_that("Handle duplicate names", {
skip_on_cran()
skip_if_offline()

png_file <- rep(load_inst_to_temp("example.png"), 2)

outs <- rep(tempfile(fileext = "_local_nodup.png"), 2)

expect_false(file.exists(outs[1]))

# But should be renamed as
renamed <- gsub("local_nodup", "local_nodup_1", outs[1])
expect_false(file.exists(renamed))

# Call
expect_silent(dm <- resmush_file(png_file, outs))

# Check that now exists
expect_true(file.exists(renamed))

expect_equal(nrow(dm), 2)
expect_equal(dm$src_img, png_file)
expect_equal(dm$dest_img, c(outs[1], renamed))
})
37 changes: 37 additions & 0 deletions tests/testthat/test-utils.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,37 @@
test_that("Handle duplicate names", {
unique_names <- c("./a/example.png", "b/example.jpg")
expect_length(unique(unique_names), 2)


same_res <- make_unique_paths(unique_names)

expect_identical(unique_names, same_res)

# More extensions
nodups <- c("./test.png", "./test.png.jpg", "./test.jpg", "./test.jpg.png")

same_res2 <- make_unique_paths(nodups)
expect_identical(nodups, same_res2)

# With duplicates

complex <- c(
"./a/example.png", "b/example.jpg", "cd/example.png",
"ss/example.jpg", "ffaa/example.png",
"a/a file with blak spaces.txt"
)

expect_false(length(unique(basename(complex))) == length(complex))

handle_complex <- make_unique_paths(complex)

expect_length(unique(basename(handle_complex)), length(handle_complex))


expect_true(all((complex == handle_complex)[c(1, 2, 6)]))

expect_identical(
basename(handle_complex)[-c(1, 2, 6)],
c("example_1.png", "example_1.jpg", "example_2.png")
)
})