Nothing
# funsamples
#'@title Class for a sample of functions
#'@description An object of class \code{funsample} can be considered both as a multivariate
#'function of one argument and as a list of univariate functions. It is generated by function \code{funsample}.
#'@param funs a single \code{function} taking one argument,
#'or a \code{list} of objects of class'\code{function}, that also take one argument.
#'@param arglim numeric vector, an interval the functions in \code{funlist} are defined on,
#', defaults to \code{c(0, 1)}.
#'@param ... predefined plot options, may be given as \code{\link{simplist}}s.
#'@details
#'When called with an argument \code{x}, an object of class \code{funsample} applies
#'all functions contained in \code{fun} to \code{x}, using R-function \code{\link{sapply}}.
#'The argument limit \code{arglim} does not matter, i.e. also values \code{x} outside
#'the "allowed range" are processed.
#'
#'The return value of a \code{funsample} is a matrix. It has \code{\link{colnames}}
#'if the list \code{funs} was named.
#'
#'Currently, only functions of one variable are allowed, i.e., for any element
#'\code{foo} of \code{funlist}, \code{foo(x)} needs to return a numeric value as
#'long as \code{x} is within \code{arglim}. The intervall \code{arglim} is necessary
#'for plotting and for coercing into an \code{\link{fdsample}} object.
#'
#'Predefining plot options may be particularly useful for plot annotation,
#'such as i.e. \code{xlab}, \code{ylab} and \code{main}. They may be also given
#'as a \code{plutils::\link{simplist}}. Options with same name are overriden
#'from left to right, i.e., the last one given counts.
#'@return \code{funsample} returns an object of class \code{funsample}, that is a function of one variable
#'adorned with attributes
#'\tabular{ll}{
#'\code{funs} \tab{a list of \code{function}s}
#'\cr\code{arglim} \tab{numeric, allowed range of function arguments}
#'\cr\code{groupsize} \tab{integer, length of \code{funs}}
#'\cr\code{options} \tab \code{\link{simplist}} of plot options, see \code{{plot.funsample}}
#'}
#'@export
#'@author Ute Hahn \email{ute@@imf.au.dk}
#'@examples
#'myfuns <- funsample(list(sin = sin, cos = cos), arglim = c(0, 2*pi))
# main = "my trigo functions")
#'myfuns(c(0, pi/4, pi/2))
#'
funsample <- function(funs, ..., arglim = c(0, 1)) #fun = mean, ...)
{
if (is.function(funs)){
funs <- list(funs)
} else {
if (!is.list(funs) || !all(sapply(funs, is.function)))
stop ("funs should be a function or a list of functions")
}
if(!all(is.finite(arglim))) stop ("need finite argument range")
options <- simplist(defaultoptions.funsample, ..., .NULL.rm = TRUE)
foos <- as.function(alist (x = , {
result <- sapply(funs, function(f) (do.call(f, list(x))))
if (is.vector(result)) result <- t(as.matrix(result))
result
} ))
firstclass(foos) <- "funsample"
attr(foos, "funs") <- funs
attr(foos, "arglim") <- range(arglim)
attr(foos, "groupsize") <- length(funs)
attr(foos, "options") <- options
foos
}
#'@rdname funsample
#'@param x an \code{R} object to be checked.
#'@description \code{is.funsample} returns \code{TRUE} if \code{x} is an object
#'of class \code{funsample}
#'@export
is.funsample <- function(x) {
inherits(x, "funsample")
}
#'@name funsample_list_methods
#'@aliases c.funsample $.funsample $<-.funsample
#'@title List like methods for class funsample
#'@description Subsetting, concatenation and printing of \code{\link{funsample}}.
#'object
#'@author Ute Hahn \email{ute@@imf.au.dk}
NA
#'@rdname funsample_list_methods
#'@method c funsample
#'@export
#'@param ... for method \code{"c"}:\code{funsample} objects or functions to be concatenated,
#'otherwise further options passed to next methods
#'@param recursive ignored, for compatibility with generic function \code{\link{c}}
#'@details Method \code{"c"} concatenates the function lists (\code{funsample} objects)
#'or functions contained in its arguments. The first argument is always a \code{funsample}
#'object, otherwise this method would not have been called. Any functions contained
#'in the further arguments are appended to the function list of the first argument.
#'The attribute \code{"arglim"} of the result is obtained
#'as intersection of the \code{arglim}s in the arguments. If this intersection is empty,
#'the method returns \code{NULL} and issues a warning. The \code{options} attribute
#'which contains plot options (in particular axis labels) is coerced from the
#'options attributes of the \code{...} arguments. Should there be several
#'options with the same name, priority is on the options of the first
#'\code{funsample} in \code{...}.
#'
#'If \code{...} contains objects that are neither \code{funsample}s nor \code{function}s,
#'an ordinary \code{\link{list}} object is returned.
#'@examples
#'myfuns <- funsample(list(sin = sin, cos = cos), arglim = c(0, 2*pi))
#'myfuns2 <- funsample(list(exp = exp, log = log), arglim = c(0, 2*pi))
#'myfuns <- c(myfuns, tan = tan, myfuns2, f = function(x) x^2)
#'myfuns(c(0, pi/4, pi/2))
#'
c.funsample <- function(..., recursive = FALSE)
{
arglist <- list(...)
if (length(arglist) < 1) return(NULL)
allfun <- all(sapply(arglist, is.funsample) | sapply(arglist, is.function))
if (!allfun)
return(arglist)
if (length(arglist) < 2) return (arglist[[1]])
# get intersection of arglims
fsamples <- arglist[sapply(arglist, is.funsample)]
# functions <- arglist[!sapply(arglist, is.funsample)]
lims <- sapply(fsamples, attr, "arglim")
minarg <- max(lims[1, ])
maxarg <- min(lims[2, ])
if (maxarg <= minarg) {
warning("argument intervals do not overlap")
return(NULL)
}
# coerce options into one simplist
lopt <- lapply(fsamples, attr, "options")
newopt <- do.call(simplist, lopt)
# get list of all functions
funlist <- unlist(lapply(arglist, function (ele){
if(is.funsample(ele)) unlist(attr(ele, "funs"))
else ele
}))
#funlist <- unlist(lapply(fsamples, attr, "funs"))
#funlist <- c(funlist, functions)
funsample(funlist, arglim = c(minarg, maxarg), newopt)
}
#'@rdname funsample_list_methods
#@S3method $ funsample
#@usage \method{$}{funsample} (x, name)
#'@method $ funsample
#'@export
#'@param x \code{funsample} object from which a function is to be extracted
#'or replaced
#'@param name character string or name (possibly backtick quoted) of a function
#'contained \code{x}.
#'@return An \code{\link{urfunction}}, or \code{NULL}.
#'@examples
#'myfuns$f(3)
"$.funsample" <- function(x, name) {
if (!attr(x, "groupsize"))
return(NULL)
funs <- attr(x, "funs")
thefun <- funs[[name]]
plopt <- attr(x,"options")
if (is.null(plopt$ylab) || identical(plopt$ylab, ""))
if (is.null(plopt$xlab) || identical(plopt$xlab, ""))
plopt$ylab <- name
else plopt$ylab <- paste(name, "(",plopt$xlab,")", sep = "")
flopt <- if (is.urfunction(thefun)) attr(thefun, "options") else NULL
urfunction(thefun, simplist(flopt, plopt))
}
#'@rdname funsample_list_methods
#@S3method $<- funsample
#'@method $<- funsample
#'@usage \method{$}{funsample}(x, name) <- value
#'@export
#@param x \code{funsample} object in which a function is to be replaced
#@param name character string or name (possibly backtick quoted) of a function
#contained in \code{x}.
#'@param value replacement value, needs to be a \code{function}, or \code{NULL}.
#'@details Assigning \code{NULL} to a function element of in a funsample \code{x}
#'is equivalent to removing that element from the function sample.
#'@return For \code{x$name <- value} a \code{funsample} object.
#'@examples
#'myfuns$f <- function(x) x - 1
#'myfuns$g <- function(x) x^2 + 1
#'myfuns$log <- NULL
#'myfuns(c(0, pi/4, pi/2, 3))
"$<-.funsample" <- function(x, name, value) {
funs <- attr(x, "funs")
stopifnot (is.null(value) || is.function(value))
funs[[name]] <- value
funsample(funs, attr(x, "arglim"), attr(x, "options"))
}
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.