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.
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 <[email protected]>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]]
______________________________________________
[email protected] mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
