X-Git-Url: https://git.auder.net/?a=blobdiff_plain;ds=sidebyside;f=pkg%2FR%2FconstructionModelesLassoMLE.R;h=75ae679f63c4678530664682c2ecf56a18bd2365;hb=9cb34faffaa6fcb78eb8ae3bdb70fb5147d73466;hp=1275ca3cc5d94c754ea3c741f605e78ac939e23a;hpb=ea5860f1b4fc91f06e371a0b26915198474a849d;p=valse.git diff --git a/pkg/R/constructionModelesLassoMLE.R b/pkg/R/constructionModelesLassoMLE.R index 1275ca3..75ae679 100644 --- a/pkg/R/constructionModelesLassoMLE.R +++ b/pkg/R/constructionModelesLassoMLE.R @@ -63,18 +63,25 @@ constructionModelesLassoMLE <- function(phiInit, rhoInit, piInit, gamInit, mini, phiLambda[col.sel[j], sel.lambda[[j]], ] <- phiLambda2[j, sel.lambda[[j]], ] dimension <- length(unlist(sel.lambda)) - # Computation of the loglikelihood - densite <- vector("double", n) - for (r in 1:k) + ## Computation of the loglikelihood + # Precompute det(rhoLambda[,,r]) for r in 1...k + detRho <- sapply(1:k, function(r) gdet(rhoLambda[, , r])) + sumLogLLH <- 0 + for (i in 1:n) { - if (length(col.sel) == 1) - { - delta <- (Y %*% rhoLambda[, , r] - (X[, col.sel] %*% t(phiLambda[col.sel, , r]))) - } else delta <- (Y %*% rhoLambda[, , r] - (X[, col.sel] %*% phiLambda[col.sel, , r])) - densite <- densite + piLambda[r] * gdet(rhoLambda[, , r])/(sqrt(2 * base::pi))^m * - exp(-diag(tcrossprod(delta))/2) + # Update gam[,]; use log to avoid numerical problems + logGam <- sapply(1:k, function(r) { + log(piLambda[r]) + log(detRho[r]) - 0.5 * + sum((Y[i, ] %*% rhoLambda[, , r] - X[i, ] %*% phiLambda[, , r])^2) + }) + + logGam <- logGam - max(logGam) #adjust without changing proportions + gam <- exp(logGam) + print(gam) + norm_fact <- sum(gam) + sumLogLLH <- sumLogLLH + log(norm_fact) - log((2 * base::pi)^(m/2)) } - llhLambda <- c(sum(log(densite)), (dimension + m + 1) * k - 1) + llhLambda <- c(sumLogLLH/n, (dimension + m + 1) * k - 1) list(phi = phiLambda, rho = rhoLambda, pi = piLambda, llh = llhLambda) }