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().

Check if the name is a function in getDefaults() and unsetDefaults().
Use try() to capture instances where 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)
+
+    # 'name' can be a function name, expression, or character
+    # the try() catches instances where name is an unexported symbol
+    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,17 @@ function (name, ...)
     }
 }
 
-
 `unsetDefaults` <-
 function(name,confirm=TRUE) {
   importDefaults(calling.fun='unsetDefaults')
-  if(is.function(name)) name <- deparse(substitute(name))
+
+  # 'name' can be a function name, expression, or character
+  # the try() catches instances where name is an unexported symbol
+  name.is.function <- try(is.function(name), silent = TRUE)
+  if(inherits(name.is.function, "try-error") || isTRUE(name.is.function)) {
+    name <- deparse(substitute(name))
+  }
+
   if(is.null(getDefaults(name))) 
     invisible(return())
     #stop(paste("no Defaults set for",sQuote(name)))
@@ -121,10 +194,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
+  # the try() catches instances where name is an unexported symbol
+  name.is.function <- try(is.function(name), silent = TRUE)
+  if(inherits(name.is.function, "try-error") || isTRUE(name.is.function)) {
+    name <- deparse(substitute(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,114 @@
+library(quantmod)
+
+api.key <- "abc"
+src <- "xyz"
+
+# {{{ Unexported function
+
+### function name as character
+### --------------------------
+
+## default argument as character
+# set
+setDefaults("getQuote.av", api.key = "abc")
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(identical("'abc'", default.key))
+# unset
+unset <- unsetDefaults("getQuote.av", confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))
+
+## default argument as symbol
+# set 
+setDefaults("getQuote.av", api.key = api.key)
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(identical(sQuote(api.key), default.key))
+# unset
+unset <- unsetDefaults("getQuote.av", confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.key <- getDefaults("getQuote.av")[["api.key"]]
+stopifnot(is.null(default.key))
+
+### function name as symbol
+### -----------------------
+
+## default argument as character
+# set
+setDefaults(getQuote.av, api.key = "abc")
+default.key <- getDefaults(getQuote.av)[["api.key"]]
+stopifnot(identical("'abc'", default.key))
+# unset
+unset <- unsetDefaults(getQuote.av, confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.key <- getDefaults(getQuote.av)[["api.key"]]
+stopifnot(is.null(default.key))
+
+## default argument as symbol
+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
+unset <- unsetDefaults(getQuote.av, confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.key <- getDefaults(getQuote.av)[["api.key"]]
+stopifnot(is.null(default.key))
+
+# }}} Unexported function
+
+
+# {{{ Exported function
+
+### function name as character
+### --------------------------
+
+## default argument as character
+# set
+setDefaults("getSymbols", src = "xyz")
+default.src <- getDefaults("getSymbols")[["src"]]
+stopifnot(identical("'xyz'", default.src))
+# unset
+unset <- unsetDefaults("getSymbols", confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.src <- getDefaults("getSymbols")[["src"]]
+stopifnot(is.null(default.src))
+
+## default argument as symbol
+# set
+setDefaults("getSymbols", src = src)
+default.src <- getDefaults("getSymbols")[["src"]]
+stopifnot(identical("'xyz'", default.src))
+# unset
+unset <- unsetDefaults("getSymbols", confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.src <- getDefaults("getSymbols")[["src"]]
+stopifnot(is.null(default.src))
+
+### function name as symbol
+### -----------------------
+
+## default argument as character
+# set
+setDefaults(getSymbols, src = "xyz")
+default.src <- getDefaults(getSymbols)[["src"]]
+stopifnot(identical("'xyz'", default.src))
+# unset
+unset <- unsetDefaults(getSymbols, confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.src <- getDefaults(getSymbols)[["src"]]
+stopifnot(is.null(default.src))
+
+## default argument as symbol
+# set
+setDefaults(getSymbols, src = src)
+default.src <- getDefaults(getSymbols)[["src"]]
+stopifnot(identical("'xyz'", default.src))
+# unset
+unset <- unsetDefaults(getSymbols, confirm = FALSE)
+stopifnot(!is.null(unset))  # should not be NULL
+default.src <- getDefaults(getSymbols)[["src"]]
+stopifnot(is.null(default.src))
+
+# }}} Exported function