R/param_setters.R
In tdeenes/eegR: Analyze EEG Signals
Defines functions
convertParams
permParams
parallelParams
tfceParams
Documented in
convertParams
parallelParams
permParams
tfceParams
#' Setting the parameters for TFCE correction
#'
#' \code{tfceParams} sets the parameters for TFCE correction
#' @param ChN channel neighbourhood matrix
#' @param EH numeric vector giving the E and H parameters
#' @param steps integer value indicating the number of thresholding steps
#' (default: 50L)
#' @param auto logical; if set to TRUE (default), ChN and EH are set
#' automagically. See Details.
#' @details The TFCE correction has three parameters: the channel neighbourhood
#' matrix, and the E and H parameters. The channel neighb. matrix is usually
#' generated by \code{\link{chanNb}}. The E and H parameters should be fixed at
#' c(0.66, 2) for t-tests and c(0.66, 1) for F-tests, unless you have very
#' good reasons to change these defaults.
#' If 'auto' is TRUE and 'ChN' is NULL, \code{tfceParams} looks for an object
#' named '.arraydat' and tries to extract its 'ChN' attribute. This usually
#' works because in the functions which perform TFCE correction
#' (\code{\link{arrayAnova}} and \code{\link{arrayTtest}}), the data argument is
#' named as \code{.arraydat}. If this automatic lookup fails, \code{tfceParams}
#' fails with an informative error message.
#' If 'auto' is TRUE and 'EH' is NULL, \code{tfceParams} investigates if it was
#' called from a function which has "anova" in its name (upper- or lower-case
#' does not matter) or not. In the former case EH is set to \code{c(0.66, 1)},
#' otherwise \code{c(0.66, 2)}.
#' @note IMPORTANT! Be extremely careful with the 'auto' parameter.
#' @export
#' @examples
#' # use example dataset
#' data(erps)
#'
#' # create channel neighb. matrix
#' chan_pos <- attr(erps, "chan")
#' chn <- chanNb(chan_pos, alpha = 0.7) # see ?chanNb how to find alpha
#' attr(erps, "ChN") <- chn
#'
#' # create a dummy function
#' myAnova <- function(.arraydat) {
#' tfce <- tfceParams()
#' tfce
#' }
#'
#' # check what it returns
#' res <- myAnova(erps)
#' str(res)
#' stopifnot(identical(res,
#' structure(list(ChN = chn, EH = c(0.66, 1), steps = 50L),
#' class = "tfceParams")
#' ))
#'
#' # if called from the global environment, provide ChN and EH
#' myAnova2 <- function(.arraydat, tfce = NULL) tfce
#'
#' # this fails
#' res <- try(myAnova2(erps, tfce = tfceParams()), silent = TRUE)
#' stopifnot(inherits(res, "try-error"))
#' res[1]
#'
#' # this works
#' res <- myAnova2(erps, tfce = tfceParams(ChN = chn, EH = c(0.66, 1)))
#' str(res)
#'
tfceParams <- function(ChN = NULL, EH = NULL, auto = TRUE, steps = 50L) {
if (any(c(is.null(ChN), is.null(EH)))) {
if (!auto) {
stop("If 'auto' is FALSE, both 'ChN' and 'EH' must be explicitly given")
}
if (auto && identical(parent.frame(), globalenv())) {
stop("Both ChN and EH must be explicitly provided if this function is called from the global environment")
}
}
if (auto & is.null(ChN)) {
ChN <- try(attr(get(".arraydat",
envir = parent.frame(), mode = "numeric"),
"ChN"),
silent = TRUE)
if (inherits(ChN, "try-error")) {
stop("Automatic extraction of the channel neigbourhood matrix failed. Provide 'ChN' parameter explicitly.")
}
}
if (auto & is.null(EH)) {
fn <- tolower(deparse(sys.call(-1)[[1]]))
EH <-
if (grepl("anova", fn)) {
c(0.66, 1)
} else {
c(0.66, 2)
}
}
# checks
assertMatrix(ChN, any.missing = FALSE, .var.name = "ChN")
assertIntegerish(ChN, .var.name = "ChN")
assertNumeric(EH, any.missing = FALSE, len = 2L, .var.name = "EH")
assertCount(steps, .var.name = "steps")
# return
structure(list(ChN = ChN, EH = EH, steps = as.integer(steps)),
class = "tfceParams")
}
#' Setting the parameters for parallel computation
#'
#' \code{parallelParams} sets the parameters for parallel computation and
#' registers the cluster. Newly registered clusters should be stopped after
#' the computations are performed.
#' @param cl an object of class "cluster" (default: NULL)
#' @param method character string of the chosen parallelization method; if
#' 'auto' (default), 'snow' is chosen on Windows and 'multicore' otherwise
#' @param ncores integer; the number of cores
#' @param ... options to be passed to the function spawning the workers. See
#' 'Details' in \code{\link[parallel]{makeCluster}} and
#' \code{\link[parallel]{mclapply}} for snow- and multicore-parallelization,
#' respectively (for multicore, one can use the "preschedule", "set.seed",
#' "silent" options, e.g. \code{options = list(preschedule = FALSE)}.
#' @export
#' @return \code{parallelParams} returns a list with five elements:
#' \itemize{
#' \item{cl: }{the cluster if a snow-type cluster was requested}
#' \item{cl_new: }{a logical whether the cluster was created by
#' \code{parallelParams}}
#' \item{snow_options: }{a list of options for snow-clusters}
#' \item{mc_options: }{a list of options for multicore-clusters}
#' }
#' @note If \code{cl_new = TRUE}, you should stop the cluster after the
#' computations (see Examples).
#' @examples
#' # create a function which computes the range of values in each column of
#' # a matrix and can run in single-core or parallel mode
#' rangeColumns <- function(x, parallel = FALSE) {
#' #
#' stopifnot(require(doParallel))
#' ob <- getDoBackend() # store active backend
#' #
#' # parallel argument can be a logical or a direct call to parallelParams
#' # or a .(key = value)-type call
#' parallel <- argumentDeparser(substitute(parallel), "parallelParams",
#' null_params = list(ncores = 0L))
#' #
#' # stop cluster on exit if it was created by parallelParams
#' if (parallel$cl_new) {
#' on.exit(stopCluster(parallel$cl))
#' }
#' on.exit(setDoBackend(ob), add = TRUE)
#' #
#' # call foreach and compute range
#' out <- foreach(xi = iter(x, by = "col"), .combine = "cbind",
#' .options.snow = parallel$snow_options,
#' .options.multicore = parallel$mc_options) %dopar%
#' range(xi)
#' #
#' # return with sensible dimension names
#' dimnames(out) <- list(range = c("min", "max"), colnames(x))
#' out
#' }
#'
#' # create a toy data matrix
#' mat <- matrix(rnorm(100), 25, 4)
#' colnames(mat) <- paste0("column", 1:4)
#'
#' # compute the range of values in each column and print to the console
#' ranges_parallel <- rangeColumns(mat,
#' parallel = .(method = "snow", ncores = 2L))
#' ranges_parallel
#'
#' # compare to single-core calculation
#' ranges_single <- apply(mat, 2, range)
#' stopifnot(identical(unname(ranges_parallel),
#' unname(ranges_single)))
#'
parallelParams <- function(cl = NULL, method = c("auto", "snow", "multicore"),
ncores = parallel::detectCores()-1L, ...) {
method <- match.arg(method)
opts <- list(...)
if (length(opts) == 0L) opts <- NULL
mc_options <- snow_options <- NULL
cl_new <- FALSE
if (is.null(cl)) {
if (ncores <= 1L) {
registerDoSEQ()
} else if (.Platform$OS.type == "windows" || method == "snow") {
snow_options <- opts
cl <- makePSOCKcluster(as.integer(ncores))
cl_new <- TRUE
registerDoParallel(cl = cl)
} else {
mc_options <- opts
registerDoParallel(cores = as.integer(ncores))
}
} else {
snow_options <- opts
registerDoParallel(cl = cl)
}
# return
list(cl = cl, cl_new = cl_new,
snow_options = snow_options, mc_options = mc_options)
}
#' Setting the parameters for parallel computation
#'
#' \code{permParams} sets the parameters for permutations (randomizations)
#' used for example in \code{arrayAnova} or \code{tanova}.
#' @param n integer number of randomization runs
#' @param type character string which defines if model residuals ("residuals",
#' the default), or the raw observations ("observations") should be permuted
#' @export
#' @return \code{parallelParams} returns a list with two elements corresponding
#' to the arguments ('n' and 'type')
#'
permParams <- function(n = 999L, type = c("residuals", "observations")) {
assertCount(n, .var.name = "n")
type <- match.arg(type)
list(n = n, type = type)
}
#' Setting the parameters for auto-conversion
#'
#' \code{convertParams} defines the rules how variables meeting user-defined
#' conditions shall be converted (most often, coerced).
#' @usage
#' convertParams(
#' ...,
#' factor = list(
#' IF = is.factor,
#' DO = list(function(x) as.logical(as.character(x)),
#' function(x) as.integer(as.character(x)),
#' function(x) as.double(as.character(x)),
#' function(x) as.Date(as.character(x)),
#' as.character),
#' EVAL = function(x, y) isTRUE(all.equal(as.character(x),
#' as.character(y),
#' check.attributes = FALSE))
#' ),
#' integer = list(
#' IF = is.integer,
#' DO = list(as.logical),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.integer(y),
#' check.attributes = FALSE))
#' ),
#' double = list(
#' IF = is.double,
#' DO = list(as.logical,
#' as.integer),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.double(y),
#' check.attributes = FALSE))
#' ),
#' character = list(
#' IF = is.character,
#' DO = list(as.logical,
#' as.integer,
#' as.Date,
#' as.double,
#' function(x) factor(x, levels = unique.default(x)),
#' as.factor),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x),
#' as.character(y),
#' check.attributes = FALSE))
#' ))
#' @param ... named definitions of new rules, each being a named list of 'IF',
#' 'DO', and 'EVAL' elements. See the pre-defined rules below and the Details
#' section for further information. Note that the argument name "ANY" is
#' reserved for internal use.
#' @param factor,integer,double,character pre-defined rules for the most
#' standard object types. See Details.
#' @details \code{convertParams} defines a collection of conversion rules. A
#' rule is a named list of three elements: 'IF', 'DO', and 'EVAL'.\cr
#' 'IF' defines the condition which triggers the conversion; it is a function
#' or a character string denoting a function (e.g., \code{"is.integer"}) which
#' accepts at least one argument (the data which should be converted). It must
#' return a single logical value (TRUE or FALSE).\cr
#' 'DO' is a list of potential conversion procedures, that is, functions or
#' character strings denoting the functions. During conversion, the functions
#' in 'DO' are called in the given order and their returned values are compared
#' to the original data as defined in 'EVAL' (see later). Therefore, each
#' function should accept at least one argument (the data), and all functions
#' should return an object which is accepted by 'EVAL'. Usually, functions in
#' 'DO' return a vector of the same length as the input data; a typical example
#' could be \code{as.logical}.\cr
#' 'EVAL' is a single function or a character string denoting a function which
#' is used to evaluate whether the conversion resulted in an acceptible return
#' value. Therefore, an 'EVAL' function must accept at least two arguments: the
#' original data and the returned value of a 'DO' function. Note that the
#' order of arguments is important. Additionally, the 'EVAL' function must
#' return a single logical value: TRUE if the conversion is acceptible, and
#' FALSE if it is not. Usually, the 'EVAL' function is a counterpart of the
#' 'IF' function, e.g. \code{as.integer}.
#' @return \code{convertParams} returns a named list of conversion rules.
#' The list has a special class "convertParams".
#' @export
#' @seealso
#' \code{\link{autoConvert}} for examples
convertParams <- function(
...,
factor = list(
IF = is.factor,
DO = list(function(x) as.logical(as.character(x)),
function(x) as.integer(as.character(x)),
function(x) as.double(as.character(x)),
function(x) as.Date(as.character(x)),
as.character),
EVAL = function(x, y) isTRUE(all.equal(as.character(x), as.character(y),
check.attributes = FALSE))
),
integer = list(
IF = is.integer,
DO = list(as.logical),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.integer(y),
check.attributes = FALSE))
),
double = list(
IF = is.double,
DO = list(as.logical,
as.integer),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.double(y),
check.attributes = FALSE))
),
character = list(
IF = is.character,
DO = list(as.logical,
as.integer,
as.Date,
as.double,
function(x) factor(x, levels = unique.default(x)),
as.factor),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x),
as.character(y),
check.attributes = FALSE))
)) {
#
# collect all arguments
out <- c(
lapply(match.call(expand.dots = FALSE)$`...`, eval),
mget(setdiff(ls(sorted = FALSE, all.names = TRUE), "..."))
)
# checks
if ("ANY" %in% names(out)) {
stop(paste0(
"The argument name 'ANY' is reserved for internal use. ",
"Choose an other name for that rule."
))
}
out <- lapply(out, function(x) {
if (!is.list(x) || is.null(names(x)) ||
!identical(sort(names(x)), c("DO", "EVAL", "IF"))) {
stop(paste0(
"convertParams: all arguments must be three-element, named ",
"lists with names 'IF', 'DO', and 'EVAL'"), call. = FALSE)
}
if (length(x$IF) != 1L) {
stop("convertParams: the 'IF' element must be of length 1",
call. = FALSE)
}
if (is.character(x$IF)) {
x$IF <- tryCatch(match.fun(x$IF), error = function(e)
stop(paste0("convertParams: function with name '",
x$IF, "' was not found"), call. = FALSE))
} else if (!is.function(x$IF)) {
stop(paste0(
"convertParams: the 'IF' element must be a function or ",
"a character string of the function name"))
}
# if (length(formals(x$IF)) < 1L) {
# stop(paste0(
# "convertParams: the 'IF' function must have at least ",
# "one argument"), call. = FALSE)
# }
if (length(x$DO) == 0L) {
stop("convertParams: the 'DO' element must be of length 1 or more",
call. = FALSE)
}
if (is.character(x$DO)) {
x$DO <- as.list(x$DO)
} else if (is.function(x$DO)) {
x$DO <- list(x$DO)
}
x$DO <- lapply(x$DO, function(fun) {
if (is.character(fun)) {
fun <- tryCatch(match.fun(fun), error = function(e)
stop(paste0("convertParams: function with name '",
fun, "' was not found"), call. = FALSE))
} else if (!is.function(fun)) {
stop(paste0(
"convertParams: the 'DO' element must be a character ",
"vector or a list of functions"))
}
# if (length(formals(fun)) < 1L) {
# stop(paste0(
# "convertParams: the 'DO' functions must have at least ",
# "one argument"), call. = FALSE)
# }
fun
})
if (length(x$EVAL) != 1L) {
stop("convertParams: the 'EVAL' element must be of length 1",
call. = FALSE)
}
if (is.character(x$EVAL)) {
x$IF <- tryCatch(match.fun(x$EVAL), error = function(e)
stop(paste0("convertParams: function with name '",
x$EVAL, "' was not found"), call. = FALSE))
} else if (!is.function(x$EVAL)) {
stop(paste0(
"convertParams: the 'EVAL' element must be a function or ",
"a character string of the function name"))
}
# if (length(formals(x$EVAL)) < 2L) {
# stop(paste0(
# "convertParams: the 'EVAL' function must have at least ",
# "two arguments"), call. = FALSE)
# }
# return
x
})
# return
setattr(out, "class", "convertParams")
out
}
tdeenes/eegR documentation built on April 19, 2021, 4:17 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions convertParams permParams parallelParams tfceParams
Documented in convertParams parallelParams permParams tfceParams
#' Setting the parameters for TFCE correction
#'
#' \code{tfceParams} sets the parameters for TFCE correction
#' @param ChN channel neighbourhood matrix
#' @param EH numeric vector giving the E and H parameters
#' @param steps integer value indicating the number of thresholding steps
#' (default: 50L)
#' @param auto logical; if set to TRUE (default), ChN and EH are set
#' automagically. See Details.
#' @details The TFCE correction has three parameters: the channel neighbourhood
#' matrix, and the E and H parameters. The channel neighb. matrix is usually
#' generated by \code{\link{chanNb}}. The E and H parameters should be fixed at
#' c(0.66, 2) for t-tests and c(0.66, 1) for F-tests, unless you have very
#' good reasons to change these defaults.
#' If 'auto' is TRUE and 'ChN' is NULL, \code{tfceParams} looks for an object
#' named '.arraydat' and tries to extract its 'ChN' attribute. This usually
#' works because in the functions which perform TFCE correction
#' (\code{\link{arrayAnova}} and \code{\link{arrayTtest}}), the data argument is
#' named as \code{.arraydat}. If this automatic lookup fails, \code{tfceParams}
#' fails with an informative error message.
#' If 'auto' is TRUE and 'EH' is NULL, \code{tfceParams} investigates if it was
#' called from a function which has "anova" in its name (upper- or lower-case
#' does not matter) or not. In the former case EH is set to \code{c(0.66, 1)},
#' otherwise \code{c(0.66, 2)}.
#' @note IMPORTANT! Be extremely careful with the 'auto' parameter.
#' @export
#' @examples
#' # use example dataset
#' data(erps)
#'
#' # create channel neighb. matrix
#' chan_pos <- attr(erps, "chan")
#' chn <- chanNb(chan_pos, alpha = 0.7) # see ?chanNb how to find alpha
#' attr(erps, "ChN") <- chn
#'
#' # create a dummy function
#' myAnova <- function(.arraydat) {
#' tfce <- tfceParams()
#' tfce
#' }
#'
#' # check what it returns
#' res <- myAnova(erps)
#' str(res)
#' stopifnot(identical(res,
#' structure(list(ChN = chn, EH = c(0.66, 1), steps = 50L),
#' class = "tfceParams")
#' ))
#'
#' # if called from the global environment, provide ChN and EH
#' myAnova2 <- function(.arraydat, tfce = NULL) tfce
#'
#' # this fails
#' res <- try(myAnova2(erps, tfce = tfceParams()), silent = TRUE)
#' stopifnot(inherits(res, "try-error"))
#' res[1]
#'
#' # this works
#' res <- myAnova2(erps, tfce = tfceParams(ChN = chn, EH = c(0.66, 1)))
#' str(res)
#'
tfceParams <- function(ChN = NULL, EH = NULL, auto = TRUE, steps = 50L) {
if (any(c(is.null(ChN), is.null(EH)))) {
if (!auto) {
stop("If 'auto' is FALSE, both 'ChN' and 'EH' must be explicitly given")
}
if (auto && identical(parent.frame(), globalenv())) {
stop("Both ChN and EH must be explicitly provided if this function is called from the global environment")
}
}
if (auto & is.null(ChN)) {
ChN <- try(attr(get(".arraydat",
envir = parent.frame(), mode = "numeric"),
"ChN"),
silent = TRUE)
if (inherits(ChN, "try-error")) {
stop("Automatic extraction of the channel neigbourhood matrix failed. Provide 'ChN' parameter explicitly.")
}
}
if (auto & is.null(EH)) {
fn <- tolower(deparse(sys.call(-1)[[1]]))
EH <-
if (grepl("anova", fn)) {
c(0.66, 1)
} else {
c(0.66, 2)
}
}
# checks
assertMatrix(ChN, any.missing = FALSE, .var.name = "ChN")
assertIntegerish(ChN, .var.name = "ChN")
assertNumeric(EH, any.missing = FALSE, len = 2L, .var.name = "EH")
assertCount(steps, .var.name = "steps")
# return
structure(list(ChN = ChN, EH = EH, steps = as.integer(steps)),
class = "tfceParams")
}
#' Setting the parameters for parallel computation
#'
#' \code{parallelParams} sets the parameters for parallel computation and
#' registers the cluster. Newly registered clusters should be stopped after
#' the computations are performed.
#' @param cl an object of class "cluster" (default: NULL)
#' @param method character string of the chosen parallelization method; if
#' 'auto' (default), 'snow' is chosen on Windows and 'multicore' otherwise
#' @param ncores integer; the number of cores
#' @param ... options to be passed to the function spawning the workers. See
#' 'Details' in \code{\link[parallel]{makeCluster}} and
#' \code{\link[parallel]{mclapply}} for snow- and multicore-parallelization,
#' respectively (for multicore, one can use the "preschedule", "set.seed",
#' "silent" options, e.g. \code{options = list(preschedule = FALSE)}.
#' @export
#' @return \code{parallelParams} returns a list with five elements:
#' \itemize{
#' \item{cl: }{the cluster if a snow-type cluster was requested}
#' \item{cl_new: }{a logical whether the cluster was created by
#' \code{parallelParams}}
#' \item{snow_options: }{a list of options for snow-clusters}
#' \item{mc_options: }{a list of options for multicore-clusters}
#' }
#' @note If \code{cl_new = TRUE}, you should stop the cluster after the
#' computations (see Examples).
#' @examples
#' # create a function which computes the range of values in each column of
#' # a matrix and can run in single-core or parallel mode
#' rangeColumns <- function(x, parallel = FALSE) {
#' #
#' stopifnot(require(doParallel))
#' ob <- getDoBackend() # store active backend
#' #
#' # parallel argument can be a logical or a direct call to parallelParams
#' # or a .(key = value)-type call
#' parallel <- argumentDeparser(substitute(parallel), "parallelParams",
#' null_params = list(ncores = 0L))
#' #
#' # stop cluster on exit if it was created by parallelParams
#' if (parallel$cl_new) {
#' on.exit(stopCluster(parallel$cl))
#' }
#' on.exit(setDoBackend(ob), add = TRUE)
#' #
#' # call foreach and compute range
#' out <- foreach(xi = iter(x, by = "col"), .combine = "cbind",
#' .options.snow = parallel$snow_options,
#' .options.multicore = parallel$mc_options) %dopar%
#' range(xi)
#' #
#' # return with sensible dimension names
#' dimnames(out) <- list(range = c("min", "max"), colnames(x))
#' out
#' }
#'
#' # create a toy data matrix
#' mat <- matrix(rnorm(100), 25, 4)
#' colnames(mat) <- paste0("column", 1:4)
#'
#' # compute the range of values in each column and print to the console
#' ranges_parallel <- rangeColumns(mat,
#' parallel = .(method = "snow", ncores = 2L))
#' ranges_parallel
#'
#' # compare to single-core calculation
#' ranges_single <- apply(mat, 2, range)
#' stopifnot(identical(unname(ranges_parallel),
#' unname(ranges_single)))
#'
parallelParams <- function(cl = NULL, method = c("auto", "snow", "multicore"),
ncores = parallel::detectCores()-1L, ...) {
method <- match.arg(method)
opts <- list(...)
if (length(opts) == 0L) opts <- NULL
mc_options <- snow_options <- NULL
cl_new <- FALSE
if (is.null(cl)) {
if (ncores <= 1L) {
registerDoSEQ()
} else if (.Platform$OS.type == "windows" || method == "snow") {
snow_options <- opts
cl <- makePSOCKcluster(as.integer(ncores))
cl_new <- TRUE
registerDoParallel(cl = cl)
} else {
mc_options <- opts
registerDoParallel(cores = as.integer(ncores))
}
} else {
snow_options <- opts
registerDoParallel(cl = cl)
}
# return
list(cl = cl, cl_new = cl_new,
snow_options = snow_options, mc_options = mc_options)
}
#' Setting the parameters for parallel computation
#'
#' \code{permParams} sets the parameters for permutations (randomizations)
#' used for example in \code{arrayAnova} or \code{tanova}.
#' @param n integer number of randomization runs
#' @param type character string which defines if model residuals ("residuals",
#' the default), or the raw observations ("observations") should be permuted
#' @export
#' @return \code{parallelParams} returns a list with two elements corresponding
#' to the arguments ('n' and 'type')
#'
permParams <- function(n = 999L, type = c("residuals", "observations")) {
assertCount(n, .var.name = "n")
type <- match.arg(type)
list(n = n, type = type)
}
#' Setting the parameters for auto-conversion
#'
#' \code{convertParams} defines the rules how variables meeting user-defined
#' conditions shall be converted (most often, coerced).
#' @usage
#' convertParams(
#' ...,
#' factor = list(
#' IF = is.factor,
#' DO = list(function(x) as.logical(as.character(x)),
#' function(x) as.integer(as.character(x)),
#' function(x) as.double(as.character(x)),
#' function(x) as.Date(as.character(x)),
#' as.character),
#' EVAL = function(x, y) isTRUE(all.equal(as.character(x),
#' as.character(y),
#' check.attributes = FALSE))
#' ),
#' integer = list(
#' IF = is.integer,
#' DO = list(as.logical),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.integer(y),
#' check.attributes = FALSE))
#' ),
#' double = list(
#' IF = is.double,
#' DO = list(as.logical,
#' as.integer),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.double(y),
#' check.attributes = FALSE))
#' ),
#' character = list(
#' IF = is.character,
#' DO = list(as.logical,
#' as.integer,
#' as.Date,
#' as.double,
#' function(x) factor(x, levels = unique.default(x)),
#' as.factor),
#' EVAL = function(x, y) isTRUE(all.equal(as.vector(x),
#' as.character(y),
#' check.attributes = FALSE))
#' ))
#' @param ... named definitions of new rules, each being a named list of 'IF',
#' 'DO', and 'EVAL' elements. See the pre-defined rules below and the Details
#' section for further information. Note that the argument name "ANY" is
#' reserved for internal use.
#' @param factor,integer,double,character pre-defined rules for the most
#' standard object types. See Details.
#' @details \code{convertParams} defines a collection of conversion rules. A
#' rule is a named list of three elements: 'IF', 'DO', and 'EVAL'.\cr
#' 'IF' defines the condition which triggers the conversion; it is a function
#' or a character string denoting a function (e.g., \code{"is.integer"}) which
#' accepts at least one argument (the data which should be converted). It must
#' return a single logical value (TRUE or FALSE).\cr
#' 'DO' is a list of potential conversion procedures, that is, functions or
#' character strings denoting the functions. During conversion, the functions
#' in 'DO' are called in the given order and their returned values are compared
#' to the original data as defined in 'EVAL' (see later). Therefore, each
#' function should accept at least one argument (the data), and all functions
#' should return an object which is accepted by 'EVAL'. Usually, functions in
#' 'DO' return a vector of the same length as the input data; a typical example
#' could be \code{as.logical}.\cr
#' 'EVAL' is a single function or a character string denoting a function which
#' is used to evaluate whether the conversion resulted in an acceptible return
#' value. Therefore, an 'EVAL' function must accept at least two arguments: the
#' original data and the returned value of a 'DO' function. Note that the
#' order of arguments is important. Additionally, the 'EVAL' function must
#' return a single logical value: TRUE if the conversion is acceptible, and
#' FALSE if it is not. Usually, the 'EVAL' function is a counterpart of the
#' 'IF' function, e.g. \code{as.integer}.
#' @return \code{convertParams} returns a named list of conversion rules.
#' The list has a special class "convertParams".
#' @export
#' @seealso
#' \code{\link{autoConvert}} for examples
convertParams <- function(
...,
factor = list(
IF = is.factor,
DO = list(function(x) as.logical(as.character(x)),
function(x) as.integer(as.character(x)),
function(x) as.double(as.character(x)),
function(x) as.Date(as.character(x)),
as.character),
EVAL = function(x, y) isTRUE(all.equal(as.character(x), as.character(y),
check.attributes = FALSE))
),
integer = list(
IF = is.integer,
DO = list(as.logical),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.integer(y),
check.attributes = FALSE))
),
double = list(
IF = is.double,
DO = list(as.logical,
as.integer),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x), as.double(y),
check.attributes = FALSE))
),
character = list(
IF = is.character,
DO = list(as.logical,
as.integer,
as.Date,
as.double,
function(x) factor(x, levels = unique.default(x)),
as.factor),
EVAL = function(x, y) isTRUE(all.equal(as.vector(x),
as.character(y),
check.attributes = FALSE))
)) {
#
# collect all arguments
out <- c(
lapply(match.call(expand.dots = FALSE)$`...`, eval),
mget(setdiff(ls(sorted = FALSE, all.names = TRUE), "..."))
)
# checks
if ("ANY" %in% names(out)) {
stop(paste0(
"The argument name 'ANY' is reserved for internal use. ",
"Choose an other name for that rule."
))
}
out <- lapply(out, function(x) {
if (!is.list(x) || is.null(names(x)) ||
!identical(sort(names(x)), c("DO", "EVAL", "IF"))) {
stop(paste0(
"convertParams: all arguments must be three-element, named ",
"lists with names 'IF', 'DO', and 'EVAL'"), call. = FALSE)
}
if (length(x$IF) != 1L) {
stop("convertParams: the 'IF' element must be of length 1",
call. = FALSE)
}
if (is.character(x$IF)) {
x$IF <- tryCatch(match.fun(x$IF), error = function(e)
stop(paste0("convertParams: function with name '",
x$IF, "' was not found"), call. = FALSE))
} else if (!is.function(x$IF)) {
stop(paste0(
"convertParams: the 'IF' element must be a function or ",
"a character string of the function name"))
}
# if (length(formals(x$IF)) < 1L) {
# stop(paste0(
# "convertParams: the 'IF' function must have at least ",
# "one argument"), call. = FALSE)
# }
if (length(x$DO) == 0L) {
stop("convertParams: the 'DO' element must be of length 1 or more",
call. = FALSE)
}
if (is.character(x$DO)) {
x$DO <- as.list(x$DO)
} else if (is.function(x$DO)) {
x$DO <- list(x$DO)
}
x$DO <- lapply(x$DO, function(fun) {
if (is.character(fun)) {
fun <- tryCatch(match.fun(fun), error = function(e)
stop(paste0("convertParams: function with name '",
fun, "' was not found"), call. = FALSE))
} else if (!is.function(fun)) {
stop(paste0(
"convertParams: the 'DO' element must be a character ",
"vector or a list of functions"))
}
# if (length(formals(fun)) < 1L) {
# stop(paste0(
# "convertParams: the 'DO' functions must have at least ",
# "one argument"), call. = FALSE)
# }
fun
})
if (length(x$EVAL) != 1L) {
stop("convertParams: the 'EVAL' element must be of length 1",
call. = FALSE)
}
if (is.character(x$EVAL)) {
x$IF <- tryCatch(match.fun(x$EVAL), error = function(e)
stop(paste0("convertParams: function with name '",
x$EVAL, "' was not found"), call. = FALSE))
} else if (!is.function(x$EVAL)) {
stop(paste0(
"convertParams: the 'EVAL' element must be a function or ",
"a character string of the function name"))
}
# if (length(formals(x$EVAL)) < 2L) {
# stop(paste0(
# "convertParams: the 'EVAL' function must have at least ",
# "two arguments"), call. = FALSE)
# }
# return
x
})
# return
setattr(out, "class", "convertParams")
out
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.