#' Serialize R objects to disk (with backup)
#'
#' The `rotate_rds*()` functions are wrappers around [base::saveRDS()][base::readRDS()] that
#' create a backup of the destination file (if it exists) instead of just
#' overwriting it.
#'
#' @note The default value for `age` is different for `rotate_rds_date()` (`-1`)
#' than for [rotate_date()] (`1`) to make it a bit safer. This means if you
#' execute `rotate_date()` twice on the same file on a given day it will
#' silently not rotate the file, while `rotate_rds_date()` will throw an
#' error.
#'
#' @param on_change_only `logical` scalaror a `list`. Rotate only if `object`
#' is different from the object saved in `file`. If a `list`, arguments
#' that will be passed on to `data.table::all.equal` (only when both obects
#' are `data.tables`)
#'
#' @inheritParams base::saveRDS
#' @inheritDotParams rotate
#' @inheritParams rotate_date
#' @inheritDotParams rotate_date
#' @inheritDotParams rotate_time
#'
#' @return the path to `file` (invisibly)
#' @export
#'
#' @examples
#' dest <- tempfile()
#' rotate_rds(iris, dest)
#' rotate_rds(iris, dest)
#' rotate_rds(iris, dest)
#'
#' list_backups(dest)
#'
#' # cleanup
#' unlink(list_backups(dest))
#' unlink(dest)
#' @rdname rotate_rds
#' @export
rotate_rds <- function(
object,
file = "",
ascii = FALSE,
version = NULL,
compress = TRUE,
refhook = NULL,
...,
on_change_only = FALSE
){
rotate_rds_internal(
object = object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook,
...,
on_change_only = on_change_only,
fun = rotate
)
}
#' @rdname rotate_rds
#' @export
rotate_rds_date <- function(
object,
file = "",
ascii = FALSE,
version = NULL,
compress = TRUE,
refhook = NULL,
...,
age = -1L,
on_change_only = FALSE
){
rotate_rds_internal(
object = object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook,
...,
age = age,
on_change_only = on_change_only,
fun = rotate_date
)
}
#' @rdname rotate_rds
#' @export
rotate_rds_time <- function(
object,
file = "",
ascii = FALSE,
version = NULL,
compress = TRUE,
refhook = NULL,
...,
age = -1L,
on_change_only = FALSE
){
rotate_rds_internal(
object = object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook,
...,
age = age,
on_change_only = on_change_only,
fun = rotate_time
)
}
rotate_rds_internal <- function(
object,
file,
ascii,
version,
compress,
refhook,
...,
on_change_only,
fun
){
assert(is_scalar_character(file))
assert(is_scalar_bool(on_change_only) || is.list(on_change_only))
if (file.exists(file)){
if (isTRUE(on_change_only) || is.list(on_change_only)){
comp <- readRDS(file)
if (is.list(on_change_only)){
extra_args <- on_change_only
} else {
extra_args <- list()
}
if (objects_are_equal(object, comp, extra_args)){
message(ObjectHasNotChangedMessage("not rotating: object has not changed"))
return(invisible(file))
}
}
fun(file, ...)
}
saveRDS(
object = object,
file = file,
ascii = ascii,
version = version,
compress = compress,
refhook = refhook
)
invisible(file)
}
objects_are_equal <- function(
x,
y,
extra_args = NULL
){
if (identical(x, y)){
return(TRUE)
}
if (inherits(x, "data.table") && inherits(y, "data.table")){
assert_namespace("data.table")
return(isTRUE(do.call(all.equal, c(list(x, y), extra_args))))
}
FALSE
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.