Simplify data sampling + cosmetics + draft unit test for W matrix in optim
[morpheus.git] / pkg / R / optimParams.R
CommitLineData
4263503b 1#' Wrapper function for OptimParams class
cbd88fe5
BA
2#'
3#' @param K Number of populations.
4#' @param link The link type, 'logit' or 'probit'.
4263503b
BA
5#' @param X Data matrix of covariables
6#' @param Y Output as a binary vector
cbd88fe5
BA
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#' }
7737c2fa
BA
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)}.
cbd88fe5
BA
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))
4263503b 25#' o <- optimParams(io$X, io$Y, 2, "logit")
7737c2fa
BA
26#' θ0 <- list(p=1/2, β=μ, b=c(0,0))
27#' par0 <- o$run(θ0)
cbd88fe5 28#' # Compare with another starting point
7737c2fa
BA
29#' θ1 <- list(p=1/2, β=2*μ, b=c(0,0))
30#' par1 <- o$run(θ1)
cbd88fe5
BA
31#' o$f( o$linArgs(par0) )
32#' o$f( o$linArgs(par1) )
33#' @export
b389a46a 34optimParams <- function(X, Y, K, link=c("logit","probit"))
cbd88fe5 35{
6dd5c2ac 36 # Check arguments
4263503b
BA
37 if (!is.matrix(X) || any(is.na(X)))
38 stop("X: numeric matrix, no NAs")
0a630686 39 if (!is.numeric(Y) || any(is.na(Y)) || any(Y!=0 & Y!=1))
4263503b 40 stop("Y: binary vector with 0 and 1 only")
6dd5c2ac 41 link <- match.arg(link)
4263503b
BA
42 if (!is.numeric(K) || K!=floor(K) || K < 2)
43 stop("K: integer >= 2")
cbd88fe5 44
6dd5c2ac
BA
45 # Build and return optimization algorithm object
46 methods::new("OptimParams", "li"=link, "X"=X,
4263503b 47 "Y"=as.integer(Y), "K"=as.integer(K))
cbd88fe5
BA
48}
49
4263503b
BA
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#'
cbd88fe5 62setRefClass(
6dd5c2ac 63 Class = "OptimParams",
cbd88fe5 64
6dd5c2ac
BA
65 fields = list(
66 # Inputs
67 li = "character", #link function
68 X = "matrix",
69 Y = "numeric",
7737c2fa 70 Mhat = "numeric", #vector of empirical moments
6dd5c2ac
BA
71 # Dimensions
72 K = "integer",
4263503b 73 n = "integer",
6dd5c2ac 74 d = "integer",
e92d9d9d
BA
75 # Weights matrix (generalized least square)
76 W = "matrix"
6dd5c2ac 77 ),
cbd88fe5 78
6dd5c2ac
BA
79 methods = list(
80 initialize = function(...)
81 {
82 "Check args and initialize K, d, W"
cbd88fe5 83
4263503b 84 callSuper(...)
6dd5c2ac
BA
85 if (!hasArg("X") || !hasArg("Y") || !hasArg("K") || !hasArg("li"))
86 stop("Missing arguments")
cbd88fe5 87
4263503b 88 # Precompute empirical moments
0a630686 89 M <- computeMoments(X, Y)
7737c2fa
BA
90 M1 <- as.double(M[[1]])
91 M2 <- as.double(M[[2]])
92 M3 <- as.double(M[[3]])
0a630686 93 Mhat <<- c(M1, M2, M3)
4263503b 94
6dd5c2ac
BA
95 n <<- nrow(X)
96 d <<- length(M1)
e92d9d9d 97 W <<- diag(d+d^2+d^3) #initialize at W = Identity
6dd5c2ac 98 },
cbd88fe5 99
6dd5c2ac
BA
100 expArgs = function(v)
101 {
102 "Expand individual arguments from vector v into a list"
cbd88fe5 103
6dd5c2ac
BA
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 "β" = matrix(v[K:(K+d*K-1)], ncol=K),
108 "b" = v[(K+d*K):(K+(d+1)*K-1)])
109 },
cbd88fe5 110
6dd5c2ac
BA
111 linArgs = function(L)
112 {
113 "Linearize vectors+matrices from list L into a vector"
cbd88fe5 114
6dd5c2ac
BA
115 c(L$p[1:(K-1)], as.double(L$β), L$b)
116 },
cbd88fe5 117
7737c2fa 118 computeW = function(θ)
4263503b 119 {
0f5fbd13
BA
120 #return (diag(c(rep(6,d), rep(3, d^2), rep(1,d^3))))
121 require(MASS)
4bf8494d 122 dd <- d + d^2 + d^3
9a6881ed
BA
123 M <- Moments(θ)
124 Omega <- matrix( .C("Compute_Omega",
125 X=as.double(X), Y=as.double(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 )
0f5fbd13 128 MASS::ginv(Omega)
4263503b
BA
129 },
130
b389a46a 131 Moments = function(θ)
4263503b 132 {
7737c2fa 133 "Vector of moments, of size d+d^2+d^3"
cbd88fe5 134
7737c2fa 135 p <- θ$p
6dd5c2ac
BA
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)))
7737c2fa
BA
148 },
149
150 f = function(θ)
151 {
6dd5c2ac 152 "Product t(hat_Mi - Mi) W (hat_Mi - Mi) with Mi(theta)"
7737c2fa 153
0a630686 154 L <- expArgs(θ)
6dd5c2ac 155 A <- as.matrix(Mhat - Moments(L))
4263503b
BA
156 t(A) %*% W %*% A
157 },
cbd88fe5 158
6dd5c2ac
BA
159 grad_f = function(θ)
160 {
161 "Gradient of f, dimension (K-1) + d*K + K = (d+2)*K - 1"
cbd88fe5 162
0a630686 163 L <- expArgs(θ)
0f5fbd13 164 -2 * t(grad_M(L)) %*% W %*% as.matrix(Mhat - Moments(L))
b389a46a 165 },
4263503b 166
7737c2fa 167 grad_M = function(θ)
4263503b 168 {
7737c2fa 169 "Gradient of the vector of moments, size (dim=)d+d^2+d^3 x K-1+K+d*K"
4263503b 170
6dd5c2ac
BA
171 p <- θ$p
172 β <- θ$β
173 λ <- sqrt(colSums(β^2))
174 μ <- sweep(β, 2, λ, '/')
175 b <- θ$b
7737c2fa
BA
176
177 res <- matrix(nrow=nrow(W), ncol=0)
cbd88fe5 178
6dd5c2ac
BA
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)
cbd88fe5 182
6dd5c2ac
BA
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)
cbd88fe5 189
7737c2fa 190 # Gradient on p: K-1 columns, dim rows
6dd5c2ac
BA
191 km1 = 1:(K-1)
192 res <- cbind(res, rbind(
0a630686
BA
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] ))
cbd88fe5 196
6dd5c2ac
BA
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 }
cbd88fe5 225
7737c2fa 226 # Gradient on b
6dd5c2ac
BA
227 res <- cbind(res, rbind(
228 sweep(β, 2, p * G2, '*'),
229 sweep(β2, 2, p * G3, '*'),
230 sweep(β3, 2, p * G4, '*') ))
cbd88fe5 231
6dd5c2ac
BA
232 res
233 },
cbd88fe5 234
6dd5c2ac
BA
235 run = function(θ0)
236 {
237 "Run optimization from θ0 with solver..."
7737c2fa 238
6dd5c2ac
BA
239 if (!is.list(θ0))
240 stop("θ0: list")
7737c2fa
BA
241 if (is.null(θ0$β))
242 stop("At least θ0$β must be provided")
0f5fbd13
BA
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 }
7737c2fa
BA
248 if (is.null(θ0$p))
249 θ0$p = rep(1/K, K-1)
0f5fbd13
BA
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))
7737c2fa 256 θ0$b = rep(0, K)
0f5fbd13
BA
257 else if (!is.numeric(θ0$b) || length(θ0$b) != K || any(is.na(θ0$b)))
258 stop("θ0$b: length K, no NA")
4bf8494d
BA
259 # TODO: stopping condition? N iterations? Delta <= epsilon ?
260 for (loop in 1:10)
261 {
262 op_res = constrOptim( linArgs(θ0), .self$f, .self$grad_f,
263 ui=cbind(
264 rbind( rep(-1,K-1), diag(K-1) ),
265 matrix(0, nrow=K, ncol=(d+1)*K) ),
266 ci=c(-1,rep(0,K-1)) )
0f5fbd13
BA
267 W <<- computeW(expArgs(op_res$par))
268 print(op_res$value) #debug
269 print(expArgs(op_res$par)) #debug
4bf8494d 270 }
4263503b 271
6dd5c2ac
BA
272 expArgs(op_res$par)
273 }
274 )
cbd88fe5
BA
275)
276
277# Compute vectorial E[g^{(order)}(<β,x> + b)] with x~N(0,Id) (integral in R^d)
278# = E[g^{(order)}(z)] with z~N(b,diag(λ))
4263503b 279# by numerically evaluating the integral.
cbd88fe5
BA
280#
281# @param link Link, 'logit' or 'probit'
282# @param order Order of derivative
283# @param λ Norm of columns of β
284# @param b Intercept
285#
286.G <- function(link, order, λ, b)
287{
6dd5c2ac
BA
288 # NOTE: weird "integral divergent" error on inputs:
289 # link="probit"; order=2; λ=c(531.8099,586.8893,523.5816); b=c(-118.512674,-3.488020,2.109969)
290 # Switch to pracma package for that (but it seems slow...)
4263503b
BA
291 sapply( seq_along(λ), function(k) {
292 res <- NULL
293 tryCatch({
294 # Fast code, may fail:
295 res <- stats::integrate(
296 function(z) .deriv[[link]][[order]](λ[k]*z+b[k]) * exp(-z^2/2) / sqrt(2*pi),
297 lower=-Inf, upper=Inf )$value
298 }, error = function(e) {
299 # Robust slow code, no fails observed:
300 sink("/dev/null") #pracma package has some useless printed outputs...
301 res <- pracma::integral(
302 function(z) .deriv[[link]][[order]](λ[k]*z+b[k]) * exp(-z^2/2) / sqrt(2*pi),
303 xmin=-Inf, xmax=Inf, method="Kronrod")
304 sink()
305 })
306 res
307 })
cbd88fe5
BA
308}
309
310# Derivatives list: g^(k)(x) for links 'logit' and 'probit'
311#
312.deriv <- list(
6dd5c2ac
BA
313 "probit"=list(
314 # 'probit' derivatives list;
315 # NOTE: exact values for the integral E[g^(k)(λz+b)] could be computed
316 function(x) exp(-x^2/2)/(sqrt(2*pi)), #g'
317 function(x) exp(-x^2/2)/(sqrt(2*pi)) * -x, #g''
318 function(x) exp(-x^2/2)/(sqrt(2*pi)) * ( x^2 - 1), #g^(3)
319 function(x) exp(-x^2/2)/(sqrt(2*pi)) * (-x^3 + 3*x), #g^(4)
320 function(x) exp(-x^2/2)/(sqrt(2*pi)) * ( x^4 - 6*x^2 + 3) #g^(5)
321 ),
322 "logit"=list(
323 # Sigmoid derivatives list, obtained with http://www.derivative-calculator.net/
324 # @seealso http://www.ece.uc.edu/~aminai/papers/minai_sigmoids_NN93.pdf
325 function(x) {e=exp(x); .zin(e /(e+1)^2)}, #g'
326 function(x) {e=exp(x); .zin(e*(-e + 1) /(e+1)^3)}, #g''
327 function(x) {e=exp(x); .zin(e*( e^2 - 4*e + 1) /(e+1)^4)}, #g^(3)
328 function(x) {e=exp(x); .zin(e*(-e^3 + 11*e^2 - 11*e + 1) /(e+1)^5)}, #g^(4)
329 function(x) {e=exp(x); .zin(e*( e^4 - 26*e^3 + 66*e^2 - 26*e + 1)/(e+1)^6)} #g^(5)
330 )
cbd88fe5
BA
331)
332
333# Utility for integration: "[return] zero if [argument is] NaN" (Inf / Inf divs)
334#
335# @param x Ratio of polynoms of exponentials, as in .S[[i]]
336#
337.zin <- function(x)
338{
6dd5c2ac
BA
339 x[is.nan(x)] <- 0.
340 x
cbd88fe5 341}