diff --git a/DESCRIPTION b/DESCRIPTION index e39fe4d..174464f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,8 +35,9 @@ LazyData: true RoxygenNote: 7.2.1 URL: https://thebioengineer.github.io/camcorder/, https://github.com/thebioengineer/camcorder BugReports: https://github.com/thebioengineer/camcorder/issues -Imports: +Imports: ggplot2, + S7 (>= 0.1.0), gifski, tools, magick, diff --git a/R/recording.R b/R/recording.R index 0fec4b0..49a19a3 100644 --- a/R/recording.R +++ b/R/recording.R @@ -182,7 +182,7 @@ plot_dim <- function(dim = c(NA, NA), from_inches <- function(x) x * c(`in` = 1, cm = 2.54,mm = 2.54 * 10, px = dpi)[units] dim <- to_inches(dim) * scale - if (any(is.na(dim))) { + if (anyNA(dim)) { if (length(grDevices::dev.list()) == 0) { default_dim <- c(7, 7) } else { diff --git a/R/shims.R b/R/shims.R index 386e865..1d90a75 100644 --- a/R/shims.R +++ b/R/shims.R @@ -1,4 +1,3 @@ - #' @importFrom rlang env_bind caller_env declare_lib_shims <- function(env = caller_env()){ env_bind(env, @@ -9,58 +8,149 @@ declare_lib_shims <- function(env = caller_env()){ #' @importFrom rlang env_unbind caller_env remove_lib_shims <- function(env = caller_env()){ - env_unbind( env, nms = c( "library", "require") ) + env_unbind(env, nms = c("library", "require")) } +#' Register camcorder shims for plot recording +#' +#' This function registers S7 methods for ggplot and patchwork print methods +#' to intercept plot printing and save them automatically. +#' +#' @return Used for side effects. Invisibly returns NULL. +#' @keywords internal register_camcorder_shims <- function(){ declare_lib_shims() - if("package:ggplot2" %in% search()){ - registerS3method( - genname = "print", - class = "ggplot", - method = "record_ggplot", - envir = getNamespace("camcorder") - ) + # Handle ggplot2 - check if it's loaded and if it uses S7 + if ("package:ggplot2" %in% search()) { + tryCatch({ + # Try S7 method registration first (ggplot2 >= 4.0.0) + if (packageVersion("ggplot2") >= "4.0.0") { + # Get the ggplot class from ggplot2 + ggplot_class <- get("ggplot", envir = getNamespace("ggplot2")) + + # Register S7 method for print + S7::method(print, ggplot_class) <- record_ggplot + } else { + # Fallback to S3 method registration for older ggplot2 + registerS3method( + genname = "print", + class = "ggplot", + method = "record_ggplot", + envir = getNamespace("camcorder") + ) + } + }, error = function(e) { + # If S7 fails, try S3 as fallback + registerS3method( + genname = "print", + class = "ggplot", + method = "record_ggplot", + envir = getNamespace("camcorder") + ) + }) } - if("package:patchwork" %in% search()){ - registerS3method( - genname = "print", - class = "patchwork", - method = "record_patchwork", - envir = getNamespace("camcorder") - ) + # Handle patchwork + if ("package:patchwork" %in% search()) { + tryCatch({ + # patchwork may also use S7 in newer versions + if (packageVersion("ggplot2") >="4.0.0") { + patchwork_class <- get("patchwork", envir = getNamespace("patchwork")) + S7::method(print, patchwork_class) <- record_patchwork + } else { + registerS3method( + genname = "print", + class = "patchwork", + method = "record_patchwork", + envir = getNamespace("camcorder") + ) + } + }, error = function(e) { + # Fallback to S3 + registerS3method( + genname = "print", + class = "patchwork", + method = "record_patchwork", + envir = getNamespace("camcorder") + ) + }) } GG_RECORDING_ENV$shims_registered <- TRUE } +#' Detach camcorder shims +#' +#' Restores the original print methods for ggplot and patchwork objects, +#' stopping the automatic recording of plots. +#' +#' @return Used for side effects. Invisibly returns NULL. +#' @keywords internal detach_camcorder_shims <- function(){ - if(!is.null(GG_RECORDING_ENV$shims_registered) & - isTRUE(GG_RECORDING_ENV$shims_registered)){ - remove_lib_shims() + if (!isTRUE(GG_RECORDING_ENV$shims_registered)) { + return(invisible(NULL)) } - if("package:ggplot2" %in% search()){ - registerS3method( - genname = "print", - class = "ggplot", - method = "print.ggplot", - envir = getNamespace("ggplot2") - ) + remove_lib_shims() + + # Restore ggplot2 print method + if ("package:ggplot2" %in% search()) { + tryCatch({ + # Try S7 method restoration first + if (packageVersion("ggplot2") >= "4.0.0") { + ggplot_class <- get("ggplot", envir = getNamespace("ggplot2")) + original_print <- get("print. ggplot", envir = getNamespace("ggplot2")) + S7::method(print, ggplot_class) <- original_print + } else { + # S3 fallback + registerS3method( + genname = "print", + class = "ggplot", + method = "print.ggplot", + envir = getNamespace("ggplot2") + ) + } + }, error = function(e) { + # S3 fallback + registerS3method( + genname = "print", + class = "ggplot", + method = "print.ggplot", + envir = getNamespace("ggplot2") + ) + }) } - if("package:patchwork" %in% search()){ - registerS3method( - genname = "print", - class = "patchwork", - method = "print.patchwork", - envir = getNamespace("patchwork") - ) + # Restore patchwork print method + if ("package:patchwork" %in% search()) { + tryCatch({ + # Try S7 method restoration + if (packageVersion("ggplot2") >= "4.0.0") { + patchwork_class <- get("patchwork", envir = getNamespace("patchwork")) + original_print <- get("print.patchwork", envir = getNamespace("patchwork")) + S7::method(print, patchwork_class) <- original_print + } else { + # S3 fallback + registerS3method( + genname = "print", + class = "patchwork", + method = "print. patchwork", + envir = getNamespace("patchwork") + ) + } + }, error = function(e) { + # S3 fallback + registerS3method( + genname = "print", + class = "patchwork", + method = "print. patchwork", + envir = getNamespace("patchwork") + ) + }) } GG_RECORDING_ENV$shims_registered <- FALSE @@ -68,7 +158,18 @@ detach_camcorder_shims <- function(){ } -shim_library <- function(package, ..., warn.conflicts = TRUE,character.only = FALSE){ +#' Shim library function +#' +#' Intercepts library() calls to properly manage print method registration +#' when packages are loaded/unloaded during recording. +#' +#' @param package Package name +#' @param ... Additional arguments passed to base::library() +#' @param warn.conflicts Logical, warn about conflicts +#' @param character.only Logical, package name as character +#' +#' @keywords internal +shim_library <- function(package, ..., warn.conflicts = TRUE, character.only = FALSE){ package <- as.character(substitute(package)) @@ -79,10 +180,21 @@ shim_library <- function(package, ..., warn.conflicts = TRUE,character.only = FA package = package, character.only = TRUE, warn.conflicts = camcorder_warn_suppress(package, warn.conflicts), - ... + ... ) } +#' Shim require function +#' +#' Intercepts require() calls to properly manage print method registration +#' when packages are loaded/unloaded during recording. +#' +#' @param package Package name +#' @param ... Additional arguments passed to base::require() +#' @param warn.conflicts Logical, warn about conflicts +#' @param character.only Logical, package name as character +#' +#' @keywords internal shim_require <- function(package, ..., warn.conflicts = TRUE, character.only = FALSE){ package <- as.character(substitute(package)) @@ -98,16 +210,19 @@ shim_require <- function(package, ..., warn.conflicts = TRUE, character.only = F ) } +#' Suppress warnings for specific packages +#' +#' @param package Package name +#' @param warn.conflicts Logical, user preference for warnings +#' +#' @return Logical value for warn.conflicts parameter +#' @keywords internal camcorder_warn_suppress <- function(package, warn.conflicts = FALSE){ - if(package %in% c("ggplot2","patchwork")){ + if (package %in% c("ggplot2", "patchwork")) { return(TRUE) } return(warn.conflicts) -} - - - - +} \ No newline at end of file diff --git a/tests/testthat/_snaps/recording/camcorder_preview_ggplot2.png b/tests/testthat/_snaps/recording/camcorder_preview_ggplot2.png index 2d77f9c..2d76126 100644 Binary files a/tests/testthat/_snaps/recording/camcorder_preview_ggplot2.png and b/tests/testthat/_snaps/recording/camcorder_preview_ggplot2.png differ diff --git a/tests/testthat/_snaps/recording/camcorder_preview_patchwork.png b/tests/testthat/_snaps/recording/camcorder_preview_patchwork.png index 64d4948..6bdc9ae 100644 Binary files a/tests/testthat/_snaps/recording/camcorder_preview_patchwork.png and b/tests/testthat/_snaps/recording/camcorder_preview_patchwork.png differ