-
Notifications
You must be signed in to change notification settings - Fork 8
/
save_rds_archive.R
197 lines (166 loc) · 6.85 KB
/
save_rds_archive.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
#' @title Archive existing .RDS files
#'
#' @description This wrapper around base R \code{saveRDS()} checks if the file
#' you attempt to save already exists. If it does, the existing file is
#' renamed / archived (with a time stamp), and the "updated" file will be
#' saved under the specified name. This means that existing code which depends
#' on the file name remaining constant (e.g., \code{readRDS()} calls in other
#' scripts) will continue to work while an archived copy of the - otherwise
#' overwritten - file will be kept.
#'
#' Please note: If the file does \emph{not} already exist (i.e., if there is
#' nothing to overwrite or archive), regular \code{\link[base]{saveRDS}}
#' behavior will be invoked. In such a case, all arguments except
#' \code{object} and \code{file} will be ignored!
#'
#' @param object Object to be saved
#' @param file Name of the file (path) where the R object is saved to. Note that
#' this wrapper function does currently not support \code{connection}s.
#' @param archive Logical - should the file be archived if it already exists
#' (default), or should it be overwritten (regular saveRDS behavior)?
#' @param last_modified Logical - should the file name of the archived file be
#' appended with the \emph{"last modified"} date/time of the original RDS
#' instead of the \emph{current} date/time? Defaults to \code{FALSE}.
#' @param with_time Logical - should the file be archived with just a date
#' suffix (default) or with a date \bold{and} time suffix? Applies to both
#' archiving and modification date. Set to \code{TRUE} if you want to keep
#' several versions of files archived on a single day. See details.
#' @param archive_dir_path Character - if desired, path to a dedicated archive
#' (sub-)directory (\emph{relative} to the directory of \code{file}!) where the
#' archived file will be saved. Will be created if it does not yet exist.
#' Defaults to \code{NULL}.
#' @param ... Additional arguments passed along to \code{\link[base]{saveRDS}}
#'
#' @details CAUTION: Note that existing \emph{archived versions} of files will
#' still be overwritten if they have the same archived file name, i.e.,
#' archived files will not be archived. This usually happens when you use only
#' the date suffix and call this function multiple times per day: Only the
#' most recent archived version will be kept. If you want to keep multiple
#' archived versions of a single file, set \code{with_time} to \code{TRUE}.
#' This will append a time stamp to the archived file name up to the current
#' second (virtually ruling out the possibility of duplicated file names).
#'
#' @return \code{NULL} (invisibly)
#'
#' @seealso \code{\link[base]{saveRDS}}
#' @author Lukas Feick
#'
#' @examples \dontrun{
#' x <- 5
#' y <- 10
#' z <- 20
#'
#' ## save to RDS
#' saveRDS(x, "temp.RDS")
#' saveRDS(y, "temp.RDS")
#'
#' ## "temp.RDS" is silently overwritten with y
#' ## previous version is lost
#' readRDS("temp.RDS")
#' #> [1] 10
#'
#' save_rds_archive(z, "temp.RDS")
#'
#' ## current version is updated
#' readRDS("temp.RDS")
#' #> [1] 20
#'
#' ## previous version is archived
#' readRDS("temp_ARCHIVED_on_2020-03-30.RDS")
#' #> [1] 10
#'
#' }
#'
#' @export
#'
save_rds_archive <- function(object,
file = "",
archive = TRUE,
last_modified = FALSE,
with_time = FALSE,
archive_dir_path = NULL,
...) {
if (file == "" || !"character" %in% class(file)) {
stop("'file' must be a non-empty character string")
}
if (!is.null(archive_dir_path) && archive_dir_path == "") {
stop("must supply a directory name to 'archive_dir_path' if not NULL")
}
if (!is.logical(archive)) {
archive <- TRUE
warning("'archive' is not set to a boolean - will use default: ", archive)
}
if (!is.logical(with_time)) {
with_time <- FALSE
warning("'with_time' is not set to a boolean - will use default: ",
with_time)
}
# IF ARCHIVE == TRUE --------------------------------------------------------
if (archive) {
# check if file exists
if (file.exists(file)) {
archived_file <- create_archived_file(file = file,
last_modified = last_modified,
with_time = with_time)
if (!is.null(archive_dir_path)) {
# get parent directory
dname <- dirname(file)
# create archive dir if it does not already exist
if (!dir.exists(file.path(dname, archive_dir_path))) {
dir.create(file.path(dname, archive_dir_path), recursive = TRUE)
message("Created missing archive directory ",
sQuote(archive_dir_path))
}
# change path of archived file into 'archive' folder
archived_file <- file.path(dirname(archived_file),
archive_dir_path,
basename(archived_file))
# copy (rather than rename) file
# rename sometimes does not work if the directory itself is changed
# save return value of the file.copy function and wrap in tryCatch
# set "overwrite" to T so an existing copy is overwritten (see details)
if (file.exists(archived_file)) {
warning("Archived copy already exists - will overwrite!")
}
temp <- tryCatch({
file.copy(from = file,
to = archived_file,
overwrite = TRUE)
},
warning = function(e) {
stop(e)
})
} else {
if (file.exists(archived_file)) {
warning("Archived copy already exists - will overwrite!")
}
# rename existing file with the new name
# save return value of the file.rename function
# (returns TRUE if successful) and wrap in tryCatch
temp <- tryCatch({
file.rename(from = file,
to = archived_file)
},
warning = function(e) {
stop(e)
})
}
# check return value and if archived file exists
if (temp && file.exists(archived_file)) {
# then save new file under specified name
saveRDS(object = object, file = file, ...)
}
} else {
warning("Nothing to overwrite - will use default saveRDS() behavior. ",
"Additional arguments will be ignored!")
# if file does not exist (but archive is set to TRUE anyways),
# save new file under specified name
saveRDS(object = object, file = file, ...)
}
} else {
# OTHERWISE USE DEFAULT RDS -----------------------------------------------
warning("'archive' is set to FALSE - will use default saveRDS() behavior. ",
"Additional arguments will be ignored!")
saveRDS(object = object, file = file, ...)
}
}