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
|
#' Extra family objects.
#'
#' Family objects not in the set of default \link[=family]{family}-objects.
#'
#' @name extra-families
#'
#' @param link Specification of the link function, as for the default
#' \link[=family]{family}-objects.
#' @param nu Degrees of freedom for the Student-t distribution.
#'
#' @return A family object analogous to those described in
#' \link[=family]{family}
#'
NULL
# TODO: uncomment all these documentation lines when Student-t projection ready.
# Currently disabled because we do not want these to appear before this
# functionality is ready.
# define a student-t family object. Dispersion is defined to be the scale
# parameter of the distribution
#' @rdname extra-families
#' @export
Student_t <- function(link = "identity", nu = 3) {
if (!(link %in% c("identity", "log", "inverse"))) {
stop(paste0("Non-supported link: ", link))
}
if (!is.character(link)) {
stop("Link must be a string.")
}
## fetch the link statistics
stats <- make.link(link)
## variance function
varfun <- function(mu) {
if (nu > 2) {
rep(nu / (nu - 2), length(mu))
} else {
rep(Inf, length(mu))
}
}
## create the object and append the relevant fields
fam <- nlist(
family = "Student_t",
nu,
link,
linkfun = stats$linkfun,
linkinv = stats$linkinv,
variance = varfun,
dev.resids = function(y, mu, wt, dis = 1) {
wt * (nu + 1) * log(1 + 1 / nu * ((y - mu) / dis)^2)
},
aic = function(y, n, mu, wt, dev) {
stop("aic not implemented for Student-t.")
},
mu.eta = stats$mu.eta,
initialize = expression({
stop("initialization for Student-t not implemented.")
}),
validmu = function(mu) {
TRUE
},
valideta = stats$valideta
)
return(structure(fam, class = "family"))
}
|
