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
|
##' @export
pars.survreg <- function(x,...) {
c(coef(x),scale=x$scale)
}
##' @export
score.survreg <- function(x,p,scale=TRUE,logscale=FALSE,indiv.logLik=FALSE,...) {
npar <- NROW(x$var)
m <- model.frame(x)
X <- model.matrix(terms(x), m)
hasscale <- npar>length(x$coefficients)
if (!missing(p)) {
if (hasscale) sigma <- tail(p,1)
p <- p[seq(length(p)-1)]
x$linear.predictors <- as.vector(X%*%p)
x$coefficients <- p
x$scale <- sigma
}
derivatives <- residuals(x, type = "matrix")
w <- model.weights(m)
if (is.null(w)) w <- 1
dldLP <- w*derivatives[,"dg"] ## Derivative wrt linear-predictor p=Xbeta
S <- apply(X,2,function(x) x*dldLP)
if (!is.null(x$naive.var)) {
V <- x$naive.var
} else {
V <- x$var
}
if (hasscale && scale) {
ds <- cbind("logsigma"=derivatives[,"ds"])
if (!logscale) {
ds <- ds/x$scale
names(ds) <- "sigma"
}
S <- cbind(S,ds)
}
if (hasscale && !scale) {
V <- V[-npar,-npar,drop=FALSE]
}
attributes(S)$logLik <-
if (indiv.logLik) derivatives[,"g"]
else sum(derivatives[,"g"])
attributes(S)$bread <- V*NROW(S)
return(S)
}
|
