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