Nothing
## ---- 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"
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.