From a3f7a73f9ce290401d95e2f7cc9a4a9edc474490 Mon Sep 17 00:00:00 2001 From: fenguoerbian <413557584@qq.com> Date: Tue, 3 Sep 2024 00:30:05 +0800 Subject: [PATCH 1/4] Fix a bug in FARMM CV parallel solver --- R/mm_path_solver.R | 46 ++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 42 insertions(+), 4 deletions(-) diff --git a/R/mm_path_solver.R b/R/mm_path_solver.R index 86713bf..0b98f19 100644 --- a/R/mm_path_solver.R +++ b/R/mm_path_solver.R @@ -778,7 +778,25 @@ Logistic_FARMM_CV_path <- function(y_vec, x_mat, h, kn, p, rand_eff_df, for(lam_id in 1 : lambda_length){ delta_vec <- train_res$delta_path[lam_id, ] eta_stack_vec <- train_res$eta_stack_path[lam_id, ] - test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) + # test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) + # fixed effect part of pi vector + test_pi_vec1 <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) + # random effect part of pi vector + if(ncol(rand_eff_df_test) == 1){ + zmat <- matrix(1, nrow = nrow(rand_eff_df_test), ncol = 1) + }else{ + zmat <- rand_eff_df_test[, which(colnames(rand_eff_df_test) != "subj_vec_fct"), drop = FALSE] + zmat <- cbind(1, zmat) + } + + rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% + left_join(post_est$rand_eff_est, + by = "subj_vec_fct") %>% + select(-subj_vec_fct) %>% + as.matrix() + test_pi_vec2 <- rowSums(zmat * rand_eff_mat) + + test_pi_vec <- test_pi_vec1 + test_pi_vec2 # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) loglik_test_mat[cv_id, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } @@ -1269,8 +1287,28 @@ Logistic_FARMM_CV_path_par <- function(y_vec, x_mat, h, kn, p, rand_eff_df, eta_stack_vec <- train_res$eta_stack_path[lam_id, ] # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) # loglik_test_mat[1, lam_id] <- sum(y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) - test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - loglik_test_mat[cv_id, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) + # test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) + + # fixed effect part of pi vector + test_pi_vec1 <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) + # random effect part of pi vector + if(ncol(rand_eff_df_test) == 1){ + zmat <- matrix(1, nrow = nrow(rand_eff_df_test), ncol = 1) + }else{ + zmat <- rand_eff_df_test[, which(colnames(rand_eff_df_test) != "subj_vec_fct"), drop = FALSE] + zmat <- cbind(1, zmat) + } + + rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% + left_join(post_est$rand_eff_est, + by = "subj_vec_fct") %>% + select(-subj_vec_fct) %>% + as.matrix() + test_pi_vec2 <- rowSums(zmat * rand_eff_mat) + + # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) + test_pi_vec <- test_pi_vec1 + test_pi_vec2 + loglik_test_mat[1, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } # test on testing set based on post-selection estimation @@ -1310,7 +1348,7 @@ Logistic_FARMM_CV_path_par <- function(y_vec, x_mat, h, kn, p, rand_eff_df, # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) test_pi_vec <- test_pi_vec1 + test_pi_vec2 - loglik_post_mat[cv_id, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) + loglik_post_mat[2, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } }else{ stop("`post_selection` must be set to `TRUE` for `Logistic_FARMM_CV_path()`!") From 51e7c638a5b019ad62c0bd85d9bf305d3816d3d6 Mon Sep 17 00:00:00 2001 From: fenguoerbian <413557584@qq.com> Date: Tue, 3 Sep 2024 07:09:50 +0800 Subject: [PATCH 2/4] Fix a bug in FARMM CV --- R/mm_path_solver.R | 41 ++--------------------------------------- 1 file changed, 2 insertions(+), 39 deletions(-) diff --git a/R/mm_path_solver.R b/R/mm_path_solver.R index 0b98f19..954cfbb 100644 --- a/R/mm_path_solver.R +++ b/R/mm_path_solver.R @@ -778,26 +778,9 @@ Logistic_FARMM_CV_path <- function(y_vec, x_mat, h, kn, p, rand_eff_df, for(lam_id in 1 : lambda_length){ delta_vec <- train_res$delta_path[lam_id, ] eta_stack_vec <- train_res$eta_stack_path[lam_id, ] - # test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - # fixed effect part of pi vector - test_pi_vec1 <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - # random effect part of pi vector - if(ncol(rand_eff_df_test) == 1){ - zmat <- matrix(1, nrow = nrow(rand_eff_df_test), ncol = 1) - }else{ - zmat <- rand_eff_df_test[, which(colnames(rand_eff_df_test) != "subj_vec_fct"), drop = FALSE] - zmat <- cbind(1, zmat) - } - rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% - left_join(post_est$rand_eff_est, - by = "subj_vec_fct") %>% - select(-subj_vec_fct) %>% - as.matrix() - test_pi_vec2 <- rowSums(zmat * rand_eff_mat) + test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - test_pi_vec <- test_pi_vec1 + test_pi_vec2 - # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) loglik_test_mat[cv_id, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } @@ -1287,27 +1270,7 @@ Logistic_FARMM_CV_path_par <- function(y_vec, x_mat, h, kn, p, rand_eff_df, eta_stack_vec <- train_res$eta_stack_path[lam_id, ] # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) # loglik_test_mat[1, lam_id] <- sum(y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) - # test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - - # fixed effect part of pi vector - test_pi_vec1 <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) - # random effect part of pi vector - if(ncol(rand_eff_df_test) == 1){ - zmat <- matrix(1, nrow = nrow(rand_eff_df_test), ncol = 1) - }else{ - zmat <- rand_eff_df_test[, which(colnames(rand_eff_df_test) != "subj_vec_fct"), drop = FALSE] - zmat <- cbind(1, zmat) - } - - rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% - left_join(post_est$rand_eff_est, - by = "subj_vec_fct") %>% - select(-subj_vec_fct) %>% - as.matrix() - test_pi_vec2 <- rowSums(zmat * rand_eff_mat) - - # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) - test_pi_vec <- test_pi_vec1 + test_pi_vec2 + test_pi_vec <- as.vector((x_mat_test[, 1 : h, drop = FALSE] %*% delta_vec) + (x_mat_test[, -(1 : h), drop = FALSE] %*% eta_stack_vec) * logit_weight_vec_test) loglik_test_mat[1, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } From d62cd3e4750c4c89210f1701e67d56b726631bc3 Mon Sep 17 00:00:00 2001 From: fenguoerbian <413557584@qq.com> Date: Wed, 4 Sep 2024 00:10:40 +0800 Subject: [PATCH 3/4] Fix a bug in FARMM post selection estimation --- DESCRIPTION | 2 +- R/mm_path_solver.R | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index f6a7f8a..9bacf17 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: LogisticFAR Title: Logistic Functional Additive Regression with log-contrast constrain. -Version: 0.0.0.9011 +Version: 0.0.0.9012 Authors@R: person(given = "Chao", family = "Cheng", diff --git a/R/mm_path_solver.R b/R/mm_path_solver.R index 954cfbb..a749478 100644 --- a/R/mm_path_solver.R +++ b/R/mm_path_solver.R @@ -821,6 +821,12 @@ Logistic_FARMM_CV_path <- function(y_vec, x_mat, h, kn, p, rand_eff_df, rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% left_join(post_est$rand_eff_est, by = "subj_vec_fct") %>% + dplyr::mutate( + dplyr::across( + tidyselect::everything(), + function(invec){ + tidyr::replace_na(data = invec, replace = 0) + })) %>% select(-subj_vec_fct) %>% as.matrix() test_pi_vec2 <- rowSums(zmat * rand_eff_mat) @@ -1305,6 +1311,12 @@ Logistic_FARMM_CV_path_par <- function(y_vec, x_mat, h, kn, p, rand_eff_df, rand_eff_mat <- data.frame(subj_vec_fct = rand_eff_df_test$subj_vec_fct) %>% left_join(post_est$rand_eff_est, by = "subj_vec_fct") %>% + dplyr::mutate( + dplyr::across( + tidyselect::everything(), + function(invec){ + tidyr::replace_na(data = invec, replace = 0) + })) %>% select(-subj_vec_fct) %>% as.matrix() test_pi_vec2 <- rowSums(zmat * rand_eff_mat) From ea30306c402b485c9c64e4eebc102f49a262cfae Mon Sep 17 00:00:00 2001 From: fenguoerbian <413557584@qq.com> Date: Wed, 4 Sep 2024 00:37:38 +0800 Subject: [PATCH 4/4] Fix a bug in parallel version of FARMM --- DESCRIPTION | 2 +- R/mm_path_solver.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9bacf17..dadca94 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: LogisticFAR Title: Logistic Functional Additive Regression with log-contrast constrain. -Version: 0.0.0.9012 +Version: 0.0.0.9013 Authors@R: person(given = "Chao", family = "Cheng", diff --git a/R/mm_path_solver.R b/R/mm_path_solver.R index a749478..cfdcaa5 100644 --- a/R/mm_path_solver.R +++ b/R/mm_path_solver.R @@ -1323,7 +1323,7 @@ Logistic_FARMM_CV_path_par <- function(y_vec, x_mat, h, kn, p, rand_eff_df, # test_pi_vec <- as.vector(x_mat_test %*% c(delta_vec, eta_stack_vec)) test_pi_vec <- test_pi_vec1 + test_pi_vec2 - loglik_post_mat[2, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) + loglik_test_mat[2, lam_id] <- sum((y_vec_test * test_pi_vec - log(1 + exp(test_pi_vec))) * weight_vec_test) } }else{ stop("`post_selection` must be set to `TRUE` for `Logistic_FARMM_CV_path()`!")