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
10rrvglm.control <-
11  function(Rank = 1,
12           Algorithm = c("alternating", "derivative"),
13           Corner = TRUE,
14           Uncorrelated.latvar = FALSE,
15           Wmat = NULL,
16           Svd.arg = FALSE,
17           Index.corner = if (length(str0))
18           head((1:1000)[-str0], Rank) else 1:Rank,
19           Ainit = NULL,
20           Alpha = 0.5,
21           Bestof = 1,
22           Cinit = NULL,
23           Etamat.colmax = 10,
24           sd.Ainit = 0.02,
25           sd.Cinit = 0.02,
26           str0 = NULL,
27
28           noRRR = ~ 1,
29           Norrr = NA,
30
31           noWarning = FALSE,
32
33           trace = FALSE,
34           Use.Init.Poisson.QO = FALSE,
35           checkwz = TRUE,
36           Check.rank = TRUE,
37           Check.cm.rank = TRUE,
38           wzepsilon = .Machine$double.eps^0.75,
39           ...) {
40
41
42
43
44
45  if (length(Norrr) != 1 || !is.na(Norrr)) {
46    warning("argument 'Norrr' has been replaced by 'noRRR'. ",
47            "Assigning the latter but using 'Norrr' will become an ",
48            "error in the next VGAM version soon.")
49    noRRR <- Norrr
50  }
51
52
53  if (mode(Algorithm) != "character" && mode(Algorithm) != "name")
54    Algorithm <- as.character(substitute(Algorithm))
55  Algorithm <- match.arg(Algorithm, c("alternating", "derivative"))[1]
56
57  if (Svd.arg)
58    Corner <- FALSE
59
60  if (!is.Numeric(Rank, positive = TRUE,
61                  length.arg = 1, integer.valued = TRUE))
62    stop("bad input for 'Rank'")
63  if (!is.Numeric(Alpha, positive = TRUE,
64                  length.arg = 1) || Alpha > 1)
65    stop("bad input for 'Alpha'")
66  if (!is.Numeric(Bestof, positive = TRUE,
67                  length.arg = 1, integer.valued = TRUE))
68    stop("bad input for 'Bestof'")
69  if (!is.Numeric(sd.Ainit, positive = TRUE,
70                  length.arg = 1))
71    stop("bad input for 'sd.Ainit'")
72  if (!is.Numeric(sd.Cinit, positive = TRUE,
73                  length.arg = 1))
74    stop("bad input for 'sd.Cinit'")
75  if (!is.Numeric(Etamat.colmax, positive = TRUE,
76                  length.arg = 1) ||
77      Etamat.colmax < Rank)
78    stop("bad input for 'Etamat.colmax'")
79
80  if (length(str0) &&
81     (any(round(str0) != str0) || any(str0 < 1)))
82    stop("bad input for the argument 'str0'")
83
84
85  Quadratic <- FALSE
86  if (!Quadratic && Algorithm == "derivative" && !Corner) {
87    dd <- "derivative algorithm only supports corner constraints"
88    if (length(Wmat) || Uncorrelated.latvar || Svd.arg)
89      stop(dd)
90    warning(dd)
91    Corner <- TRUE
92  }
93  if (Quadratic && Algorithm != "derivative")
94      stop("Quadratic model can only be fitted using the",
95           "derivative algorithm")
96
97  if (Corner && (Svd.arg || Uncorrelated.latvar || length(Wmat)))
98      stop("cannot have 'Corner = TRUE' and either 'Svd = TRUE' or ",
99           "'Uncorrelated.latvar = TRUE' or Wmat")
100
101  if (Corner && length(intersect(str0, Index.corner)))
102    stop("cannot have arguments 'str0' and 'Index.corner' having ",
103         "common values")
104
105  if (length(Index.corner) != Rank)
106    stop("length(Index.corner) != Rank")
107
108  if (!is.logical(checkwz) ||
109      length(checkwz) != 1)
110    stop("bad input for 'checkwz'")
111
112  if (!is.Numeric(wzepsilon, length.arg = 1,
113                  positive = TRUE))
114    stop("bad input for 'wzepsilon'")
115
116  if (class(noRRR) != "formula" && !is.null(noRRR))
117    stop("argument 'noRRR' should be a formula or a NULL")
118
119
120  ans <-
121  c(vglm.control(
122                 trace = trace,
123                 checkwz = checkwz,
124                 Check.rank = Check.rank,
125                 Check.cm.rank = Check.cm.rank,
126                 wzepsilon = wzepsilon,
127                 noWarning = noWarning,
128                 ...),
129
130    switch(Algorithm,
131           "alternating" = valt.control(...),
132           "derivative"  = rrvglm.optim.control(...)),
133    list(Rank = Rank,
134         Ainit = Ainit,
135         Algorithm = Algorithm,
136         Alpha = Alpha,
137         Bestof = Bestof,
138         Cinit = Cinit,
139         Index.corner = Index.corner,
140         noRRR = noRRR,
141
142         Corner = Corner,
143         Uncorrelated.latvar = Uncorrelated.latvar,
144         Wmat = Wmat,
145         OptimizeWrtC = TRUE,  # OptimizeWrtC,
146         Quadratic = FALSE,  # A constant now, here.
147         sd.Ainit = sd.Ainit,
148         sd.Cinit = sd.Cinit,
149         Etamat.colmax = Etamat.colmax,
150         str0 = str0,
151         Svd.arg = Svd.arg,
152         Use.Init.Poisson.QO = Use.Init.Poisson.QO),
153    if (Quadratic) qrrvglm.control(Rank = Rank, ...) else NULL)
154
155
156  if (Quadratic && ans$I.tolerances) {
157      ans$Svd.arg <- FALSE
158      ans$Uncorrelated.latvar <- FALSE
159      ans$Corner <- FALSE
160  }
161
162
163  ans$half.stepsizing <- FALSE  # Turn it off
164  ans
165}
166
167
168
169
170
171
172
173
174
175setClass("summary.rrvglm",
176         representation("rrvglm",
177                        coef3 = "matrix",
178                        coef4lrt0   = "matrix",
179                        coef4score0 = "matrix",
180                        coef4wald0  = "matrix",
181                        cov.unscaled = "matrix",
182                        correlation = "matrix",
183                        df = "numeric",
184                        pearson.resid = "matrix",
185                        sigma = "numeric"))
186
187
188setMethod("summary", "rrvglm",
189         function(object, ...)
190         summary.rrvglm(object, ...))
191
192
193
194
195show.summary.rrvglm <-
196  function(x, digits = NULL, quote = TRUE, prefix = "",
197           signif.stars = NULL) {
198
199
200  show.summary.vglm(x, digits = digits, quote = quote, prefix = prefix)
201
202
203  invisible(x)
204  NULL
205}
206
207
208
209
210
211
212 setMethod("show", "summary.rrvglm",
213           function(object)
214             show.summary.rrvglm(x = object))
215
216
217
218
219setMethod("coefficients", "summary.rrvglm", function(object, ...)
220          object@coef3)
221setMethod("coef",         "summary.rrvglm", function(object, ...)
222          object@coef3)
223
224
225
226