X-Git-Url: https://git.auder.net/?p=valse.git;a=blobdiff_plain;f=pkg%2FR%2FselectVariables.R;h=d863a4b7faeb5fc7e315c05b017801fb8e06fe2c;hp=f717caeb46125472a1565b3024f7385c43ec952d;hb=ea5860f1b4fc91f06e371a0b26915198474a849d;hpb=1b698c1619dbcf5b3a0608dc894d249945d2bce3 diff --git a/pkg/R/selectVariables.R b/pkg/R/selectVariables.R index f717cae..d863a4b 100644 --- a/pkg/R/selectVariables.R +++ b/pkg/R/selectVariables.R @@ -23,7 +23,7 @@ #' @export #' selectVariables <- function(phiInit, rhoInit, piInit, gamInit, mini, maxi, gamma, - glambda, X, Y, thresh = 1e-08, eps, ncores = 3, fast = TRUE) + glambda, X, Y, thresh = 1e-08, eps, ncores = 3, fast) { if (ncores > 1) { cl <- parallel::makeCluster(ncores, outfile = "") @@ -37,29 +37,40 @@ selectVariables <- function(phiInit, rhoInit, piInit, gamInit, mini, maxi, gamma params <- EMGLLF(phiInit, rhoInit, piInit, gamInit, mini, maxi, gamma, lambda, X, Y, eps, fast) - p <- dim(phiInit)[1] - m <- dim(phiInit)[2] + p <- ncol(X) + m <- ncol(Y) # selectedVariables: list where element j contains vector of selected variables # in [1,m] selectedVariables <- lapply(1:p, function(j) { # from boolean matrix mxk of selected variables obtain the corresponding boolean # m-vector, and finally return the corresponding indices - seq_len(m)[apply(abs(params$phi[j, , ]) > thresh, 1, any)] + if (m>1) { + seq_len(m)[apply(abs(params$phi[j, , ]) > thresh, 1, any)] + } else { + if (any(params$phi[j, , ] > thresh)) + 1 + else + numeric(0) + } }) list(selected = selectedVariables, Rho = params$rho, Pi = params$pi) } # For each lambda in the grid, we compute the coefficients - out <- if (ncores > 1) - parLapply(cl, glambda, computeCoefs) else lapply(glambda, computeCoefs) + out <- + if (ncores > 1) { + parLapply(cl, glambda, computeCoefs) + } else { + lapply(glambda, computeCoefs) + } if (ncores > 1) parallel::stopCluster(cl) # Suppress models which are computed twice En fait, ca ca fait la comparaison de # tous les parametres On veut juste supprimer ceux qui ont les memes variables - # sélectionnées sha1_array <- lapply(out, digest::sha1) out[ - # duplicated(sha1_array) ] + # sélectionnées + # sha1_array <- lapply(out, digest::sha1) out[ duplicated(sha1_array) ] selec <- lapply(out, function(model) model$selected) ind_dup <- duplicated(selec) ind_uniq <- which(!ind_dup)