Site icon R-bloggers

Inheriting in Items

[This article was first published on Struggling Through Problems, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
< !-- begin{Schunk} !--> < !--\end{Schunk}!-->

What if we want to extend the behavior of one item with another? Or, to put it another way, what if we want one item to be able to grab the functionality of another?

It turns out we can (almost) get this behavior without modifying the item constructor at all. Here’s how you do the grabbing:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> grab = function(src, obj=parent.frame()) {

> for (name in ls(src)) {

> (function(name) {

> if (!exists(name, obj, inh=F)) {

> delayedAssign(name, src[[name]], assign.env=obj)

> }

> })(name)

> }

> }

< !-- ccc --> < !--\end{Sinput}!--> < !--\end{Schunk}!-->

Now let’s use that:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> A = item(

> x =,

> y =,

>

> sum = x + y

> )

< !-- ccc -->

> B = item(

> x =,

> y =,

>

> init = grab(A(x, y))

> )

< !-- ccc -->

> b = B(2, 3)

< !-- ccc -->

> as.list(b)

< !-- ccc --> < !-- end{Sinput} !-->

$sum
[1] 2

$x
[1] 3

$y
NULL

< !--\end{Schunk}!-->

What is going on here?? This one is really tricky; it took me 1/2 hour or so to figure it out.

So, clearly, the problem starts with the fact that init is evaluated too late. We could easily fix the problem like this:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> b = B(2, 3)

< !-- ccc -->

> force(b$init)

< !-- ccc --> < !-- end{Sinput} !-->

NULL

< !-- begin{Sinput} !-->

> as.list(b)

< !-- ccc --> < !-- end{Sinput} !-->

$sum
[1] 5

$x
[1] 2

$y
[1] 3

$init
NULL

< !--\end{Schunk}!-->

But what’s with the argument values appearing with the wrong names? Here’s the C function that implements as.list.environment:

    1 SEXP attribute_hidden do_env2list(SEXP call, SEXP op, SEXP args, SEXP rho)
    2 {
    3     SEXP env, ans, names;
    4     int k, all;
    5 
    6     checkArity(op, args);
    7 
    8     env = CAR(args);
    9     if (ISNULL(env))
   10     error(_("use of NULL environment is defunct"));
   11     if( !isEnvironment(env) ) {
   12         SEXP xdata;
   13     if( IS_S4_OBJECT(env) && TYPEOF(env) == S4SXP &&
   14         (xdata = R_getS4DataSlot(env, ENVSXP)) != R_NilValue)
   15         env = xdata;
   16     else
   17         error(_("argument must be an environment"));
   18     }
   19 
   20     all = asLogical(CADR(args));
   21     if (all == NA_LOGICAL) all = 0;
   22 
   23     if (env == R_BaseEnv || env == R_BaseNamespace)
   24     k = BuiltinSize(all, 0);
   25     else if (HASHTAB(env) != R_NilValue)
   26     k = HashTableSize(HASHTAB(env), all);
   27     else
   28     k = FrameSize(FRAME(env), all);
   29 
   30     PROTECT(names = allocVector(STRSXP, k));
   31     PROTECT(ans = allocVector(VECSXP, k));
   32 
   33     k = 0;
   34     if (env == R_BaseEnv || env == R_BaseNamespace)
   35     BuiltinValues(all, 0, ans, &k);
   36     else if (HASHTAB(env) != R_NilValue)
   37     HashTableValues(HASHTAB(env), all, ans, &k);
   38     else
   39     FrameValues(FRAME(env), all, ans, &k);
   40 
   41     k = 0;
   42     if (env == R_BaseEnv || env == R_BaseNamespace)
   43     BuiltinNames(all, 0, names, &k);
   44     else if (HASHTAB(env) != R_NilValue)
   45     HashTableNames(HASHTAB(env), all, names, &k);
   46     else
   47     FrameNames(FRAME(env), all, names, &k);
   48 
   49     setAttrib(ans, R_NamesSymbol, names);
   50     UNPROTECT(2);
   51     return(ans);
   52 }
   53 

Notice that it grabs the values first, and the names second. So when it goes to grab the values, they are 2, 3, and a promise to evaluate grab(A(x, y)). But wait… while it’s getting those values, won’t the promise be evaluated, and change the structure R is working on?

Yes… and that could be a problem, but it isn’t:

    1 static void FrameValues(SEXP frame, int all, SEXP values, int *indx)
    2 {
    3     while (frame != R_NilValue) {
    4     if ((all || CHAR(PRINTNAME(TAG(frame)))[0] != '.') &&
    5                       CAR(frame) != R_UnboundValue) {
    6         SEXP value = CAR(frame);
    7         if (TYPEOF(value) == PROMSXP) {
    8         PROTECT(value);
    9         value = eval(value, R_GlobalEnv);
   10         UNPROTECT(1);
   11         }
   12         SET_VECTOR_ELT(values, *indx, duplicate(value));
   13         (*indx)++;
   14     }
   15     frame = CDR(frame);
   16     }
   17 }
   18 

Values are stored in a pair list, which is like a linked list in that modifications to the front of the list don’t affect someone already iterating further down. So grab() sticks sum at the beginning, where it won’t show up in the values. And the result of grab() is the NULL that you see in the 3rd value.

Then it goes to get the names. But it’s only allocated space for 3 names, because it already checked the size. So the first 3 names are sum, x, and y. And that’s what you see. From looking at how FrameNames works, it looks like this should cause a buffer overrun, but that doesn’t show up.

We could have an item automatically check for the existence of init at instantiation time and run it if it exists, but I prefer a more general solution:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> item = function() {

> foo = function() {

> E = environment()

>

> for (i in seq_along(args)) {

> name = args.names[[i]]

> if (substr(name, 1, 1) == ‘.’) {

> force(E[[name]])

> }

> }

>

> E

> }

>

> args = process.args(as.list(substitute(list()))[1L])

> args.names = names(args)

> formals(foo) = args

>

> foo

> }

< !-- ccc --> < !--\end{Sinput}!--> < !--\end{Schunk}!-->

That is, we force all arguments starting with a ‘.’. Then we can modify process.args to give unnamed arguments a name with a ‘.’:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> process.args = function(args) {

> arg.names = names(args)

> if (is.null(arg.names)) {

> arg.names = replicate(length(args), NULL)

> }

>

> for (i in seq_along(args)) {

> if (is.null(arg.names[[i]]) || arg.names[[i]] == ) {

> arg.names[[i]] = paste(‘.’, as.character(i), sep=)

> }

> }

>

> names(args) = arg.names

>

> args

> }

< !-- ccc --> < !--\end{Sinput}!--> < !--\end{Schunk}!-->

Now we can write:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> B = item(

> x =,

> y =,

>

> grab(A(x, y))

> )

< !-- ccc -->

> b = B(2, 3)

< !-- ccc -->

> as.list(b)

< !-- ccc --> < !-- end{Sinput} !-->

$sum
[1] 5

$name
[1] “.3”

$i
[1] 3

$E
< environment: 0x138cbb0>

$x
[1] 2

$y
[1] 3

< !--\end{Schunk}!-->

Oh yeah we have some extra junk in there. We could hide it with ‘.’ names, or we could hide everything by nesting:

< !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> item = function() {

> foo = function() {

> (function() {

> E = parent.frame()

>

> for (i in seq_along(args)) {

> name = args.names[[i]]

> if (substr(name, 1, 1) == ‘.’) {

> force(E[[name]])

> }

> }

> })()

>

> environment()

> }

>

> args = process.args(as.list(substitute(list()))[1L])

> args.names = names(args)

> formals(foo) = args

>

> foo

> }

< !-- ccc --> < !--\end{Sinput}!--> < !--\end{Schunk}!--> < !-- begin{Schunk} !--> < !-- begin{Sinput} !-->

> B = item(

> x =,

> y =,

>

> grab(A(x, y))

> )

< !-- ccc -->

> b = B(2, 3)

< !-- ccc -->

> as.list(b)

< !-- ccc --> < !-- end{Sinput} !-->

$sum
[1] 5

$x
[1] 2

$y
[1] 3

< !--\end{Schunk}!-->

Perfect.

To leave a comment for the author, please follow the link and comment on their blog: Struggling Through Problems.

R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.