You can more or less get what you want by reassigning the environment
of the formula to be a child of its original environment, where you put
your private functions in the new environment. For example, do not
export trt and make the following change to your R code:
% diff -u foo/R/cmt.R~ foo/R/cmt.R
--- foo/R/cmt.R~ 2014-01-28 09:10:58.272711000 -0800
+++ foo/R/cmt.R 2014-01-28 09:09:06.299398000 -0800
@@ -1,9 +1,12 @@
-trt <- function(x) x
+trt <- function(x) { cat("Calling foo:::trt\n"); x }
cmt <- function(formula, data, subset, na.action = na.pass) {
if (!inherits(formula, "formula"))
stop("Method is only for formula objects.")
+ intercalatedEnvir <- new.env(parent=environment(formula))
+ intercalatedEnvir$trt <- trt
+ environment(formula) <- intercalatedEnvir
mf <- match.call(expand.dots = FALSE)
args <- match(c("formula", "data", "subset", "na.action"),
names(mf), 0)
Bill Dunlap
TIBCO Software
wdunlap tibco.com
> -----Original Message-----
> From: r-devel-boun...@r-project.org [mailto:r-devel-boun...@r-project.org] On
> Behalf
> Of Axel Urbiz
> Sent: Tuesday, January 28, 2014 3:33 AM
> To: Henrik Bengtsson
> Cc: r-devel
> Subject: Re: [Rd] package NAMESPACE question
>
> Hi,
>
> I've tried to put together a simpler example where I'm having the issue.
>
> I've built a foo package by only including a single .R file with the two
> functions listed below: trt and cmt. The second function calls the first.
> In the namespace file, if I only export(cmt), I get the following error
> message when running this
>
> library(foo)
> set.seed(1)
> dd <- data.frame(y = rbinom(100, 1, 0.5), treat = rbinom(100, 1, 0.5), x =
> rnorm(100),
> f = gl(4, 250, labels = c("A", "B", "C", "D")))
> dd2 <- cmt(y ~ x + f + trt(treat), data =dd)
> > Error could not find function "trt"
>
> The problem is solved by doing export(cmt, trt) in the namespace. However,
> I'd like to avoid exporting trt and should not be required. Sorry I can't
> seem to figure this out by myself, and so I'd appreciate your help.
>
> Thanks,
> Axel.
>
> ----
>
> #mycodefiles <- c("cmt.R")
> #package.skeleton(name = "foo", code_files = mycodefiles)
> #promptPackage("foo")
>
> #where cmt.R includes the code below:
>
> trt <- function(x) x
>
> cmt <- function(formula, data, subset, na.action = na.pass) {
>
> if (!inherits(formula, "formula"))
> stop("Method is only for formula objects.")
> mf <- match.call(expand.dots = FALSE)
> args <- match(c("formula", "data", "subset", "na.action"),
> names(mf), 0)
> mf <- mf[c(1, args)]
> mf$drop.unused.levels <- TRUE
> mf[[1]] <- as.name("model.frame")
> special <- "trt"
> mt <- if(missing(data)) terms(formula, special) else terms(formula,
> special, data = data)
> browser()
> mf$formula <- mt
> mf <- eval.parent(mf)
> Terms <- attr(mf, "terms")
> attr(Terms, "intercept") <- 0
> trt.var <- attr(Terms, "specials")$trt
> ct <- mf[, trt.var]
> y <- model.response(mf, "numeric")
> var_names <- attributes(Terms)$term.labels[-(trt.var-1)]
> x <- model.matrix(terms(reformulate(var_names)),
> mf, contrasts)
> intercept <- which(colnames(x) == "(Intercept)")
> if (length(intercept > 0)) x <- x[, -intercept]
> return(x)
> }
>
>
>
>
> On Mon, Jan 27, 2014 at 2:42 AM, Henrik Bengtsson
> <h...@biostat.ucsf.edu>wrote:
>
> > On Sun, Jan 26, 2014 at 6:34 AM, Axel Urbiz <axel.ur...@gmail.com> wrote:
> > > Hi Duncan,
> > >
> > > My most sincere apologies. It's really not my intention to waste anyones
> > > time. More the opposite...for some reason I thought that the problem had
> > to
> > > do with my call to options() and thought that would be enough. Here's
> > > something reproducible:
> > >
> > > I built a foo package based on the code under the "----" below. In the
> > > namespace file, I've only exported: trt and cmt (not contr.none and
> > > contr.diff). Notice that cmt calls contr.none and contr.diff by default.
> >
> > As a start, try to export everything, particularly 'contr.none' and
> > 'contr.diff' and see if that works. Just a guess, but worth trying
> > out.
> >
> > My $.02
> >
> > /Henrik
> >
> > >
> > > Then in R, I run this code and I get this error message:
> > >
> > > library(foo)
> > > set.seed(1)
> > > dd <- data.frame(y = rbinom(100, 1, 0.5), treat = rbinom(100, 1, 0.5), x
> > =
> > > rnorm(100),
> > > f = gl(4, 250, labels = c("A", "B", "C", "D")))
> > > dd2 <- cmt(y ~ x + f + trt(treat), data =dd)
> > >> Error in get(ctr, mode = "function", envir = parent.frame()) :
> > > object 'contr.none' of mode 'function' was not found
> > >
> > > Thanks,
> > > Axel.
> > >
> > > --------------------------------------------
> > >
> > > trt <- function(x) x
> > >
> > > cmt <- function(formula, data, subset, na.action = na.pass, cts = TRUE)
> > {
> > >
> > > if (!inherits(formula, "formula"))
> > > stop("Method is only for formula objects.")
> > > mf <- match.call(expand.dots = FALSE)
> > > args <- match(c("formula", "data", "subset", "na.action"),
> > > names(mf), 0)
> > > mf <- mf[c(1, args)]
> > > mf$drop.unused.levels <- TRUE
> > > mf[[1]] <- as.name("model.frame")
> > > special <- "trt"
> > > mt <- if(missing(data)) terms(formula, special) else terms(formula,
> > > special, data = data)
> > > mf$formula <- mt
> > > mf <- eval.parent(mf)
> > > Terms <- attr(mf, "terms")
> > > attr(Terms, "intercept") <- 0
> > > trt.var <- attr(Terms, "specials")$trt
> > > ct <- mf[, trt.var]
> > > y <- model.response(mf, "numeric")
> > > var_names <- attributes(Terms)$term.labels[-(trt.var-1)]
> > > treat.names <- levels(as.factor(ct))
> > > oldcontrasts <- unlist(options("contrasts"))
> > > if (cts)
> > > options(contrasts = c(unordered = "contr.none", ordered =
> > "contr.diff"))
> > > x <- model.matrix(terms(reformulate(var_names)),
> > > mf, contrasts)
> > > options(contrasts = oldcontrasts)
> > > intercept <- which(colnames(x) == "(Intercept)")
> > > if (length(intercept > 0)) x <- x[, -intercept]
> > > return(x)
> > > }
> > >
> > > #######################################
> > > # An alternative contrasts function for unordered factors
> > > # Ensures symmetric treatment of all levels of a factor
> > > #######################################
> > > contr.none <- function(n, contrasts) {
> > > if (length(n) == 1)
> > > contr.treatment(n, contrasts = n<=2)
> > > else
> > > contr.treatment(n, contrasts = length(unique(n))<=2)
> > > }
> > >
> > > #######################################
> > > # An alternative contrasts function for ordered factors
> > > # Ensures use of a difference penalty for such factors
> > > #######################################
> > > contr.diff <- function (n, contrasts = TRUE)
> > > {
> > > if (is.numeric(n) && length(n) == 1) {
> > > if (n > 1)
> > > levs <- 1:n
> > > else stop("not enough degrees of freedom to define contrasts")
> > > }
> > > else {
> > > levs <- n
> > > n <- length(n)
> > > }
> > > contr <- array(0, c(n, n), list(levs, paste(">=", levs, sep="")))
> > > contr[outer(1:n,1:n, ">=")] <- 1
> > > if (n < 2)
> > > stop(gettextf("contrasts not defined for %d degrees of freedom",
> > > n - 1), domain = NA)
> > > if (contrasts)
> > > contr <- contr[, -1, drop = FALSE]
> > > contr
> > > }
> > >
> > >
> > >
> > > On Sun, Jan 26, 2014 at 1:21 PM, Duncan Murdoch <
> > murdoch.dun...@gmail.com>wrote:
> > >
> > >> On 14-01-25 6:05 PM, Axel Urbiz wrote:
> > >>
> > >>> Thanks again all. Essentially, this is the section of the code that is
> > >>> causing trouble. This is part of the (exported) function which calls
> > >>> contr.none (not exported). As mentioned, when I call the exported
> > function
> > >>> it complains with the error described before.
> > >>>
> > >>>
> > >>> oldcontrasts <- unlist(options("contrasts"))
> > >>> if (cts)
> > >>> options(contrasts = c(unordered = "contr.none", ordered =
> > >>> "contr.diff"))
> > >>> x <- model.matrix(terms(reformulate(var_names)), mf, contrasts)
> > >>> options(contrasts = oldcontrasts)
> > >>>
> > >>
> > >> This is hugely incomplete. Please stop wasting everyone's time, and
> > post
> > >> something reproducible.
> > >>
> > >> Duncan Murdoch
> > >>
> > >>
> > >
> > > [[alternative HTML version deleted]]
> > >
> > > ______________________________________________
> > > R-devel@r-project.org mailing list
> > > https://stat.ethz.ch/mailman/listinfo/r-devel
> >
>
> [[alternative HTML version deleted]]
>
> ______________________________________________
> R-devel@r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
