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
|
bread <- function(x, ...)
{
UseMethod("bread")
}
bread.lm <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
sx <- summary.lm(x)
return(sx$cov.unscaled * as.vector(sum(sx$df[1:2])))
}
bread.mlm <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
sx <- summary.lm(x)
rval <- diag(ncol(residuals(x))) %x% sx$cov.unscaled * as.vector(sum(sx$df[1:2]))
colnames(rval) <- rownames(rval) <- colnames(vcov(x))
return(rval)
}
bread.glm <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
sx <- summary(x)
wres <- as.vector(residuals(x, "working")) * weights(x, "working")
dispersion <- if(substr(x$family$family, 1, 17) %in% c("poisson", "binomial", "Negative Binomial")) 1
else sum(wres^2)/sum(weights(x, "working"))
return(sx$cov.unscaled * as.vector(sum(sx$df[1:2])) * dispersion)
}
bread.nls <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
sx <- summary(x)
return(sx$cov.unscaled * as.vector(sum(sx$df[1:2])))
}
bread.polr <- function(x, ...)
{
vcov(x) * x$n
}
bread.clm <- function(x, ...)
{
vcov(x) * x$n
}
bread.survreg <- function(x, ...)
length(x$linear.predictors) * x$var
bread.gam <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
sx <- summary(x)
sx$cov.unscaled * sx$n
}
bread.coxph <- function(x, ...)
{
rval <- x$var * x$n
dimnames(rval) <- list(names(coef(x)), names(coef(x)))
return(rval)
}
bread.hurdle <- function(x, ...)
{
x$vcov * x$n
}
bread.zeroinfl <- function(x, ...)
{
x$vcov * x$n
}
bread.mlogit <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
vcov(x) * length(residuals(x))
}
bread.rlm <- function(x, ...)
{
if(!is.null(x$na.action)) class(x$na.action) <- "omit"
xmat <- model.matrix(x)
xmat <- naresid(x$na.action, xmat)
wts <- weights(x)
if(is.null(wts)) wts <- 1
res <- residuals(x)
psi_deriv <- function(z) x$psi(z, deriv = 1)
rval <- sqrt(abs(as.vector(psi_deriv(res/x$s)/x$s))) * wts * xmat
rval <- chol2inv(qr.R(qr(rval))) * nrow(xmat)
return(rval)
}
|
