R/funsample.R

In fdnonpar: Methods for Multivariate or Functional Data

# 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"))
}