Handle unexported functions in *Defaults()

setDefaults() was not able to find unexported functions (e.g.
getQuote.av()), so users could not set defaults for them.

The bulk of the changes are in setDefaults() in order to verify the
function exists, exported or not, and has a call to importDefaults().

Then we always capture the call in getDefaults() and unsetDefaults()
to avoid the possibility that the function is not exported. We do not
need to re-verify because the default options will only exist if
setDefaults() created them.

Fixes #316.

R/Defaults.R

@@ -41,25 +41,92 @@ function(calling.fun=NULL) {
     }
   }
 }
+
 `setDefaults` <-
 function (name, ...) 
 {
-    if (is.function(name)) 
+    # 'name' can be a character string or a symbol.
+    # We need the character string representation of the function name so
+    # we can use it to create the option name. Then we can look it up via
+    # importDefaults() when the function is called.
+
+    # Should also document that 'name' can be a symbol, but only at the top
+    # level. Calls to setDefaults() (etc.) within functions must use character
+    # strings to identify functions.
+
+    is.func <-
+      try({
+        is.function(name)
+        eval(parse(text=name))
+      }, silent=TRUE)
+
+    # if the try() errors, try to find the function anywhere
+    # the error is likely because the function is not exported
+    if(inherits(is.func, "try-error")) {
+      # get the character representation of the symbol
+      name.str <- deparse(substitute(name))
+      # remove quotes in the case 'name' is already character
+      name.str <- gsub("['\"]", "", name.str)
+
+      ga.func <- getAnywhere(name.str)
+      ga.objs <- ga.func[["objs"]]
+
+      if (length(ga.objs) < 1) {
+        stop("no function named '", ga.func$name, "' was found")
+      }
+
+      # check that the function body has a call to importDefaults()
+      has.importDefaults <- function(fn) {
+        out <- FALSE
+        if (is.function(fn)) {
+          chr <- as.character(body(fn))
+          has <- grepl("importDefaults", chr, fixed = TRUE)
+          out <- any(has)
+        } else {
+          out <- FALSE
+        }
+        out
+      }
+      is.valid <- sapply(ga.objs, has.importDefaults)
+      is.visible <- ga.func[["visible"]]
+      first.choice <- which(is.valid & is.visible)
+
+      if(length(first.choice) < 1) {
+        # first non-visible function
+        first.choice <- which(is.valid)
+        if(length(first.choice) < 1) {
+          # nothing visible and valid
+          stop("argument 'name' must be a function that contains a",
+               "call to 'importDefaults()'")
+        }
+      } else {
+        first.choice <- first.choice[1]
+      }
+
+      name <- ga.func[["name"]]
+      avail.defaults <- formals(ga.objs[[first.choice]])
+    } else {
+      if (is.function(name)) {
         name <- deparse(substitute(name))
-    if(!is.function(eval(parse(text=name))))
-      stop("argument 'name' must be a function")
+      }
+      func <- eval(parse(text=name))
+      if (!is.function(func)) {
+        stop("argument 'name' must be a function", call. = FALSE)
+      }
+      avail.defaults <- formals(func)
+    }
 
     default.name <- paste(name, "Default", sep = ".")
     old.defaults <- getDefaults(name)
     new.defaults <- list(...)
-    avail.defaults <- formals(name)
+
     matched.defaults <- list()
     for(arg in names(new.defaults)) {
       if(!is.na(pmatch(arg,names(avail.defaults)))) {
         # if partial match is made:
         arg.name <- match.arg(arg,names(avail.defaults))
         mc <- match.call()[[arg]]
-        if(typeof(mc)=='language') mc <- eval(mc)
+        if(is.language(mc)) mc <- eval(mc)
         if(is.character(mc))
             new.defaults[[arg]] <-  paste("'", mc, "'", sep = "")
         if(is.name(mc))
@@ -94,11 +161,16 @@ function (name, ...)
     }
 }
 
-
 `unsetDefaults` <-
 function(name,confirm=TRUE) {
   importDefaults(calling.fun='unsetDefaults')
-  if(is.function(name)) name <- deparse(substitute(name))
+
+  fcall <- match.call()
+  fc.name <- fcall[['name']]
+  if(is.language(fc.name)) {
+    name <- deparse(substitute(fc.name))
+  }
+
   if(is.null(getDefaults(name))) 
     invisible(return())
     #stop(paste("no Defaults set for",sQuote(name)))
@@ -121,10 +193,24 @@ function(name,confirm=TRUE) {
     eval(parse(text=paste('options(',default.name,'=NULL)',sep='')),envir=env)
   }
 }
+
 "getDefaults" <-
 function(name=NULL,arg=NULL) {
-  if(is.function(name)) name <- deparse(substitute(name))
+
+  # 'name' can be a function name, expression, or character
+  fcall <- match.call()
+  fc.name <- fcall[['name']]
+  if(is.language(fc.name)) {
+    name <- deparse(substitute(fc.name))
+  }
+
   if(!is.null(name)) {
+
+    if(!is.character(name)) {
+      fcall <- match.call()
+      name <- as.character(fcall[['name']])
+    }
+
     if(length(name) > 1) {
       if(!is.character(name))
         stop(paste(sQuote('name'),"must be a character vector",

man/Defaults.Rd

@@ -17,7 +17,7 @@ getDefaults(name = NULL, arg = NULL)
 importDefaults(calling.fun)
 }
 \arguments{
-  \item{name}{ name of function, quoted or unquoted }
+  \item{name}{ name of function, quoted or unquoted (see Details) }
   \item{\dots}{ name=value default pairs }
   \item{confirm}{ prompt before unsetting defaults }
   \item{arg}{ values to retrieve } 
@@ -35,6 +35,10 @@ importDefaults(calling.fun)
       function one at a time, without having to retype all previous values.
       Assigning \code{NULL} to any argument will remove the argument from
       the defaults list.
+
+      \code{name} can be an unquoted, bare symbol only at the top-level. It
+      must be a quoted character string if you call \code{setDefaults} inside
+      a function. 
     }
     \item{unsetDefaults}{
       Removes name=value pairs from the defaults list.

tests/test_Defaults.R

@@ -0,0 +1,57 @@
+library(quantmod)
+
+
+### tests with character function name
+# set
+setDefaults("getQuote.av", api.key = "abc")
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(identical("'abc'", default.key))
+# unset
+unsetDefaults("getQuote.av", confirm = FALSE)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))
+
+
+### tests with character function name and symbol default
+fake.key <- "abc"
+# set
+setDefaults("getQuote.av", api.key = fake.key)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(identical(sQuote(fake.key), default.key))
+# unset
+unsetDefaults("getQuote.av", confirm = FALSE)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))
+
+
+### tests with exported symbol function name
+# set
+setDefaults(getSymbols, src = "abc")
+default.key <- getDefaults(getSymbols)[["src"]]
+stopifnot(identical("'abc'", default.key))
+# unset
+unsetDefaults(getSymbols, confirm = FALSE)
+default.key <- getDefaults("getSymbols")[["api.key"]]
+stopifnot(is.null(default.key))
+
+
+# set
+setDefaults(getQuote.av, api.key = "abc")
+default.key <- getDefaults(getQuote.av)[["api.key"]]
+stopifnot(identical("'abc'", default.key))
+# unset
+unsetDefaults(getQuote.av, confirm = FALSE)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))
+
+
+# tests with symbol function name and symbol default
+fake.key <- "abc"
+# set
+setDefaults(getQuote.av, api.key = fake.key)
+default.key <- getDefaults(getQuote.av)[["api.key"]]
+stopifnot(identical(sQuote(fake.key), default.key))
+# unset
+unsetDefaults(getQuote.av, confirm = FALSE)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))