1# These functions are 2# Copyright (C) 1998-2021 T.W. Yee, University of Auckland. 3# All rights reserved. 4 5 6 7 8 9coef.vlm <- function(object, ...) { 10 coefvlm(object, ...) 11} 12 13 14 15coefvlm <- function(object, matrix.out = FALSE, label = TRUE, 16 colon = FALSE) { 17 Ans <- object@coefficients 18 19 if (colon) { 20 if (matrix.out) 21 stop("cannot have 'matrix.out = TRUE' and 'colon = TRUE'") 22 if (!label) 23 stop("cannot have 'label = FALSE' and 'colon = TRUE'") 24 25 d1 <- object@misc$colnames.x 26 Hlist <- object@constraints 27 M <- object@misc$M 28 ncolHlist <- unlist(lapply(Hlist, ncol)) 29 new.labs <- vlabel(xn = d1, ncolHlist, M = M, colon = colon) 30 names(Ans) <- new.labs 31 return(Ans) 32 } 33 34 if (!label) 35 names(Ans) <- NULL 36 if (!matrix.out) 37 return(Ans) 38 39 40 ncolx <- object@misc$p # = length(object@constraints) 41 M <- object@misc$M 42 43 Hlist <- object@constraints 44 if (all(trivial.constraints(Hlist) == 1)) { 45 Bmat <- matrix(Ans, nrow = ncolx, ncol = M, byrow = TRUE) 46 } else { 47 Bmat <- matrix(NA_real_, nrow = ncolx, ncol = M) 48 49 if (!matrix.out) 50 return(Ans) 51 52 ncolHlist <- unlist(lapply(Hlist, ncol)) 53 nasgn <- names(Hlist) 54 temp <- c(0, cumsum(ncolHlist)) 55 for (ii in seq_along(nasgn)) { 56 index <- (temp[ii] + 1):temp[ii + 1] 57 cmat <- Hlist[[nasgn[ii]]] 58 Bmat[ii, ] <- cmat %*% Ans[index] 59 } 60 } 61 62 if (label) { 63 d1 <- object@misc$colnames.x 64 d2 <- object@misc$predictors.names # Could be NULL 65 dimnames(Bmat) <- list(d1, d2) 66 } 67 68 Bmat 69} # coefvlm 70 71 72 73setMethod("coefficients", "vlm", function(object, ...) 74 coefvlm(object, ...)) 75setMethod("coef", "vlm", function(object, ...) 76 coefvlm(object, ...)) 77setMethod("coefficients", "vglm", function(object, ...) 78 coefvlm(object, ...)) 79setMethod("coef", "vglm", function(object, ...) 80 coefvlm(object, ...)) 81 82 83 84 85setMethod("coefficients", "summary.vglm", function(object, ...) 86 object@coef3) 87setMethod("coef", "summary.vglm", function(object, ...) 88 object@coef3) 89 90 91 92 93Coef.vlm <- function(object, ...) { 94 95 LL <- length(object@family@vfamily) 96 funname <- paste("Coef.", object@family@vfamily[LL], sep = "") 97 98 if (exists(funname)) { 99 newcall <- paste("Coef.", object@family@vfamily[LL], 100 "(object, ...)", sep = "") 101 newcall <- parse(text = newcall)[[1]] 102 return(eval(newcall)) 103 } 104 105 Answer <- 106 if (length(tmp2 <- object@misc$link) != 0 && 107 object@misc$intercept.only && 108 all(as.logical(trivial.constraints(object@constraints)))) { 109 110 111 112 if (!is.list(use.earg <- object@misc$earg)) 113 use.earg <- list() 114 115 Answer <- eta2theta(rbind(coefvlm(object)), 116 link = object@misc$link, earg = use.earg) 117 118 Answer <- c(Answer) 119 if (length(ntmp2 <- names(tmp2)) == object@misc$M) { 120 special.case <- sum(object@misc$link == "multilogitlink") > 0 121 try.this <- object@family@infos()$parameters.names 122 names(Answer) <- if (special.case && 123 length(try.this) == length(Answer)) 124 try.this else ntmp2 125 } 126 Answer 127 } else { 128 coefvlm(object, ... ) 129 } 130 131 if (length(tmp3 <- object@misc$parameter.names) != 0 && 132 object@misc$intercept.only && 133 all(as.logical(trivial.constraints(object@constraints)))) { 134 Answer <- c(Answer) 135 if (length(tmp3) == object@misc$M && is.character(tmp3)) 136 names(Answer) <- tmp3 137 } 138 139 Answer 140} # Coef.vlm 141 142 143 144setMethod("Coefficients", "vlm", function(object, ...) 145 Coef.vlm(object, ...)) 146setMethod("Coef", "vlm", function(object, ...) 147 Coef.vlm(object, ...)) 148 149 150 151 152 153coefvgam <- 154 function(object, type = c("linear", "nonlinear"), ...) { 155 type <- match.arg(type, c("linear", "nonlinear"))[1] 156 157 if (type == "linear") { 158 coefvlm(object, ...) 159 } else { 160 object@Bspline 161 } 162} 163 164 165setMethod("coefficients", "vgam", 166 function(object, ...) 167 coefvgam(object, ...)) 168 169 170setMethod("coef", "vgam", 171 function(object, ...) 172 coefvgam(object, ...)) 173 174 175 176