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