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 13 14 15 16 17 18 19 20 21 dtheta.deta <- 22 function(theta, 23 link = "identitylink", 24 earg = list(theta = theta, # Needed 25 inverse = TRUE, # 20150711: big change!!!! 26 deriv = 1, 27 short = TRUE, 28 tag = FALSE)) { 29 30 function.name <- link 31 32 function.name2 <- attr(earg, "function.name") 33 if (length(function.name2) && function.name != function.name2) { 34 warning("apparent conflict in name of link function") 35 } 36 37 earg[["theta"]] <- theta # New data 38 39 if (length(earg$inverse)) 40 earg[["inverse"]] <- TRUE else 41 earg$inverse <- TRUE 42 43 earg[["deriv"]] <- 1 # New 44 45 46 do.call(function.name, earg) 47} # dtheta.deta 48 49 50 51 52 53 54 d2theta.deta2 <- 55 function(theta, 56 link = "identitylink", 57 earg = list(theta = theta, # Needed 58 inverse = TRUE, # 20150711: big change!!!! 59 deriv = 2, 60 short = TRUE, 61 tag = FALSE)) { 62 63 64 function.name <- link 65 66 function.name2 <- attr(earg, "function.name") 67 if (length(function.name2) && function.name != function.name2) 68 warning("apparent conflict in name of link function in ", 69 "D2theta.deta2()") 70 71 earg[["theta"]] <- theta # New data 72 73 74 if (length(earg$inverse)) 75 earg[["inverse"]] <- TRUE else 76 earg$inverse <- TRUE 77 78 earg[["deriv"]] <- 2 # New 79 80 do.call(function.name, earg) 81} # d2theta.deta2 82 83 84 85 86 87 88 d3theta.deta3 <- 89 function(theta, 90 link = "identitylink", 91 earg = list(theta = theta, 92 inverse = TRUE, 93 deriv = 3, 94 short = TRUE, 95 tag = FALSE)) { 96 97 function.name <- link 98 earg[["theta"]] <- theta # New data 99 100 if (length(earg$inverse)) 101 earg[["inverse"]] <- TRUE else 102 earg$inverse <- TRUE 103 104 earg[["deriv"]] <- 3 # New 105 do.call(function.name, earg) 106} # d3theta.deta3 107 108 109 110 111 112 113 theta2eta <- 114 function(theta, 115 link = "identitylink", 116 earg = list(theta = NULL)) { 117 118 function.name <- link 119 120 function.name2 <- attr(earg, "function.name") 121 if (length(function.name2) && function.name != function.name2) 122 warning("apparent conflict in name of link function") 123 124 earg[["theta"]] <- theta # New data 125 126 do.call(function.name, earg) 127} # theta2eta 128 129 130 131 132 133 134 eta2theta <- 135 function(theta, # This is really eta. 136 link = "identitylink", 137 earg = list(theta = NULL), 138 special.fun = "multilogitlink", 139 delete.coln = TRUE # Only for "multilogitlink" 140 ) { 141 142 143 orig.earg <- earg 144 if (!is.list(earg)) 145 stop("argument 'earg' is not a list") 146 147 level1 <- length(earg) > 3 && 148 length(intersect(names(earg), 149 c("theta", "inverse", "deriv", "short", "tag"))) > 3 150 151 if (level1) 152 earg <- list(oneOnly = earg) 153 154 155 156 157 158 159 llink <- length(link) 160 161 if (llink != length(earg)) 162 stop("length of argument 'link' differs from ", 163 "length of argument 'earg'") 164 if (llink == 0) 165 stop("length(earg) == 0 not allowed") 166 if (llink == 1) { # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 167 168 169 if (is.list(earg[[1]])) 170 earg <- earg[[1]] 171 172 function.name <- link # First chance 173 174 function.name2 <- attr(earg, "function.name") # May be, e.g., NULL 175 if (length(function.name2) && function.name != function.name2) 176 warning("apparent conflict in name of link function") 177 178 earg[["theta"]] <- theta # New data 179 180 earg[["inverse"]] <- TRUE # New 181 return(do.call(function.name, earg)) 182 } # llink == 1 183 184 185 186 187 188 if (!is.matrix(theta) && 189 length(theta) == length(earg)) 190 theta <- rbind(theta) 191 192 vecTF <- link == special.fun 193 Ans <- NULL 194 iii <- 1 195 while (iii <= llink) { 196 first.index <- last.index <- iii # Ordinary case 197 special.case <- vecTF[iii] # && sum(vecTF) < length(vecTF) 198 199 if (special.case) { 200 next.i <- iii+1 201 while (next.i <= llink) { 202 if (vecTF[next.i]) { 203 last.index <- next.i 204 next.i <- next.i + 1 205 } else { 206 break 207 } 208 } # while 209 } # special.case 210 211 iii <- iii + last.index - first.index + 1 # For next time 212 use.earg <- earg[[first.index]] 213 use.earg[["inverse"]] <- TRUE # New 214 use.earg[["theta"]] <- theta[, first.index:last.index, 215 drop = FALSE] # New 216 use.function.name <- link[first.index] # "multilogitlink" 217 218 if (first.index != last.index && special.case) { 219 adjusted.M <- last.index - first.index + 1 220 use.earg$M <- adjusted.M 221 } 222 223 Ans2 <- do.call(use.function.name, use.earg) 224 if (special.case && special.fun == "multilogitlink" && 225 delete.coln) 226 Ans2 <- Ans2[, -use.earg$refLevel, drop = FALSE] 227 228 Ans <- cbind(Ans, Ans2) 229 } # while (iii <= llink) 230 231 if (length(orig.earg) == ncol(Ans) && 232 length(names(orig.earg)) > 0 && 233 ncol(Ans) > 0) 234 colnames(Ans) <- names(orig.earg) 235 236 Ans 237} # eta2theta 238 239 240 241 242 243 244 namesof <- function(theta, 245 link = "identitylink", 246 earg = list(tag = tag, short = short), 247 tag = FALSE, 248 short = TRUE) { 249 250 funname.only <- strsplit(as.character(link), "(", fixed = TRUE) 251 funname.only <- (funname.only[[1]])[1] 252 link <- funname.only 253 254 earg[["theta"]] <- as.character(theta) 255 256 earg[["tag"]] <- tag 257 earg[["short"]] <- short 258 259 260 do.call(link, earg) 261} # namesof 262 263 264 265 266 267link2list <- function(link 268 ) { 269 270 ans <- link 271 272 fun.name <- as.character(ans[[1]]) 273 274 275 big.list <- as.list(as.function(get(fun.name))) 276 277 278 big.list[[length(big.list)]] <- NULL # Kill the body of code 279 280 281 282 283 284 t.index <- pmatch(names(ans[-1]), names(big.list)) 285 t.index 286 if (anyNA(t.index)) 287 stop("in '", fun.name, "' could not match argument(s) ", 288 paste('"', names(ans[-1])[is.na(t.index)], '"', sep = "", 289 collapse = ", ")) 290 291 292 Big.list <- big.list 293 trivial.call <- (length(t.index) == 0) 294 if (!trivial.call) { 295 Big.list[t.index] <- ans[-1] 296 } 297 298 299 attr(Big.list, "function.name") <- fun.name 300 301 302 Big.list 303} # link2list 304 305 306 307 308