File: earth.methods.R

package info (click to toggle)
r-cran-earth 4.7.0-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 3,948 kB
  • sloc: ansic: 3,830; fortran: 894; sh: 13; makefile: 5
file content (104 lines) | stat: -rw-r--r-- 3,205 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
# earth.methods.R: miscellaneous earth methods

anova.earth <- function(object, warn=TRUE, ...)
{
    if(warn)
        warning0("anova.earth: returning NULL")
    NULL
}
case.names.earth <- function(object, ...)
{
    if(is.null(row.names(object$residuals)))
        paste(seq_len(nrow(object$residuals)))
    else
        row.names(object$residuals)
}
coef.earth <- function(object, decomp="none", ...)
{
    warn.if.dots(...)
    coef <- object$coefficients
    if(NCOL(coef) > 1)
        stop0("coef.earth: multiple response models not supported")
    new.order <- reorder.earth(object, decomp=decomp)
    names <- spaceout(rownames(coef))
    coef <- coef[new.order,]
    names(coef) <- names
    coef
}
deviance.earth <- function(object, warn=TRUE, ...)
{
    if(warn && !is.null(object$glm.list))
        warning0("deviance.earth: returning earth (not GLM) deviance")
    object$rss
}
effects.earth <- function(object, warn=TRUE, ...)
{
    if(warn)
        warning0("effects.earth: returning NULL")
    NULL
}
# Fake the AIC by returning the GCV.  This is enough for step() to work.
extractAIC.earth <- function(fit, scale = 0, k = 2, warn=TRUE, ...)
{
    if(warn)
        warning0("extractAIC.earth: returning GCV instead of AIC")
    if(scale != 0)
        warning0("extractAIC.earth: ignored scale parameter ", scale)
    if(k != 2)
        warning0("extractAIC.earth: ignored k parameter ", k)
    warn.if.dots(...)
    nterms <- length(fit$selected.terms)
    c(effective.nbr.of.params(nterms, get.nknots(nterms), fit$penalty), fit$gcv)
}
family.earth <- function(object, ...)
{
    stopifnot(!is.null(object$glm.list))
    family(object$glm.list[[1]])
}
hatvalues.earth <- function(model, ...)
{
    stop.if.dots(...)
    if(is.null(model$leverages))
        stop0("this earth model does not have leverages")
    model$leverages
}
fitted.earth <- function(object, type="response", ...)
{
    predict.earth(object, newdata=NULL, type=type, ...)
}
fitted.values.earth <- function(object, type="response", ...)
{
    predict.earth(object, newdata=NULL, type=type, ...)
}
# use.names can have the following values:
#   TRUE:  return name if possible, else return x[,i] or x[i-1].
#   FALSE: return x[,i]
#   -1:    return x[i] with 0 based indexing (treat x as a C array)

variable.names.earth <- function(object, ..., use.names=TRUE)
{
    warn.if.dots(...)
    ipred <- seq_len(ncol(object$dirs))
    if(length(use.names) != 1)
        stop0("illegal value for use.names")
    if(use.names == TRUE) {
        varname <- colnames(object$dirs)[ipred]
        if(!is.null(varname) && !anyNA(varname))
            varname
        else
            paste0("x[,", ipred, "]")
    } else if(use.names == FALSE)
        paste0("x[,", ipred, "]")
    else if(use.names == -1)
        paste0("x[", ipred-1, "]")
    else
        stop0("illegal value for use.names \"", use.names, "\"")
}
weights.earth <- function(object, ...)
{
    warn.if.dots(...)
    if(is.null(object$weights)) # weights arg to earth was NULL?
        repl(1, length(object$fitted.values[,1]))
    else
        object$weights
}