1# These functions are
2# Copyright (C) 1998-2021 T.W. Yee, University of Auckland.
3# All rights reserved.
4
5
6
7
8
9
10
11
12
13logLik.vlm <- function(object,
14                       summation = TRUE,
15                       ...) {
16
17  if (summation) {
18    object@criterion$loglikelihood
19  } else {
20
21
22    Args <- formals(args(object@family@loglikelihood))
23    if (length(Args$summation) == 0)
24      stop("there is no 'summation' argument for the function in the ",
25           "'loglikelihood' slot of the object.")
26
27
28    object@family@loglikelihood(mu = fitted(object),
29                                y = depvar(object),
30                          w = as.vector(weights(object, type = "prior")),
31                                residuals = FALSE,
32                                eta = predict(object),
33                                extra = object@extra,
34                                summation = summation)
35  }
36}
37
38
39
40
41logLik.qrrvglm <- function(object,
42                           summation = TRUE,
43                           ...) {
44
45  ff.code <- object@family
46  ll.ff.code <- ff.code@loglikelihood
47
48  prior.weights <- weights(object, type = "prior")
49  if (is.matrix(prior.weights) &&
50      ncol(prior.weights) == 1)
51    prior.weights <- c(prior.weights)
52
53  loglik.try <-
54    ll.ff.code(mu = fitted(object),
55               y = depvar(object),
56               w = prior.weights,
57               residuals = FALSE,
58               eta = predict(object),
59               extra = object@extra,
60               summation = summation)
61  if (!is.numeric(loglik.try))
62    loglik.try <- NULL
63
64  loglik.try
65}
66
67
68
69
70
71
72
73if (!isGeneric("logLik"))
74  setGeneric("logLik", function(object, ...)
75             standardGeneric("logLik"),
76             package = "VGAM")
77
78
79
80setMethod("logLik",  "vlm", function(object, ...)
81  logLik.vlm(object, ...))
82
83
84setMethod("logLik",  "vglm", function(object, ...)
85  logLik.vlm(object, ...))
86
87
88setMethod("logLik",  "vgam", function(object, ...)
89  logLik.vlm(object, ...))
90
91
92
93
94
95setMethod("logLik",  "qrrvglm", function(object, ...)
96  logLik.qrrvglm(object, ...))
97
98
99setMethod("logLik",  "rrvgam", function(object, ...)
100  logLik.qrrvglm(object, ...))
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124constraints.vlm <-
125  function(object,
126           type = c("lm", "term"),
127           all = TRUE, which,
128           matrix.out = FALSE,
129           colnames.arg = TRUE,  # 20130827
130           rownames.arg = TRUE,  # 20170606
131           ...) {
132
133
134  type <- match.arg(type, c("lm", "term"))[1]
135
136
137  Hlist <- ans <- slot(object, "constraints")  # For "lm" (formerly "vlm")
138
139  if (type == "term") {
140    oassign.LM <- object@misc$orig.assign
141
142    x.LM <- model.matrix(object)
143    att.x.LM  <- attr(x.LM,  "assign")
144    names.att.x.LM <- names(att.x.LM)
145    ppp <- length(names.att.x.LM)
146
147
148    ans <- vector("list", ppp)
149    for (ii in 1:ppp) {
150      col.ptr <- (oassign.LM[[ii]])[1]  # 20110114
151      ans[[ii]] <- (Hlist[[col.ptr]])
152    }
153    names(ans) <- names.att.x.LM
154  } # End of "term"
155
156
157
158  if (matrix.out) {
159    if (all) {
160      M <- npred(object)
161      mat.ans <- matrix(unlist(ans), nrow = M)
162      if (length(object@misc$predictors.names) == M)
163        rownames(mat.ans) <- object@misc$predictors.names
164      if (length(object@misc$colnames.X_vlm) == ncol(mat.ans))
165        colnames(mat.ans) <- object@misc$colnames.X_vlm
166
167
168      if (colnames.arg || rownames.arg) {
169        rownames.cm <- colnames(predict(object))
170        if (!rownames.arg || nrow(mat.ans) != length(rownames.cm))
171          rownames.cm <- NULL
172        colnames.cm <- if (colnames.arg)
173          colnames(model.matrix(object, type = "vlm")) else NULL
174        dimnames(mat.ans) <- list(rownames.cm, colnames.cm)
175      }
176      mat.ans
177    } else {
178      ans[[which]]
179    }
180  } else {
181    if (all) ans else ans[[which]]
182  }
183}
184
185
186
187if (!isGeneric("constraints"))
188  setGeneric("constraints", function(object, ...)
189             standardGeneric("constraints"))
190
191
192setMethod("constraints",  "vlm", function(object, ...)
193  constraints.vlm(object, ...))
194
195
196
197
198
199
200
201