## ---- include = FALSE---------------------------------------------------------
library(valaddin)
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
## -----------------------------------------------------------------------------
f <- function(x, h) (sin(x + h) - sin(x)) / h
## -----------------------------------------------------------------------------
ff <- firmly(f, ~is.numeric)
## ---- include = FALSE---------------------------------------------------------
tz_original <- Sys.getenv("TZ", unset = NA)
## -----------------------------------------------------------------------------
Sys.setenv(TZ = "CET")
(d <- as.POSIXct("2017-01-01 09:30:00"))
## -----------------------------------------------------------------------------
as.POSIXlt(d, tz = "EST")$hour
## -----------------------------------------------------------------------------
Sys.setenv(TZ = "EST")
d <- as.POSIXct("2017-01-01 09:30:00")
as.POSIXlt(d, tz = "EST")$hour
## ---- include = FALSE---------------------------------------------------------
if (isTRUE(is.na(tz_original))) {
Sys.unsetenv("TZ")
} else {
Sys.setenv(TZ = tz_original)
}
## -----------------------------------------------------------------------------
as.POSIXct <- firmly(as.POSIXct, .warn_missing = "tz")
## -----------------------------------------------------------------------------
as.POSIXct("2017-01-01 09:30:00")
as.POSIXct("2017-01-01 09:30:00", tz = "CET")
## -----------------------------------------------------------------------------
loosely(as.POSIXct)("2017-01-01 09:30:00")
identical(loosely(as.POSIXct), base::as.POSIXct)
## -----------------------------------------------------------------------------
w <- {set.seed(1); rnorm(5)}
ifelse(w > 0, w, 0)
## -----------------------------------------------------------------------------
z <- rep(1, 6)
pos <- 1:5
neg <- -6:-1
ifelse(z > 0, pos, neg)
## -----------------------------------------------------------------------------
chk_length_type <- list(
"'yes', 'no' differ in length" ~ length(yes) == length(no),
"'yes', 'no' differ in type" ~ typeof(yes) == typeof(no)
) ~ isTRUE
ifelse_f <- firmly(ifelse, chk_length_type)
## -----------------------------------------------------------------------------
deposit <- function(account, value) {
if (is_student(account)) {
account$fees <- 0
}
account$balance <- account$balance + value
account
}
is_student <- function(account) {
if (isTRUE(account$is_student)) TRUE else FALSE
}
## -----------------------------------------------------------------------------
bobs_acct <- list(balance = 10, fees = 3, is_student = FALSE)
## -----------------------------------------------------------------------------
deposit(bobs_acct, bobs_acct$fees)$balance
## -----------------------------------------------------------------------------
bobs_acct$is_student <- TRUE
## -----------------------------------------------------------------------------
bobs_acct <- list2env(bobs_acct)
## -----------------------------------------------------------------------------
deposit(bobs_acct, bobs_acct$fees)$balance
## -----------------------------------------------------------------------------
err_msg <- "`acccount` should not be an environment"
deposit <- firmly(deposit, list(err_msg ~ account) ~ Negate(is.environment))
## ---- eval = FALSE------------------------------------------------------------
# x <- "An expensive object"
# save(x, file = "my-precious.rda")
#
# x <- "Oops! A bug or lapse has tarnished your expensive object"
#
# # Many computations later, you again save x, oblivious to the accident ...
# save(x, file = "my-precious.rda")
## -----------------------------------------------------------------------------
# Argument `gear` is a list with components:
# fun: Function name
# ns : Namespace of `fun`
# chk: Formula that specify input checks
hardhat <- function(gear, env = .GlobalEnv) {
for (. in gear) {
safe_fun <- firmly(getFromNamespace(.$fun, .$ns), .$chk)
assign(.$fun, safe_fun, envir = env)
}
}
## -----------------------------------------------------------------------------
protection <- list(
list(
fun = "save",
ns = "base",
chk = list("Won't overwrite `file`" ~ file) ~ Negate(file.exists)
),
list(
fun = "load",
ns = "base",
chk = list("Won't load objects into current environment" ~ envir) ~
{!identical(., parent.frame(2))}
)
)
## -----------------------------------------------------------------------------
hardhat(protection)
## ---- eval = FALSE------------------------------------------------------------
# x <- "An expensive object"
# save(x, file = "my-precious.rda")
#
# x <- "Oops! A bug or lapse has tarnished your expensive object"
# #> Error: save(x, file = "my-precious.rda")
# #> Won't overwrite `file`
#
# save(x, file = "my-precious.rda")
#
# # Inspecting x, you notice it's changed, so you try to retrieve the original ...
# x
# #> [1] "Oops! A bug or lapse has tarnished your expensive object"
# load("my-precious.rda")
# #> Error: load(file = "my-precious.rda")
# #> Won't load objects into current environment
#
# # Keep calm and carry on
# loosely(load)("my-precious.rda")
#
# x
# #> [1] "An expensive object"
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.