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