#' Recording functions
#'
#' Return a new function which is identical to the \code{soofunction}
#' passed in except that evaluated parameter settings and function
#' values are recorded.
#'
#' @param fn A test function (class \code{soo_function} or
#' \code{wrapped_soo_function}).
#'
#' @param record_pars [\code{boolean(1)}]\cr If \code{TRUE}, parameter
#' values (x) will be recorded.
#'
#' @param record_values [\code{boolean(1)}]\cr If \code{TRUE}, function
#' values (y) will be recorded.
#'
#' @param predicate [\code{function(par, value, time)}]\cr Predicate
#' function that returns \code{TRUE} if recoding should take place
#' for the given parameter setting \code{par}, function value
#' \code{value} and evaluation \code{time}. Note that \code{time} is
#' measured in function evaluations.
#'
#' @seealso \code{\link{recorded_values}} to retrieve the recorded
#' parameter and function values.
#'
#' @examples
#' fn <- recording_function(generate_sphere_function(2))
#' X <- random_parameters(10, fn)
#' y <- fn(X)
#' rv <- recorded_values(fn)
#' all.equal(rv$par, X)
#' all.equal(rv$value, y)
#'
#' ## With a predicate
#' pv <- function(par, value, time)
#' time %% 3 == 0
#' fn <- recording_function(generate_sphere_function(2), predicate=pv)
#' X <- random_parameters(10, fn)
#' y <- fn(X)
#' rv <- recorded_values(fn)
#' all(rv$time %% 3 == 0)
#' all.equal(rv$par, X[, rv$time])
#' all.equal(rv$value, y[rv$time])
#'
#' @export
recording_function <- function(fn,
record_pars=TRUE,
record_values=TRUE,
predicate) {
force(fn)
force(record_pars)
force(record_values)
if (!record_values && !record_pars)
stop("At least one of 'record_pars' and 'record_values' should be TRUE.")
## If no predicate is given, record _all_ evaluations.
if (missing(predicate))
predicate <- function(...) TRUE
stopifnot(is_soo_function(fn))
if (is_recording_function(fn))
stop("Function already is of type 'recording_function'.")
times <- numeric(0L)
pars <- matrix(0, nrow=number_of_parameters(fn), ncol=0)
values <- numeric(0L)
current_position <- 0L
current_time <- 0L
cfun <- function(x, ...) {
## Make sure 'x' is a matrix:
if (!is.matrix(x))
dim(x) <- c(length(x), 1)
y <- fn(x, ...)
for (i in 1:ncol(x)) {
current_par <- x[, i]
current_value <- y[i]
current_time <<- current_time + 1L
if (predicate(current_par, current_value, current_time)) {
current_position <<- current_position + 1L
times[current_position] <<- current_time
if (record_pars)
pars <<- cbind(pars, current_par, deparse.level=0)
if (record_values)
values[current_position] <<- current_value
}
}
y
}
class(cfun) <- c("recording_function", "wrapped_soo_function")
cfun
}
#' Return the internally recorded parameter settings and function
#' values for a test function.
#'
#' @param fn A function whos recorded parameter settings and function
#' values should be returnd.
#'
#' @return A list with elements \code{time}, \code{par} and
#' \code{value} which are the point in time (in number of function
#' evaluations), the parameter setting and the function value
#' recorded. The parameter settings are stored in a matrix where each
#' column is one parameter settings.
#'
#' @export
recorded_values <- function(fn)
UseMethod("recorded_values")
#' @export
#' @method recorded_values recording_function
#' @method recorded_values recording_function
recorded_values.recording_function <- function(fn) {
ee <- environment(fn)
list(time=ee$times,
par=ee$pars,
value=ee$values)
}
#' @export
#' @method recorded_values wrapped_soo_function
#' @method recorded_values wrapped_soo_function
recorded_values.wrapped_soo_function <- function(fn) {
recorded_values(inner_function(fn))
}
#' Recording function
#'
#' Check if a function supports the \sQuote{recording_function} interface.
#'
#' @param fn Function to check.
#'
#' @return \code{TRUE} if \code{fn} is a \sQuote{recording_function}
#' else \code{FALSE}.
#'
#' @export
is_recording_function <- function(fn)
UseMethod("is_recording_function")
#' @export
#' @method is_recording_function wrapped_soo_function
is_recording_function.wrapped_soo_function <- function(fn)
is_recording_function(inner_function(fn))
#' @export
#' @method is_recording_function recording_function
is_recording_function.recording_function <- function(fn)
TRUE
#' @export
#' @method is_recording_function soo_function
is_recording_function.soo_function <- function(fn)
FALSE
#' @export
#' @method inner_function recording_function
inner_function.recording_function <- function(fn) {
ee <- environment(fn)
ee$fn
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.