polarolouis/mia-stage-2024
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Homogénéisation des simulations d'inférence

Browse source
This commit is contained in:
Louis Lacoste 2024-04-29 15:28:51 +02:00
parent 39b6b53d25
commit f04ea43aa2
2 changed files with 44 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
code/simulations/simulations_inference_bernoulli.R
View file

@ -13,8 +13,8 @@ suppressPackageStartupMessages(library(colSBM))
set.seed(1234)
# Network param
nr <- 2*120
nc <- 2*120
nr <- 2 * 120
nc <- 2 * 120
M <- 2
# Changing parameters
@ -215,7 +215,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
BICLs <- c(sep_BICL, iid_BICL, pi_BICL, rho_BICL, pirho_BICL)
# ARIs
#  Functions
compute_mean_ARI <- function(model) {
# We compute the mean amongst the two networks and return values for
# rows and columns in a vector
@ -347,7 +347,8 @@ results <- parallel::mclapply(conditions_rows, function(s) {
}
return(data_frame_output)
}, mc.cores = parallelly::availableCores(omit = 1)
},
mc.cores = parallelly::availableCores(omit = 1)
)
@ -357,4 +358,4 @@ full_data_frame <- do.call(rbind, results)
saveRDS(full_data_frame,
file = file_save
)
message("Finished simulations.")
message("Finished simulations.")

52
code/simulations/simulations_inference_poisson.R
View file

@ -155,7 +155,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
global_opts = list(
verbosity = 0,
plot_details = 0,
nb_cores = parallel::detectCores() - 1
nb_cores = parallelly::availableCores(omit = 1)
)
)
@ -171,7 +171,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
global_opts = list(
verbosity = 0,
plot_details = 0,
nb_cores = parallel::detectCores() - 1
nb_cores = parallelly::availableCores(omit = 1)
),
sep_BiSBM = sep_BiSBM
)
@ -184,7 +184,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
global_opts = list(
verbosity = 0,
plot_details = 0,
nb_cores = parallel::detectCores() - 1
nb_cores = parallelly::availableCores(omit = 1)
),
sep_BiSBM = sep_BiSBM
)
@ -197,14 +197,14 @@ results <- parallel::mclapply(conditions_rows, function(s) {
global_opts = list(
verbosity = 0,
plot_details = 0,
nb_cores = parallel::detectCores() - 1
nb_cores = parallelly::availableCores(omit = 1)
),
sep_BiSBM = sep_BiSBM
)
stop_time_condition <- Sys.time()
## Preparing date for export
##  Preparing date for export
# BICLs
sep_BICL <- sum(sep_BiSBM$BICL)
iid_BICL <- fitted_bisbmpop_iid$best_fit$BICL
@ -214,6 +214,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
BICLs <- c(sep_BICL, iid_BICL, pi_BICL, rho_BICL, pirho_BICL)
# ARIs
compute_mean_ARI <- function(model) {
# We compute the mean amongst the two networks and return values for
# rows and columns in a vector
@ -229,11 +230,7 @@ results <- parallel::mclapply(conditions_rows, function(s) {
), nrow = 2, ncol = 1)
}))
}
sep_mean_ARIs <- compute_mean_ARI(sep_BiSBM)
iid_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_iid$best_fit)
pi_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_pi$best_fit)
rho_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_rho$best_fit)
pirho_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_pirho$best_fit)
compute_double_ARI <- function(model) {
model_row_Z <- as.vector(sapply(
@ -252,6 +249,12 @@ results <- parallel::mclapply(conditions_rows, function(s) {
))
}
sep_mean_ARIs <- compute_mean_ARI(sep_BiSBM)
iid_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_iid$best_fit)
pi_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_pi$best_fit)
rho_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_rho$best_fit)
pirho_mean_ARIs <- compute_mean_ARI(fitted_bisbmpop_pirho$best_fit)
sep_double_ARIs <- compute_double_ARI(fitted_bisbmpop_iid$sep_BiSBM)
iid_double_ARIs <- compute_double_ARI(fitted_bisbmpop_iid$best_fit)
pi_double_ARIs <- compute_double_ARI(fitted_bisbmpop_pi$best_fit)
@ -307,9 +310,10 @@ results <- parallel::mclapply(conditions_rows, function(s) {
pirho_double_col_ARI = pirho_double_ARIs[[2]],
pirho_Q1 = fitted_bisbmpop_pirho$best_fit$Q[1],
pirho_Q2 = fitted_bisbmpop_pirho$best_fit$Q[2],
elapsed_secs = difftime(stop_time_condition,
start_time_condition, units = "sec")
elapsed_secs = difftime(stop_time_condition,
start_time_condition,
units = "sec"
)
)
message("Finished step ", s, "/", nrow(conditions))
@ -321,9 +325,29 @@ results <- parallel::mclapply(conditions_rows, function(s) {
saveRDS(object = data_frame_output, file = temp_file_save)
#  Saving inhabitual data
if (all(unlist(pirho_mean_ARIs) == 1L) & any(unlist(pirho_double_ARIs) < 1L)) {
warning("Incorrect result encountered, saving.")
incorrect_filepath <- file.path(temp_dir, paste0(
"incorrect_conditions_", s, "_on_",
nrow(conditions), ".Rds"
))
inc_data <- list(
epsilon_alpha = ea,
pi1 = current_pi1,
rho2 = current_rho2,
alpha = current_alpha,
pirho_double_row_ARI = pirho_double_ARIs[[1]],
pirho_double_col_ARI = pirho_double_ARIs[[2]],
netlist = netlist_generated
)
saveRDS(object = inc_data, file = incorrect_filepath)
}
return(data_frame_output)
},
mc.cores = parallel::detectCores() - 1
mc.cores = parallelly::availableCores(omit = 1)
)