R devel - Apr 2006 - page() (Was: Re: predict.smooth.spline.fit and Recall() (Was: Re: Return function from function and Recall()))

Here I think S3 dispatch is very natural.  Try the following:

page <- function(x, method = c("dput", "print"), ...)
UseMethod("page")

page.getAnywhere <- function(x, ..., idx=NULL) {
  name <- x$name;
  objects <- x$obj;

  if (length(objects) == 0)
    stop("no object named '", name, "' was found");

  if (is.null(idx)) {
    # Include all non-duplicated objects found
    idx <- (1:length(objects))[!x$dups];
  }

  for (ii in idx) {
    title <- paste(name, " (", x$where[ii], ")",
sep="");
    eval(substitute({
      object <- x$obj[[ii]];
      page(object, ...);
    }, list(object=as.name(title))));
  }
}

page.default <- utils::page;

page(getAnywhere("predict.smooth.spline.fit"))

You can have page.function(), page.character(), page.environment(),
etc. and make these call page.default() indirectly.  What I think
would be a very useful add on is to add an argument 'title' for which
you can set/override the title.  Then the "ugly" substitute() calls
could be limited to one specific case; where a "default" object is
passed and no title is set.

If you want to, I could play around with a bit.

/Henrik

On 4/5/06, Kurt Hornik <Kurt.Hornik at wu-wien.ac.at>
wrote:
> >>>>> Prof Brian Ripley writes:
>
> > On Wed, 5 Apr 2006, Henrik Bengtsson wrote:
> >> Hi,
[snip]
> > As for
>
> >>> PS, may I suggest to modify page() so that
> >>>
'page(getAnywhere("predict.smooth.spline.fit"))' works? DS.
>
> > it is rather tricky.  page() takes a name aka symbol as its argument
> > (and is thereby S-compatible), and also works with a bare character
> > string (undocumented).  What you have here is a call that does not
> > even return a function.  It is more reasonable that
> > stats:::predict.smooth.spline.fit should work, and it is also a call.
> > I have in the past thought about special-casing that, but it is a
> > valid name (you would have to back-quote it, but it does work).  So
> > one possible way out would be to use get() on a name and evaluate
> > calls, e.g.
>
> > page <- function(x, method = c("dput",
"print"), ...)
> > {
> >      subx <- substitute(x)
> >      have_object <- FALSE
> >      if(is.call(subx)) {
> >          object <- x
> >          have_object <- TRUE
> >          subx <- deparse(subx)
> >      } else {
> >          if(is.character(x)) subx <- x
> >          else if(is.name(subx)) subx <- deparse(subx)
> >          if (!is.character(subx) || length(subx) != 1)
> >              stop("'page' requires a name, call or
character string")
> >          parent <- parent.frame()
> >          if(exists(subx, envir = parent, inherits=TRUE)) {
> >              object <- get(subx, envir = parent, inherits=TRUE)
> >              have_object <- TRUE
> >          }
> >      }
> >      if(have_object) {
> >          method <- match.arg(method)
> >          file <- tempfile("Rpage.")
> >          if(method == "dput")
> >              dput(object, file)
> >          else {
> >              sink(file)
> >              print(object)
> >              sink()
> >          }
> >       file.show(file, title = subx, delete.file = TRUE, ...)
> >      } else
> >       stop(gettextf("no object named '%s' to show",
subx), domain = NA)
> > }
>
> > which also allows 1-element character vectors (and I am not entirely
> > sure we want that).
>
> There was a similar issue with prompt() (actually, its default method)
> for which I ended up "temporarily" providing the following
(argh):
>
>         else {
>             name <- substitute(object)
>             if (is.name(name))
>                 as.character(name)
>             else if (is.call(name) && (as.character(name[[1]]) %in%
>                 c("::", ":::",
"getAnywhere"))) {
>                 name <- as.character(name)
>                 name[length(name)]
>             }
>             else stop("cannot determine a usable name")
>         }
>
> Best
> -k
>
> ______________________________________________
> R-devel at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel

On Wed, 5 Apr 2006, Henrik Bengtsson wrote:
> Here I think S3 dispatch is very natural.  Try the following:
I don't: it is documented to work on a name not an object.
> page <- function(x, method = c("dput", "print"),
...) UseMethod("page")
>
> page.getAnywhere <- function(x, ..., idx=NULL) {
>  name <- x$name;
>  objects <- x$obj;
>
>  if (length(objects) == 0)
>    stop("no object named '", name, "' was
found");
>
>  if (is.null(idx)) {
>    # Include all non-duplicated objects found
>    idx <- (1:length(objects))[!x$dups];
>  }
>
>  for (ii in idx) {
>    title <- paste(name, " (", x$where[ii], ")",
sep="");
>    eval(substitute({
>      object <- x$obj[[ii]];
>      page(object, ...);
>    }, list(object=as.name(title))));
>  }
> }
>
> page.default <- utils::page;
>
> page(getAnywhere("predict.smooth.spline.fit"))
>
> You can have page.function(), page.character(), page.environment(),
> etc. and make these call page.default() indirectly.  What I think
> would be a very useful add on is to add an argument 'title' for
which
> you can set/override the title.  Then the "ugly" substitute()
calls
> could be limited to one specific case; where a "default" object
is
> passed and no title is set.
>
> If you want to, I could play around with a bit.
>
> /Henrik
>
> On 4/5/06, Kurt Hornik <Kurt.Hornik at wu-wien.ac.at> wrote:
>>>>>>> Prof Brian Ripley writes:
>>
>>> On Wed, 5 Apr 2006, Henrik Bengtsson wrote:
>>>> Hi,
>
> [snip]
>
>>> As for
>>
>>>>> PS, may I suggest to modify page() so that
>>>>>
'page(getAnywhere("predict.smooth.spline.fit"))' works? DS.
>>
>>> it is rather tricky.  page() takes a name aka symbol as its
argument
>>> (and is thereby S-compatible), and also works with a bare character
>>> string (undocumented).  What you have here is a call that does not
>>> even return a function.  It is more reasonable that
>>> stats:::predict.smooth.spline.fit should work, and it is also a
call.
>>> I have in the past thought about special-casing that, but it is a
>>> valid name (you would have to back-quote it, but it does work).  So
>>> one possible way out would be to use get() on a name and evaluate
>>> calls, e.g.
>>
>>> page <- function(x, method = c("dput",
"print"), ...)
>>> {
>>>      subx <- substitute(x)
>>>      have_object <- FALSE
>>>      if(is.call(subx)) {
>>>          object <- x
>>>          have_object <- TRUE
>>>          subx <- deparse(subx)
>>>      } else {
>>>          if(is.character(x)) subx <- x
>>>          else if(is.name(subx)) subx <- deparse(subx)
>>>          if (!is.character(subx) || length(subx) != 1)
>>>              stop("'page' requires a name, call or
character string")
>>>          parent <- parent.frame()
>>>          if(exists(subx, envir = parent, inherits=TRUE)) {
>>>              object <- get(subx, envir = parent, inherits=TRUE)
>>>              have_object <- TRUE
>>>          }
>>>      }
>>>      if(have_object) {
>>>          method <- match.arg(method)
>>>          file <- tempfile("Rpage.")
>>>          if(method == "dput")
>>>              dput(object, file)
>>>          else {
>>>              sink(file)
>>>              print(object)
>>>              sink()
>>>          }
>>>       file.show(file, title = subx, delete.file = TRUE, ...)
>>>      } else
>>>       stop(gettextf("no object named '%s' to
show", subx), domain = NA)
>>> }
>>
>>> which also allows 1-element character vectors (and I am not
entirely
>>> sure we want that).
>>
>> There was a similar issue with prompt() (actually, its default method)
>> for which I ended up "temporarily" providing the following
(argh):
>>
>>         else {
>>             name <- substitute(object)
>>             if (is.name(name))
>>                 as.character(name)
>>             else if (is.call(name) && (as.character(name[[1]])
%in%
>>                 c("::", ":::",
"getAnywhere"))) {
>>                 name <- as.character(name)
>>                 name[length(name)]
>>             }
>>             else stop("cannot determine a usable name")
>>         }
>>
>> Best
>> -k
>>
>> ______________________________________________
>> R-devel at r-project.org mailing list
>> https://stat.ethz.ch/mailman/listinfo/r-devel
>
> ______________________________________________
> R-devel at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
>
>
-- 
Brian D. Ripley,                  ripley at stats.ox.ac.uk
Professor of Applied Statistics,  http://www.stats.ox.ac.uk/~ripley/
University of Oxford,             Tel:  +44 1865 272861 (self)
1 South Parks Road,                     +44 1865 272866 (PA)
Oxford OX1 3TG, UK                Fax:  +44 1865 272595