| # File src/library/base/R/match.fun.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2012 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| ### clean up FUN arguments to *apply, outer, sweep, etc. |
| ### note that this grabs two levels back and is not designed |
| ### to be called at top level |
| match.fun <- function (FUN, descend = TRUE) |
| { |
| if ( is.function(FUN) ) |
| return(FUN) |
| if (!(is.character(FUN) && length(FUN) == 1L || is.symbol(FUN))) { |
| ## Substitute in parent |
| FUN <- eval.parent(substitute(substitute(FUN))) |
| if (!is.symbol(FUN)) |
| stop(gettextf("'%s' is not a function, character or symbol", |
| deparse(FUN)), domain = NA) |
| } |
| envir <- parent.frame(2) |
| if( descend ) |
| FUN <- get(as.character(FUN), mode = "function", envir = envir) |
| else { |
| FUN <- get(as.character(FUN), mode = "any", envir = envir) |
| if( !is.function(FUN) ) |
| stop(gettextf("found non-function '%s'", FUN), domain = NA) |
| } |
| return(FUN) |
| } |