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