Remove debug traces, inline matrix index function
[morpheus.git] / pkg / R / optimParams.R
... / ...
CommitLineData
1#' Wrapper function for OptimParams class
2#'
3#' @param K Number of populations.
4#' @param link The link type, 'logit' or 'probit'.
5#' @param X Data matrix of covariables
6#' @param Y Output as a binary vector
7#'
8#' @return An object 'op' of class OptimParams, initialized so that \code{op$run(x0)}
9#' outputs the list of optimized parameters
10#' \itemize{
11#' \item p: proportions, size K
12#' \item β: regression matrix, size dxK
13#' \item b: intercepts, size K
14#' }
15#' θ0 is a vector containing respectively the K-1 first elements of p, then β by
16#' columns, and finally b: \code{θ0 = c(p[1:(K-1)],as.double(β),b)}.
17#'
18#' @seealso \code{multiRun} to estimate statistics based on β, and
19#' \code{generateSampleIO} for I/O random generation.
20#'
21#' @examples
22#' # Optimize parameters from estimated μ
23#' io = generateSampleIO(10000, 1/2, matrix(c(1,-2,3,1),ncol=2), c(0,0), "logit")
24#' μ = computeMu(io$X, io$Y, list(K=2))
25#' o <- optimParams(io$X, io$Y, 2, "logit")
26#' θ0 <- list(p=1/2, β=μ, b=c(0,0))
27#' par0 <- o$run(θ0)
28#' # Compare with another starting point
29#' θ1 <- list(p=1/2, β=2*μ, b=c(0,0))
30#' par1 <- o$run(θ1)
31#' o$f( o$linArgs(par0) )
32#' o$f( o$linArgs(par1) )
33#' @export
34optimParams <- function(X, Y, K, link=c("logit","probit"))
35{
36 # Check arguments
37 if (!is.matrix(X) || any(is.na(X)))
38 stop("X: numeric matrix, no NAs")
39 if (!is.numeric(Y) || any(is.na(Y)) || any(Y!=0 & Y!=1))
40 stop("Y: binary vector with 0 and 1 only")
41 link <- match.arg(link)
42 if (!is.numeric(K) || K!=floor(K) || K < 2)
43 stop("K: integer >= 2")
44
45 # Build and return optimization algorithm object
46 methods::new("OptimParams", "li"=link, "X"=X,
47 "Y"=as.integer(Y), "K"=as.integer(K))
48}
49
50#' Encapsulated optimization for p (proportions), β and b (regression parameters)
51#'
52#' Optimize the parameters of a mixture of logistic regressions model, possibly using
53#' \code{mu <- computeMu(...)} as a partial starting point.
54#'
55#' @field li Link function, 'logit' or 'probit'
56#' @field X Data matrix of covariables
57#' @field Y Output as a binary vector
58#' @field K Number of populations
59#' @field d Number of dimensions
60#' @field W Weights matrix (iteratively refined)
61#'
62setRefClass(
63 Class = "OptimParams",
64
65 fields = list(
66 # Inputs
67 li = "character", #link function
68 X = "matrix",
69 Y = "numeric",
70 Mhat = "numeric", #vector of empirical moments
71 # Dimensions
72 K = "integer",
73 n = "integer",
74 d = "integer",
75 # Weights matrix (generalized least square)
76 W = "matrix"
77 ),
78
79 methods = list(
80 initialize = function(...)
81 {
82 "Check args and initialize K, d, W"
83
84 callSuper(...)
85 if (!hasArg("X") || !hasArg("Y") || !hasArg("K") || !hasArg("li"))
86 stop("Missing arguments")
87
88 # Precompute empirical moments
89 M <- computeMoments(X, Y)
90 M1 <- as.double(M[[1]])
91 M2 <- as.double(M[[2]])
92 M3 <- as.double(M[[3]])
93 Mhat <<- c(M1, M2, M3)
94
95 n <<- nrow(X)
96 d <<- length(M1)
97 W <<- diag(d+d^2+d^3) #initialize at W = Identity
98 },
99
100 expArgs = function(v)
101 {
102 "Expand individual arguments from vector v into a list"
103
104 list(
105 # p: dimension K-1, need to be completed
106 "p" = c(v[1:(K-1)], 1-sum(v[1:(K-1)])),
107 "β" = t(matrix(v[K:(K+d*K-1)], ncol=d)),
108 "b" = v[(K+d*K):(K+(d+1)*K-1)])
109 },
110
111 linArgs = function(L)
112 {
113 "Linearize vectors+matrices from list L into a vector"
114
115 # β linearized row by row, to match derivatives order
116 c(L$p[1:(K-1)], as.double(t(L$β)), L$b)
117 },
118
119 computeW = function(θ)
120 {
121 require(MASS)
122 dd <- d + d^2 + d^3
123 M <- Moments(θ)
124 Omega <- matrix( .C("Compute_Omega",
125 X=as.double(X), Y=as.integer(Y), M=as.double(M),
126 pn=as.integer(n), pd=as.integer(d),
127 W=as.double(W), PACKAGE="morpheus")$W, nrow=dd, ncol=dd )
128 MASS::ginv(Omega)
129 },
130
131 Moments = function(θ)
132 {
133 "Vector of moments, of size d+d^2+d^3"
134
135 p <- θ$p
136 β <- θ$β
137 λ <- sqrt(colSums(β^2))
138 b <- θ$b
139
140 # Tensorial products β^2 = β2 and β^3 = β3 must be computed from current β1
141 β2 <- apply(β, 2, function(col) col %o% col)
142 β3 <- apply(β, 2, function(col) col %o% col %o% col)
143
144 c(
145 β %*% (p * .G(li,1,λ,b)),
146 β2 %*% (p * .G(li,2,λ,b)),
147 β3 %*% (p * .G(li,3,λ,b)))
148 },
149
150 f = function(θ)
151 {
152 "Product t(hat_Mi - Mi) W (hat_Mi - Mi) with Mi(theta)"
153
154 L <- expArgs(θ)
155 A <- as.matrix(Mhat - Moments(L))
156 t(A) %*% W %*% A
157 },
158
159 grad_f = function(θ)
160 {
161 "Gradient of f, dimension (K-1) + d*K + K = (d+2)*K - 1"
162
163 L <- expArgs(θ)
164 -2 * t(grad_M(L)) %*% W %*% as.matrix(Mhat - Moments(L))
165 },
166
167 grad_M = function(θ)
168 {
169 "Gradient of the vector of moments, size (dim=)d+d^2+d^3 x K-1+K+d*K"
170
171 p <- θ$p
172 β <- θ$β
173 λ <- sqrt(colSums(β^2))
174 μ <- sweep(β, 2, λ, '/')
175 b <- θ$b
176
177 res <- matrix(nrow=nrow(W), ncol=0)
178
179 # Tensorial products β^2 = β2 and β^3 = β3 must be computed from current β1
180 β2 <- apply(β, 2, function(col) col %o% col)
181 β3 <- apply(β, 2, function(col) col %o% col %o% col)
182
183 # Some precomputations
184 G1 = .G(li,1,λ,b)
185 G2 = .G(li,2,λ,b)
186 G3 = .G(li,3,λ,b)
187 G4 = .G(li,4,λ,b)
188 G5 = .G(li,5,λ,b)
189
190 # Gradient on p: K-1 columns, dim rows
191 km1 = 1:(K-1)
192 res <- cbind(res, rbind(
193 sweep(as.matrix(β [,km1]), 2, G1[km1], '*') - G1[K] * β [,K],
194 sweep(as.matrix(β2[,km1]), 2, G2[km1], '*') - G2[K] * β2[,K],
195 sweep(as.matrix(β3[,km1]), 2, G3[km1], '*') - G3[K] * β3[,K] ))
196
197 for (i in 1:d)
198 {
199 # i determines the derivated matrix dβ[2,3]
200
201 dβ_left <- sweep(β, 2, p * G3 * β[i,], '*')
202 dβ_right <- matrix(0, nrow=d, ncol=K)
203 block <- i
204 dβ_right[block,] <- dβ_right[block,] + 1
205 dβ <- dβ_left + sweep(dβ_right, 2, p * G1, '*')
206
207 dβ2_left <- sweep(β2, 2, p * G4 * β[i,], '*')
208 dβ2_right <- do.call( rbind, lapply(1:d, function(j) {
209 sweep(dβ_right, 2, β[j,], '*')
210 }) )
211 block <- ((i-1)*d+1):(i*d)
212 dβ2_right[block,] <- dβ2_right[block,] + β
213 dβ2 <- dβ2_left + sweep(dβ2_right, 2, p * G2, '*')
214
215 dβ3_left <- sweep(β3, 2, p * G5 * β[i,], '*')
216 dβ3_right <- do.call( rbind, lapply(1:d, function(j) {
217 sweep(dβ2_right, 2, β[j,], '*')
218 }) )
219 block <- ((i-1)*d*d+1):(i*d*d)
220 dβ3_right[block,] <- dβ3_right[block,] + β2
221 dβ3 <- dβ3_left + sweep(dβ3_right, 2, p * G3, '*')
222
223 res <- cbind(res, rbind(dβ, dβ2, dβ3))
224 }
225
226 # Gradient on b
227 res <- cbind(res, rbind(
228 sweep(β, 2, p * G2, '*'),
229 sweep(β2, 2, p * G3, '*'),
230 sweep(β3, 2, p * G4, '*') ))
231
232 res
233 },
234
235 run = function(θ0)
236 {
237 "Run optimization from θ0 with solver..."
238
239 if (!is.list(θ0))
240 stop("θ0: list")
241 if (is.null(θ0$β))
242 stop("At least θ0$β must be provided")
243 if (!is.matrix(θ0$β) || any(is.na(θ0$β))
244 || nrow(θ0$β) != d || ncol(θ0$β) != K)
245 {
246 stop("θ0$β: matrix, no NA, nrow = d, ncol = K")
247 }
248 if (is.null(θ0$p))
249 θ0$p = rep(1/K, K-1)
250 else if (!is.numeric(θ0$p) || length(θ0$p) != K-1
251 || any(is.na(θ0$p)) || sum(θ0$p) > 1)
252 {
253 stop("θ0$p: length K-1, no NA, positive integers, sum to <= 1")
254 }
255 if (is.null(θ0$b))
256 θ0$b = rep(0, K)
257 else if (!is.numeric(θ0$b) || length(θ0$b) != K || any(is.na(θ0$b)))
258 stop("θ0$b: length K, no NA")
259 # TODO: stopping condition? N iterations? Delta <= epsilon ?
260 loopMax <- 2
261 for (loop in 1:loopMax)
262 {
263 op_res = constrOptim( linArgs(θ0), .self$f, .self$grad_f,
264 ui=cbind(
265 rbind( rep(-1,K-1), diag(K-1) ),
266 matrix(0, nrow=K, ncol=(d+1)*K) ),
267 ci=c(-1,rep(0,K-1)) )
268 if (loop < loopMax) #avoid computing an extra W
269 W <<- computeW(expArgs(op_res$par))
270 #print(op_res$value) #debug
271 #print(expArgs(op_res$par)) #debug
272 }
273
274 expArgs(op_res$par)
275 }
276 )
277)
278
279# Compute vectorial E[g^{(order)}(<β,x> + b)] with x~N(0,Id) (integral in R^d)
280# = E[g^{(order)}(z)] with z~N(b,diag(λ))
281# by numerically evaluating the integral.
282#
283# @param link Link, 'logit' or 'probit'
284# @param order Order of derivative
285# @param λ Norm of columns of β
286# @param b Intercept
287#
288.G <- function(link, order, λ, b)
289{
290 # NOTE: weird "integral divergent" error on inputs:
291 # link="probit"; order=2; λ=c(531.8099,586.8893,523.5816); b=c(-118.512674,-3.488020,2.109969)
292 # Switch to pracma package for that (but it seems slow...)
293 sapply( seq_along(λ), function(k) {
294 res <- NULL
295 tryCatch({
296 # Fast code, may fail:
297 res <- stats::integrate(
298 function(z) .deriv[[link]][[order]](λ[k]*z+b[k]) * exp(-z^2/2) / sqrt(2*pi),
299 lower=-Inf, upper=Inf )$value
300 }, error = function(e) {
301 # Robust slow code, no fails observed:
302 sink("/dev/null") #pracma package has some useless printed outputs...
303 res <- pracma::integral(
304 function(z) .deriv[[link]][[order]](λ[k]*z+b[k]) * exp(-z^2/2) / sqrt(2*pi),
305 xmin=-Inf, xmax=Inf, method="Kronrod")
306 sink()
307 })
308 res
309 })
310}
311
312# Derivatives list: g^(k)(x) for links 'logit' and 'probit'
313#
314.deriv <- list(
315 "probit"=list(
316 # 'probit' derivatives list;
317 # NOTE: exact values for the integral E[g^(k)(λz+b)] could be computed
318 function(x) exp(-x^2/2)/(sqrt(2*pi)), #g'
319 function(x) exp(-x^2/2)/(sqrt(2*pi)) * -x, #g''
320 function(x) exp(-x^2/2)/(sqrt(2*pi)) * ( x^2 - 1), #g^(3)
321 function(x) exp(-x^2/2)/(sqrt(2*pi)) * (-x^3 + 3*x), #g^(4)
322 function(x) exp(-x^2/2)/(sqrt(2*pi)) * ( x^4 - 6*x^2 + 3) #g^(5)
323 ),
324 "logit"=list(
325 # Sigmoid derivatives list, obtained with http://www.derivative-calculator.net/
326 # @seealso http://www.ece.uc.edu/~aminai/papers/minai_sigmoids_NN93.pdf
327 function(x) {e=exp(x); .zin(e /(e+1)^2)}, #g'
328 function(x) {e=exp(x); .zin(e*(-e + 1) /(e+1)^3)}, #g''
329 function(x) {e=exp(x); .zin(e*( e^2 - 4*e + 1) /(e+1)^4)}, #g^(3)
330 function(x) {e=exp(x); .zin(e*(-e^3 + 11*e^2 - 11*e + 1) /(e+1)^5)}, #g^(4)
331 function(x) {e=exp(x); .zin(e*( e^4 - 26*e^3 + 66*e^2 - 26*e + 1)/(e+1)^6)} #g^(5)
332 )
333)
334
335# Utility for integration: "[return] zero if [argument is] NaN" (Inf / Inf divs)
336#
337# @param x Ratio of polynoms of exponentials, as in .S[[i]]
338#
339.zin <- function(x)
340{
341 x[is.nan(x)] <- 0.
342 x
343}