← Back to branch summary

~ubuntu-branches/ubuntu/edgy/lme4/edgy

« back to all changes in this revision

Viewing changes to R/formulas.R

  • Committer: Bazaar Package Importer
  • Author(s): Dirk Eddelbuettel
  • Date: 2006-02-17 20:01:03 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20060217200103-u67qhxscdt4gd713
Tags: 0.995.2-1.1
http://bugs.debian.org/352854
* NMU
* debian/rules: Standardized to be aligned with other R packages
                                         (Closes: #352854)
* debian/control: Changed to Architecture: to `all'
* debian/control: Changed Build-Depends: to Build-Depends-Indep:
* debian/watch: Updated regular expression, added `uversionmangle'

Show diffs side-by-side

added added

removed removed

Lines of Context:
R/formulas.R
1
 
## Methods for dealing with formulas
2
 
 
3
 
splitFormula <-
4
 
    function(form, sep = "/")
5
 
{
6
 
    ## split, on the sep call, the rhs of a formula into a list of subformulas
7
 
    if (inherits(form, "formula") ||
8
 
        mode(form) == "call" && form[[1]] == as.name("~"))
9
 
        return(splitFormula(form[[length(form)]], sep = sep))
10
 
    if (mode(form) == "call" && form[[1]] == as.name(sep))
11
 
        return(do.call("c", lapply(as.list(form[-1]), splitFormula, sep = sep)))
12
 
    if (mode(form) == "(") return(splitFormula(form[[2]], sep = sep))
13
 
    if (length(form) < 1) return(NULL)
14
 
    list(asOneSidedFormula(form))
15
 
}
16
 
 
17
 
subFormula <- function(form, pos = 2)
18
 
{
19
 
    ## extract component pos of form as a formula preserving the environment
20
 
    comp = form[[pos]]
21
 
    val = eval(substitute(~comp))
22
 
    environment(val) = environment(form)
23
 
    val
24
 
}
25
 
 
26
 
getCovariateFormula <- function(object)
27
 
{
28
 
    ## Return the primary covariate formula as a one sided formula
29
 
    form <- formula(object)
30
 
    form <- form[[length(form)]]
31
 
    if (length(form) == 3 && form[[1]] == as.name("|")){ # conditional expression
32
 
        form <- form[[2]]
33
 
    }
34
 
    eval(substitute(~form))
35
 
}
36
 
 
37
 
getResponseFormula <- function(object)
38
 
{
39
 
    ## Return the response formula as a one sided formula
40
 
    form <- formula(object)
41
 
    if (!(inherits(form, "formula") && (length(form) == 3)))
42
 
        stop("object must yield a two-sided formula")
43
 
    subFormula(form, 2)
44
 
}
45
 
 
46
 
setMethod("getGroupsFormula", signature(object = "ANY"),
47
 
          function(object, asList = FALSE, sep = "/")
48
 
      {
49
 
          form = formula(object)
50
 
          if (!inherits(form, "formula")) stop("object must yield a formula")
51
 
          rhs = form[[length(form)]]
52
 
          if (length(rhs) < 2 || rhs[[1]] != as.name("|")) return(NULL)
53
 
          if (asList) {
54
 
              val = splitFormula(asOneSidedFormula(rhs[[3]]), sep = sep)
55
 
              names(val) = unlist(lapply(val, function(el) deparse(el[[2]])))
56
 
              return(val)
57
 
          }
58
 
          asOneSidedFormula(rhs[[3]])
59
 
      })
60
 
 
61
 
 
62
 
setMethod("getGroups", signature(object="data.frame", form="formula"),
63
 
          function(object, form, level, data, sep, ...)
64
 
              eval(getGroupsFormula(form)[[2]], object))
65
 
 
66
 
# Return the pairs of expressions separated by vertical bars
67
 
 
68
 
findbars <- function(term)
69
 
{
70
 
    if (is.name(term) || is.numeric(term)) return(NULL)
71
 
    if (term[[1]] == as.name("(")) return(findbars(term[[2]]))
72
 
    if (!is.call(term)) stop("term must be of class call")
73
 
    if (term[[1]] == as.name('|')) return(term)
74
 
    if (length(term) == 2) return(findbars(term[[2]]))
75
 
    c(findbars(term[[2]]), findbars(term[[3]]))
76
 
}
77
 
 
78
 
# Return the formula omitting the pairs of expressions separated by vertical bars
79
 
 
80
 
nobars <- function(term)
81
 
{
82
 
    # FIXME: is the is.name in the condition redundant?
83
 
    #   A name won't satisfy the first condition.
84
 
    if (!('|' %in% all.names(term)) || is.name(term)) return(term)
85
 
    if (is.call(term) && term[[1]] == as.name('|')) return(NULL)
86
 
    if (length(term) == 2) {
87
 
        nb <- nobars(term[[2]])
88
 
        if (is.null(nb)) return(NULL)
89
 
        term[[2]] <- nb
90
 
        return(term)
91
 
    }
92
 
    nb2 <- nobars(term[[2]])
93
 
    nb3 <- nobars(term[[3]])
94
 
    if (is.null(nb2)) return(nb3)
95
 
    if (is.null(nb3)) return(nb2)
96
 
    term[[2]] <- nb2
97
 
    term[[3]] <- nb3
98
 
    term
99
 
}
100
 
 
101
 
# Substitute the '+' function for the '|' function
102
 
 
103
 
subbars <- function(term)
104
 
{
105
 
    if (is.name(term) || is.numeric(term)) return(term)
106
 
    if (length(term) == 2) {
107
 
        term[[2]] <- subbars(term[[2]])
108
 
        return(term)
109
 
    }
110
 
    stopifnot(length(term) == 3)
111
 
    if (is.call(term) && term[[1]] == as.name('|')) term[[1]] <- as.name('+')
112
 
    term[[2]] <- subbars(term[[2]])
113
 
    term[[3]] <- subbars(term[[3]])
114
 
    term
115
 
}
116
 
    
117
 
 
118