From 4d21953aa5034689ac71273edf57849ff38782eb Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 19:44:05 +0800 Subject: [PATCH 01/68] Suppress a harmless warning in a test --- tests/testthat/test-check_sem_out.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-check_sem_out.R b/tests/testthat/test-check_sem_out.R index 617480b3..87f9beb3 100644 --- a/tests/testthat/test-check_sem_out.R +++ b/tests/testthat/test-check_sem_out.R @@ -26,7 +26,8 @@ fit02 <- lavaan::sem(mod, dat, estimator = "MLR") # fit03 <- lavaan::sem(mod, dat, estimator = "ML", se = "robust") # (out_03 <- check_sem_out(fit03)) -fit04<- lavaan::sem(mod, dat, estimator = "DWLS") +# The warning can be ignored because this problem is intentional +suppressWarnings(fit04 <- lavaan::sem(mod, dat, estimator = "DWLS")) (out_04 <- check_sem_out(fit04)) suppressWarnings(fit05 <- lavaan::sem(mod, dat, group = "gp")) From 93dedc614e557523be34661b0050df57596369e5 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 19:45:47 +0800 Subject: [PATCH 02/68] Update to 0.10.4.1 --- DESCRIPTION | 2 +- NEWS.md | 7 +++++++ README.md | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e718af91..4ca5c525 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4 +Version: 0.10.4.1 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 839e8214..18503c72 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,10 @@ +# semlbci 0.10.4.1 + +## Miscellaneous + +- Suppressed a harmless warning in a + test. (0.10.4.1) + # semlbci 0.10.4 ## New Feature diff --git a/README.md b/README.md index 0ed490a8..422aa47c 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4, updated on 2023-10-31, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.1, updated on 2024-05-25, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 8abc7d73b4fe28025ec6caae641ed625a2c79629 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 22:26:17 +0800 Subject: [PATCH 03/68] WIP: Add ci_bound_ur Not yet working. Work in progress --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/ci_bound_ur_i.R | 654 +++++++++++++++++++++++++ R/ci_bound_ur_i_helpers.R | 573 ++++++++++++++++++++++ R/loglike_at_user.R | 32 ++ _pkgdown.yml | 1 + man/ci_bound_ur_i.Rd | 198 ++++++++ man/semlbci-package.Rd | 1 - tests/testthat/test-ur_add_func.R | 198 ++++++++ tests/testthat/test-ur_ci_bound_ur_i.R | 204 ++++++++ tests/testthat/test-ur_gen_est_i.R | 329 +++++++++++++ tests/testthat/test-ur_gen_userp.R | 50 ++ 12 files changed, 2241 insertions(+), 2 deletions(-) create mode 100644 R/ci_bound_ur_i.R create mode 100644 R/ci_bound_ur_i_helpers.R create mode 100644 R/loglike_at_user.R create mode 100644 man/ci_bound_ur_i.Rd create mode 100644 tests/testthat/test-ur_add_func.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_i.R create mode 100644 tests/testthat/test-ur_gen_est_i.R create mode 100644 tests/testthat/test-ur_gen_userp.R diff --git a/DESCRIPTION b/DESCRIPTION index 4ca5c525..49652aba 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,7 +28,7 @@ License: GPL-3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Suggests: testthat (>= 3.0.0), knitr, diff --git a/NAMESPACE b/NAMESPACE index 999e4ef3..6ad91374 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ S3method(print,ci_order) S3method(print,cibound) S3method(print,semlbci) export(check_sem_out) +export(ci_bound_ur_i) export(ci_bound_wn_i) export(ci_i_one) export(ci_order) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R new file mode 100644 index 00000000..c08c9fd2 --- /dev/null +++ b/R/ci_bound_ur_i.R @@ -0,0 +1,654 @@ +# NOTE: +# - Copied from semlbci::ci_bound_wn_i() +# - Need to be edited later. + +#' @title Likelihood-based Confidence Bound For One parameter (uniroot) +#' +#' @description Find the lower or upper bound of the likelihood-based +#' confidence interval (LBCI) for one parameter in a structural +#' equation model fitted in [lavaan::lavaan()] using [uniroot()]. +#' +#' @details +#' +#' ## Important Notice +#' +#' This function is not supposed to be used directly by users in +#' typical scenarios. Its interface is user-*unfriendly* because it +#' should be used through [semlbci()]. It is exported such that +#' interested users can examine how a confidence bound is found, or +#' use it for experiments or simulations. +#' +#' ## Usage +#' +#' This function is the lowest level function used by [semlbci()]. +#' [semlbci()] calls this function once for each bound of each +#' parameter. +#' +#' For consistency in the interface, most of the arguments +#' in [ci_bound_wn_i()] are also included in this function, +#' even those not used internally. +#' +#' ## Algorithm +#' +#' This function, unlike [ci_bound_wn_i()], use a simple +#' root finding algorithm. Basically, it try fixing the +#' target parameters to different values until the +#' likelihood ratio test *p*-value is equal to the desired +#' value. +#' +#' This algorithm is known to be very inefficient, compared +#' to the one proposed by Wu and Neale (2012). It is included +#' as a backup algorithm for parameters which are difficult +#' for the method by Wu and Neale. +#' +#' ## Limitation(s) +#' +#' Like [ci_bound_wn_i()], this function does not an estimate +#' close to an attainable bound. +#' +#' @return A `cibound`-class object which is a list with three elements: +#' +#' - `bound`: A single number. The value of the bound located. `NA` is +#' the search failed for various reasons. +#' +#' - `diag`: A list of diagnostic information. +#' +#' - `call`: The original call. +#' +#' A detailed and organized output can be printed by the default print +#' method ([print.cibound()]). +#' +#' @param i The position of the target parameter as appeared in the +#' parameter table of a lavaan object, generated by +#' [lavaan::parameterTable()]. +#' +#' @param npar Ignored by this function. Included for having +#' a unified interface. +#' +#' @param sem_out The fit object. Currently supports +#' [lavaan::lavaan-class] objects only. +#' +#' @param f_constr Ignored by this function. Included for having +#' a unified interface. +#' +#' @param which Whether the lower bound or the upper bound is to be +#' found. Must be `"lbound"` or `"ubound"`. +#' +#' @param history Not used. Kept for backward compatibility. +#' +#' @param perturbation_factor Ignored by this function. Included for having +#' a unified interface. +#' +#' @param lb_var Ignored by this function. Included for having +#' a unified interface. +#' +#' @param wald_ci_start Ignored by this function. Included for having +#' a unified interface. +#' +#' @param standardized If `TRUE`, the LBCI is for the requested +#' estimate in the standardized solution. Default is `FALSE`. +#' +#' @param opts Options to be passed to [stats::uniroot()]. +#' Default is `list()`. +#' +#' @param ciperc The intended coverage probability for the confidence +#' interval. Default is .95, and the bound for a 95% confidence +#' interval will be sought. +#' +#' @param ci_limit_ratio_tol The tolerance for the ratio of `a` to +#' `b`, where `a` is the distance between an LBCI limit and the point +#' estimate, and the `b` is the distance between the original +#' confidence limit (by default the Wald CI in [lavaan::lavaan()]) +#' and the point estimate. If the ratio is larger than this value or +#' smaller than the reciprocal of this value, a warning is set in the +#' status code. Default is 1.5. +#' +#' @param verbose If `TRUE`, the function will store more diagnostic +#' information in the attribute `diag`. Default is `FALSE`. +#' +#' @param sf Ignored by this function. Included for having +#' a unified interface. +#' +#' @param sf2 Ignored by this function. Included for having +#' a unified interface. +#' +#' @param p_tol Tolerance for checking the achieved level of +#' confidence. If the absolute difference between the achieved level +#' and `ciperc` is greater than this amount, a warning is set in the +#' status code and the bound is set to `NA`. Default is 5e-4. +#' +#' @param std_method The method used to find the standardized +#' solution. If equal to `"lavaan"``, +#' [lavaan::standardizedSolution()] will be used. If equal to +#' `"internal"`, an internal function will be used. The `"lavaan"` +#' method should work in all situations, but the `"internal"` method +#' is usually much faster. Default is `"internal"`. +#' +#' @param bounds Ignored by this function. Included for having +#' a unified interface. +#' +#' @param xtol_rel_factor Ignored by this function. Included for having +#' a unified interface. +#' +#' @param ftol_rel_factor Ignored by this function. Included for having +#' a unified interface. +#' +#' @param lb_prop Ignored by this function. Included for having +#' a unified interface. +#' +#' @param lb_se_k Ignored by this function. Included for having +#' a unified interface. +#' +#' @param ... Optional arguments. Not used. +#' +#' @references +#' +#' Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for a +#' bounded parameter. *Behavior Genetics, 42*(6), 886-898. +#' \doi{10.1007/s10519-012-9560-z} +#' +#' @seealso [print.cibound()], [semlbci()], [ci_i_one()] +#' +#' @examples +#' +#' data(simple_med) +#' dat <- simple_med +#' +#' mod <- +#' " +#' m ~ x +#' y ~ m +#' " +#' +#' fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) +#' +#' out1l <- ci_bound_ur_i(i = 1, +#' sem_out = fit_med, +#' which = "lbound") +#' out1l +#' +#' @export + +# Workflow +# - Input: +# - sem_out +# - A function which receive parameters and return a value + +ci_bound_ur_i <- function(i = NULL, + npar = NULL, # Not used by ur + sem_out = NULL, + f_constr = NULL, # Not used by ur + which = NULL, + history = FALSE, + perturbation_factor = .9, # Can be used by sem_out_userp() + lb_var = -Inf, # Not used by ur. Set in sem_out + standardized = FALSE, + wald_ci_start = !standardized, # Not used by ur + opts = list(), + ciperc = .95, + ci_limit_ratio_tol = 1.5, + verbose = FALSE, + sf = 1, # Not used by ur + sf2 = 0, # Not used by ur + p_tol = 5e-4, + std_method = "internal", # Not used by ur + bounds = "none", # Not used by ur + xtol_rel_factor = 1, # Not used by ur + ftol_rel_factor = 1, # Not used by ur + lb_prop = .05, # Not used by ur + lb_se_k = 3, # Not used by ur + ...) { + + # Basic info + + est <- lavaan::parameterEstimates(sem_out, ci = TRUE) + i_est <- est[i, "est"] + i_org_ci_limit <- switch(which, + lbound = est[i, "ci.lower"], + ubound = est[i, "ci.upper"]) + npar <- lavaan::lavTech(sem_out, "npar") + + # Generate the user-parameter function + est_i_func <- gen_est_i(i = i, + sem_out = sem_out, + standardized = standardized) + + # Find the root + ur_opts <- list(sem_out = sem_out, + func = est_i_func, + level = ciperc, + which = which, + tol = p_tol, + uniroot_maxiter = 500) + ur_opts <- utils::modifyList(ur_opts, + opts) + out <- do.call(ci_bound_ur, + ur_opts) + + # Process the results + + bound <- out$bound + bound_unchecked <- bound + + # Initialize the status code + ## Any values other than 0 denotes a problem + status <- 0 + + # Check convergence + # TODO: + # - Find the status code of uniroot + # - Need to be done in the call to uniroot() + # if (out$status < 0) { + # # Verify the range of nloptr that denotes an error + # status <- 1 + # check_optimization <- FALSE + # # bound <- NA + # } else { + check_optimization <- TRUE + # } + + # Check the limit + + if (!is.na(bound)) { + ci_limit_ratio <- abs((bound - i_est) / (i_org_ci_limit - i_est)) + ci_limit_ratio2 <- 1 / ci_limit_ratio + if (any(ci_limit_ratio > ci_limit_ratio_tol, + ci_limit_ratio2 > ci_limit_ratio_tol)) { + # status <- 1 + # Do not set the bound to NA because the limit may still be valid. + } + } else { + ci_limit_ratio <- NA + } + + # Check whether admissible + + fit_final <- out$sem_out_bound + + fit_post_check <- lavaan::lavTech(fit_final, "post.check") + if (!fit_post_check) { + status <- 1 + check_post_check <- FALSE + # bound <- NA + # The warning should be raised by the calling function, not this one. + } else { + check_post_check <- TRUE + } + + # Achieved level of confidence + + ciperc_final <- 1 - out$lrt[2, "Pr(>Chisq)"] + if (abs(ciperc_final - ciperc) > p_tol) { + status <- 1 + check_level_of_confidence <- FALSE + # bound <- NA + } else { + check_level_of_confidence <- TRUE + } + + if (!all(check_optimization, + check_post_check, + check_level_of_confidence)) { + bound <- NA + } + + coef0 <- methods::getMethod("coef", + signature = "lavaan", + where = asNamespace("lavaan"))(sem_out) + coef_final <- methods::getMethod("coef", + signature = "lavaan", + where = asNamespace("lavaan"))(fit_final) + xstart <- coef0 + xstart[] <- NA + + ## Collect diagnostic information + diag <- list(status = status, + est_org = i_est, + ci_org_limit = i_org_ci_limit, + ci_limit_ratio = ci_limit_ratio, + fit_post_check = fit_post_check, + start_values = unname(xstart), + bound_unchecked = bound_unchecked, + org_values = coef0, + final_values = coef_final, + ciperc = ciperc, + ciperc_final = ciperc_final, + i = i, + # TODO: + # - Remove semlbci::: + i_lor = semlbci:::get_lhs_op_rhs(i, sem_out, more = TRUE), + optim_message = "Nil", # out$message + optim_iterations = out$optimize_out$iter, + optim_status = NA, # out$status + optim_termination_conditions = "Nil", # out$termination_conditions, + method = "ur", + which = which, + standardized = standardized, + check_optimization = check_optimization, + check_post_check = check_post_check, + check_level_of_confidence = check_level_of_confidence + ) + if (verbose) { + out0 <- out + out0$sem_out_bound <- NULL + diag$history <- out0 + diag$fit_final <- fit_final + } else { + diag$history <- NULL + diag$fit_final <- NULL + } + if (status < 0) { + # If convergence status < 0, override verbose + diag$history <- out + } + out <- list(bound = bound, + diag = diag, + call = match.call()) + class(out) <- c("cibound", class(out)) + out + } + +#' @title Find a Likelihood-Based +#' Confidence Bound By 'uniroot()' +#' +#' @description Find the lower or upper +#' bound of the likelihood-based +#' confidence interval (LBCI) for one +#' parameter in a structural equation +#' model fitted in [lavaan::lavaan()] +#' using [uniroot()]. +#' +#' @details +#' This function is called xby +#' [ci_bound_ur_i()]. This function will +#' be exported later because it is a +#' stand-alone function that can be used +#' directly for any function that +#' receives a lavaan object and returns +#' a scalar. +#' +#' @param sem_out The fit object. +#' Currently supports +#' [lavaan::lavaan-class] objects only. +#' +#' @param func A function that receives +#' a lavaan object and returns a scalar. +#' Usually the output of +#' [gen_sem_out_userp()]. +#' +#' @param ... Optional arguments to be +#' passed to `func`. +#' +#' @param level The level of confidence +#' of the confidence interval. Default +#' is .95, or 95%. +#' +#' @param which Whether the lower bound +#' or the upper bound is to be found. +#' Must be `"lbound"` or `"ubound"`. +#' +#' @param interval A numeric vector of +#' two values, which is the initial +#' interval to be searched. If `NULL`, +#' the default, it will be determined +#' internally using Wald or delta +#' method confidence interval, if +#' available. +#' +#' @param progress Whether progress will +#' be reported on screen. Default is +#' `FALSE`. +#' +#' @param method The actual function to +#' be used in the search. which can only +#' be `"uniroot"`, the default, for now. +#' May include other function in the +#' future. +#' +#' @param tol The tolerance used in +#' [uniroot()], default is .005. +#' +#' @param root_target Whether the +#' chi-square difference (`"chisq"`), +#' the default, or its *p*-value +#' (`"pvalue"`) is used as the function +#' value in finding the root. Should have +#' little impact on the results. +#' +#' @param d A value used to determine +#' the width of the interval in the +#' initial search. Larger this value, +#' *narrow* the interval. Default is 5. +#' +#' @param uniroot_extendInt To be passed +#' to the argument `extendInt` of +#' [uniroot()]. Whether the interval +#' should be extended if the root is not +#' found. Default is `"yes"`. Refer to +#' the help page of [uniroot()] for +#' possible values. +#' +#' @param uniroot_trace To be passed to +#' the argument `trace` of [uniroot()]. +#' How much information is printed +#' during the search. Default is 0, and +#' no information is printed during the +#' search. Refer to the help page of +#' [uniroot()] for possible values. +#' +#' @param uniroot_maxiter The maximum +#' number of iteration in the search. +#' Default is 1000. +#' +#' @param use_callr Whether the +#' [callr] package will be used to +#' do the search in a separate R +#' process. Default is `TRUE`. Should +#' not set to `FALSE` if used in the +#' global environment unless this is +#' intentional. +#' +#' @return +#' A list with the following elements: +#' +#' - `bound`: The bound found. +#' +#' - `optimize_out`: THe output of the +#' root finding function, [uniroot()] +#' for now. (Called `optimize_out` +#' because an earlier version of this +#' function also uses [optimize()]). +#' +#' - `sem_out_bound`: The `lavaan` model +#' with the user-defined parameter fixed +#' to the bound. +#' +#' - `lrt`: The output of +#' [lavaan::lavTestLRT()] comparing +#' `sem_out` and `sem_out_bound`. +#' +#' - `bound_start`: The Wald or delta +#' method confidence bound returned when +#' determining the interval internally. +#' +#' - `user_est`: The estimate of the +#' user-defined parameter when +#' determining the interval internally. +#' +#' +#' @noRd + +# Internal Workflow +# - Define the function that works on the lavaan object. +# - Call add_func() to generate a modified lavaan object. +# - Call sem_out_userp_run() to fix to a value + +ci_bound_ur <- function(sem_out, + func, + ..., + level = .95, + which = c("lbound", "ubound"), + interval = NULL, + progress = FALSE, + method = "uniroot", + tol = .0005, # This is the tolerance in x, not in y + root_target = c("chisq", "pvalue"), + d = 5, + uniroot_extendInt = "yes", + uniroot_trace = 0, + uniroot_maxiter = 1000, + use_callr = TRUE) { + # TODO: + # - Support satorra.2000 + which <- match.arg(which) + root_target <- match.arg(root_target) + # Only support uniroot() for now + method <- match.arg(method) + lrt_alpha <- 1 - level + # Create the modified model + fit_i <- add_func(func = func, + sem_out = sem_out) + if (is.null(interval)) { + # Set the interval to search + if (progress) { + cat("\nFinding the initial interval ...") + } + interval <- uniroot_interval(sem_out = sem_out, + func = func, + which = which, + d = d) + bound_start <- attr(interval, "bound_start") + user_est <- attr(interval, "user_est") + } else { + bound_start <- NA + user_est <- NA + } + if (method == "uniroot") { + # Define the function for which to find the root + lrtp_i <- function(x, + alpha, + root_target = "pvalue", + global_ok = FALSE) { + sem_out_x <- sem_out_userp_run(target = x, + object = fit_i, + global_ok = global_ok) + lrt0 <- lavaan::lavTestLRT(sem_out_x, sem_out) + cname <- switch(root_target, + pvalue = "Pr(>Chisq)", + chisq = "Chisq diff") + out1 <- lrt0[2, cname] + y_target <- switch(root_target, + pvalue = alpha, + chisq = stats::qchisq(level, df = 1)) + out1 - y_target + } + if (use_callr) { + on.exit(try(r1$close(), silent = TRUE)) + r1 <- callr::r_session$new() + # TODO: + # - Mo need to export when gen_fit_userp is in the package + r1$run(function(x) {sem_out_userp_run <<- x}, + args = list(x = sem_out_userp_run)) + if (progress) { + browser() + optimize_out <- r1$call(function(f, + interval, + alpha, + root_target, + global_ok, + extendInt, + tol, + trace, + maxiter) { + tryCatch(stats::uniroot(f = f, + interval = interval, + alpha = alpha, + root_target = root_target, + global_ok = global_ok, + extendInt = extendInt, + tol = tol, + trace = trace, + maxiter = maxiter, + check.conv = TRUE), + error = function(e) e, + warning = function(w) w) + }, + args = list(f = lrtp_i, + interval = interval, + alpha = lrt_alpha, + root_target = root_target, + global_ok = TRUE, + extendInt = uniroot_extendInt, + tol = tol, + trace = uniroot_trace, + maxiter = uniroot_maxiter)) + cat("\nSearch started ...\n") + while (r1$poll_process(500) != "ready") { + rtime <- r1$get_running_time()["total"] + # TODO: + # - Need to handle time longer than 1 mins. + cat("\r", "Time spent: ", round(rtime, 2), " sec.", spe = "") + } + cat("\nSearch finished. Finalize the results ... \n") + optimize_out <- r1$read()$result + } else { + optimize_out <- r1$run(function(f, + interval, + alpha, + root_target, + global_ok, + extendInt, + tol, + trace, + maxiter) { + tryCatch(stats::uniroot(f = f, + interval = interval, + alpha = alpha, + root_target = root_target, + global_ok = global_ok, + extendInt = extendInt, + tol = tol, + trace = trace, + maxiter = maxiter, + check.conv = TRUE), + error = function(e) e, + warning = function(w) w) + }, + args = list(f = lrtp_i, + interval = interval, + alpha = lrt_alpha, + root_target = root_target, + global_ok = TRUE, + extendInt = uniroot_extendInt, + tol = tol, + trace = uniroot_trace, + maxiter = uniroot_maxiter)) + } + } else { + # Run locally. Need global_ok == FALSE. + optimize_out <- tryCatch(stats::uniroot(lrtp_i, + interval = interval, + alpha = lrt_alpha, + root_target = root_target, + global_ok = FALSE, + extendInt = uniroot_extendInt, + tol = tol, + trace = uniroot_trace, + maxiter = uniroot_maxiter, + check.conv = TRUE), + error = function(e) e, + warning = function(w) w) + } + } + out_root <- optimize_out$root + sem_out_final <- sem_out_userp_run(target = out_root, + object = fit_i) + lrt_final <- lavaan::lavTestLRT(sem_out_final, sem_out) + out <- list(bound = out_root, + optimize_out = optimize_out, + sem_out_bound = sem_out_final, + lrt = lrt_final, + bound_start = bound_start, + user_est = user_est) + out + } diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R new file mode 100644 index 00000000..4471479d --- /dev/null +++ b/R/ci_bound_ur_i_helpers.R @@ -0,0 +1,573 @@ + +#' @title Initial Interval for the +#' Search by 'ci_bound_ur()' +#' +#' @description Determine the interval to +#' be used by [ci_bound_ur()]. +#' +#' @details +#' Used when the parameter is the output +#' of a function a lavaan object, for +#' which it is not easy to get the Wald +#' or delta method confidence interval. +#' +#' It fits the model to the data in +#' `sem_out` and gets the confidence +#' interval of the function value of +#' `func`. The distance from the target +#' confidence bound (determiend by +#' `which`) to the estimate is computed, +#' divided by `d`. The confidence bound +#' plus and minus this value is the +#' interval to be used. +#' +#' @param sem_out The fit object. +#' Currently supports +#' [lavaan::lavaan-class] objects only. +#' +#' @param func A function that receives +#' a lavaan object and returns a scalar. +#' Usually the output of +#' [gen_sem_out_userp()]. +#' +#' @param which Whether the lower bound +#' or the upper bound is to be found. +#' Must be `"lbound"` or `"ubound"`. +#' +#' @param d A value used to determine +#' the width of the interval in the +#' initial search. Larger this value, +#' *narrow* the interval. Default is 5. +#' +#' @param level The level of confidence +#' of the confidence interval. Default +#' is .95, or 95%. +#' +#' @noRd + +uniroot_interval <- function(sem_out, + func, + which, + d = 5, + level = .95) { + # Set the interval to search + fit_i_free <- add_func(func = func, + sem_out = sem_out, + fix = FALSE) + fit_start <- sem_out_userp_run(target = 0, + object = fit_i_free) + est_start <- lavaan::parameterEstimates(fit_start, + ci = TRUE, + level = level) + i <- which(est_start$rhs == paste0(fit_i_free$userp_name, "()")) + user_est <- est_start[i, "est"] + bound_start <- est_start[i, switch(which, + lbound = "ci.lower", + ubound = "ci.upper")] + bound_start_d <- abs(bound_start - user_est) + i_l <- bound_start - bound_start_d / d + i_u <- bound_start + bound_start_d / d + out <- c(i_l, i_u) + attr(out, "bound_start") <- bound_start + attr(out, "user_est") <- user_est + return(out) + } + +#' @noRd +# Generate a function to extract a parameter +# To be used by [ci_bound_ur_i()]. + +gen_est_i <- function(i, + sem_out, + standardized = FALSE, + std_method = c("lavaan", "internal")) { + std_method <- match.arg(std_method) + ptable <- lavaan::parameterTable(sem_out) + # From the help page of lavaan-class object, + # type = "user" should return *all* parameters + # in the parameter table, including equality constraints. + # Therefore, the row number should be equal to the order + # in the vector of coefficients. + i_est <- i + is_def <- (ptable$op[i] == ":=") + i_lhs <- (ptable$lhs[i]) + i_rhs <- (ptable$rhs[i]) + i_op <- ptable$op[i] + i_gp <- ptable$group[i] + i_free <- (ptable$free > 0) + def_label <- ifelse(is_def, + ptable$label[i], + NA) + if (standardized) { + if (is_def) { + if (std_method == "internal") { + # Does not yet work + out <- function(object) { + # Just in case + force(i_est) + force(def_label) + force(ptable) + force(i_free) + force(sem_out) + object@implied <- lavaan::lav_model_implied(object@Model) + est <- lavaan::lav_model_get_parameters(object@Model) + std <- std_lav(param = est, sem_out = sem_out)[i_free] + est_def <- object@Model@def.function(std)[def_label] + unname(est_def) + } + } + if (std_method == "lavaan") { + out <- function(object) { + # Just in case + force(i_est) + std <- lavaan::standardizedSolution(object, + est = lavaan::lav_model_get_parameters(object@Model, type = "user"), + GLIST = object@Model@GLIST, + se = FALSE, + zstat = FALSE, + pvalue = FALSE, + ci = FALSE, + remove.eq = FALSE, + remove.ineq = FALSE, + remove.def = FALSE, + type = "std.all") + unname(std[i_est, "est.std"]) + } + } + } else { + out <- function(object) { + # Just in case + force(i_est) + force(i_gp) + force(i_op) + force(i_lhs) + force(i_rhs) + object@implied <- lavaan::lav_model_implied(object@Model) + est <- lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est] + implied <- lavaan::lavInspect(object, "cov.all", drop.list.single.group = FALSE) + implied_sd <- sqrt(diag(implied[[i_gp]])) + est1 <- switch(i_op, + `~~` = est / (implied_sd[i_lhs] * implied_sd[i_rhs]), + `~` = est * implied_sd[i_rhs] / implied_sd[i_lhs], + `=~` = est * implied_sd[i_lhs] / implied_sd[i_rhs]) + unname(est1) + } + } + } else { + out <- function(object) { + force(i_est) + unname(lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est]) + } + } + return(out) + } + + +#' @title Fix a User Parameter To a +#' Value and Refit a Model +#' +#' @description Fix a user parameter in +#' a lavaan model to a target value, +#' refit the model, and return the +#' results. +#' +#' @details +#' The model must be the output of +#' [add_func()]. +#' +#' @param target The value to which the +#' user parameter will be fixed to. +#' +#' @param object The output of +#' [add_func()]. +#' +#' @param verbose Whether diagnostic +#' information will be printed. Default +#' is `FALSE`. +#' +#' @param control To be passed to the +#' argument of the same name in +#' [lavaan::lavaan()]. Default is +#' `list()`. +#' +#' @param seed Numeric. If supplied, it +#' will be used in [set.seed()] to +#' initialize the random number +#' generator. Necessary to reproduce +#' some results because random numbers +#' are used in some steps in `lavaan`. +#' If `NULL`, the default, [set.seed()] +#' will not be called. +#' +#' @param global_ok Logical. Whether +#' is the user function can be stored +#' in the global environment. Default +#' is `FALSE`. Should not be set to +#' `TRUE` unless users are pretty sure +#' it is acceptable to store the +#' function in the global environment, +#' which is the case when this function +#' is called in an R process started +#' by `callr` dedicated to running this +#' function. +#' +#' @return +#' A `lavaan` object, with the value +#' of the user-defined parameters +#' fixed to the target value. +#' +#' @noRd + +sem_out_userp_run <- function(target, + object, + verbose = FALSE, + control = list(), + seed = NULL, + global_ok = FALSE) { + on.exit(try(r1$close(), silent = TRUE)) + + userp <- object$userp + userp_name <- object$userp_name + + if (global_ok) { + assign(userp_name, + value = userp, + envir = globalenv()) + out <- object$sem_out_userp(target = target, + verbose = verbose, + control = control, + seed = seed) + } else { + r1 <- callr::r_session$new() + r1$run(function(userp, userp_name) {assign(userp_name, + value = userp, + envir = globalenv())}, + args = list(userp = userp, + userp_name = userp_name)) + # TODO: + # - No need to export when gen_fit_userp is in the package + r1$run(function(x) {sem_out_userp <<- x}, + args = list(object$sem_out_userp)) + out <- r1$run(function(...) { + sem_out_userp(...) + }, + args = list(target = target, + verbose = verbose, + control = control, + seed = seed)) + } + out + } + + +#' @title Add a User Function to a 'lavaan' +#' model +#' +#' @description It adds a user function +#' to a `lavaan` model. +#' +#' @details +#' +#' The function is one accepts a +#' `lavaan` object and returns a scalar. +#' An R session will be started to +#' create the model. This is necessary +#' because the function needs to be +#' present in the global environment +#' even if the model is only created +#' but not fitted. +#' +#' @param func A function that accepts +#' a `lavaan` object and returns a +#' scalar. +#' +#' @param sem_out The fit object. +#' Currently supports +#' [lavaan::lavaan-class] objects only. +#' +#' @param userp_name The name of the +#' function (`func`) to be used in the +#' `lavaan` model. Should be changed +#' only if it conflicts with another +#' object in the global environment, +#' which should not happen if the model +#' is always fitted in a clean R +#' session. +#' +#' @param fix To be passed to +#' [gen_sem_out_userp()]. If `TRUE`, the +#' default, the function generated fix +#' the value of `func` to a target value +#' using an equality constraint. If +#' `FALSE`, then the function simply +#' fits the model to the data. +#' +#' @return +#' A list with the following elements: +#' +#' - `sem_out_userp`: The `lavaan` model +#' with the user function, `func`, added +#' as a user-defined parameter. +#' +#' - `userp`: A copy of `func`. +#' +#' - `userp_name`: The value of +#' `userp_name`, the label of the +#' user defined parameter in the model. +#' +#' @noRd + +add_func <- function(func, + sem_out, + userp_name = "semlbciuserp1234", + fix = TRUE) { + on.exit(try(r1$close(), silent = TRUE)) + userp <- gen_userp(func = func, + sem_out = sem_out) + # Create a child process + r1 <- callr::r_session$new() + # Store the function there + r1$run(function(userp, userp_name) {assign(userp_name, + value = userp, + envir = globalenv())}, + args = list(userp = userp, + userp_name = userp_name)) + # TODO: + # - Mo need to export when gen_fit_userp is in the package + r1$run(function(x) {gen_sem_out_userp <<- x}, + args = list(gen_sem_out_userp)) + # Generate sem_out_userp in the child process + fit_i <- r1$run(function(...) { + gen_sem_out_userp(...) + }, args = list(userp = userp, + sem_out = sem_out, + userp_name = userp_name, + fix = fix)) + list(sem_out_userp = fit_i, + userp = userp, + userp_name = userp_name) + } + +#' @title Generate a Function to Fix a User-Defined Parameter + +#' @noRd + +# Generate a function that: +# - refits the model with the user-parameter fixed to a target value. + +# For add_fun using callr +gen_sem_out_userp <- function(userp, + sem_out, + userp_name = "semlbciuserp1234", + fix = TRUE, + control_args = list(), + iter.max = 10000, + max_attempts = 5, + verbose = TRUE) { + iter.max <- max(lavaan::lavInspect(sem_out, "optim")$iterations, + iter.max) + ptable <- lavaan::parameterTable(sem_out) + # Create a unique label: userp_label + labels <- unique(ptable$label) + labels <- labels[nchar(labels) > 0] + userp_label <- make.unique(c(labels, "user")) + userp_label <- userp_label[length(userp_label)] + # Generate the user parameter row using userp() + user_pt1 <- data.frame(lhs = userp_label[length(userp_label)], + op = ":=", + rhs = paste0(userp_name, "()"), + user = 1, + block = 0, + group = 0, + free = 0, + ustart = NA, + label = userp_label, + exo = 0) + user_pt1 <- lavaan::lav_partable_complete(partable = user_pt1, + start = TRUE) + # Add the user parameter to the model + ptable1 <- lavaan::lav_partable_add(partable = ptable, + add = user_pt1) + ptable1$se[which(ptable1$label == userp_label)] <- NA + + # Extract slots to be used + slot_opt <- sem_out@Options + slot_dat <- sem_out@Data + + if (fix) { + # Create the row of equality constraint + user_pt2 <- data.frame(lhs = userp_label, + op = "==", + rhs = NA, + user = 1, + block = 0, + group = 0, + free = 0, + ustart = NA, + exo = 0) + user_pt2 <- lavaan::lav_partable_complete(partable = user_pt2, + start = TRUE) + # Add the equality constraint to the parameter tahle + ptable2 <- lavaan::lav_partable_add(partable = ptable1, + add = user_pt2) + # Store the position of the constraint + i_eq <- which((ptable2$lhs == userp_label) & + (ptable2$op == "==")) + + # Fix the ids of the rows + ptable2$id <- seq_along(ptable2$id) + + # Set the options + slot_opt$do.fit <- TRUE + # The "mplus" version does not take into account the user-parameter + slot_opt$start <- "simple" + # Heywood cases are allowed + slot_opt$check.start <- FALSE + slot_opt$check.post <- FALSE + # Disable some options for efficiency + slot_opt$se <- "none" + # slot_opt$h1 <- FALSE + # slot_opt$baseline <- FALSE + + out <- function(target, + verbose = FALSE, + control = list(), + seed = NULL) { + if (!is.null(seed)) set.seed(seed) + # Just in case ... + force(control_args) + force(slot_opt) + force(slot_dat) + force(ptable2) + force(userp_label) + force(i_eq) + + ptable3 <- ptable2 + ptable3$rhs[i_eq] <- target + control_args <- utils::modifyList(control, + list(iter.max = iter.max)) + slot_opt$control <- control_args + + # Fit once to update the model slot + attempted <- 0 + fit_new_converged <- FALSE + if (verbose) {cat("Target:", target, "\n")} + if (verbose) {cat("First attempt ...\n")} + # Fail when + # eq.constraints.K is 0x0 + # Succeed when + # fit_new@Model@eq.constraints, or + # length(fit_new@Model@ceq.nonlinear.idx) > 0 + slot_opt_tmp <- slot_opt + slot_opt_tmp$do.fit <- FALSE + eq_not_ok <- TRUE + while (eq_not_ok) { + fit_new <- lavaan::lavaan(model = ptable3, + slotOptions = slot_opt_tmp, + slotData = slot_dat) + eq_not_ok <- !fit_new@Model@eq.constraints && + !(length(fit_new@Model@ceq.nonlinear.idx) > 0) + } + + # Extract the updated slots + slot_pat_new <- fit_new@ParTable + slot_model_new <- fit_new@Model + slot_smp_new <- fit_new@SampleStats + + # Fit the model with the user parameter constrained + # to the target value + # TODO: + # - Add an error handler + fit_new <- lavaan::lavaan(slotParTable = slot_pat_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat) + + fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + + # Try max_attempts more times + if (!fit_new_converged) { + if (verbose) {cat("More attempts ...\n")} + while (!((attempted > max_attempts) || + fit_new_converged)) { + if (verbose) {cat("Attempt", attempted, "\n")} + ptable_new <- fit_new@ParTable + i_free <- ptable_new$free > 0 + ptable_new$est[i_free] <- jitter(ptable_new$est[i_free], + factor = 50) + slot_opt$start <- as.data.frame(ptable_new) + # TODO: + # - Add an error handler + fit_new <- lavaan::lavaan(slotParTable = ptable_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat) + fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + attempted <- attempted + 1 + } + } + if (!fit_new_converged) { + # TODO: + # - Need to decide what to do + cat("Failed to converge.") + } + if (verbose) {cat("Done!\n")} + fit_new + } + } else { + out <- function(...) { + # Generate a model with the user parameter added. + # For debugging + # Just in case ... + force(slot_opt) + force(slot_dat) + force(ptable1) + slot_opt$do.fit <- TRUE + fit_new <- lavaan::lavaan(model = ptable1, + slotOptions = slot_opt, + slotData = slot_dat) + fit_new + } + } + out + } + + + +#' @param func A function that receives a +#' `lavaan`-object and returns a scalar. +#' +#' @param sem_out A `lavaan`-class object. +#' +#' @return +#' `gen_userp()` returns a function that +#' accepts a numeric vector of length +#' equals to the number of free parameters +#' in `sem_out`, and returns a scalar +#' which is the output of `func`. +#' +#' @noRd + +gen_userp <- function(func, + sem_out) { + stopifnot(is.function(func)) + stopifnot(inherits(sem_out, "lavaan")) + out <- function(.x., ...) { + if (missing(.x.)) { + .x. <- get(".x.", parent.frame()) + } + # Just in case ... + force(sem_out) + + sem_out@Model <- lavaan::lav_model_set_parameters(sem_out@Model, .x.) + sem_out@implied <- lavaan::lav_model_implied(sem_out@Model) + f0 <- func(sem_out) + if (is.na(f0) || is.nan(f0)) { + f0 <- Inf + } + f0 + } + out + } \ No newline at end of file diff --git a/R/loglike_at_user.R b/R/loglike_at_user.R new file mode 100644 index 00000000..46837702 --- /dev/null +++ b/R/loglike_at_user.R @@ -0,0 +1,32 @@ +#' @noRd +# TODO: +# - To be exported for plotting loglikelihood + +loglik_user <- function(x, + sem_out_userp, + sem_out, + lrt_method = "default", + ...) { + sem_out_userp_tmp <- sem_out_userp_run(target = x, + object = sem_out_userp, + ...) + lrt_x <- tryCatch(lavaan::lavTestLRT(sem_out_userp_tmp, + sem_out, + method = lrt_method), + error = function(e) e, + warning = function(w) w) + if (inherits(lrt_x, "warning")) { + tmp <- as.character(lrt_msg) + if (grepl("scaling factor is negative", + tmp, fixed = TRUE)) { + lrt_x <- tryCatch(lavaan::lavTestLRT(sem_out_userp_tmp, + sem_out, + method = "satorra.2000"), + error = function(e) e, + warning = function(w) w) + } + } + out <- lrt_x[2, "Chisq diff"] / (-2) + attr(out, "sem_out_userp_x") <- sem_out_userp_tmp + out + } \ No newline at end of file diff --git a/_pkgdown.yml b/_pkgdown.yml index 87e676c4..5507f234 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -66,6 +66,7 @@ reference: desc: Low level functions for advanced users. - contents: - ci_bound_wn_i + - ci_bound_ur_i - ci_i_one - set_constraint - print.cibound diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd new file mode 100644 index 00000000..c96e4397 --- /dev/null +++ b/man/ci_bound_ur_i.Rd @@ -0,0 +1,198 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ci_bound_ur_i.R +\name{ci_bound_ur_i} +\alias{ci_bound_ur_i} +\title{Likelihood-based Confidence Bound For One parameter (uniroot)} +\usage{ +ci_bound_ur_i( + i = NULL, + npar = NULL, + sem_out = NULL, + f_constr = NULL, + which = NULL, + history = FALSE, + perturbation_factor = 0.9, + lb_var = -Inf, + standardized = FALSE, + wald_ci_start = !standardized, + opts = list(), + ciperc = 0.95, + ci_limit_ratio_tol = 1.5, + verbose = FALSE, + sf = 1, + sf2 = 0, + p_tol = 5e-04, + std_method = "internal", + bounds = "none", + xtol_rel_factor = 1, + ftol_rel_factor = 1, + lb_prop = 0.05, + lb_se_k = 3, + ... +) +} +\arguments{ +\item{i}{The position of the target parameter as appeared in the +parameter table of a lavaan object, generated by +\code{\link[lavaan:lavParTable]{lavaan::parameterTable()}}.} + +\item{npar}{Ignored by this function. Included for having +a unified interface.} + +\item{sem_out}{The fit object. Currently supports +\link[lavaan:lavaan-class]{lavaan::lavaan} objects only.} + +\item{f_constr}{Ignored by this function. Included for having +a unified interface.} + +\item{which}{Whether the lower bound or the upper bound is to be +found. Must be \code{"lbound"} or \code{"ubound"}.} + +\item{history}{Not used. Kept for backward compatibility.} + +\item{perturbation_factor}{Ignored by this function. Included for having +a unified interface.} + +\item{lb_var}{Ignored by this function. Included for having +a unified interface.} + +\item{standardized}{If \code{TRUE}, the LBCI is for the requested +estimate in the standardized solution. Default is \code{FALSE}.} + +\item{wald_ci_start}{Ignored by this function. Included for having +a unified interface.} + +\item{opts}{Options to be passed to \code{\link[stats:uniroot]{stats::uniroot()}}. +Default is \code{list()}.} + +\item{ciperc}{The intended coverage probability for the confidence +interval. Default is .95, and the bound for a 95\% confidence +interval will be sought.} + +\item{ci_limit_ratio_tol}{The tolerance for the ratio of \code{a} to +\code{b}, where \code{a} is the distance between an LBCI limit and the point +estimate, and the \code{b} is the distance between the original +confidence limit (by default the Wald CI in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}) +and the point estimate. If the ratio is larger than this value or +smaller than the reciprocal of this value, a warning is set in the +status code. Default is 1.5.} + +\item{verbose}{If \code{TRUE}, the function will store more diagnostic +information in the attribute \code{diag}. Default is \code{FALSE}.} + +\item{sf}{Ignored by this function. Included for having +a unified interface.} + +\item{sf2}{Ignored by this function. Included for having +a unified interface.} + +\item{p_tol}{Tolerance for checking the achieved level of +confidence. If the absolute difference between the achieved level +and \code{ciperc} is greater than this amount, a warning is set in the +status code and the bound is set to \code{NA}. Default is 5e-4.} + +\item{std_method}{The method used to find the standardized +solution. If equal to \verb{"lavaan"``, [lavaan::standardizedSolution()] will be used. If equal to }"internal"\verb{, an internal function will be used. The }"lavaan"\verb{method should work in all situations, but the}"internal"\verb{method is usually much faster. Default is}"internal"`.} + +\item{bounds}{Ignored by this function. Included for having +a unified interface.} + +\item{xtol_rel_factor}{Ignored by this function. Included for having +a unified interface.} + +\item{ftol_rel_factor}{Ignored by this function. Included for having +a unified interface.} + +\item{lb_prop}{Ignored by this function. Included for having +a unified interface.} + +\item{lb_se_k}{Ignored by this function. Included for having +a unified interface.} + +\item{...}{Optional arguments. Not used.} +} +\value{ +A \code{cibound}-class object which is a list with three elements: +\itemize{ +\item \code{bound}: A single number. The value of the bound located. \code{NA} is +the search failed for various reasons. +\item \code{diag}: A list of diagnostic information. +\item \code{call}: The original call. +} + +A detailed and organized output can be printed by the default print +method (\code{\link[=print.cibound]{print.cibound()}}). +} +\description{ +Find the lower or upper bound of the likelihood-based +confidence interval (LBCI) for one parameter in a structural +equation model fitted in \code{\link[lavaan:lavaan]{lavaan::lavaan()}} using \code{\link[=uniroot]{uniroot()}}. +} +\details{ +\subsection{Important Notice}{ + +This function is not supposed to be used directly by users in +typical scenarios. Its interface is user-\emph{unfriendly} because it +should be used through \code{\link[=semlbci]{semlbci()}}. It is exported such that +interested users can examine how a confidence bound is found, or +use it for experiments or simulations. +} + +\subsection{Usage}{ + +This function is the lowest level function used by \code{\link[=semlbci]{semlbci()}}. +\code{\link[=semlbci]{semlbci()}} calls this function once for each bound of each +parameter. + +For consistency in the interface, most of the arguments +in \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} are also included in this function, +even those not used internally. +} + +\subsection{Algorithm}{ + +This function, unlike \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}, use a simple +root finding algorithm. Basically, it try fixing the +target parameters to different values until the +likelihood ratio test \emph{p}-value is equal to the desired +value. + +This algorithm is known to be very inefficient, compared +to the one proposed by Wu and Neale (2012). It is included +as a backup algorithm for parameters which are difficult +for the method by Wu and Neale. +} + +\subsection{Limitation(s)}{ + +Like \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}, this function does not an estimate +close to an attainable bound. +} +} +\examples{ + +data(simple_med) +dat <- simple_med + +mod <- +" +m ~ x +y ~ m +" + +fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) + +out1l <- ci_bound_ur_i(i = 1, + sem_out = fit_med, + which = "lbound") +out1l + +} +\references{ +Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for a +bounded parameter. \emph{Behavior Genetics, 42}(6), 886-898. +\doi{10.1007/s10519-012-9560-z} +} +\seealso{ +\code{\link[=print.cibound]{print.cibound()}}, \code{\link[=semlbci]{semlbci()}}, \code{\link[=ci_i_one]{ci_i_one()}} +} diff --git a/man/semlbci-package.Rd b/man/semlbci-package.Rd index 561a3c3b..0cfc2600 100644 --- a/man/semlbci-package.Rd +++ b/man/semlbci-package.Rd @@ -3,7 +3,6 @@ \docType{package} \name{semlbci-package} \alias{semlbci-package} -\alias{_PACKAGE} \title{semlbci: Likelihood-Based Confidence Interval in Structural Equation Models} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} diff --git a/tests/testthat/test-ur_add_func.R b/tests/testthat/test-ur_add_func.R new file mode 100644 index 00000000..eb61b43b --- /dev/null +++ b/tests/testthat/test-ur_add_func.R @@ -0,0 +1,198 @@ +library(testthat) +library(lavaan) + +# cfa() example +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + textual ~ a*visual + speed ~ b*textual + ab := a*b' +fit <- cfa(HS.model, data = HolzingerSwineford1939) + +# Get one parameter + +test_that("add_func", { + ind <- function(object) { + # Need to use lav_model_get_parameters() + # because coef() may not work. + est <- lavaan::lav_model_get_parameters(object@Model, type = "user") + unname(est[10] * est[11]) + } + fit_i_free <- add_func(func = ind, + sem_out = fit, + fix = FALSE) + fit_i <- add_func(func = ind, + sem_out = fit) + # Need to see whether fit_i() can run without ind + rm(ind) + + fit_i_tmp <- sem_out_userp_run(target = .400, + object = fit_i) + expect_equal(lavTestLRT(fit_i_tmp, fit)[2, "Df diff"], + 1) + expect_equal(unname(coef(fit_i_tmp, type = "user")["user"]), + .400, + tolerance = 1e-4) +}) + +skip("Long test") + +# Not ready + +ind <- function(object) { + # Need to use lav_model_get_parameters() + # because coef() may not work. + est <- lavaan::lav_model_get_parameters(object@Model, type = "user") + unname(est[10] * est[11]) + } + +fit_i_free <- add_func(func = ind, + sem_out = fit, + fix = FALSE) +fit_i <- add_func(func = ind, + sem_out = fit) + +tmp <- loglik_user(.250, + sem_out_userp = fit_i, + sem_out = fit) +fit_tmp <- sem_out_userp_run(target = .400, + object = fit_i_free) +est_i <- parameterEstimates(fit_tmp)[25, ] +x_range <- unlist(est_i[, c("ci.lower", "ci.upper")]) +d <- (x_range[2] - x_range[1]) / 10 +x_seq <- seq(x_range[1] - d, x_range[2] + d, length.out = 15) +x_seq +x_range + +# Plot loglikelihood + +library(pbapply) +library(parallel) +my_cl <- makeCluster(length(x_seq)) +clusterExport(cl = my_cl, c("sem_out_userp_run")) +ll_out <- pbsapply(x_seq, + FUN = loglik_user, + sem_out_userp = fit_i, + sem_out = fit, + global_ok = TRUE, + cl = my_cl) +stopCluster(my_cl) + +plot(x_seq, ll_out, type = "l", lwd = 4, col = "red") +abline(h = 3.84159 / -2, lwd = 4, col = "blue") + +# Plot p-value + +ll2p <- function(x) { + stats::pchisq(abs(-2 * x), df = 1, lower.tail = FALSE) + } + +p_out <- sapply(ll_out, ll2p) + +plot(x_seq, p_out, type = "l", lwd = 4, col = "red") +abline(h = 0, lwd = 4, col = "blue") + +# Zoom in + +x_seq <- seq(x_range[1] - d, x_range[1] + d, length.out = 15) + +library(pbapply) +library(parallel) +my_cl <- makeCluster(length(x_seq)) +clusterExport(cl = my_cl, c("sem_out_userp_run")) +ll_out <- pbsapply(x_seq, + FUN = loglik_user, + sem_out_userp = fit_i, + sem_out = fit, + global_ok = TRUE, + cl = my_cl) +stopCluster(my_cl) + +plot(x_seq, ll_out, type = "l", lwd = 4, col = "red") +abline(h = 3.84159 / -2, lwd = 4, col = "blue") + +p_out <- sapply(ll_out, ll2p) + +plot(x_seq, p_out, type = "l", lwd = 4, col = "red") +abline(h = 0.05, lwd = 4, col = "blue") + +fit_i_l <- sem_out_userp_run(target = x_seq[1], + object = fit_i) +lavTestLRT(fit_i_l, fit) +fit_i_u <- sem_out_userp_run(target = x_seq[length(x_seq)], + object = fit_i) +lavTestLRT(fit_i_u, fit) + +# Bound + +ind <- function(object) { + # Need to use lav_model_get_parameters() + # because coef() may not work. + est <- lavaan::lav_model_get_parameters(object@Model, type = "user") + unname(est[10] * est[11]) + } + +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = ind, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = ind, + which = "ubound", + progress = TRUE, + d = 5) +) + +ci_lb$lrt +ci_ub$lrt + + +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = ind, + which = "lbound", + root_target = "pvalue", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = ind, + which = "ubound", + root_target = "pvalue", + progress = TRUE) +) + +ci_lb$lrt +ci_ub$lrt + + +# Compare with WN + +library(semlbci) + +ciperc <- .95 + +fn_constr0 <- set_constraint(fit, ciperc = ciperc) + +opts0 <- list() +opts0 <- list(ftol_abs = 1e-7, + ftol_rel = 1e-7, + xtol_abs = 1e-7, + xtol_rel = 1e-7 + # tol_constraints_eq = 1e-10 + ) +time1l <- system.time(out1l <- ci_bound_wn_i(i = 24, npar = 20, sem_out = fit, which = "lbound", opts = opts0, f_constr = fn_constr0, verbose = TRUE, ciperc = ciperc)) +time1u <- system.time(out1u <- ci_bound_wn_i(i = 24, npar = 20, sem_out = fit, which = "ubound", opts = opts0, f_constr = fn_constr0, verbose = TRUE, ciperc = ciperc)) + +time1l +time1u + +round(out1l$bound, 3) +round(ci_lb$bound, 3) + +round(out1u$bound, 3) +round(ci_ub$bound, 3) diff --git a/tests/testthat/test-ur_ci_bound_ur_i.R b/tests/testthat/test-ur_ci_bound_ur_i.R new file mode 100644 index 00000000..27ea6e55 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i.R @@ -0,0 +1,204 @@ +skip("WIP") + +# Not Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit <- sem(HS.model, data = HolzingerSwineford1939) +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "intercepts") + +# Unstandardized + +ci_lb <- ci_bound_ur_i(i = 9, + sem_out = fit, + which = "lbound", + opts = list(progress = TRUE)) +ci_lb + +est_i <- gen_est_i(i = 9, sem_out = fit) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +parameterEstimates(fit)[9, ] + +est_i <- gen_est_i(i = 25, sem_out = fit) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=") + +ci_lb$lrt +ci_ub$lrt +round(c(ci_lb$bound, ci_ub$bound), 3) +round(confint(ci_lbci), 3) +parameterEstimates(fit)[25, ] + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = TRUE) +) +ci_lbci <- semlbci(sem_out = fit, pars = "visual ~~ textual", progress = FALSE) + +ci_lb$lrt +ci_ub$lrt +round(c(ci_lb$bound, ci_ub$bound), 3) +round(confint(ci_lbci), 3) +parameterEstimates(fit_gp)[46, ] + +# # Too long to run +# est_i <- gen_est_i(i = 73, sem_out = fit_gp) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "lbound", +# progress = TRUE) +# ) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "ubound", +# progress = TRUE) +# ) +# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=") + +# ci_lb$lrt +# ci_ub$lrt +# c(ci_lb$bound, ci_ub$bound) +# confint(ci_lbci) +# parameterEstimates(fit_gp)[73, ] + +# Standardized + +skip("WIP") + +est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "speed =~ x9", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit)[9, ] + +est_i <- gen_est_i(i = 25, sem_out = fit, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit)[25, ] + +est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit_gp, pars = "visual ~~ 2*textual", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit_gp)[46, ] + + +# Too difficult to search by both methods + +# est_i <- gen_est_i(i = 73, sem_out = fit_gp, standardized = TRUE) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "lbound", +# progress = TRUE) +# ) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "ubound", +# progress = TRUE) +# ) + +# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=", standardized = TRUE) + +# ci_lb$lrt +# ci_ub$lrt +# c(ci_lb$bound, ci_ub$bound) +# confint(ci_lbci) +# standardizedSolution(fit_gp)[46, ] diff --git a/tests/testthat/test-ur_gen_est_i.R b/tests/testthat/test-ur_gen_est_i.R new file mode 100644 index 00000000..e2f92a85 --- /dev/null +++ b/tests/testthat/test-ur_gen_est_i.R @@ -0,0 +1,329 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +# cfa() example +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + textual ~ a*visual + speed ~ b*textual + ab := a*b' +fit <- sem(HS.model, data = HolzingerSwineford1939) +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "intercepts") + +# Unstandardized + +test_that("Unstandardized", { + est_i <- gen_est_i(i = 9, sem_out = fit) + expect_equal(est_i(fit), + unname(coef(fit, type = "user")["speed=~x9"])) + est_i <- gen_est_i(i = 24, sem_out = fit) + expect_equal(est_i(fit), + unname(coef(fit, type = "user")["ab"])) + est_i <- gen_est_i(i = 46, sem_out = fit_gp) + expect_equal(est_i(fit_gp), + unname(coef(fit_gp, type = "user")["b"])) + est_i <- gen_est_i(i = 71, sem_out = fit_gp) + expect_equal(est_i(fit_gp), + unname(coef(fit_gp, type = "user")["ab"])) +}) + +# Standardized + +test_that("Standardized", { + std_all <- standardizedSolution(fit) + std_all_gp <- standardizedSolution(fit_gp) + + est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) + expect_equal(est_i(fit), + unname(std_all[9, "est.std"])) + est_i <- gen_est_i(i = 24, sem_out = fit, standardized = TRUE) + expect_equal(est_i(fit), + unname(std_all[24, "est.std"])) + est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) + expect_equal(est_i(fit_gp), + unname(std_all_gp[46, "est.std"])) + est_i <- gen_est_i(i = 71, sem_out = fit_gp, standardized = TRUE) + expect_equal(est_i(fit_gp), + unname(std_all_gp[71, "est.std"])) +}) + +# gne_userp + +test_that("Unstandardized", { + +est_i <- gen_est_i(i = 9, sem_out = fit) +userp <- gen_userp(func = est_i, sem_out = fit) +expect_equal(userp(coef(fit)), + coef(fit, type = "user")[9], + ignore_attr = TRUE) +tmp <- coef(fit) +tmp[6] <- .30 +expect_equal(userp(tmp), + .30) + +est_i <- gen_est_i(i = 24, sem_out = fit) +userp <- gen_userp(func = est_i, sem_out = fit) +expect_equal(userp(coef(fit)), + coef(fit, type = "user")[24], + ignore_attr = TRUE) +tmp <- coef(fit) +tmp[7] <- .30 +tmp[8] <- .40 +expect_equal(userp(tmp), + .30 * .40) + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +userp <- gen_userp(func = est_i, sem_out = fit_gp) +expect_equal(userp(coef(fit_gp)), + coef(fit_gp, type = "user")[46], + ignore_attr = TRUE) +tmp <- coef(fit_gp) +tmp[37] <- .30 +expect_equal(userp(tmp), + .30) + +est_i <- gen_est_i(i = 71, sem_out = fit_gp) +userp <- gen_userp(func = est_i, sem_out = fit_gp) +expect_equal(userp(coef(fit_gp)), + coef(fit_gp, type = "user")[71], + ignore_attr = TRUE) +tmp <- coef(fit_gp) +tmp[7] <- .30 +tmp[8] <- .40 +tmp[37] <- .30 +tmp[38] <- .40 +expect_equal(userp(tmp), + .30 * .40) +}) + + +test_that("Standardized", { + + std_all <- standardizedSolution(fit) + std_all_gp <- standardizedSolution(fit_gp) + + est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) + userp <- gen_userp(func = est_i, sem_out = fit) + expect_equal(userp(coef(fit)), + std_all[9, "est.std"], + ignore_attr = TRUE) + + est_i <- gen_est_i(i = 24, sem_out = fit, standardized = TRUE) + userp <- gen_userp(func = est_i, sem_out = fit) + expect_equal(userp(coef(fit)), + std_all[24, "est.std"], + ignore_attr = TRUE) + + est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) + userp <- gen_userp(func = est_i, sem_out = fit_gp) + expect_equal(userp(coef(fit_gp)), + std_all_gp[46, "est.std"], + ignore_attr = TRUE) + + est_i <- gen_est_i(i = 71, sem_out = fit_gp, standardized = TRUE) + userp <- gen_userp(func = est_i, sem_out = fit_gp) + expect_equal(userp(coef(fit_gp)), + std_all_gp[71, "est.std"], + ignore_attr = TRUE) +}) + +# Not ready + +skip("Long test") +skip("WIP") + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit <- sem(HS.model, data = HolzingerSwineford1939) +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "intercepts") + +# Unstandardized + +est_i <- gen_est_i(i = 9, sem_out = fit) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +parameterEstimates(fit)[9, ] + +est_i <- gen_est_i(i = 25, sem_out = fit) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=") + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +parameterEstimates(fit)[25, ] + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = TRUE) +) +ci_lbci <- semlbci(sem_out = fit, pars = "visual ~~ textual") + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +parameterEstimates(fit_gp)[46, ] + +est_i <- gen_est_i(i = 73, sem_out = fit_gp) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = TRUE) +) +ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=") + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +parameterEstimates(fit_gp)[73, ] + +# Standardized + +est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "speed =~ x9", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit)[9, ] + +est_i <- gen_est_i(i = 25, sem_out = fit, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit)[25, ] + +est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = TRUE) +) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = TRUE) +) + +ci_lbci <- semlbci(sem_out = fit_gp, pars = "visual ~~ 2*textual", standardized = TRUE) + +ci_lb$lrt +ci_ub$lrt +c(ci_lb$bound, ci_ub$bound) +confint(ci_lbci) +standardizedSolution(fit_gp)[46, ] + + +# Too difficult to search by both methods + +# est_i <- gen_est_i(i = 73, sem_out = fit_gp, standardized = TRUE) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "lbound", +# progress = TRUE) +# ) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "ubound", +# progress = TRUE) +# ) + +# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=", standardized = TRUE) + +# ci_lb$lrt +# ci_ub$lrt +# c(ci_lb$bound, ci_ub$bound) +# confint(ci_lbci) +# standardizedSolution(fit_gp)[46, ] diff --git a/tests/testthat/test-ur_gen_userp.R b/tests/testthat/test-ur_gen_userp.R new file mode 100644 index 00000000..77e9adc3 --- /dev/null +++ b/tests/testthat/test-ur_gen_userp.R @@ -0,0 +1,50 @@ +# Ready + +library(testthat) +library(lavaan) + +# cfa() example +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + textual ~ a*visual + speed ~ b*textual + ab := a*b' +fit <- cfa(HS.model, data = HolzingerSwineford1939) + +# Get one parameter + +ind <- function(object) { + # Need to use lav_model_get_parameters() + # because coef() may not work. + est <- lavaan::lav_model_get_parameters(object@Model, type = "user") + unname(est[10] * est[11]) + } + +test_that("Indirect effect", { + userp <- gen_userp(func = ind, sem_out = fit) + expect_equal(userp(coef(fit)), + coef(fit, type = "user")[24], + ignore_attr = TRUE) + tmp <- coef(fit) + tmp[7] <- .30 + tmp[8] <- .40 + expect_equal(userp(tmp), + .30 * .40) +}) + +# gen_sem_out_userp + +skip("To be run in an interactive sessi") + +test_that("gen_sem_out_userp", { + userp1234 <- gen_userp(func = ind, sem_out = fit) + fit_userp <- gen_sem_out_userp(userp = userp1234, + userp_name = "userp1234", + sem_out = fit) + fit_test <- fit_userp(.12) + expect_equal(coef(fit_test, type = "user")["user"], + .12, + ignore_attr = TRUE, + tolerance = 1e-4) +}) From 7438f029814983e9b04f821139db268408295bd4 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 22:50:43 +0800 Subject: [PATCH 04/68] Update ci_bound_ur_i.R --- R/ci_bound_ur_i.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index c08c9fd2..e25c9c6f 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -550,7 +550,6 @@ ci_bound_ur <- function(sem_out, r1$run(function(x) {sem_out_userp_run <<- x}, args = list(x = sem_out_userp_run)) if (progress) { - browser() optimize_out <- r1$call(function(f, interval, alpha, From bac95bac7474ba01d7fca7831a1171120622193c Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 22:51:31 +0800 Subject: [PATCH 05/68] Tests are ready to use --- tests/testthat/test-ur_add_func.R | 163 +----------------------- tests/testthat/test-ur_gen_est_i.R | 194 ----------------------------- tests/testthat/test-ur_gen_userp.R | 2 +- 3 files changed, 3 insertions(+), 356 deletions(-) diff --git a/tests/testthat/test-ur_add_func.R b/tests/testthat/test-ur_add_func.R index eb61b43b..ae816307 100644 --- a/tests/testthat/test-ur_add_func.R +++ b/tests/testthat/test-ur_add_func.R @@ -1,3 +1,5 @@ +# Ready + library(testthat) library(lavaan) @@ -35,164 +37,3 @@ test_that("add_func", { .400, tolerance = 1e-4) }) - -skip("Long test") - -# Not ready - -ind <- function(object) { - # Need to use lav_model_get_parameters() - # because coef() may not work. - est <- lavaan::lav_model_get_parameters(object@Model, type = "user") - unname(est[10] * est[11]) - } - -fit_i_free <- add_func(func = ind, - sem_out = fit, - fix = FALSE) -fit_i <- add_func(func = ind, - sem_out = fit) - -tmp <- loglik_user(.250, - sem_out_userp = fit_i, - sem_out = fit) -fit_tmp <- sem_out_userp_run(target = .400, - object = fit_i_free) -est_i <- parameterEstimates(fit_tmp)[25, ] -x_range <- unlist(est_i[, c("ci.lower", "ci.upper")]) -d <- (x_range[2] - x_range[1]) / 10 -x_seq <- seq(x_range[1] - d, x_range[2] + d, length.out = 15) -x_seq -x_range - -# Plot loglikelihood - -library(pbapply) -library(parallel) -my_cl <- makeCluster(length(x_seq)) -clusterExport(cl = my_cl, c("sem_out_userp_run")) -ll_out <- pbsapply(x_seq, - FUN = loglik_user, - sem_out_userp = fit_i, - sem_out = fit, - global_ok = TRUE, - cl = my_cl) -stopCluster(my_cl) - -plot(x_seq, ll_out, type = "l", lwd = 4, col = "red") -abline(h = 3.84159 / -2, lwd = 4, col = "blue") - -# Plot p-value - -ll2p <- function(x) { - stats::pchisq(abs(-2 * x), df = 1, lower.tail = FALSE) - } - -p_out <- sapply(ll_out, ll2p) - -plot(x_seq, p_out, type = "l", lwd = 4, col = "red") -abline(h = 0, lwd = 4, col = "blue") - -# Zoom in - -x_seq <- seq(x_range[1] - d, x_range[1] + d, length.out = 15) - -library(pbapply) -library(parallel) -my_cl <- makeCluster(length(x_seq)) -clusterExport(cl = my_cl, c("sem_out_userp_run")) -ll_out <- pbsapply(x_seq, - FUN = loglik_user, - sem_out_userp = fit_i, - sem_out = fit, - global_ok = TRUE, - cl = my_cl) -stopCluster(my_cl) - -plot(x_seq, ll_out, type = "l", lwd = 4, col = "red") -abline(h = 3.84159 / -2, lwd = 4, col = "blue") - -p_out <- sapply(ll_out, ll2p) - -plot(x_seq, p_out, type = "l", lwd = 4, col = "red") -abline(h = 0.05, lwd = 4, col = "blue") - -fit_i_l <- sem_out_userp_run(target = x_seq[1], - object = fit_i) -lavTestLRT(fit_i_l, fit) -fit_i_u <- sem_out_userp_run(target = x_seq[length(x_seq)], - object = fit_i) -lavTestLRT(fit_i_u, fit) - -# Bound - -ind <- function(object) { - # Need to use lav_model_get_parameters() - # because coef() may not work. - est <- lavaan::lav_model_get_parameters(object@Model, type = "user") - unname(est[10] * est[11]) - } - -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = ind, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = ind, - which = "ubound", - progress = TRUE, - d = 5) -) - -ci_lb$lrt -ci_ub$lrt - - -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = ind, - which = "lbound", - root_target = "pvalue", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = ind, - which = "ubound", - root_target = "pvalue", - progress = TRUE) -) - -ci_lb$lrt -ci_ub$lrt - - -# Compare with WN - -library(semlbci) - -ciperc <- .95 - -fn_constr0 <- set_constraint(fit, ciperc = ciperc) - -opts0 <- list() -opts0 <- list(ftol_abs = 1e-7, - ftol_rel = 1e-7, - xtol_abs = 1e-7, - xtol_rel = 1e-7 - # tol_constraints_eq = 1e-10 - ) -time1l <- system.time(out1l <- ci_bound_wn_i(i = 24, npar = 20, sem_out = fit, which = "lbound", opts = opts0, f_constr = fn_constr0, verbose = TRUE, ciperc = ciperc)) -time1u <- system.time(out1u <- ci_bound_wn_i(i = 24, npar = 20, sem_out = fit, which = "ubound", opts = opts0, f_constr = fn_constr0, verbose = TRUE, ciperc = ciperc)) - -time1l -time1u - -round(out1l$bound, 3) -round(ci_lb$bound, 3) - -round(out1u$bound, 3) -round(ci_ub$bound, 3) diff --git a/tests/testthat/test-ur_gen_est_i.R b/tests/testthat/test-ur_gen_est_i.R index e2f92a85..c6ad3426 100644 --- a/tests/testthat/test-ur_gen_est_i.R +++ b/tests/testthat/test-ur_gen_est_i.R @@ -133,197 +133,3 @@ test_that("Standardized", { std_all_gp[71, "est.std"], ignore_attr = TRUE) }) - -# Not ready - -skip("Long test") -skip("WIP") - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 - visual ~~ a*textual - visual ~~ b*speed - textual ~~ d*speed - ab := a*b' -fit <- sem(HS.model, data = HolzingerSwineford1939) -fit_gp <- sem(HS.model, data = HolzingerSwineford1939, - group = "school", - group.equal = "intercepts") - -# Unstandardized - -est_i <- gen_est_i(i = 9, sem_out = fit) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) -) -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -parameterEstimates(fit)[9, ] - -est_i <- gen_est_i(i = 25, sem_out = fit) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit, pars = "ab :=") - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -parameterEstimates(fit)[25, ] - -est_i <- gen_est_i(i = 46, sem_out = fit_gp) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "ubound", - progress = TRUE) -) -ci_lbci <- semlbci(sem_out = fit, pars = "visual ~~ textual") - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -parameterEstimates(fit_gp)[46, ] - -est_i <- gen_est_i(i = 73, sem_out = fit_gp) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "ubound", - progress = TRUE) -) -ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=") - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -parameterEstimates(fit_gp)[73, ] - -# Standardized - -est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit, pars = "speed =~ x9", standardized = TRUE) - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit)[9, ] - -est_i <- gen_est_i(i = 25, sem_out = fit, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", standardized = TRUE) - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit)[25, ] - -est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit_gp, pars = "visual ~~ 2*textual", standardized = TRUE) - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit_gp)[46, ] - - -# Too difficult to search by both methods - -# est_i <- gen_est_i(i = 73, sem_out = fit_gp, standardized = TRUE) -# system.time( -# ci_lb <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "lbound", -# progress = TRUE) -# ) -# system.time( -# ci_ub <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "ubound", -# progress = TRUE) -# ) - -# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=", standardized = TRUE) - -# ci_lb$lrt -# ci_ub$lrt -# c(ci_lb$bound, ci_ub$bound) -# confint(ci_lbci) -# standardizedSolution(fit_gp)[46, ] diff --git a/tests/testthat/test-ur_gen_userp.R b/tests/testthat/test-ur_gen_userp.R index 77e9adc3..39b55089 100644 --- a/tests/testthat/test-ur_gen_userp.R +++ b/tests/testthat/test-ur_gen_userp.R @@ -35,7 +35,7 @@ test_that("Indirect effect", { # gen_sem_out_userp -skip("To be run in an interactive sessi") +skip("To be run in an interactive session") test_that("gen_sem_out_userp", { userp1234 <- gen_userp(func = ind, sem_out = fit) From 545f237bc58e131fa5e5b17fabbed2f359f5d42f Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 25 May 2024 22:54:29 +0800 Subject: [PATCH 06/68] Update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 49652aba..5a883667 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,4 +48,4 @@ Imports: VignetteBuilder: knitr Config/testthat/parallel: true Config/testthat/edition: 3 -Config/testthat/start-first: semlbci_wn_mg_* +Config/testthat/start-first: semlbci_wn_mg_*, ur_ci_bound_ur* From f8c1aeb6824cc131ea968ea464fe9d42c75fbf83 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 00:02:40 +0800 Subject: [PATCH 07/68] Fix an issue with export --- NAMESPACE | 1 + R/ci_bound_ur_i.R | 88 ++++++++--------- R/ci_bound_ur_i_helpers.R | 80 ++++++--------- ..._ci_bound_ur_i.R => test-ur_ci_bound_ur.R} | 98 +++++++++++-------- 4 files changed, 129 insertions(+), 138 deletions(-) rename tests/testthat/{test-ur_ci_bound_ur_i.R => test-ur_ci_bound_ur.R} (66%) diff --git a/NAMESPACE b/NAMESPACE index 6ad91374..9fc7bddc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ export(ci_bound_ur_i) export(ci_bound_wn_i) export(ci_i_one) export(ci_order) +export(gen_sem_out_userp) export(get_cibound) export(loglike_compare) export(loglike_point) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index e25c9c6f..ef2c6ae4 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -519,6 +519,9 @@ ci_bound_ur <- function(sem_out, d = d) bound_start <- attr(interval, "bound_start") user_est <- attr(interval, "user_est") + if (progress) { + cat("\rInitial interval computed. ") + } } else { bound_start <- NA user_est <- NA @@ -551,26 +554,23 @@ ci_bound_ur <- function(sem_out, args = list(x = sem_out_userp_run)) if (progress) { optimize_out <- r1$call(function(f, - interval, - alpha, - root_target, - global_ok, - extendInt, - tol, - trace, - maxiter) { - tryCatch(stats::uniroot(f = f, - interval = interval, - alpha = alpha, - root_target = root_target, - global_ok = global_ok, - extendInt = extendInt, - tol = tol, - trace = trace, - maxiter = maxiter, - check.conv = TRUE), - error = function(e) e, - warning = function(w) w) + interval, + alpha, + root_target, + global_ok, + extendInt, + tol, + trace, + maxiter) { + stats::uniroot(f = f, + interval = interval, + alpha = alpha, + root_target = root_target, + global_ok = global_ok, + extendInt = extendInt, + tol = tol, + trace = trace, + maxiter = maxiter) }, args = list(f = lrtp_i, interval = interval, @@ -600,18 +600,15 @@ ci_bound_ur <- function(sem_out, tol, trace, maxiter) { - tryCatch(stats::uniroot(f = f, - interval = interval, - alpha = alpha, - root_target = root_target, - global_ok = global_ok, - extendInt = extendInt, - tol = tol, - trace = trace, - maxiter = maxiter, - check.conv = TRUE), - error = function(e) e, - warning = function(w) w) + stats::uniroot(f = f, + interval = interval, + alpha = alpha, + root_target = root_target, + global_ok = global_ok, + extendInt = extendInt, + tol = tol, + trace = trace, + maxiter = maxiter) }, args = list(f = lrtp_i, interval = interval, @@ -625,18 +622,21 @@ ci_bound_ur <- function(sem_out, } } else { # Run locally. Need global_ok == FALSE. - optimize_out <- tryCatch(stats::uniroot(lrtp_i, - interval = interval, - alpha = lrt_alpha, - root_target = root_target, - global_ok = FALSE, - extendInt = uniroot_extendInt, - tol = tol, - trace = uniroot_trace, - maxiter = uniroot_maxiter, - check.conv = TRUE), - error = function(e) e, - warning = function(w) w) + if (progress) { + cat("\nSearch started ...\n") + } + optimize_out <- stats::uniroot(lrtp_i, + interval = interval, + alpha = lrt_alpha, + root_target = root_target, + global_ok = FALSE, + extendInt = uniroot_extendInt, + tol = tol, + trace = uniroot_trace, + maxiter = uniroot_maxiter) + if (progress) { + cat("\nSearch finished. Finalize the results ... \n") + } } } out_root <- optimize_out$root diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 4471479d..1f1956d5 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -44,7 +44,7 @@ #' is .95, or 95%. #' #' @noRd - +# CHECKED: The only change is the level argument uniroot_interval <- function(sem_out, func, which, @@ -76,63 +76,42 @@ uniroot_interval <- function(sem_out, #' @noRd # Generate a function to extract a parameter # To be used by [ci_bound_ur_i()]. - +# CHECKED: Reverted to the experimental version gen_est_i <- function(i, sem_out, - standardized = FALSE, - std_method = c("lavaan", "internal")) { - std_method <- match.arg(std_method) + standardized = FALSE) { ptable <- lavaan::parameterTable(sem_out) + # i_user <- (ptable$free > 0) | (ptable$user > 0) + # i_est <- which(which(i_user) == i) # From the help page of lavaan-class object, # type = "user" should return *all* parameters # in the parameter table, including equality constraints. # Therefore, the row number should be equal to the order # in the vector of coefficients. + i_user <- i i_est <- i is_def <- (ptable$op[i] == ":=") i_lhs <- (ptable$lhs[i]) i_rhs <- (ptable$rhs[i]) i_op <- ptable$op[i] i_gp <- ptable$group[i] - i_free <- (ptable$free > 0) - def_label <- ifelse(is_def, - ptable$label[i], - NA) if (standardized) { if (is_def) { - if (std_method == "internal") { - # Does not yet work - out <- function(object) { - # Just in case - force(i_est) - force(def_label) - force(ptable) - force(i_free) - force(sem_out) - object@implied <- lavaan::lav_model_implied(object@Model) - est <- lavaan::lav_model_get_parameters(object@Model) - std <- std_lav(param = est, sem_out = sem_out)[i_free] - est_def <- object@Model@def.function(std)[def_label] - unname(est_def) - } - } - if (std_method == "lavaan") { - out <- function(object) { - # Just in case - force(i_est) - std <- lavaan::standardizedSolution(object, - est = lavaan::lav_model_get_parameters(object@Model, type = "user"), - GLIST = object@Model@GLIST, - se = FALSE, - zstat = FALSE, - pvalue = FALSE, - ci = FALSE, - remove.eq = FALSE, - remove.ineq = FALSE, - remove.def = FALSE, - type = "std.all") - unname(std[i_est, "est.std"]) - } + out <- function(object) { + # Just in case + force(i_est) + std <- lavaan::standardizedSolution(object, + est = lavaan::lav_model_get_parameters(object@Model, type = "user"), + GLIST = object@Model@GLIST, + se = FALSE, + zstat = FALSE, + pvalue = FALSE, + ci = FALSE, + remove.eq = FALSE, + remove.ineq = FALSE, + remove.def = FALSE, + type = "std.all") + unname(std[i_est, "est.std"]) } } else { out <- function(object) { @@ -217,7 +196,7 @@ gen_est_i <- function(i, #' fixed to the target value. #' #' @noRd - +# CHECKED: Identical to the experimental version sem_out_userp_run <- function(target, object, verbose = FALSE, @@ -244,8 +223,6 @@ sem_out_userp_run <- function(target, envir = globalenv())}, args = list(userp = userp, userp_name = userp_name)) - # TODO: - # - No need to export when gen_fit_userp is in the package r1$run(function(x) {sem_out_userp <<- x}, args = list(object$sem_out_userp)) out <- r1$run(function(...) { @@ -316,7 +293,7 @@ sem_out_userp_run <- function(target, #' user defined parameter in the model. #' #' @noRd - +# CHECKED: Identical to the experimental version add_func <- function(func, sem_out, userp_name = "semlbciuserp1234", @@ -334,11 +311,11 @@ add_func <- function(func, userp_name = userp_name)) # TODO: # - Mo need to export when gen_fit_userp is in the package - r1$run(function(x) {gen_sem_out_userp <<- x}, - args = list(gen_sem_out_userp)) + # r1$run(function(x) {gen_sem_out_userp <<- x}, + # args = list(gen_sem_out_userp)) # Generate sem_out_userp in the child process fit_i <- r1$run(function(...) { - gen_sem_out_userp(...) + semlbci::gen_sem_out_userp(...) }, args = list(userp = userp, sem_out = sem_out, userp_name = userp_name, @@ -354,8 +331,9 @@ add_func <- function(func, # Generate a function that: # - refits the model with the user-parameter fixed to a target value. - +# CHECKED: Identical to the experimental version # For add_fun using callr +#' @export gen_sem_out_userp <- function(userp, sem_out, userp_name = "semlbciuserp1234", @@ -549,7 +527,7 @@ gen_sem_out_userp <- function(userp, #' which is the output of `func`. #' #' @noRd - +# CHECKED: Identical to the experimental version gen_userp <- function(func, sem_out) { stopifnot(is.function(func)) diff --git a/tests/testthat/test-ur_ci_bound_ur_i.R b/tests/testthat/test-ur_ci_bound_ur.R similarity index 66% rename from tests/testthat/test-ur_ci_bound_ur_i.R rename to tests/testthat/test-ur_ci_bound_ur.R index 27ea6e55..4a9e063c 100644 --- a/tests/testthat/test-ur_ci_bound_ur_i.R +++ b/tests/testthat/test-ur_ci_bound_ur.R @@ -1,6 +1,8 @@ -skip("WIP") +skip_on_cran() + +# Ready -# Not Ready +# After skip("Long test"): WIP library(testthat) library(lavaan) @@ -19,72 +21,74 @@ fit_gp <- sem(HS.model, data = HolzingerSwineford1939, # Unstandardized -ci_lb <- ci_bound_ur_i(i = 9, - sem_out = fit, - which = "lbound", - opts = list(progress = TRUE)) -ci_lb +# One group est_i <- gen_est_i(i = 9, sem_out = fit) system.time( ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) + func = est_i, + which = "lbound", + user_callr = FALSE) ) system.time( ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) + func = est_i, + which = "ubound", + user_callr = TRUE) ) -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -parameterEstimates(fit)[9, ] +expect_equal(ci_lb$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-3) +expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-3) est_i <- gen_est_i(i = 25, sem_out = fit) system.time( ci_lb <- ci_bound_ur(sem_out = fit, func = est_i, which = "lbound", - progress = TRUE) + use_callr = TRUE) ) system.time( ci_ub <- ci_bound_ur(sem_out = fit, func = est_i, which = "ubound", - progress = TRUE) + user_callr = FALSE) ) +expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-2) +expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-3) -ci_lbci <- semlbci(sem_out = fit, pars = "ab :=") +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", use_pbapply = FALSE) -ci_lb$lrt -ci_ub$lrt -round(c(ci_lb$bound, ci_ub$bound), 3) -round(confint(ci_lbci), 3) -parameterEstimates(fit)[25, ] +expect_equal(unname(round(c(ci_lb$bound, ci_ub$bound), 3)), + unname(round(unlist(confint(ci_lbci)), 3))) + +# Two groups est_i <- gen_est_i(i = 46, sem_out = fit_gp) system.time( ci_lb <- ci_bound_ur(sem_out = fit_gp, func = est_i, which = "lbound", - progress = TRUE) + use_callr = FALSE) ) system.time( ci_ub <- ci_bound_ur(sem_out = fit_gp, func = est_i, which = "ubound", - progress = TRUE) + use_callr = TRUE) ) -ci_lbci <- semlbci(sem_out = fit, pars = "visual ~~ textual", progress = FALSE) - -ci_lb$lrt -ci_ub$lrt -round(c(ci_lb$bound, ci_ub$bound), 3) -round(confint(ci_lbci), 3) -parameterEstimates(fit_gp)[46, ] +expect_equal(ci_lb$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-2) +expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-3) # # Too long to run # est_i <- gen_est_i(i = 73, sem_out = fit_gp) @@ -117,22 +121,30 @@ system.time( ci_lb <- ci_bound_ur(sem_out = fit, func = est_i, which = "lbound", - progress = TRUE) + progress = TRUE, + use_callr = FALSE) ) system.time( ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) + func = est_i, + which = "ubound", + progress = TRUE, + use_callr = TRUE) ) ci_lbci <- semlbci(sem_out = fit, pars = "speed =~ x9", standardized = TRUE) -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit)[9, ] +expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-2) +expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], + .05, + tolerance = 1e-2) + +expect_equal(unname(round(c(ci_lb$bound, ci_ub$bound), 3)), + unname(round(unlist(confint(ci_lbci)), 3))) + +# TO WORK est_i <- gen_est_i(i = 25, sem_out = fit, standardized = TRUE) system.time( From e1da4312acff92c0d8053cf5f2d399c629168635 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 01:38:09 +0800 Subject: [PATCH 08/68] Document gen_sem_out_userp() Tests passed. --- R/ci_bound_ur_i_helpers.R | 111 +++++++++++++++++++++++++++++++++----- man/gen_sem_out_userp.Rd | 107 ++++++++++++++++++++++++++++++++++++ 2 files changed, 205 insertions(+), 13 deletions(-) create mode 100644 man/gen_sem_out_userp.Rd diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 1f1956d5..dd92e92b 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -273,7 +273,8 @@ sem_out_userp_run <- function(target, #' #' @param fix To be passed to #' [gen_sem_out_userp()]. If `TRUE`, the -#' default, the function generated fix +#' default, the function generated is +#' used to fix #' the value of `func` to a target value #' using an equality constraint. If #' `FALSE`, then the function simply @@ -290,7 +291,7 @@ sem_out_userp_run <- function(target, #' #' - `userp_name`: The value of #' `userp_name`, the label of the -#' user defined parameter in the model. +#' user-defined parameter in the model. #' #' @noRd # CHECKED: Identical to the experimental version @@ -309,10 +310,6 @@ add_func <- function(func, envir = globalenv())}, args = list(userp = userp, userp_name = userp_name)) - # TODO: - # - Mo need to export when gen_fit_userp is in the package - # r1$run(function(x) {gen_sem_out_userp <<- x}, - # args = list(gen_sem_out_userp)) # Generate sem_out_userp in the child process fit_i <- r1$run(function(...) { semlbci::gen_sem_out_userp(...) @@ -325,23 +322,111 @@ add_func <- function(func, userp_name = userp_name) } -#' @title Generate a Function to Fix a User-Defined Parameter - -#' @noRd - +#' @title Generate a Function to Fix a +#' User-Defined Parameter +#' +#' @description Add a function to a +#' lavaan object as a user-defined +#' parameter and return a function which +#' can fix this user-defined parameter +#' to ba value. +#' +#' @details +#' This function is to be used internally +#' for generating a function for searching +#' a likelihood-based confidence bound. +#' +#' It is exported because it needs to +#' be run in an external R process, +#' usually created by `callr` in other +#' functions, such as [add_func()]. +#' +#' @param userp A function that receives +#' a `lavaan` object and returns a +#' scalars. +#' +#' @param userp_name The name of the +#' function `userp` to be used in the +#' `lavaan` model. It does not have to +#' be the name of the function in +#' `userp`. Should be changed only if it +#' conflicts with another object in the +#' global environment, which should not +#' happen if the model is always fitted +#' in a clean R session. +#' +#' @param sem_out A `lavaan`-class object, +#' to which the function will be added +#' as a user-defined parameter. +#' +#' @param fix If `TRUE`, the default, +#' the function generated is used to fix +#' the value of `userp` to a target +#' value using an equality constraint. +#' If `FALSE`, then the function simply +#' fits the model to the data. +#' +#' @param control_args To be passed to +#' the argument of the same name in +#' [lavaan::lavaan()]. Default is +#' `list()`. Can be used to set the +#' default values of this argument +#' in the generated function. +#' +#' @param iter.max The maximum number of +#' iteration when the generated function +#' fit the model. Default is 10000. +#' +#' @param max_attempts If the initial +#' fit with the equality constraint +#' fails, how many more attempts +#' will be made by the generated +#' function. Default is 5. +#' +#' @return +#' If `fix` is `TRUE`, it returns a +#' function with these arguments: +#' +#' - `target`: The value to which the +#' user-defined parameter will be fixed +#' to. +#' +#' - `verbose`: If `TRUE`, additional +#' information will be printed when +#' fitting the model. +#' +#' - `control`: The values to be passed +#' as a list to the argument of the +#' same name in [lavaan::lavaan()]. +#' +#' - `seed`: Numeric. If supplied, it +#' will be used in [set.seed()] to +#' initialize the random number +#' generator. Necessary to reproduce +#' some results because random numbers +#' are used in some steps in `lavaan`. +#' If `NULL`, the default, [set.seed()] +#' will not be called. +#' +#' If `fix` is `FALSE, then it returns a +#' function with optional arguments that +#' will be ignored, Calling it will +#' simply fit the modified model to the +#' data. Useful for getting the value of +#' the user-defined parameter. +#' +#' @export # Generate a function that: # - refits the model with the user-parameter fixed to a target value. # CHECKED: Identical to the experimental version # For add_fun using callr -#' @export gen_sem_out_userp <- function(userp, sem_out, userp_name = "semlbciuserp1234", fix = TRUE, control_args = list(), iter.max = 10000, - max_attempts = 5, - verbose = TRUE) { + max_attempts = 5) { iter.max <- max(lavaan::lavInspect(sem_out, "optim")$iterations, iter.max) ptable <- lavaan::parameterTable(sem_out) diff --git a/man/gen_sem_out_userp.Rd b/man/gen_sem_out_userp.Rd new file mode 100644 index 00000000..f58504ec --- /dev/null +++ b/man/gen_sem_out_userp.Rd @@ -0,0 +1,107 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ci_bound_ur_i_helpers.R +\name{gen_sem_out_userp} +\alias{gen_sem_out_userp} +\title{Generate a Function to Fix a +User-Defined Parameter} +\usage{ +gen_sem_out_userp( + userp, + sem_out, + userp_name = "semlbciuserp1234", + fix = TRUE, + control_args = list(), + iter.max = 10000, + max_attempts = 5 +) +} +\arguments{ +\item{userp}{A function that receives +a \code{lavaan} object and returns a +scalars.} + +\item{sem_out}{A \code{lavaan}-class object, +to which the function will be added +as a user-defined parameter.} + +\item{userp_name}{The name of the +function \code{userp} to be used in the +\code{lavaan} model. It does not have to +be the name of the function in +\code{userp}. Should be changed only if it +conflicts with another object in the +global environment, which should not +happen if the model is always fitted +in a clean R session.} + +\item{fix}{If \code{TRUE}, the default, +the function generated is used to fix +the value of \code{userp} to a target +value using an equality constraint. +If \code{FALSE}, then the function simply +fits the model to the data.} + +\item{control_args}{To be passed to +the argument of the same name in +\code{\link[lavaan:lavaan]{lavaan::lavaan()}}. Default is +\code{list()}. Can be used to set the +default values of this argument +in the generated function.} + +\item{iter.max}{The maximum number of +iteration when the generated function +fit the model. Default is 10000.} + +\item{max_attempts}{If the initial +fit with the equality constraint +fails, how many more attempts +will be made by the generated +function. Default is 5.} +} +\value{ +If \code{fix} is \code{TRUE}, it returns a +function with these arguments: +\itemize{ +\item \code{target}: The value to which the +user-defined parameter will be fixed +to. +\item \code{verbose}: If \code{TRUE}, additional +information will be printed when +fitting the model. +\item \code{control}: The values to be passed +as a list to the argument of the +same name in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. +\item \code{seed}: Numeric. If supplied, it +will be used in \code{\link[=set.seed]{set.seed()}} to +initialize the random number +generator. Necessary to reproduce +some results because random numbers +are used in some steps in \code{lavaan}. +If \code{NULL}, the default, \code{\link[=set.seed]{set.seed()}} +will not be called. +} + +If \code{fix} is `FALSE, then it returns a +function with optional arguments that +will be ignored, Calling it will +simply fit the modified model to the +data. Useful for getting the value of +the user-defined parameter. +} +\description{ +Add a function to a +lavaan object as a user-defined +parameter and return a function which +can fix this user-defined parameter +to ba value. +} +\details{ +This function is to be used internally +for generating a function for searching +a likelihood-based confidence bound. + +It is exported because it needs to +be run in an external R process, +usually created by \code{callr} in other +functions, such as \code{\link[=add_func]{add_func()}}. +} From 0954b4bebe06873695d4b81f6b6088e4b448ec9b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 08:32:56 +0800 Subject: [PATCH 09/68] Add a note to uniroot_interval --- R/ci_bound_ur_i_helpers.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index dd92e92b..26718dd9 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -51,6 +51,11 @@ uniroot_interval <- function(sem_out, d = 5, level = .95) { # Set the interval to search + + # NOTE: + # No need to know standardized or not because + # standardization, if any, is done inside func. + fit_i_free <- add_func(func = func, sem_out = sem_out, fix = FALSE) From d5aeabf4cf096795b55cb4578e68a8a247dd124b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 09:01:02 +0800 Subject: [PATCH 10/68] Shorten the run time of some tests --- tests/testthat/test-ur_ci_bound_ur.R | 216 ------------------ tests/testthat/test-ur_ci_bound_ur_mg_std_1.R | 55 +++++ .../testthat/test-ur_ci_bound_ur_mg_ustd_1.R | 48 ++++ tests/testthat/test-ur_ci_bound_ur_std_1.R | 77 +++++++ tests/testthat/test-ur_ci_bound_ur_ustd_1.R | 73 ++++++ 5 files changed, 253 insertions(+), 216 deletions(-) delete mode 100644 tests/testthat/test-ur_ci_bound_ur.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_mg_std_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_mg_ustd_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_std_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_ustd_1.R diff --git a/tests/testthat/test-ur_ci_bound_ur.R b/tests/testthat/test-ur_ci_bound_ur.R deleted file mode 100644 index 4a9e063c..00000000 --- a/tests/testthat/test-ur_ci_bound_ur.R +++ /dev/null @@ -1,216 +0,0 @@ -skip_on_cran() - -# Ready - -# After skip("Long test"): WIP - -library(testthat) -library(lavaan) - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 - visual ~~ a*textual - visual ~~ b*speed - textual ~~ d*speed - ab := a*b' -fit <- sem(HS.model, data = HolzingerSwineford1939) -fit_gp <- sem(HS.model, data = HolzingerSwineford1939, - group = "school", - group.equal = "intercepts") - -# Unstandardized - -# One group - -est_i <- gen_est_i(i = 9, sem_out = fit) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - user_callr = FALSE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - user_callr = TRUE) -) -expect_equal(ci_lb$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-3) -expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-3) - -est_i <- gen_est_i(i = 25, sem_out = fit) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - use_callr = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - user_callr = FALSE) -) -expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), - .05, - tolerance = 1e-2) -expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-3) - -ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", use_pbapply = FALSE) - -expect_equal(unname(round(c(ci_lb$bound, ci_ub$bound), 3)), - unname(round(unlist(confint(ci_lbci)), 3))) - -# Two groups - -est_i <- gen_est_i(i = 46, sem_out = fit_gp) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "lbound", - use_callr = FALSE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "ubound", - use_callr = TRUE) -) -expect_equal(ci_lb$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-2) -expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-3) - -# # Too long to run -# est_i <- gen_est_i(i = 73, sem_out = fit_gp) -# system.time( -# ci_lb <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "lbound", -# progress = TRUE) -# ) -# system.time( -# ci_ub <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "ubound", -# progress = TRUE) -# ) -# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=") - -# ci_lb$lrt -# ci_ub$lrt -# c(ci_lb$bound, ci_ub$bound) -# confint(ci_lbci) -# parameterEstimates(fit_gp)[73, ] - -# Standardized - -skip("WIP") - -est_i <- gen_est_i(i = 9, sem_out = fit, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE, - use_callr = FALSE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE, - use_callr = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit, pars = "speed =~ x9", standardized = TRUE) - -expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), - .05, - tolerance = 1e-2) -expect_equal(ci_ub$lrt[2, "Pr(>Chisq)"], - .05, - tolerance = 1e-2) - -expect_equal(unname(round(c(ci_lb$bound, ci_ub$bound), 3)), - unname(round(unlist(confint(ci_lbci)), 3))) - -# TO WORK - -est_i <- gen_est_i(i = 25, sem_out = fit, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", standardized = TRUE) - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit)[25, ] - -est_i <- gen_est_i(i = 46, sem_out = fit_gp, standardized = TRUE) -system.time( -ci_lb <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "lbound", - progress = TRUE) -) -system.time( -ci_ub <- ci_bound_ur(sem_out = fit_gp, - func = est_i, - which = "ubound", - progress = TRUE) -) - -ci_lbci <- semlbci(sem_out = fit_gp, pars = "visual ~~ 2*textual", standardized = TRUE) - -ci_lb$lrt -ci_ub$lrt -c(ci_lb$bound, ci_ub$bound) -confint(ci_lbci) -standardizedSolution(fit_gp)[46, ] - - -# Too difficult to search by both methods - -# est_i <- gen_est_i(i = 73, sem_out = fit_gp, standardized = TRUE) -# system.time( -# ci_lb <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "lbound", -# progress = TRUE) -# ) -# system.time( -# ci_ub <- ci_bound_ur(sem_out = fit_gp, -# func = est_i, -# which = "ubound", -# progress = TRUE) -# ) - -# ci_lbci <- semlbci(sem_out = fit_gp, pars = "ab :=", standardized = TRUE) - -# ci_lb$lrt -# ci_ub$lrt -# c(ci_lb$bound, ci_ub$bound) -# confint(ci_lbci) -# standardizedSolution(fit_gp)[46, ] diff --git a/tests/testthat/test-ur_ci_bound_ur_mg_std_1.R b/tests/testthat/test-ur_ci_bound_ur_mg_std_1.R new file mode 100644 index 00000000..dce239d3 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_mg_std_1.R @@ -0,0 +1,55 @@ +skip_on_cran() +skip("To be run in an interactive session") + +# Ready + +library(testthat) +library(lavaan) + +HS.model_gp <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + visual ~~ c(a1, a2)*textual + adiff := a1^2' +fit_gp <- sem(HS.model_gp, data = HolzingerSwineford1939, + group = "school", + group.equal = "loadings") + +## Two groups + +test_that("ci_bound_ur: Two groups, standardized", { + +# Take more than one minute to run +# Test one bound is enough + +est_i <- gen_est_i(i = 29, sem_out = fit_gp, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "lbound", + progress = FALSE) +) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "ubound", +# progress = FALSE) +# ) + +expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) +# expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) + +ci_lbci <- semlbci(sem_out = fit_gp, pars = "textual =~ 2*x6", standardized = TRUE, use_pbapply = FALSE) + +expect_equal(unname(round(c(ci_lb$bound), 3)), + unname(round(unlist(confint(ci_lbci))[1], 3)), + tolerance = 1e-2) + +# expect_equal(unname(round(c(ci_lb$bound, ci_ub$bound), 3)), +# unname(round(unlist(confint(ci_lbci)), 3)), +# tolerance = 1e-2) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_mg_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_mg_ustd_1.R new file mode 100644 index 00000000..59708f62 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_mg_ustd_1.R @@ -0,0 +1,48 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "loadings") + +## Two groups + +test_that("ci_bound_ur: Two groups, unstandardized", { + +# Test one bound is enough + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "lbound", +# progress = FALSE, +# use_callr = FALSE) +# ) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = FALSE, + use_callr = TRUE) +) + +# expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_std_1.R b/tests/testthat/test-ur_ci_bound_ur_std_1.R new file mode 100644 index 00000000..e90abf27 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_std_1.R @@ -0,0 +1,77 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +# Standardized + +HS.model <- ' visual =~ x1 + x2 + d1*x3 + textual =~ x4 + x5 + d2*x6 + visual ~~ textual + d12 := d1^2' +fit <- sem(HS.model, data = HolzingerSwineford1939) + +## One group + +test_that("ci_bound_ur: One group, standardized", { + +# Take more than one minute to run +# Test one bound is enough + +est_i <- gen_est_i(i = 7, sem_out = fit, standardized = TRUE) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = FALSE) +) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "ubound", +# progress = FALSE) +# ) + +expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) +# expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) + +ci_lbci <- semlbci(sem_out = fit, pars = "visual ~~ textual", standardized = TRUE, use_pbapply = FALSE) + +expect_equal(unname(round(c(ci_lb$bound), 3)), + unname(round(unlist(confint(ci_lbci))[1], 3)), + tolerance = 1e-2) + +# est_i <- gen_est_i(i = 3, sem_out = fit, standardized = TRUE) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "lbound", +# progress = FALSE) +# ) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "ubound", +# progress = FALSE) +# ) + +# expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) +# expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) + +# ci_lbci <- semlbci(sem_out = fit, pars = "visual =~ x3", standardized = TRUE, use_pbapply = FALSE) + +# expect_equal(unname(round(c(ci_lb$bound), 3)), +# unname(round(unlist(confint(ci_lbci))[1], 3)), +# tolerance = 1e-2) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_ustd_1.R new file mode 100644 index 00000000..1a8fef42 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_ustd_1.R @@ -0,0 +1,73 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit <- sem(HS.model, data = HolzingerSwineford1939) + +# Unstandardized + +## One group + +test_that("ci_bound_ur: One group, unstandardized", { + +# Test one bound is enough + +est_i <- gen_est_i(i = 9, sem_out = fit) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "lbound", +# progress = FALSE, +# user_callr = FALSE) +# ) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = FALSE, + user_callr = TRUE) +) +# expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) + +est_i <- gen_est_i(i = 25, sem_out = fit) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "lbound", +# progress = FALSE, +# use_callr = TRUE) +# ) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "ubound", + progress = FALSE, + user_callr = FALSE) +) +# expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) + +ci_lbci <- semlbci(sem_out = fit, pars = "ab :=", use_pbapply = FALSE) + +expect_equal(unname(round(c(ci_ub$bound), 3)), + unname(round(unlist(confint(ci_lbci))[2], 3))) +}) From c0f39127ada013920b9fd13ce2d7c3b37ed2e227 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 09:06:56 +0800 Subject: [PATCH 11/68] Update doc and export ci_bound_ur Tests passed --- NAMESPACE | 1 + R/ci_bound_ur_i.R | 42 +++++++--- R/ci_bound_ur_i_helpers.R | 9 ++ man/ci_bound_ur.Rd | 169 ++++++++++++++++++++++++++++++++++++++ man/ci_bound_ur_i.Rd | 3 + man/gen_sem_out_userp.Rd | 9 ++ 6 files changed, 222 insertions(+), 11 deletions(-) create mode 100644 man/ci_bound_ur.Rd diff --git a/NAMESPACE b/NAMESPACE index 9fc7bddc..d3385611 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ S3method(print,ci_order) S3method(print,cibound) S3method(print,semlbci) export(check_sem_out) +export(ci_bound_ur) export(ci_bound_ur_i) export(ci_bound_wn_i) export(ci_i_one) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index ef2c6ae4..8ed79ea8 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -151,6 +151,9 @@ #' #' @examples #' +#' # TODO: +#' # - Update the example +#' #' data(simple_med) #' dat <- simple_med #' @@ -169,11 +172,6 @@ #' #' @export -# Workflow -# - Input: -# - sem_out -# - A function which receive parameters and return a value - ci_bound_ur_i <- function(i = NULL, npar = NULL, # Not used by ur sem_out = NULL, @@ -476,12 +474,28 @@ ci_bound_ur_i <- function(i = NULL, #' determining the interval internally. #' #' -#' @noRd - -# Internal Workflow -# - Define the function that works on the lavaan object. -# - Call add_func() to generate a modified lavaan object. -# - Call sem_out_userp_run() to fix to a value +#' @examples +#' +#' # TODO: +#' # - Update the example +#' +#' data(simple_med) +#' dat <- simple_med +#' +#' mod <- +#' " +#' m ~ x +#' y ~ m +#' " +#' +#' fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) +#' +#' out1l <- ci_bound_ur_i(i = 1, +#' sem_out = fit_med, +#' which = "lbound") +#' out1l +#' +#' @export ci_bound_ur <- function(sem_out, func, @@ -498,6 +512,12 @@ ci_bound_ur <- function(sem_out, uniroot_trace = 0, uniroot_maxiter = 1000, use_callr = TRUE) { + + # Internal Workflow + # - Define the function that works on the lavaan object. + # - Call add_func() to generate a modified lavaan object. + # - Call sem_out_userp_run() to fix to a value + # TODO: # - Support satorra.2000 which <- match.arg(which) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 26718dd9..34fb6f4c 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -420,6 +420,15 @@ add_func <- function(func, #' data. Useful for getting the value of #' the user-defined parameter. #' +#' +#' @examples +#' +#' # TODO: +#' # - Add an example +#' data(simple_med) +#' dat <- simple_med +#' +#' #' @export # Generate a function that: # - refits the model with the user-parameter fixed to a target value. diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd new file mode 100644 index 00000000..a3066351 --- /dev/null +++ b/man/ci_bound_ur.Rd @@ -0,0 +1,169 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ci_bound_ur_i.R +\name{ci_bound_ur} +\alias{ci_bound_ur} +\title{Find a Likelihood-Based +Confidence Bound By 'uniroot()'} +\usage{ +ci_bound_ur( + sem_out, + func, + ..., + level = 0.95, + which = c("lbound", "ubound"), + interval = NULL, + progress = FALSE, + method = "uniroot", + tol = 5e-04, + root_target = c("chisq", "pvalue"), + d = 5, + uniroot_extendInt = "yes", + uniroot_trace = 0, + uniroot_maxiter = 1000, + use_callr = TRUE +) +} +\arguments{ +\item{sem_out}{The fit object. +Currently supports +\link[lavaan:lavaan-class]{lavaan::lavaan} objects only.} + +\item{func}{A function that receives +a lavaan object and returns a scalar. +Usually the output of +\code{\link[=gen_sem_out_userp]{gen_sem_out_userp()}}.} + +\item{...}{Optional arguments to be +passed to \code{func}.} + +\item{level}{The level of confidence +of the confidence interval. Default +is .95, or 95\%.} + +\item{which}{Whether the lower bound +or the upper bound is to be found. +Must be \code{"lbound"} or \code{"ubound"}.} + +\item{interval}{A numeric vector of +two values, which is the initial +interval to be searched. If \code{NULL}, +the default, it will be determined +internally using Wald or delta +method confidence interval, if +available.} + +\item{progress}{Whether progress will +be reported on screen. Default is +\code{FALSE}.} + +\item{method}{The actual function to +be used in the search. which can only +be \code{"uniroot"}, the default, for now. +May include other function in the +future.} + +\item{tol}{The tolerance used in +\code{\link[=uniroot]{uniroot()}}, default is .005.} + +\item{root_target}{Whether the +chi-square difference (\code{"chisq"}), +the default, or its \emph{p}-value +(\code{"pvalue"}) is used as the function +value in finding the root. Should have +little impact on the results.} + +\item{d}{A value used to determine +the width of the interval in the +initial search. Larger this value, +\emph{narrow} the interval. Default is 5.} + +\item{uniroot_extendInt}{To be passed +to the argument \code{extendInt} of +\code{\link[=uniroot]{uniroot()}}. Whether the interval +should be extended if the root is not +found. Default is \code{"yes"}. Refer to +the help page of \code{\link[=uniroot]{uniroot()}} for +possible values.} + +\item{uniroot_trace}{To be passed to +the argument \code{trace} of \code{\link[=uniroot]{uniroot()}}. +How much information is printed +during the search. Default is 0, and +no information is printed during the +search. Refer to the help page of +\code{\link[=uniroot]{uniroot()}} for possible values.} + +\item{uniroot_maxiter}{The maximum +number of iteration in the search. +Default is 1000.} + +\item{use_callr}{Whether the +\link{callr} package will be used to +do the search in a separate R +process. Default is \code{TRUE}. Should +not set to \code{FALSE} if used in the +global environment unless this is +intentional.} +} +\value{ +A list with the following elements: +\itemize{ +\item \code{bound}: The bound found. +\item \code{optimize_out}: THe output of the +root finding function, \code{\link[=uniroot]{uniroot()}} +for now. (Called \code{optimize_out} +because an earlier version of this +function also uses \code{\link[=optimize]{optimize()}}). +\item \code{sem_out_bound}: The \code{lavaan} model +with the user-defined parameter fixed +to the bound. +\item \code{lrt}: The output of +\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} comparing +\code{sem_out} and \code{sem_out_bound}. +\item \code{bound_start}: The Wald or delta +method confidence bound returned when +determining the interval internally. +\item \code{user_est}: The estimate of the +user-defined parameter when +determining the interval internally. +} +} +\description{ +Find the lower or upper +bound of the likelihood-based +confidence interval (LBCI) for one +parameter in a structural equation +model fitted in \code{\link[lavaan:lavaan]{lavaan::lavaan()}} +using \code{\link[=uniroot]{uniroot()}}. +} +\details{ +This function is called xby +\code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}}. This function will +be exported later because it is a +stand-alone function that can be used +directly for any function that +receives a lavaan object and returns +a scalar. +} +\examples{ + +# TODO: +# - Update the example + +data(simple_med) +dat <- simple_med + +mod <- +" +m ~ x +y ~ m +" + +fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) + +out1l <- ci_bound_ur_i(i = 1, + sem_out = fit_med, + which = "lbound") +out1l + +} diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index c96e4397..7dd593bb 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -171,6 +171,9 @@ close to an attainable bound. } \examples{ +# TODO: +# - Update the example + data(simple_med) dat <- simple_med diff --git a/man/gen_sem_out_userp.Rd b/man/gen_sem_out_userp.Rd index f58504ec..2c3d6ef1 100644 --- a/man/gen_sem_out_userp.Rd +++ b/man/gen_sem_out_userp.Rd @@ -105,3 +105,12 @@ be run in an external R process, usually created by \code{callr} in other functions, such as \code{\link[=add_func]{add_func()}}. } +\examples{ + +# TODO: +# - Add an example +data(simple_med) +dat <- simple_med + + +} From e6ea8c964f8ec97f51738789a8d6d6b97a20eaa6 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 09:10:11 +0800 Subject: [PATCH 12/68] Remove the assignment to workspace Tests passed --- R/ci_bound_ur_i.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 8ed79ea8..e06b4edf 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -568,10 +568,6 @@ ci_bound_ur <- function(sem_out, if (use_callr) { on.exit(try(r1$close(), silent = TRUE)) r1 <- callr::r_session$new() - # TODO: - # - Mo need to export when gen_fit_userp is in the package - r1$run(function(x) {sem_out_userp_run <<- x}, - args = list(x = sem_out_userp_run)) if (progress) { optimize_out <- r1$call(function(f, interval, From b3dc86a41d587c5ed3caad424e80548b0901094d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 09:22:14 +0800 Subject: [PATCH 13/68] Add error handlers to gen_sem_out_userp Tests passed --- R/ci_bound_ur_i_helpers.R | 60 +++++++++++++++++++++++++-------------- 1 file changed, 38 insertions(+), 22 deletions(-) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 34fb6f4c..9b8baca9 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -528,8 +528,12 @@ gen_sem_out_userp <- function(userp, # Fit once to update the model slot attempted <- 0 fit_new_converged <- FALSE - if (verbose) {cat("Target:", target, "\n")} - if (verbose) {cat("First attempt ...\n")} + if (verbose) { + cat("Target:", target, "\n") + } + if (verbose) { + cat("First attempt ...\n") + } # Fail when # eq.constraints.K is 0x0 # Succeed when @@ -553,19 +557,24 @@ gen_sem_out_userp <- function(userp, # Fit the model with the user parameter constrained # to the target value - # TODO: - # - Add an error handler - fit_new <- lavaan::lavaan(slotParTable = slot_pat_new, - slotModel = slot_model_new, - slotSampleStats = slot_smp_new, - slotOptions = slot_opt, - slotData = slot_dat) + fit_new <- tryCatch(lavaan::lavaan(slotParTable = slot_pat_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat), + error = function(e) e) + if (inherits(fit_new, "error")) { + stop("Something's with the function.", + "Error occurred when fitting the modified model.") + } fit_new_converged <- lavaan::lavInspect(fit_new, "converged") # Try max_attempts more times if (!fit_new_converged) { - if (verbose) {cat("More attempts ...\n")} + if (verbose) { + cat("More attempts ...\n") + } while (!((attempted > max_attempts) || fit_new_converged)) { if (verbose) {cat("Attempt", attempted, "\n")} @@ -574,23 +583,30 @@ gen_sem_out_userp <- function(userp, ptable_new$est[i_free] <- jitter(ptable_new$est[i_free], factor = 50) slot_opt$start <- as.data.frame(ptable_new) - # TODO: - # - Add an error handler - fit_new <- lavaan::lavaan(slotParTable = ptable_new, - slotModel = slot_model_new, - slotSampleStats = slot_smp_new, - slotOptions = slot_opt, - slotData = slot_dat) - fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + fit_old <- fit_new + fit_new <- tryCatch(lavaan::lavaan(slotParTable = ptable_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat), + error = function(e) e) + if (inherits(fit_new, "error")) { + fit_new <- fit_old + fit_new_converged <- FALSE + } else { + fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + } attempted <- attempted + 1 } } if (!fit_new_converged) { - # TODO: - # - Need to decide what to do - cat("Failed to converge.") + if (verbose) { + cat("The modified model failed to converge.") + } + } + if (verbose) { + cat("Done!\n") } - if (verbose) {cat("Done!\n")} fit_new } } else { From d6d0b84219ca0001e1415b8ecfcb4cd269006fbf Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 15:24:19 +0800 Subject: [PATCH 14/68] Update the doc of ur functions. Tests passed. --- R/ci_bound_ur_i.R | 335 ++++++++++++++++++++++++-------------- R/ci_bound_ur_i_helpers.R | 17 +- man/ci_bound_ur.Rd | 30 +++- man/ci_bound_ur_i.Rd | 290 +++++++++++++++++++++------------ man/gen_sem_out_userp.Rd | 6 +- 5 files changed, 432 insertions(+), 246 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index e06b4edf..f111420a 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -1,153 +1,228 @@ -# NOTE: -# - Copied from semlbci::ci_bound_wn_i() -# - Need to be edited later. - -#' @title Likelihood-based Confidence Bound For One parameter (uniroot) +#' @title Likelihood-Based Confidence +#' Bound By Root Finding #' -#' @description Find the lower or upper bound of the likelihood-based -#' confidence interval (LBCI) for one parameter in a structural -#' equation model fitted in [lavaan::lavaan()] using [uniroot()]. +#' @description Using root finding +#' to find the lower or +#' upper bound of the likelihood-based +#' confidence interval (LBCI) for one +#' parameter in a structural equation +#' model fitted in [lavaan::lavaan()]. #' #' @details #' #' ## Important Notice #' -#' This function is not supposed to be used directly by users in -#' typical scenarios. Its interface is user-*unfriendly* because it -#' should be used through [semlbci()]. It is exported such that -#' interested users can examine how a confidence bound is found, or -#' use it for experiments or simulations. +#' This function is not supposed to be +#' used directly by users in typical +#' scenarios. Its interface is +#' user-*unfriendly* because it should +#' be used through [semlbci()]. It is +#' exported such that interested users +#' can examine how a confidence bound is +#' found, or use it for experiments or +#' simulations. #' #' ## Usage #' -#' This function is the lowest level function used by [semlbci()]. -#' [semlbci()] calls this function once for each bound of each -#' parameter. +#' This function is the lowest level +#' function used by [semlbci()]. +#' [semlbci()] calls this function once +#' for each bound of each parameter. #' -#' For consistency in the interface, most of the arguments -#' in [ci_bound_wn_i()] are also included in this function, -#' even those not used internally. +#' For consistency in the interface, +#' most of the arguments in +#' [ci_bound_wn_i()] are also included +#' in this function, even those not used +#' internally. #' #' ## Algorithm #' -#' This function, unlike [ci_bound_wn_i()], use a simple -#' root finding algorithm. Basically, it try fixing the -#' target parameters to different values until the -#' likelihood ratio test *p*-value is equal to the desired -#' value. -#' -#' This algorithm is known to be very inefficient, compared -#' to the one proposed by Wu and Neale (2012). It is included -#' as a backup algorithm for parameters which are difficult +#' This function, unlike +#' [ci_bound_wn_i()], use a simple root +#' finding algorithm. Basically, it tries +#' fixing the target parameter to +#' different values until the likelihood +#' ratio test *p*-value, or the +#' corresponding chi-square difference, +#' is equal to the +#' value corresponding to the desired +#' level of confidence. (Internally, +#' the difference between the *p*-value +#' and the target *p*-value, that for +#' the chi-square difference, is the +#' function value.) +#' +#' For finding the bound, this algorithm +#' can be inefficient compared to the +#' one proposed by Wu and Neale (2012). +#' The difference can be less than +#' one second versus 10 seconds. +#' It is included as a backup algorithm +#' for parameters which are difficult #' for the method by Wu and Neale. #' +#' Internally, it uses [uniroot()] to +#' find the root. +#' #' ## Limitation(s) #' -#' Like [ci_bound_wn_i()], this function does not an estimate -#' close to an attainable bound. +#' This function does not handle an +#' estimate close to an attainable bound +#' using the method proposed by Wu and +#' Neale (2012). Use it for such +#' parameters with cautions. #' -#' @return A `cibound`-class object which is a list with three elements: +#' @return A `cibound`-class object +#' which is a list with three elements: #' -#' - `bound`: A single number. The value of the bound located. `NA` is -#' the search failed for various reasons. +#' - `bound`: A single number. The value +#' of the bound located. `NA` is the +#' search failed for various reasons. #' -#' - `diag`: A list of diagnostic information. +#' - `diag`: A list of diagnostic +#' information. #' #' - `call`: The original call. #' -#' A detailed and organized output can be printed by the default print +#' A detailed and organized output can +#' be printed by the default print #' method ([print.cibound()]). #' -#' @param i The position of the target parameter as appeared in the -#' parameter table of a lavaan object, generated by -#' [lavaan::parameterTable()]. -#' -#' @param npar Ignored by this function. Included for having -#' a unified interface. -#' -#' @param sem_out The fit object. Currently supports -#' [lavaan::lavaan-class] objects only. -#' -#' @param f_constr Ignored by this function. Included for having -#' a unified interface. -#' -#' @param which Whether the lower bound or the upper bound is to be -#' found. Must be `"lbound"` or `"ubound"`. -#' -#' @param history Not used. Kept for backward compatibility. -#' -#' @param perturbation_factor Ignored by this function. Included for having -#' a unified interface. -#' -#' @param lb_var Ignored by this function. Included for having -#' a unified interface. -#' -#' @param wald_ci_start Ignored by this function. Included for having -#' a unified interface. +#' @param i The position of the target +#' parameter as appeared in the +#' parameter table of a lavaan object, +#' generated by +#' [lavaan::parameterTable()]. #' -#' @param standardized If `TRUE`, the LBCI is for the requested -#' estimate in the standardized solution. Default is `FALSE`. +#' @param npar Ignored by this function. +#' Included consistency in the +#' interface. #' -#' @param opts Options to be passed to [stats::uniroot()]. -#' Default is `list()`. -#' -#' @param ciperc The intended coverage probability for the confidence -#' interval. Default is .95, and the bound for a 95% confidence -#' interval will be sought. -#' -#' @param ci_limit_ratio_tol The tolerance for the ratio of `a` to -#' `b`, where `a` is the distance between an LBCI limit and the point -#' estimate, and the `b` is the distance between the original -#' confidence limit (by default the Wald CI in [lavaan::lavaan()]) -#' and the point estimate. If the ratio is larger than this value or -#' smaller than the reciprocal of this value, a warning is set in the -#' status code. Default is 1.5. -#' -#' @param verbose If `TRUE`, the function will store more diagnostic -#' information in the attribute `diag`. Default is `FALSE`. -#' -#' @param sf Ignored by this function. Included for having -#' a unified interface. -#' -#' @param sf2 Ignored by this function. Included for having -#' a unified interface. +#' @param sem_out The fit object. +#' Currently supports +#' [lavaan::lavaan-class] objects only. #' -#' @param p_tol Tolerance for checking the achieved level of -#' confidence. If the absolute difference between the achieved level -#' and `ciperc` is greater than this amount, a warning is set in the -#' status code and the bound is set to `NA`. Default is 5e-4. +#' @param f_constr Ignored by this +#' function. Included consistency in the +#' interface. #' -#' @param std_method The method used to find the standardized -#' solution. If equal to `"lavaan"``, -#' [lavaan::standardizedSolution()] will be used. If equal to -#' `"internal"`, an internal function will be used. The `"lavaan"` -#' method should work in all situations, but the `"internal"` method -#' is usually much faster. Default is `"internal"`. +#' @param which Whether the lower bound +#' or the upper bound is to be found. +#' Must be `"lbound"` or `"ubound"`. #' -#' @param bounds Ignored by this function. Included for having -#' a unified interface. +#' @param history Not used. Kept for +#' backward compatibility. #' -#' @param xtol_rel_factor Ignored by this function. Included for having -#' a unified interface. +#' @param perturbation_factor Ignored by +#' this function. Included consistency +#' in the interface. #' -#' @param ftol_rel_factor Ignored by this function. Included for having -#' a unified interface. +#' @param lb_var Ignored by this +#' function. Included consistency in the +#' interface. #' -#' @param lb_prop Ignored by this function. Included for having -#' a unified interface. +#' @param wald_ci_start Ignored by this +#' function. Included consistency in the +#' interface. #' -#' @param lb_se_k Ignored by this function. Included for having -#' a unified interface. +#' @param standardized If `TRUE`, the +#' LBCI is for the requested estimate in +#' the standardized solution. Default is +#' `FALSE`. #' -#' @param ... Optional arguments. Not used. +#' @param opts Options to be passed to +#' [stats::uniroot()]. Default is +#' `list()`. +#' +#' @param ciperc The intended coverage +#' probability for the confidence +#' interval. Default is .95, and the +#' bound for a 95% confidence interval +#' will be sought. +#' +#' @param ci_limit_ratio_tol The +#' tolerance for the ratio of `a` to +#' `b`, where `a` is the distance +#' between an LBCI limit and the point +#' estimate, and the `b` is the distance +#' between the original confidence limit +#' (by default the Wald CI in +#' [lavaan::lavaan()]) and the point +#' estimate. If the ratio is larger than +#' this value or smaller than the +#' reciprocal of this value, a warning +#' is set in the status code. Default is +#' 1.5. +#' +#' @param verbose If `TRUE`, the +#' function will store more diagnostic +#' information in the attribute `diag`. +#' Default is `FALSE`. +#' +#' @param sf Ignored by this function. +#' Included consistency in the +#' interface. +#' +#' @param sf2 Ignored by this function. +#' Included consistency in the +#' interface. +#' +#' @param p_tol Tolerance for checking +#' the achieved level of confidence. If +#' the absolute difference between the +#' achieved level and `ciperc` is +#' greater than this amount, a warning +#' is set in the status code and the +#' bound is set to `NA`. Default is +#' 5e-4. +#' +#' @param std_method The method used to +#' find the standardized solution. If +#' equal to `"lavaan"``, +#' [lavaan::standardizedSolution()] will +#' be used. If equal to `"internal"`, an +#' internal function will be used. The +#' `"lavaan"` method should work in all +#' situations, but the `"internal"` +#' method is usually much faster. +#' Default is `"internal"`. +#' +#' @param bounds Ignored by this +#' function. Included consistency in the +#' interface. +#' +#' @param xtol_rel_factor Ignored by +#' this function. Included consistency +#' in the interface. +#' +#' @param ftol_rel_factor Ignored by +#' this function. Included consistency +#' in the interface. +#' +#' @param lb_prop Ignored by this +#' function. Included consistency in the +#' interface. +#' +#' @param lb_se_k Ignored by this +#' function. Included consistency in the +#' interface. +#' +#' @param ... Optional arguments. Not +#' used. #' #' @references #' -#' Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for a -#' bounded parameter. *Behavior Genetics, 42*(6), 886-898. -#' \doi{10.1007/s10519-012-9560-z} +#' Wu, H., & Neale, M. C. (2012). +#' Adjusted confidence intervals for a +#' bounded parameter. *Behavior +#' Genetics, 42*(6), 886-898. +#' \doi{10.1007/s10519-012-9560-z} #' -#' @seealso [print.cibound()], [semlbci()], [ci_i_one()] +#' @seealso [print.cibound()], +#' [semlbci()], [ci_i_one()]; see +#' [ci_bound_wn_i()] on the version +#' for the method by Wu and Neale +#' (2012). #' #' @examples #' @@ -347,32 +422,47 @@ ci_bound_ur_i <- function(i = NULL, } #' @title Find a Likelihood-Based -#' Confidence Bound By 'uniroot()' +#' Confidence Bound By Root Finding #' #' @description Find the lower or upper -#' bound of the likelihood-based -#' confidence interval (LBCI) for one -#' parameter in a structural equation -#' model fitted in [lavaan::lavaan()] -#' using [uniroot()]. +#' bound of the likelihood-based +#' confidence interval (LBCI) for one +#' parameter in a structural equation +#' model fitted in [lavaan::lavaan()] +#' using [uniroot()]. #' #' @details #' This function is called xby -#' [ci_bound_ur_i()]. This function will -#' be exported later because it is a +#' [ci_bound_ur_i()]. This function is +#' exported later because it is a #' stand-alone function that can be used #' directly for any function that #' receives a lavaan object and returns #' a scalar. #' +#' The function [ci_bound_ur_i()] is a +#' wrapper of this function, with an +#' interface similar to that of +#' [ci_bound_wn_i()] and returns a +#' `cibound`-class object. The +#' user-parameter function is generated +#' internally by [ci_bound_wn_i()]. +#' +#' This function, on the other hand, +#' requires users to supply the function +#' directly through the `func` argument. +#' This provides the flexibility to find +#' the bound for any function of the +#' model parameter, even one that cannot +#' be easily coded in `lavaan`` model +#' syntax. +#' #' @param sem_out The fit object. #' Currently supports #' [lavaan::lavaan-class] objects only. #' #' @param func A function that receives #' a lavaan object and returns a scalar. -#' Usually the output of -#' [gen_sem_out_userp()]. #' #' @param ... Optional arguments to be #' passed to `func`. @@ -394,7 +484,8 @@ ci_bound_ur_i <- function(i = NULL, #' available. #' #' @param progress Whether progress will -#' be reported on screen. Default is +#' be reported on screen during the +#' search. Default is #' `FALSE`. #' #' @param method The actual function to diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 9b8baca9..2beb8ead 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -331,10 +331,10 @@ add_func <- function(func, #' User-Defined Parameter #' #' @description Add a function to a -#' lavaan object as a user-defined +#' `lavaan` object as a user-defined #' parameter and return a function which #' can fix this user-defined parameter -#' to ba value. +#' to a value. #' #' @details #' This function is to be used internally @@ -348,7 +348,7 @@ add_func <- function(func, #' #' @param userp A function that receives #' a `lavaan` object and returns a -#' scalars. +#' scalar. #' #' @param userp_name The name of the #' function `userp` to be used in the @@ -430,10 +430,7 @@ add_func <- function(func, #' #' #' @export -# Generate a function that: -# - refits the model with the user-parameter fixed to a target value. -# CHECKED: Identical to the experimental version -# For add_fun using callr + gen_sem_out_userp <- function(userp, sem_out, userp_name = "semlbciuserp1234", @@ -441,6 +438,12 @@ gen_sem_out_userp <- function(userp, control_args = list(), iter.max = 10000, max_attempts = 5) { + + # Generate a function that: + # - refits the model with the user-parameter fixed to a target value. + # CHECKED: Identical to the experimental version + # For add_fun() using callr. + iter.max <- max(lavaan::lavInspect(sem_out, "optim")$iterations, iter.max) ptable <- lavaan::parameterTable(sem_out) diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index a3066351..f22f2b08 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -3,7 +3,7 @@ \name{ci_bound_ur} \alias{ci_bound_ur} \title{Find a Likelihood-Based -Confidence Bound By 'uniroot()'} +Confidence Bound By Root Finding} \usage{ ci_bound_ur( sem_out, @@ -29,9 +29,7 @@ Currently supports \link[lavaan:lavaan-class]{lavaan::lavaan} objects only.} \item{func}{A function that receives -a lavaan object and returns a scalar. -Usually the output of -\code{\link[=gen_sem_out_userp]{gen_sem_out_userp()}}.} +a lavaan object and returns a scalar.} \item{...}{Optional arguments to be passed to \code{func}.} @@ -53,7 +51,8 @@ method confidence interval, if available.} \item{progress}{Whether progress will -be reported on screen. Default is +be reported on screen during the +search. Default is \code{FALSE}.} \item{method}{The actual function to @@ -138,12 +137,29 @@ using \code{\link[=uniroot]{uniroot()}}. } \details{ This function is called xby -\code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}}. This function will -be exported later because it is a +\code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}}. This function is +exported later because it is a stand-alone function that can be used directly for any function that receives a lavaan object and returns a scalar. + +The function \code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}} is a +wrapper of this function, with an +interface similar to that of +\code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} and returns a +\code{cibound}-class object. The +user-parameter function is generated +internally by \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}. + +This function, on the other hand, +requires users to supply the function +directly through the \code{func} argument. +This provides the flexibility to find +the bound for any function of the +model parameter, even one that cannot +be easily coded in `lavaan`` model +syntax. } \examples{ diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index 7dd593bb..9b1e5877 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -2,7 +2,8 @@ % Please edit documentation in R/ci_bound_ur_i.R \name{ci_bound_ur_i} \alias{ci_bound_ur_i} -\title{Likelihood-based Confidence Bound For One parameter (uniroot)} +\title{Likelihood-Based Confidence +Bound By Root Finding} \usage{ ci_bound_ur_i( i = NULL, @@ -32,141 +33,210 @@ ci_bound_ur_i( ) } \arguments{ -\item{i}{The position of the target parameter as appeared in the -parameter table of a lavaan object, generated by +\item{i}{The position of the target +parameter as appeared in the +parameter table of a lavaan object, +generated by \code{\link[lavaan:lavParTable]{lavaan::parameterTable()}}.} -\item{npar}{Ignored by this function. Included for having -a unified interface.} +\item{npar}{Ignored by this function. +Included consistency in the +interface.} -\item{sem_out}{The fit object. Currently supports +\item{sem_out}{The fit object. +Currently supports \link[lavaan:lavaan-class]{lavaan::lavaan} objects only.} -\item{f_constr}{Ignored by this function. Included for having -a unified interface.} - -\item{which}{Whether the lower bound or the upper bound is to be -found. Must be \code{"lbound"} or \code{"ubound"}.} - -\item{history}{Not used. Kept for backward compatibility.} - -\item{perturbation_factor}{Ignored by this function. Included for having -a unified interface.} - -\item{lb_var}{Ignored by this function. Included for having -a unified interface.} - -\item{standardized}{If \code{TRUE}, the LBCI is for the requested -estimate in the standardized solution. Default is \code{FALSE}.} - -\item{wald_ci_start}{Ignored by this function. Included for having -a unified interface.} - -\item{opts}{Options to be passed to \code{\link[stats:uniroot]{stats::uniroot()}}. -Default is \code{list()}.} - -\item{ciperc}{The intended coverage probability for the confidence -interval. Default is .95, and the bound for a 95\% confidence -interval will be sought.} - -\item{ci_limit_ratio_tol}{The tolerance for the ratio of \code{a} to -\code{b}, where \code{a} is the distance between an LBCI limit and the point -estimate, and the \code{b} is the distance between the original -confidence limit (by default the Wald CI in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}) -and the point estimate. If the ratio is larger than this value or -smaller than the reciprocal of this value, a warning is set in the -status code. Default is 1.5.} - -\item{verbose}{If \code{TRUE}, the function will store more diagnostic -information in the attribute \code{diag}. Default is \code{FALSE}.} - -\item{sf}{Ignored by this function. Included for having -a unified interface.} - -\item{sf2}{Ignored by this function. Included for having -a unified interface.} - -\item{p_tol}{Tolerance for checking the achieved level of -confidence. If the absolute difference between the achieved level -and \code{ciperc} is greater than this amount, a warning is set in the -status code and the bound is set to \code{NA}. Default is 5e-4.} - -\item{std_method}{The method used to find the standardized -solution. If equal to \verb{"lavaan"``, [lavaan::standardizedSolution()] will be used. If equal to }"internal"\verb{, an internal function will be used. The }"lavaan"\verb{method should work in all situations, but the}"internal"\verb{method is usually much faster. Default is}"internal"`.} - -\item{bounds}{Ignored by this function. Included for having -a unified interface.} - -\item{xtol_rel_factor}{Ignored by this function. Included for having -a unified interface.} - -\item{ftol_rel_factor}{Ignored by this function. Included for having -a unified interface.} - -\item{lb_prop}{Ignored by this function. Included for having -a unified interface.} - -\item{lb_se_k}{Ignored by this function. Included for having -a unified interface.} - -\item{...}{Optional arguments. Not used.} +\item{f_constr}{Ignored by this +function. Included consistency in the +interface.} + +\item{which}{Whether the lower bound +or the upper bound is to be found. +Must be \code{"lbound"} or \code{"ubound"}.} + +\item{history}{Not used. Kept for +backward compatibility.} + +\item{perturbation_factor}{Ignored by +this function. Included consistency +in the interface.} + +\item{lb_var}{Ignored by this +function. Included consistency in the +interface.} + +\item{standardized}{If \code{TRUE}, the +LBCI is for the requested estimate in +the standardized solution. Default is +\code{FALSE}.} + +\item{wald_ci_start}{Ignored by this +function. Included consistency in the +interface.} + +\item{opts}{Options to be passed to +\code{\link[stats:uniroot]{stats::uniroot()}}. Default is +\code{list()}.} + +\item{ciperc}{The intended coverage +probability for the confidence +interval. Default is .95, and the +bound for a 95\% confidence interval +will be sought.} + +\item{ci_limit_ratio_tol}{The +tolerance for the ratio of \code{a} to +\code{b}, where \code{a} is the distance +between an LBCI limit and the point +estimate, and the \code{b} is the distance +between the original confidence limit +(by default the Wald CI in +\code{\link[lavaan:lavaan]{lavaan::lavaan()}}) and the point +estimate. If the ratio is larger than +this value or smaller than the +reciprocal of this value, a warning +is set in the status code. Default is +1.5.} + +\item{verbose}{If \code{TRUE}, the +function will store more diagnostic +information in the attribute \code{diag}. +Default is \code{FALSE}.} + +\item{sf}{Ignored by this function. +Included consistency in the +interface.} + +\item{sf2}{Ignored by this function. +Included consistency in the +interface.} + +\item{p_tol}{Tolerance for checking +the achieved level of confidence. If +the absolute difference between the +achieved level and \code{ciperc} is +greater than this amount, a warning +is set in the status code and the +bound is set to \code{NA}. Default is +5e-4.} + +\item{std_method}{The method used to +find the standardized solution. If +equal to \verb{"lavaan"``, [lavaan::standardizedSolution()] will be used. If equal to }"internal"\verb{, an internal function will be used. The }"lavaan"\verb{method should work in all situations, but the}"internal"\verb{method is usually much faster. Default is}"internal"`.} + +\item{bounds}{Ignored by this +function. Included consistency in the +interface.} + +\item{xtol_rel_factor}{Ignored by +this function. Included consistency +in the interface.} + +\item{ftol_rel_factor}{Ignored by +this function. Included consistency +in the interface.} + +\item{lb_prop}{Ignored by this +function. Included consistency in the +interface.} + +\item{lb_se_k}{Ignored by this +function. Included consistency in the +interface.} + +\item{...}{Optional arguments. Not +used.} } \value{ -A \code{cibound}-class object which is a list with three elements: +A \code{cibound}-class object +which is a list with three elements: \itemize{ -\item \code{bound}: A single number. The value of the bound located. \code{NA} is -the search failed for various reasons. -\item \code{diag}: A list of diagnostic information. +\item \code{bound}: A single number. The value +of the bound located. \code{NA} is the +search failed for various reasons. +\item \code{diag}: A list of diagnostic +information. \item \code{call}: The original call. } -A detailed and organized output can be printed by the default print +A detailed and organized output can +be printed by the default print method (\code{\link[=print.cibound]{print.cibound()}}). } \description{ -Find the lower or upper bound of the likelihood-based -confidence interval (LBCI) for one parameter in a structural -equation model fitted in \code{\link[lavaan:lavaan]{lavaan::lavaan()}} using \code{\link[=uniroot]{uniroot()}}. +Using root finding +to find the lower or +upper bound of the likelihood-based +confidence interval (LBCI) for one +parameter in a structural equation +model fitted in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. } \details{ \subsection{Important Notice}{ -This function is not supposed to be used directly by users in -typical scenarios. Its interface is user-\emph{unfriendly} because it -should be used through \code{\link[=semlbci]{semlbci()}}. It is exported such that -interested users can examine how a confidence bound is found, or -use it for experiments or simulations. +This function is not supposed to be +used directly by users in typical +scenarios. Its interface is +user-\emph{unfriendly} because it should +be used through \code{\link[=semlbci]{semlbci()}}. It is +exported such that interested users +can examine how a confidence bound is +found, or use it for experiments or +simulations. } \subsection{Usage}{ -This function is the lowest level function used by \code{\link[=semlbci]{semlbci()}}. -\code{\link[=semlbci]{semlbci()}} calls this function once for each bound of each -parameter. +This function is the lowest level +function used by \code{\link[=semlbci]{semlbci()}}. +\code{\link[=semlbci]{semlbci()}} calls this function once +for each bound of each parameter. -For consistency in the interface, most of the arguments -in \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} are also included in this function, -even those not used internally. +For consistency in the interface, +most of the arguments in +\code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} are also included +in this function, even those not used +internally. } \subsection{Algorithm}{ -This function, unlike \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}, use a simple -root finding algorithm. Basically, it try fixing the -target parameters to different values until the -likelihood ratio test \emph{p}-value is equal to the desired -value. - -This algorithm is known to be very inefficient, compared -to the one proposed by Wu and Neale (2012). It is included -as a backup algorithm for parameters which are difficult +This function, unlike +\code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}, use a simple root +finding algorithm. Basically, it tries +fixing the target parameter to +different values until the likelihood +ratio test \emph{p}-value, or the +corresponding chi-square difference, +is equal to the +value corresponding to the desired +level of confidence. (Internally, +the difference between the \emph{p}-value +and the target \emph{p}-value, that for +the chi-square difference, is the +function value.) + +For finding the bound, this algorithm +can be inefficient compared to the +one proposed by Wu and Neale (2012). +The difference can be less than +one second versus 10 seconds. +It is included as a backup algorithm +for parameters which are difficult for the method by Wu and Neale. + +Internally, it uses \code{\link[=uniroot]{uniroot()}} to +find the root. } \subsection{Limitation(s)}{ -Like \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}}, this function does not an estimate -close to an attainable bound. +This function does not handle an +estimate close to an attainable bound +using the method proposed by Wu and +Neale (2012). Use it for such +parameters with cautions. } } \examples{ @@ -192,10 +262,16 @@ out1l } \references{ -Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for a -bounded parameter. \emph{Behavior Genetics, 42}(6), 886-898. +Wu, H., & Neale, M. C. (2012). +Adjusted confidence intervals for a +bounded parameter. \emph{Behavior +Genetics, 42}(6), 886-898. \doi{10.1007/s10519-012-9560-z} } \seealso{ -\code{\link[=print.cibound]{print.cibound()}}, \code{\link[=semlbci]{semlbci()}}, \code{\link[=ci_i_one]{ci_i_one()}} +\code{\link[=print.cibound]{print.cibound()}}, +\code{\link[=semlbci]{semlbci()}}, \code{\link[=ci_i_one]{ci_i_one()}}; see +\code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} on the version +for the method by Wu and Neale +(2012). } diff --git a/man/gen_sem_out_userp.Rd b/man/gen_sem_out_userp.Rd index 2c3d6ef1..2c57b496 100644 --- a/man/gen_sem_out_userp.Rd +++ b/man/gen_sem_out_userp.Rd @@ -18,7 +18,7 @@ gen_sem_out_userp( \arguments{ \item{userp}{A function that receives a \code{lavaan} object and returns a -scalars.} +scalar.} \item{sem_out}{A \code{lavaan}-class object, to which the function will be added @@ -90,10 +90,10 @@ the user-defined parameter. } \description{ Add a function to a -lavaan object as a user-defined +\code{lavaan} object as a user-defined parameter and return a function which can fix this user-defined parameter -to ba value. +to a value. } \details{ This function is to be used internally From c58015963420429f456ad99935933eda0845963c Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:11:23 +0800 Subject: [PATCH 15/68] Remove lines changing the global environemnt Tests passed. --- R/ci_bound_ur_i_helpers.R | 68 +++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 2beb8ead..496593d3 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -185,15 +185,10 @@ gen_est_i <- function(i, #' #' @param global_ok Logical. Whether #' is the user function can be stored -#' in the global environment. Default -#' is `FALSE`. Should not be set to -#' `TRUE` unless users are pretty sure -#' it is acceptable to store the -#' function in the global environment, -#' which is the case when this function -#' is called in an R process started -#' by `callr` dedicated to running this -#' function. +#' in the global environment. This +#' option is disabled for now because +#' it is not a good practice to change +#' the global environment. #' #' @return #' A `lavaan` object, with the value @@ -213,30 +208,37 @@ sem_out_userp_run <- function(target, userp <- object$userp userp_name <- object$userp_name + # This option is disabled to avoid + # storing things to the global + # environment + global_ok <- FALSE if (global_ok) { - assign(userp_name, - value = userp, - envir = globalenv()) - out <- object$sem_out_userp(target = target, - verbose = verbose, - control = control, - seed = seed) + # Disabled for now } else { r1 <- callr::r_session$new() - r1$run(function(userp, userp_name) {assign(userp_name, - value = userp, - envir = globalenv())}, - args = list(userp = userp, - userp_name = userp_name)) - r1$run(function(x) {sem_out_userp <<- x}, - args = list(object$sem_out_userp)) - out <- r1$run(function(...) { - sem_out_userp(...) + out <- r1$run(function(target, + verbose, + control, + seed, + sem_out_userp, + userp, + userp_name) { + assign(userp_name, + value = userp, + envir = parent.frame()) + do.call(sem_out_userp, + list(target = target, + verbose = verbose, + control = control, + seed = seed)) }, args = list(target = target, verbose = verbose, control = control, - seed = seed)) + seed = seed, + sem_out_userp = object$sem_out_userp, + userp = userp, + userp_name = userp_name)) } out } @@ -309,14 +311,12 @@ add_func <- function(func, sem_out = sem_out) # Create a child process r1 <- callr::r_session$new() - # Store the function there - r1$run(function(userp, userp_name) {assign(userp_name, - value = userp, - envir = globalenv())}, - args = list(userp = userp, - userp_name = userp_name)) - # Generate sem_out_userp in the child process - fit_i <- r1$run(function(...) { + fit_i <- r1$run(function(..., + userp, + userp_name) { + assign(userp_name, + value = userp, + parent.frame()) semlbci::gen_sem_out_userp(...) }, args = list(userp = userp, sem_out = sem_out, From f30003908490b722b7428c31306309b13a08c076 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:11:39 +0800 Subject: [PATCH 16/68] Amend a test Tests passed in an interactive session --- tests/testthat/test-ur_gen_userp.R | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/tests/testthat/test-ur_gen_userp.R b/tests/testthat/test-ur_gen_userp.R index 39b55089..61a3f4e7 100644 --- a/tests/testthat/test-ur_gen_userp.R +++ b/tests/testthat/test-ur_gen_userp.R @@ -37,14 +37,12 @@ test_that("Indirect effect", { skip("To be run in an interactive session") -test_that("gen_sem_out_userp", { - userp1234 <- gen_userp(func = ind, sem_out = fit) - fit_userp <- gen_sem_out_userp(userp = userp1234, - userp_name = "userp1234", - sem_out = fit) - fit_test <- fit_userp(.12) - expect_equal(coef(fit_test, type = "user")["user"], - .12, - ignore_attr = TRUE, - tolerance = 1e-4) -}) +userp1234 <- gen_userp(func = ind, sem_out = fit) +fit_userp <- gen_sem_out_userp(userp = userp1234, + userp_name = "userp1234", + sem_out = fit) +fit_test <- fit_userp(.12) +expect_equal(coef(fit_test, type = "user")["user"], + .12, + ignore_attr = TRUE, + tolerance = 1e-4) \ No newline at end of file From e0ffa1a497f3b5540d1a57baee2abccaae499a0b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:14:29 +0800 Subject: [PATCH 17/68] Fix an R CMD check issue --- R/ci_bound_ur_i_helpers.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 496593d3..6acb4606 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -613,7 +613,11 @@ gen_sem_out_userp <- function(userp, fit_new } } else { - out <- function(...) { + # The arguments are not used in this version + out <- function(target, + verbose = FALSE, + control = list(), + seed = NULL) { # Generate a model with the user parameter added. # For debugging # Just in case ... From e335c82ed21d6819a23b7d358f35bc77b987ac68 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:14:35 +0800 Subject: [PATCH 18/68] Fix a typo --- R/loglike_at_user.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/loglike_at_user.R b/R/loglike_at_user.R index 46837702..ee47262f 100644 --- a/R/loglike_at_user.R +++ b/R/loglike_at_user.R @@ -16,7 +16,7 @@ loglik_user <- function(x, error = function(e) e, warning = function(w) w) if (inherits(lrt_x, "warning")) { - tmp <- as.character(lrt_msg) + tmp <- as.character(lrt_x) if (grepl("scaling factor is negative", tmp, fixed = TRUE)) { lrt_x <- tryCatch(lavaan::lavTestLRT(sem_out_userp_tmp, From b6c8c1c5ce59ff3145cec641ae54e413d722535a Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:25:30 +0800 Subject: [PATCH 19/68] Fix a few R CMD check issues. Tests and checks passed --- DESCRIPTION | 4 +++- R/ci_bound_ur_i.R | 10 ++++------ R/ci_bound_ur_i_helpers.R | 6 +++--- man/ci_bound_ur.Rd | 7 ++----- man/gen_sem_out_userp.Rd | 4 ++-- 5 files changed, 14 insertions(+), 17 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5a883667..8a6d381d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -44,7 +44,9 @@ Imports: ggplot2, ggrepel, rlang, - pbapply + pbapply, + callr, + methods VignetteBuilder: knitr Config/testthat/parallel: true Config/testthat/edition: 3 diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index f111420a..187ac926 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -387,9 +387,7 @@ ci_bound_ur_i <- function(i = NULL, ciperc = ciperc, ciperc_final = ciperc_final, i = i, - # TODO: - # - Remove semlbci::: - i_lor = semlbci:::get_lhs_op_rhs(i, sem_out, more = TRUE), + i_lor = get_lhs_op_rhs(i, sem_out, more = TRUE), optim_message = "Nil", # out$message optim_iterations = out$optimize_out$iter, optim_status = NA, # out$status @@ -530,11 +528,11 @@ ci_bound_ur_i <- function(i = NULL, #' Default is 1000. #' #' @param use_callr Whether the -#' [callr] package will be used to +#' `callr`` package will be used to #' do the search in a separate R #' process. Default is `TRUE`. Should -#' not set to `FALSE` if used in the -#' global environment unless this is +#' not set to `FALSE` if used in an +#' interactive environment unless this is #' intentional. #' #' @return diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 6acb4606..bf622698 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -273,7 +273,7 @@ sem_out_userp_run <- function(target, #' function (`func`) to be used in the #' `lavaan` model. Should be changed #' only if it conflicts with another -#' object in the global environment, +#' object in the parent environment, #' which should not happen if the model #' is always fitted in a clean R #' session. @@ -344,7 +344,7 @@ add_func <- function(func, #' It is exported because it needs to #' be run in an external R process, #' usually created by `callr` in other -#' functions, such as [add_func()]. +#' internal functions. #' #' @param userp A function that receives #' a `lavaan` object and returns a @@ -356,7 +356,7 @@ add_func <- function(func, #' be the name of the function in #' `userp`. Should be changed only if it #' conflicts with another object in the -#' global environment, which should not +#' parent environment, which should not #' happen if the model is always fitted #' in a clean R session. #' diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index f22f2b08..21556283 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -97,11 +97,8 @@ number of iteration in the search. Default is 1000.} \item{use_callr}{Whether the -\link{callr} package will be used to -do the search in a separate R -process. Default is \code{TRUE}. Should -not set to \code{FALSE} if used in the -global environment unless this is +\verb{callr`` package will be used to do the search in a separate R process. Default is }TRUE\verb{. Should not set to }FALSE` if used in an +interactive environment unless this is intentional.} } \value{ diff --git a/man/gen_sem_out_userp.Rd b/man/gen_sem_out_userp.Rd index 2c57b496..f3bf3f97 100644 --- a/man/gen_sem_out_userp.Rd +++ b/man/gen_sem_out_userp.Rd @@ -30,7 +30,7 @@ function \code{userp} to be used in the be the name of the function in \code{userp}. Should be changed only if it conflicts with another object in the -global environment, which should not +parent environment, which should not happen if the model is always fitted in a clean R session.} @@ -103,7 +103,7 @@ a likelihood-based confidence bound. It is exported because it needs to be run in an external R process, usually created by \code{callr} in other -functions, such as \code{\link[=add_func]{add_func()}}. +internal functions. } \examples{ From 422c81902c87581301516a6d5b987b6e19c412ac Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 16:56:21 +0800 Subject: [PATCH 20/68] Shorten some tests Tests passed. --- .../testthat/test-ur_ci_bound_ur_i_mg_std_1.R | 44 +++++++++++++ .../test-ur_ci_bound_ur_i_mg_ustd_1.R | 44 +++++++++++++ tests/testthat/test-ur_ci_bound_ur_i_std_1.R | 43 +++++++++++++ tests/testthat/test-ur_ci_bound_ur_i_ustd_1.R | 61 +++++++++++++++++++ 4 files changed, 192 insertions(+) create mode 100644 tests/testthat/test-ur_ci_bound_ur_i_mg_std_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_i_mg_ustd_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_i_std_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_i_ustd_1.R diff --git a/tests/testthat/test-ur_ci_bound_ur_i_mg_std_1.R b/tests/testthat/test-ur_ci_bound_ur_i_mg_std_1.R new file mode 100644 index 00000000..334dd200 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i_mg_std_1.R @@ -0,0 +1,44 @@ +skip_on_cran() +skip("To be run in an interactive session") + +# Ready + +library(testthat) +library(lavaan) + +HS.model_gp <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + visual ~~ c(a1, a2)*textual + adiff := a1^2' +fit_gp <- sem(HS.model_gp, data = HolzingerSwineford1939, + group = "school", + group.equal = "loadings") + +## Two groups + +test_that("ci_bound_ur: Two groups, standardized", { + +# Take more than one minute to run +# Test one bound is enough + +system.time( +ci_lb <- ci_bound_ur_i(i = 29, + sem_out = fit_gp, + which = "lbound", + standardized = TRUE) +) +# system.time( +# ci_ub <- ci_bound_ur_i(i = 29, +# sem_out = fit_gp, +# which = "ubound", +# standardized = TRUE) +# ) + +expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) +# expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_i_mg_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_i_mg_ustd_1.R new file mode 100644 index 00000000..a0ad7e2f --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i_mg_ustd_1.R @@ -0,0 +1,44 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "loadings") + +## Two groups + +test_that("ci_bound_ur: Two groups, unstandardized", { + +# Test one bound is enough + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +system.time( +ci_lb <- ci_bound_ur_i(i = 46, + sem_out = fit_gp, + which = "ubound") +) +# system.time( +# ci_ub <- ci_bound_ur_i(i = 46, +# sem_out = fit_gp, +# which = "ubound") +# ) + +expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) +# expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_i_std_1.R b/tests/testthat/test-ur_ci_bound_ur_i_std_1.R new file mode 100644 index 00000000..40ce7360 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i_std_1.R @@ -0,0 +1,43 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +# Standardized + +HS.model <- ' visual =~ x1 + x2 + d1*x3 + textual =~ x4 + x5 + d2*x6 + visual ~~ textual + d12 := d1^2' +fit <- sem(HS.model, data = HolzingerSwineford1939) + +## One group + +test_that("ci_bound_ur: One group, standardized", { + +# Take more than one minute to run +# Test one bound is enough + +system.time( +ci_lb <- ci_bound_ur_i(i = 7, + sem_out = fit, + which = "ubound", + standardized = TRUE) +) +# system.time( +# ci_ub <- ci_bound_ur_i(i = 7, +# sem_out = fit, +# which = "ubound", +# standardized = TRUE) +# ) + +expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) +# expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_i_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_i_ustd_1.R new file mode 100644 index 00000000..1023b4e1 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i_ustd_1.R @@ -0,0 +1,61 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit <- sem(HS.model, data = HolzingerSwineford1939) + +# Unstandardized + +## One group + +test_that("ci_bound_ur: One group, unstandardized", { + +# Test one bound is enough + +# system.time( +# ci_ub <- ci_bound_ur_i(i = 9, +# sem_out = fit, +# which = "lbound") +# ) +system.time( +ci_ub <- ci_bound_ur_i(i = 9, + sem_out = fit, + which = "ubound") +) +# expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) + + +# system.time( +# ci_ub <- ci_bound_ur_i(i = 25, +# sem_out = fit, +# which = "lbound") +# ) +system.time( +ci_ub <- ci_bound_ur_i(i = 25, + sem_out = fit, + which = "ubound") +) +# expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) + + +}) From 8e55810514e2ae91909e4871c0da736f7d270c3a Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 17:00:10 +0800 Subject: [PATCH 21/68] Update _pkgdown.yml --- _pkgdown.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 5507f234..44a27f85 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -67,9 +67,11 @@ reference: - contents: - ci_bound_wn_i - ci_bound_ur_i + - ci_bound_ur - ci_i_one - set_constraint - print.cibound + - gen_sem_out_userp - title: Datasets desc: Datasets used in examples. - contents: From 4d4a401390cf8cd149c25a6e28a8e4e6d4cd922f Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 18:59:06 +0800 Subject: [PATCH 22/68] Export gen_userp and fix the examples and docs Tests, checks, and build_site() passed. --- NAMESPACE | 1 + R/ci_bound_ur_i_helpers.R | 344 -------------------------- R/gen_userp.R | 491 ++++++++++++++++++++++++++++++++++++++ _pkgdown.yml | 1 + man/gen_sem_out_userp.Rd | 116 --------- man/gen_userp.Rd | 265 ++++++++++++++++++++ 6 files changed, 758 insertions(+), 460 deletions(-) create mode 100644 R/gen_userp.R delete mode 100644 man/gen_sem_out_userp.Rd create mode 100644 man/gen_userp.Rd diff --git a/NAMESPACE b/NAMESPACE index d3385611..4f7b9d6b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(ci_bound_wn_i) export(ci_i_one) export(ci_order) export(gen_sem_out_userp) +export(gen_userp) export(get_cibound) export(loglike_compare) export(loglike_point) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index bf622698..cd12ea78 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -327,347 +327,3 @@ add_func <- function(func, userp_name = userp_name) } -#' @title Generate a Function to Fix a -#' User-Defined Parameter -#' -#' @description Add a function to a -#' `lavaan` object as a user-defined -#' parameter and return a function which -#' can fix this user-defined parameter -#' to a value. -#' -#' @details -#' This function is to be used internally -#' for generating a function for searching -#' a likelihood-based confidence bound. -#' -#' It is exported because it needs to -#' be run in an external R process, -#' usually created by `callr` in other -#' internal functions. -#' -#' @param userp A function that receives -#' a `lavaan` object and returns a -#' scalar. -#' -#' @param userp_name The name of the -#' function `userp` to be used in the -#' `lavaan` model. It does not have to -#' be the name of the function in -#' `userp`. Should be changed only if it -#' conflicts with another object in the -#' parent environment, which should not -#' happen if the model is always fitted -#' in a clean R session. -#' -#' @param sem_out A `lavaan`-class object, -#' to which the function will be added -#' as a user-defined parameter. -#' -#' @param fix If `TRUE`, the default, -#' the function generated is used to fix -#' the value of `userp` to a target -#' value using an equality constraint. -#' If `FALSE`, then the function simply -#' fits the model to the data. -#' -#' @param control_args To be passed to -#' the argument of the same name in -#' [lavaan::lavaan()]. Default is -#' `list()`. Can be used to set the -#' default values of this argument -#' in the generated function. -#' -#' @param iter.max The maximum number of -#' iteration when the generated function -#' fit the model. Default is 10000. -#' -#' @param max_attempts If the initial -#' fit with the equality constraint -#' fails, how many more attempts -#' will be made by the generated -#' function. Default is 5. -#' -#' @return -#' If `fix` is `TRUE`, it returns a -#' function with these arguments: -#' -#' - `target`: The value to which the -#' user-defined parameter will be fixed -#' to. -#' -#' - `verbose`: If `TRUE`, additional -#' information will be printed when -#' fitting the model. -#' -#' - `control`: The values to be passed -#' as a list to the argument of the -#' same name in [lavaan::lavaan()]. -#' -#' - `seed`: Numeric. If supplied, it -#' will be used in [set.seed()] to -#' initialize the random number -#' generator. Necessary to reproduce -#' some results because random numbers -#' are used in some steps in `lavaan`. -#' If `NULL`, the default, [set.seed()] -#' will not be called. -#' -#' If `fix` is `FALSE, then it returns a -#' function with optional arguments that -#' will be ignored, Calling it will -#' simply fit the modified model to the -#' data. Useful for getting the value of -#' the user-defined parameter. -#' -#' -#' @examples -#' -#' # TODO: -#' # - Add an example -#' data(simple_med) -#' dat <- simple_med -#' -#' -#' @export - -gen_sem_out_userp <- function(userp, - sem_out, - userp_name = "semlbciuserp1234", - fix = TRUE, - control_args = list(), - iter.max = 10000, - max_attempts = 5) { - - # Generate a function that: - # - refits the model with the user-parameter fixed to a target value. - # CHECKED: Identical to the experimental version - # For add_fun() using callr. - - iter.max <- max(lavaan::lavInspect(sem_out, "optim")$iterations, - iter.max) - ptable <- lavaan::parameterTable(sem_out) - # Create a unique label: userp_label - labels <- unique(ptable$label) - labels <- labels[nchar(labels) > 0] - userp_label <- make.unique(c(labels, "user")) - userp_label <- userp_label[length(userp_label)] - # Generate the user parameter row using userp() - user_pt1 <- data.frame(lhs = userp_label[length(userp_label)], - op = ":=", - rhs = paste0(userp_name, "()"), - user = 1, - block = 0, - group = 0, - free = 0, - ustart = NA, - label = userp_label, - exo = 0) - user_pt1 <- lavaan::lav_partable_complete(partable = user_pt1, - start = TRUE) - # Add the user parameter to the model - ptable1 <- lavaan::lav_partable_add(partable = ptable, - add = user_pt1) - ptable1$se[which(ptable1$label == userp_label)] <- NA - - # Extract slots to be used - slot_opt <- sem_out@Options - slot_dat <- sem_out@Data - - if (fix) { - # Create the row of equality constraint - user_pt2 <- data.frame(lhs = userp_label, - op = "==", - rhs = NA, - user = 1, - block = 0, - group = 0, - free = 0, - ustart = NA, - exo = 0) - user_pt2 <- lavaan::lav_partable_complete(partable = user_pt2, - start = TRUE) - # Add the equality constraint to the parameter tahle - ptable2 <- lavaan::lav_partable_add(partable = ptable1, - add = user_pt2) - # Store the position of the constraint - i_eq <- which((ptable2$lhs == userp_label) & - (ptable2$op == "==")) - - # Fix the ids of the rows - ptable2$id <- seq_along(ptable2$id) - - # Set the options - slot_opt$do.fit <- TRUE - # The "mplus" version does not take into account the user-parameter - slot_opt$start <- "simple" - # Heywood cases are allowed - slot_opt$check.start <- FALSE - slot_opt$check.post <- FALSE - # Disable some options for efficiency - slot_opt$se <- "none" - # slot_opt$h1 <- FALSE - # slot_opt$baseline <- FALSE - - out <- function(target, - verbose = FALSE, - control = list(), - seed = NULL) { - if (!is.null(seed)) set.seed(seed) - # Just in case ... - force(control_args) - force(slot_opt) - force(slot_dat) - force(ptable2) - force(userp_label) - force(i_eq) - - ptable3 <- ptable2 - ptable3$rhs[i_eq] <- target - control_args <- utils::modifyList(control, - list(iter.max = iter.max)) - slot_opt$control <- control_args - - # Fit once to update the model slot - attempted <- 0 - fit_new_converged <- FALSE - if (verbose) { - cat("Target:", target, "\n") - } - if (verbose) { - cat("First attempt ...\n") - } - # Fail when - # eq.constraints.K is 0x0 - # Succeed when - # fit_new@Model@eq.constraints, or - # length(fit_new@Model@ceq.nonlinear.idx) > 0 - slot_opt_tmp <- slot_opt - slot_opt_tmp$do.fit <- FALSE - eq_not_ok <- TRUE - while (eq_not_ok) { - fit_new <- lavaan::lavaan(model = ptable3, - slotOptions = slot_opt_tmp, - slotData = slot_dat) - eq_not_ok <- !fit_new@Model@eq.constraints && - !(length(fit_new@Model@ceq.nonlinear.idx) > 0) - } - - # Extract the updated slots - slot_pat_new <- fit_new@ParTable - slot_model_new <- fit_new@Model - slot_smp_new <- fit_new@SampleStats - - # Fit the model with the user parameter constrained - # to the target value - fit_new <- tryCatch(lavaan::lavaan(slotParTable = slot_pat_new, - slotModel = slot_model_new, - slotSampleStats = slot_smp_new, - slotOptions = slot_opt, - slotData = slot_dat), - error = function(e) e) - if (inherits(fit_new, "error")) { - stop("Something's with the function.", - "Error occurred when fitting the modified model.") - } - - fit_new_converged <- lavaan::lavInspect(fit_new, "converged") - - # Try max_attempts more times - if (!fit_new_converged) { - if (verbose) { - cat("More attempts ...\n") - } - while (!((attempted > max_attempts) || - fit_new_converged)) { - if (verbose) {cat("Attempt", attempted, "\n")} - ptable_new <- fit_new@ParTable - i_free <- ptable_new$free > 0 - ptable_new$est[i_free] <- jitter(ptable_new$est[i_free], - factor = 50) - slot_opt$start <- as.data.frame(ptable_new) - fit_old <- fit_new - fit_new <- tryCatch(lavaan::lavaan(slotParTable = ptable_new, - slotModel = slot_model_new, - slotSampleStats = slot_smp_new, - slotOptions = slot_opt, - slotData = slot_dat), - error = function(e) e) - if (inherits(fit_new, "error")) { - fit_new <- fit_old - fit_new_converged <- FALSE - } else { - fit_new_converged <- lavaan::lavInspect(fit_new, "converged") - } - attempted <- attempted + 1 - } - } - if (!fit_new_converged) { - if (verbose) { - cat("The modified model failed to converge.") - } - } - if (verbose) { - cat("Done!\n") - } - fit_new - } - } else { - # The arguments are not used in this version - out <- function(target, - verbose = FALSE, - control = list(), - seed = NULL) { - # Generate a model with the user parameter added. - # For debugging - # Just in case ... - force(slot_opt) - force(slot_dat) - force(ptable1) - slot_opt$do.fit <- TRUE - fit_new <- lavaan::lavaan(model = ptable1, - slotOptions = slot_opt, - slotData = slot_dat) - fit_new - } - } - out - } - - - -#' @param func A function that receives a -#' `lavaan`-object and returns a scalar. -#' -#' @param sem_out A `lavaan`-class object. -#' -#' @return -#' `gen_userp()` returns a function that -#' accepts a numeric vector of length -#' equals to the number of free parameters -#' in `sem_out`, and returns a scalar -#' which is the output of `func`. -#' -#' @noRd -# CHECKED: Identical to the experimental version -gen_userp <- function(func, - sem_out) { - stopifnot(is.function(func)) - stopifnot(inherits(sem_out, "lavaan")) - out <- function(.x., ...) { - if (missing(.x.)) { - .x. <- get(".x.", parent.frame()) - } - # Just in case ... - force(sem_out) - - sem_out@Model <- lavaan::lav_model_set_parameters(sem_out@Model, .x.) - sem_out@implied <- lavaan::lav_model_implied(sem_out@Model) - f0 <- func(sem_out) - if (is.na(f0) || is.nan(f0)) { - f0 <- Inf - } - f0 - } - out - } \ No newline at end of file diff --git a/R/gen_userp.R b/R/gen_userp.R new file mode 100644 index 00000000..235e783e --- /dev/null +++ b/R/gen_userp.R @@ -0,0 +1,491 @@ +#' @title Create a Wrapper To Be Used +#' in 'lavaan' Models +#' +#' @description Make a function on +#' `lavaan` object usable in a `lavaan` +#' model syntax. +#' +#' @details +#' +#' ## `gen_userp` +#' +#' There are cases in which we want to +#' create a user parameter which is a +#' function of other free parameters, +#' computed by a function. However such +#' a function may work only on a +#' `lavaan` object. +#' +#' If the target function works by +#' extracting parameter estimates stored +#' in the `Model` slot and/or the +#' `implied` slot, then [gen_userp()] +#' can be used to convert it to a +#' function that retrieves the parameter +#' estimates when being called by +#' [lavaan::lavaan()] or its wrappers, +#' modifies the stored +#' `lavaan` object using +#' [lavaan::lav_model_set_parameters()] +#' and [lavaan::lav_model_implied()] to +#' change the estimates, and call the +#' target function. +#' +#' Note that this is an unconventional +#' way to define a user parameter and +#' the generated function should always +#' be checked to see whether it works as +#' expected. +#' +#' As shown in the examples, the +#' parameter computed this may not +#' have standard error nor *p*-value. +#' +#' The main purpose is for the point +#' estimate, for searching the +#' likelihood-based confidence bound +#' using [ci_bound_ur()] and +#' [ci_bound_ur_i()]. +#' +#' Note that the target function +#' specified in `func` should work +#' directly on the parameter estimates +#' stored in the `Model` slot and then +#' get the estimates using +#' [lavaan::lav_model_get_parameters()]. +#' Functions that work on the unmodified +#' output generated by +#' [lavaan::lavaan()] usually do not +#' work. +#' +#' Users are not recommended to use +#' [gen_userp()] and [gen_sem_out_userp()] +#' directly because they require +#' unconventional way to extract +#' parameter estimates from a lavaan +#' model. However, developers may use +#' them to include functions +#' they wrote in a lavaan model. This +#' is the technique used by +#' [ci_bound_ur_i()] to constrain any +#' parameter in a model to an arbitrary +#' value. +#' +#' @param func A function that receives a +#' `lavaan`-object and returns a scalar. +#' See Details on the restriction on this +#' function. +#' +#' @param sem_out A `lavaan`-class object +#' to be modified. +#' +#' @return +#' +#' ## `gen_userp` +#' +#' It returns a function that +#' accepts a numeric vector of length +#' equals to the number of free parameters +#' in `sem_out`, and returns a scalar +#' which is the output of `func`. If this +#' vector is not supplied, it will try to +#' find it in the `parent.frame()`. This +#' is how it works inside a `lavaan` +#' model. +#' +#' @examples +#' +#' library(lavaan) +#' +#' data(simple_med) +#' dat <- simple_med +#' mod <- +#' " +#' m ~ a*x +#' y ~ b*m +#' ab := a*b +#' " +#' fit_med <- sem(mod, simple_med, fixed.x = FALSE) +#' parameterEstimates(fit_med) +#' +#' # A trivial example for verifying the results +#' my_ab <- function(object) { +#' # Need to use lav_model_get_parameters() +#' # because the object is only a modified +#' # lavaan-object, not one directly +#' # generated by lavaan function +#' est <- lavaan::lav_model_get_parameters(object@Model, type = "user") +#' unname(est[1] * est[2]) +#' } +#' +#' # Check the function +#' my_ab(fit_med) +#' coef(fit_med, type = "user")["ab"] +#' +#' # Create the function +#' my_userp <- gen_userp(func = my_ab, +#' sem_out = fit_med) +#' # Try it on the vector of free parameters +#' my_userp(coef(fit_med)) +#' +#' # Generate a modified lavaan model +#' fit_userp <- gen_sem_out_userp(userp = my_userp, +#' userp_name = "my_userp", +#' sem_out = fit_med) +#' +#' # This function can then be used in the model syntax. +#' +#' # Note that the following example only work when called inside the +#' # workspace or inside other functions such as ci_bound_ur()` +#' # and `ci_bound_ur_i()` because `lavaan::sem()` will +#' # search `my_userp()` in the global environment. +#' +#' # Therefore, the following lines are commented out. +#' # They should be run only in a "TRUE" interactive +#' # session. +#' +#' # mod2 <- +#' # " +#' # m ~ x +#' # y ~ m +#' # ab := my_userp() +#' # " +#' # fit_med2 <- sem(mod2, simple_med, fixed.x = FALSE) +#' # parameterEstimates(fit_med2) +#' # +#' # # Fit the model with the output of the function, a*b +#' # # fixed to .50 +#' # +#' # fit_new <- fit_userp(.50) +#' # +#' # # Check if the parameter ab is fixed to .50 +#' # parameterEstimates(fit_new) +#' +#' +#' @rdname gen_userp +#' +#' @export + +gen_userp <- function(func, + sem_out) { + stopifnot(is.function(func)) + stopifnot(inherits(sem_out, "lavaan")) + out <- function(.x., ...) { + if (missing(.x.)) { + .x. <- get(".x.", parent.frame()) + } + # Just in case ... + force(sem_out) + + sem_out@Model <- lavaan::lav_model_set_parameters(sem_out@Model, .x.) + sem_out@implied <- lavaan::lav_model_implied(sem_out@Model) + f0 <- func(sem_out) + if (is.na(f0) || is.nan(f0)) { + f0 <- Inf + } + f0 + } + out + } + +# @title Generate a Function to Fix a +# User-Defined Parameter +# +# @description Add a function to a +# `lavaan` object as a user-defined +# parameter and return a function which +# can fix this user-defined parameter +# to a value. +# +#' @details +#' +#' ## `gen_sem_out_userp` +#' +#' The function [gen_sem_out_userp()] +#' is to be used internally +#' for generating a function for searching +#' a likelihood-based confidence bound. +#' It is exported because it needs to +#' be run in an fresh external R process, +#' usually created by `callr` in other +#' internal functions. +#' +#' @param userp A function that is +#' generated by [gen_userp()]. +#' +#' @param userp_name The name of the +#' function `userp` to be used in the +#' `lavaan` model. It does not have to +#' be the name of the function in +#' `userp`. Should be changed only if it +#' conflicts with another object in the +#' parent environment, which should not +#' happen if the model is always fitted +#' in a clean R session. +#' +#' @param fix If `TRUE`, the default, +#' the function generated is used to fix +#' the value of `userp` to a target +#' value using an equality constraint. +#' If `FALSE`, then the function simply +#' fits the model to the data. +#' +#' @param control_args To be passed to +#' the argument of the same name in +#' [lavaan::lavaan()]. Default is +#' `list()`. Can be used to set the +#' default values of this argument +#' in the generated function. +#' +#' @param iter.max The maximum number of +#' iteration when the generated function +#' fit the model. Default is 10000. +#' +#' @param max_attempts If the initial +#' fit with the equality constraint +#' fails, how many more attempts +#' will be made by the generated +#' function. Default is 5. +#' +#' @return +#' +#' ## `gen_sem_out_userp` +#' +#' If `fix` is `TRUE`, it returns a +#' function with these arguments: +#' +#' - `target`: The value to which the +#' user-defined parameter will be fixed +#' to. +#' +#' - `verbose`: If `TRUE`, additional +#' information will be printed when +#' fitting the model. +#' +#' - `control`: The values to be passed +#' as a list to the argument of the +#' same name in [lavaan::lavaan()]. +#' +#' - `seed`: Numeric. If supplied, it +#' will be used in [set.seed()] to +#' initialize the random number +#' generator. Necessary to reproduce +#' some results because random numbers +#' are used in some steps in `lavaan`. +#' If `NULL`, the default, [set.seed()] +#' will not be called. +#' +#' If `fix` is `FALSE, then it returns a +#' function with optional arguments that +#' will be ignored, Calling it will +#' simply fit the modified model to the +#' data. Useful for getting the value of +#' the user-defined parameter. +#' +#' @rdname gen_userp +#' +#' @export + +gen_sem_out_userp <- function(userp, + sem_out, + userp_name = "semlbciuserp1234", + fix = TRUE, + control_args = list(), + iter.max = 10000, + max_attempts = 5) { + + # Generate a function that: + # - refits the model with the user-parameter fixed to a target value. + # CHECKED: Identical to the experimental version + # For add_fun() using callr. + + iter.max <- max(lavaan::lavInspect(sem_out, "optim")$iterations, + iter.max) + ptable <- lavaan::parameterTable(sem_out) + # Create a unique label: userp_label + labels <- unique(ptable$label) + labels <- labels[nchar(labels) > 0] + userp_label <- make.unique(c(labels, "user")) + userp_label <- userp_label[length(userp_label)] + # Generate the user parameter row using userp() + user_pt1 <- data.frame(lhs = userp_label[length(userp_label)], + op = ":=", + rhs = paste0(userp_name, "()"), + user = 1, + block = 0, + group = 0, + free = 0, + ustart = NA, + label = userp_label, + exo = 0) + user_pt1 <- lavaan::lav_partable_complete(partable = user_pt1, + start = TRUE) + # Add the user parameter to the model + ptable1 <- lavaan::lav_partable_add(partable = ptable, + add = user_pt1) + ptable1$se[which(ptable1$label == userp_label)] <- NA + + # Extract slots to be used + slot_opt <- sem_out@Options + slot_dat <- sem_out@Data + + if (fix) { + # Create the row of equality constraint + user_pt2 <- data.frame(lhs = userp_label, + op = "==", + rhs = NA, + user = 1, + block = 0, + group = 0, + free = 0, + ustart = NA, + exo = 0) + user_pt2 <- lavaan::lav_partable_complete(partable = user_pt2, + start = TRUE) + # Add the equality constraint to the parameter tahle + ptable2 <- lavaan::lav_partable_add(partable = ptable1, + add = user_pt2) + # Store the position of the constraint + i_eq <- which((ptable2$lhs == userp_label) & + (ptable2$op == "==")) + + # Fix the ids of the rows + ptable2$id <- seq_along(ptable2$id) + + # Set the options + slot_opt$do.fit <- TRUE + # The "mplus" version does not take into account the user-parameter + slot_opt$start <- "simple" + # Heywood cases are allowed + slot_opt$check.start <- FALSE + slot_opt$check.post <- FALSE + # Disable some options for efficiency + slot_opt$se <- "none" + # slot_opt$h1 <- FALSE + # slot_opt$baseline <- FALSE + + out <- function(target, + verbose = FALSE, + control = list(), + seed = NULL) { + if (!is.null(seed)) set.seed(seed) + # Just in case ... + force(control_args) + force(slot_opt) + force(slot_dat) + force(ptable2) + force(userp_label) + force(i_eq) + + ptable3 <- ptable2 + ptable3$rhs[i_eq] <- target + control_args <- utils::modifyList(control, + list(iter.max = iter.max)) + slot_opt$control <- control_args + + # Fit once to update the model slot + attempted <- 0 + fit_new_converged <- FALSE + if (verbose) { + cat("Target:", target, "\n") + } + if (verbose) { + cat("First attempt ...\n") + } + # Fail when + # eq.constraints.K is 0x0 + # Succeed when + # fit_new@Model@eq.constraints, or + # length(fit_new@Model@ceq.nonlinear.idx) > 0 + slot_opt_tmp <- slot_opt + slot_opt_tmp$do.fit <- FALSE + eq_not_ok <- TRUE + while (eq_not_ok) { + fit_new <- lavaan::lavaan(model = ptable3, + slotOptions = slot_opt_tmp, + slotData = slot_dat) + eq_not_ok <- !fit_new@Model@eq.constraints && + !(length(fit_new@Model@ceq.nonlinear.idx) > 0) + } + + # Extract the updated slots + slot_pat_new <- fit_new@ParTable + slot_model_new <- fit_new@Model + slot_smp_new <- fit_new@SampleStats + + # Fit the model with the user parameter constrained + # to the target value + fit_new <- tryCatch(lavaan::lavaan(slotParTable = slot_pat_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat), + error = function(e) e) + if (inherits(fit_new, "error")) { + stop("Something's with the function.", + "Error occurred when fitting the modified model.") + } + + fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + + # Try max_attempts more times + if (!fit_new_converged) { + if (verbose) { + cat("More attempts ...\n") + } + while (!((attempted > max_attempts) || + fit_new_converged)) { + if (verbose) {cat("Attempt", attempted, "\n")} + ptable_new <- fit_new@ParTable + i_free <- ptable_new$free > 0 + ptable_new$est[i_free] <- jitter(ptable_new$est[i_free], + factor = 50) + slot_opt$start <- as.data.frame(ptable_new) + fit_old <- fit_new + fit_new <- tryCatch(lavaan::lavaan(slotParTable = ptable_new, + slotModel = slot_model_new, + slotSampleStats = slot_smp_new, + slotOptions = slot_opt, + slotData = slot_dat), + error = function(e) e) + if (inherits(fit_new, "error")) { + fit_new <- fit_old + fit_new_converged <- FALSE + } else { + fit_new_converged <- lavaan::lavInspect(fit_new, "converged") + } + attempted <- attempted + 1 + } + } + if (!fit_new_converged) { + if (verbose) { + cat("The modified model failed to converge.") + } + } + if (verbose) { + cat("Done!\n") + } + fit_new + } + } else { + # The arguments are not used in this version + out <- function(target, + verbose = FALSE, + control = list(), + seed = NULL) { + # Generate a model with the user parameter added. + # For debugging + # Just in case ... + force(slot_opt) + force(slot_dat) + force(ptable1) + slot_opt$do.fit <- TRUE + fit_new <- lavaan::lavaan(model = ptable1, + slotOptions = slot_opt, + slotData = slot_dat) + fit_new + } + } + out + } + diff --git a/_pkgdown.yml b/_pkgdown.yml index 44a27f85..debf77a0 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -72,6 +72,7 @@ reference: - set_constraint - print.cibound - gen_sem_out_userp + - gen_userp - title: Datasets desc: Datasets used in examples. - contents: diff --git a/man/gen_sem_out_userp.Rd b/man/gen_sem_out_userp.Rd deleted file mode 100644 index f3bf3f97..00000000 --- a/man/gen_sem_out_userp.Rd +++ /dev/null @@ -1,116 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ci_bound_ur_i_helpers.R -\name{gen_sem_out_userp} -\alias{gen_sem_out_userp} -\title{Generate a Function to Fix a -User-Defined Parameter} -\usage{ -gen_sem_out_userp( - userp, - sem_out, - userp_name = "semlbciuserp1234", - fix = TRUE, - control_args = list(), - iter.max = 10000, - max_attempts = 5 -) -} -\arguments{ -\item{userp}{A function that receives -a \code{lavaan} object and returns a -scalar.} - -\item{sem_out}{A \code{lavaan}-class object, -to which the function will be added -as a user-defined parameter.} - -\item{userp_name}{The name of the -function \code{userp} to be used in the -\code{lavaan} model. It does not have to -be the name of the function in -\code{userp}. Should be changed only if it -conflicts with another object in the -parent environment, which should not -happen if the model is always fitted -in a clean R session.} - -\item{fix}{If \code{TRUE}, the default, -the function generated is used to fix -the value of \code{userp} to a target -value using an equality constraint. -If \code{FALSE}, then the function simply -fits the model to the data.} - -\item{control_args}{To be passed to -the argument of the same name in -\code{\link[lavaan:lavaan]{lavaan::lavaan()}}. Default is -\code{list()}. Can be used to set the -default values of this argument -in the generated function.} - -\item{iter.max}{The maximum number of -iteration when the generated function -fit the model. Default is 10000.} - -\item{max_attempts}{If the initial -fit with the equality constraint -fails, how many more attempts -will be made by the generated -function. Default is 5.} -} -\value{ -If \code{fix} is \code{TRUE}, it returns a -function with these arguments: -\itemize{ -\item \code{target}: The value to which the -user-defined parameter will be fixed -to. -\item \code{verbose}: If \code{TRUE}, additional -information will be printed when -fitting the model. -\item \code{control}: The values to be passed -as a list to the argument of the -same name in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. -\item \code{seed}: Numeric. If supplied, it -will be used in \code{\link[=set.seed]{set.seed()}} to -initialize the random number -generator. Necessary to reproduce -some results because random numbers -are used in some steps in \code{lavaan}. -If \code{NULL}, the default, \code{\link[=set.seed]{set.seed()}} -will not be called. -} - -If \code{fix} is `FALSE, then it returns a -function with optional arguments that -will be ignored, Calling it will -simply fit the modified model to the -data. Useful for getting the value of -the user-defined parameter. -} -\description{ -Add a function to a -\code{lavaan} object as a user-defined -parameter and return a function which -can fix this user-defined parameter -to a value. -} -\details{ -This function is to be used internally -for generating a function for searching -a likelihood-based confidence bound. - -It is exported because it needs to -be run in an external R process, -usually created by \code{callr} in other -internal functions. -} -\examples{ - -# TODO: -# - Add an example -data(simple_med) -dat <- simple_med - - -} diff --git a/man/gen_userp.Rd b/man/gen_userp.Rd new file mode 100644 index 00000000..3c07ce98 --- /dev/null +++ b/man/gen_userp.Rd @@ -0,0 +1,265 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gen_userp.R +\name{gen_userp} +\alias{gen_userp} +\alias{gen_sem_out_userp} +\title{Create a Wrapper To Be Used +in 'lavaan' Models} +\usage{ +gen_userp(func, sem_out) + +gen_sem_out_userp( + userp, + sem_out, + userp_name = "semlbciuserp1234", + fix = TRUE, + control_args = list(), + iter.max = 10000, + max_attempts = 5 +) +} +\arguments{ +\item{func}{A function that receives a +\code{lavaan}-object and returns a scalar. +See Details on the restriction on this +function.} + +\item{sem_out}{A \code{lavaan}-class object +to be modified.} + +\item{userp}{A function that is +generated by \code{\link[=gen_userp]{gen_userp()}}.} + +\item{userp_name}{The name of the +function \code{userp} to be used in the +\code{lavaan} model. It does not have to +be the name of the function in +\code{userp}. Should be changed only if it +conflicts with another object in the +parent environment, which should not +happen if the model is always fitted +in a clean R session.} + +\item{fix}{If \code{TRUE}, the default, +the function generated is used to fix +the value of \code{userp} to a target +value using an equality constraint. +If \code{FALSE}, then the function simply +fits the model to the data.} + +\item{control_args}{To be passed to +the argument of the same name in +\code{\link[lavaan:lavaan]{lavaan::lavaan()}}. Default is +\code{list()}. Can be used to set the +default values of this argument +in the generated function.} + +\item{iter.max}{The maximum number of +iteration when the generated function +fit the model. Default is 10000.} + +\item{max_attempts}{If the initial +fit with the equality constraint +fails, how many more attempts +will be made by the generated +function. Default is 5.} +} +\value{ +\subsection{\code{gen_userp}}{ + +It returns a function that +accepts a numeric vector of length +equals to the number of free parameters +in \code{sem_out}, and returns a scalar +which is the output of \code{func}. If this +vector is not supplied, it will try to +find it in the \code{parent.frame()}. This +is how it works inside a \code{lavaan} +model. +} + +\subsection{\code{gen_sem_out_userp}}{ + +If \code{fix} is \code{TRUE}, it returns a +function with these arguments: +\itemize{ +\item \code{target}: The value to which the +user-defined parameter will be fixed +to. +\item \code{verbose}: If \code{TRUE}, additional +information will be printed when +fitting the model. +\item \code{control}: The values to be passed +as a list to the argument of the +same name in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. +\item \code{seed}: Numeric. If supplied, it +will be used in \code{\link[=set.seed]{set.seed()}} to +initialize the random number +generator. Necessary to reproduce +some results because random numbers +are used in some steps in \code{lavaan}. +If \code{NULL}, the default, \code{\link[=set.seed]{set.seed()}} +will not be called. +} + +If \code{fix} is `FALSE, then it returns a +function with optional arguments that +will be ignored, Calling it will +simply fit the modified model to the +data. Useful for getting the value of +the user-defined parameter. +} +} +\description{ +Make a function on +\code{lavaan} object usable in a \code{lavaan} +model syntax. +} +\details{ +\subsection{\code{gen_userp}}{ + +There are cases in which we want to +create a user parameter which is a +function of other free parameters, +computed by a function. However such +a function may work only on a +\code{lavaan} object. + +If the target function works by +extracting parameter estimates stored +in the \code{Model} slot and/or the +\code{implied} slot, then \code{\link[=gen_userp]{gen_userp()}} +can be used to convert it to a +function that retrieves the parameter +estimates when being called by +\code{\link[lavaan:lavaan]{lavaan::lavaan()}} or its wrappers, +modifies the stored +\code{lavaan} object using +\code{\link[lavaan:lav_model]{lavaan::lav_model_set_parameters()}} +and \code{\link[lavaan:lav_model]{lavaan::lav_model_implied()}} to +change the estimates, and call the +target function. + +Note that this is an unconventional +way to define a user parameter and +the generated function should always +be checked to see whether it works as +expected. + +As shown in the examples, the +parameter computed this may not +have standard error nor \emph{p}-value. + +The main purpose is for the point +estimate, for searching the +likelihood-based confidence bound +using \code{\link[=ci_bound_ur]{ci_bound_ur()}} and +\code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}}. + +Note that the target function +specified in \code{func} should work +directly on the parameter estimates +stored in the \code{Model} slot and then +get the estimates using +\code{\link[lavaan:lav_model]{lavaan::lav_model_get_parameters()}}. +Functions that work on the unmodified +output generated by +\code{\link[lavaan:lavaan]{lavaan::lavaan()}} usually do not +work. + +Users are not recommended to use +\code{\link[=gen_userp]{gen_userp()}} and \code{\link[=gen_sem_out_userp]{gen_sem_out_userp()}} +directly because they require +unconventional way to extract +parameter estimates from a lavaan +model. However, developers may use +them to include functions +they wrote in a lavaan model. This +is the technique used by +\code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}} to constrain any +parameter in a model to an arbitrary +value. +} + +\subsection{\code{gen_sem_out_userp}}{ + +The function \code{\link[=gen_sem_out_userp]{gen_sem_out_userp()}} +is to be used internally +for generating a function for searching +a likelihood-based confidence bound. +It is exported because it needs to +be run in an fresh external R process, +usually created by \code{callr} in other +internal functions. +} +} +\examples{ + +library(lavaan) + +data(simple_med) +dat <- simple_med +mod <- +" +m ~ a*x +y ~ b*m +ab := a*b +" +fit_med <- sem(mod, simple_med, fixed.x = FALSE) +parameterEstimates(fit_med) + +# A trivial example for verifying the results +my_ab <- function(object) { + # Need to use lav_model_get_parameters() + # because the object is only a modified + # lavaan-object, not one directly + # generated by lavaan function + est <- lavaan::lav_model_get_parameters(object@Model, type = "user") + unname(est[1] * est[2]) + } + +# Check the function +my_ab(fit_med) +coef(fit_med, type = "user")["ab"] + +# Create the function +my_userp <- gen_userp(func = my_ab, + sem_out = fit_med) +# Try it on the vector of free parameters +my_userp(coef(fit_med)) + +# Generate a modified lavaan model +fit_userp <- gen_sem_out_userp(userp = my_userp, + userp_name = "my_userp", + sem_out = fit_med) + +# This function can then be used in the model syntax. + +# Note that the following example only work when called inside the +# workspace or inside other functions such as ci_bound_ur()` +# and `ci_bound_ur_i()` because `lavaan::sem()` will +# search `my_userp()` in the global environment. + +# Therefore, the following lines are commented out. +# They should be run only in a "TRUE" interactive +# session. + +# mod2 <- +# " +# m ~ x +# y ~ m +# ab := my_userp() +# " +# fit_med2 <- sem(mod2, simple_med, fixed.x = FALSE) +# parameterEstimates(fit_med2) +# +# # Fit the model with the output of the function, a*b +# # fixed to .50 +# +# fit_new <- fit_userp(.50) +# +# # Check if the parameter ab is fixed to .50 +# parameterEstimates(fit_new) + + +} From b093fe2d2d43069ac63103adb812d8ca5a958f08 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 19:21:17 +0800 Subject: [PATCH 23/68] Update the example of ci_bound_ur Tests, checks, and build_site() passed. --- NAMESPACE | 1 + R/ci_bound_ur_i.R | 134 +++++++++++++++++++++++++++++++++----- R/ci_bound_ur_i_helpers.R | 68 ------------------- man/ci_bound_ur.Rd | 59 +++++++++++++---- man/ci_bound_ur_i.Rd | 6 +- 5 files changed, 166 insertions(+), 102 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4f7b9d6b..b3fd228a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ export(ci_bound_ur_i) export(ci_bound_wn_i) export(ci_i_one) export(ci_order) +export(gen_est_i) export(gen_sem_out_userp) export(gen_userp) export(get_cibound) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 187ac926..a07bb4ac 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -226,9 +226,7 @@ #' #' @examples #' -#' # TODO: -#' # - Update the example -#' +#' library(lavaan) #' data(simple_med) #' dat <- simple_med #' @@ -238,7 +236,7 @@ #' y ~ m #' " #' -#' fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) +#' fit_med <- sem(mod, simple_med, fixed.x = FALSE) #' #' out1l <- ci_bound_ur_i(i = 1, #' sem_out = fit_med, @@ -432,7 +430,7 @@ ci_bound_ur_i <- function(i = NULL, #' @details #' This function is called xby #' [ci_bound_ur_i()]. This function is -#' exported later because it is a +#' exported because it is a #' stand-alone function that can be used #' directly for any function that #' receives a lavaan object and returns @@ -461,9 +459,16 @@ ci_bound_ur_i <- function(i = NULL, #' #' @param func A function that receives #' a lavaan object and returns a scalar. +#' This function is to be used by +#' [gen_userp()] and so there are +#' special requirements on it. +#' Alternatively, it can be the output +#' of [gen_est_i()]. #' #' @param ... Optional arguments to be -#' passed to `func`. +#' passed to `func`. Usually not used +#' but included in case the function +#' has such arguments. #' #' @param level The level of confidence #' of the confidence interval. Default @@ -536,7 +541,8 @@ ci_bound_ur_i <- function(i = NULL, #' intentional. #' #' @return -#' A list with the following elements: +#' The function [ci_bound_ur()] returns +#' a list with the following elements: #' #' - `bound`: The bound found. #' @@ -562,28 +568,33 @@ ci_bound_ur_i <- function(i = NULL, #' user-defined parameter when #' determining the interval internally. #' -#' #' @examples #' -#' # TODO: -#' # - Update the example -#' +#' library(lavaan) #' data(simple_med) #' dat <- simple_med -#' #' mod <- #' " #' m ~ x #' y ~ m #' " -#' #' fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) -#' -#' out1l <- ci_bound_ur_i(i = 1, -#' sem_out = fit_med, -#' which = "lbound") +#' parameterTable(fit_med) + +#' # Create a function to get the second parameter +#' est_i <- gen_est_i(i = 2, sem_out = fit_med) + +#' # Find the lower bound of the likelihood-based confidence interval +#' # of the second parameter. +#' # user_callr should be TRUE or omitted in read research. +#' out1l <- ci_bound_ur(sem_out = fit_med, +#' func = est_i, +#' which = "lbound", +#' use_callr = FALSE) #' out1l #' +#' @rdname ci_bound_ur +#' #' @export ci_bound_ur <- function(sem_out, @@ -756,3 +767,92 @@ ci_bound_ur <- function(sem_out, user_est = user_est) out } + +#' @param i The position of the target +#' parameter as appeared in the +#' parameter table of an lavaan object, +#' generated by +#' [lavaan::parameterTable()]. +#' +#' @param standardized If `TRUE`, the +#' standardized estimate is to be +#' retrieved. Default is `FALSE`. +#' Only support `"std.all"` for now. +#' +#' @return +#' The function [gen_est_i()] returns +#' a special function can inspects the +#' `Model` slot (and `implied` slot +#' if necessary) of a modified `lavaan` +#' object and return the parameter +#' estimate. This function is to be used +#' by [ci_bound_ur()] or +#' [gen_sem_out_userp()]. +#' +#' @rdname ci_bound_ur +#' +#' @export + +gen_est_i <- function(i, + sem_out, + standardized = FALSE) { + ptable <- lavaan::parameterTable(sem_out) + # i_user <- (ptable$free > 0) | (ptable$user > 0) + # i_est <- which(which(i_user) == i) + # From the help page of lavaan-class object, + # type = "user" should return *all* parameters + # in the parameter table, including equality constraints. + # Therefore, the row number should be equal to the order + # in the vector of coefficients. + i_user <- i + i_est <- i + is_def <- (ptable$op[i] == ":=") + i_lhs <- (ptable$lhs[i]) + i_rhs <- (ptable$rhs[i]) + i_op <- ptable$op[i] + i_gp <- ptable$group[i] + if (standardized) { + if (is_def) { + out <- function(object) { + # Just in case + force(i_est) + std <- lavaan::standardizedSolution(object, + est = lavaan::lav_model_get_parameters(object@Model, type = "user"), + GLIST = object@Model@GLIST, + se = FALSE, + zstat = FALSE, + pvalue = FALSE, + ci = FALSE, + remove.eq = FALSE, + remove.ineq = FALSE, + remove.def = FALSE, + type = "std.all") + unname(std[i_est, "est.std"]) + } + } else { + out <- function(object) { + # Just in case + force(i_est) + force(i_gp) + force(i_op) + force(i_lhs) + force(i_rhs) + object@implied <- lavaan::lav_model_implied(object@Model) + est <- lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est] + implied <- lavaan::lavInspect(object, "cov.all", drop.list.single.group = FALSE) + implied_sd <- sqrt(diag(implied[[i_gp]])) + est1 <- switch(i_op, + `~~` = est / (implied_sd[i_lhs] * implied_sd[i_rhs]), + `~` = est * implied_sd[i_rhs] / implied_sd[i_lhs], + `=~` = est * implied_sd[i_lhs] / implied_sd[i_rhs]) + unname(est1) + } + } + } else { + out <- function(object) { + force(i_est) + unname(lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est]) + } + } + return(out) + } diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index cd12ea78..3fe06f9d 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -78,74 +78,6 @@ uniroot_interval <- function(sem_out, return(out) } -#' @noRd -# Generate a function to extract a parameter -# To be used by [ci_bound_ur_i()]. -# CHECKED: Reverted to the experimental version -gen_est_i <- function(i, - sem_out, - standardized = FALSE) { - ptable <- lavaan::parameterTable(sem_out) - # i_user <- (ptable$free > 0) | (ptable$user > 0) - # i_est <- which(which(i_user) == i) - # From the help page of lavaan-class object, - # type = "user" should return *all* parameters - # in the parameter table, including equality constraints. - # Therefore, the row number should be equal to the order - # in the vector of coefficients. - i_user <- i - i_est <- i - is_def <- (ptable$op[i] == ":=") - i_lhs <- (ptable$lhs[i]) - i_rhs <- (ptable$rhs[i]) - i_op <- ptable$op[i] - i_gp <- ptable$group[i] - if (standardized) { - if (is_def) { - out <- function(object) { - # Just in case - force(i_est) - std <- lavaan::standardizedSolution(object, - est = lavaan::lav_model_get_parameters(object@Model, type = "user"), - GLIST = object@Model@GLIST, - se = FALSE, - zstat = FALSE, - pvalue = FALSE, - ci = FALSE, - remove.eq = FALSE, - remove.ineq = FALSE, - remove.def = FALSE, - type = "std.all") - unname(std[i_est, "est.std"]) - } - } else { - out <- function(object) { - # Just in case - force(i_est) - force(i_gp) - force(i_op) - force(i_lhs) - force(i_rhs) - object@implied <- lavaan::lav_model_implied(object@Model) - est <- lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est] - implied <- lavaan::lavInspect(object, "cov.all", drop.list.single.group = FALSE) - implied_sd <- sqrt(diag(implied[[i_gp]])) - est1 <- switch(i_op, - `~~` = est / (implied_sd[i_lhs] * implied_sd[i_rhs]), - `~` = est * implied_sd[i_rhs] / implied_sd[i_lhs], - `=~` = est * implied_sd[i_lhs] / implied_sd[i_rhs]) - unname(est1) - } - } - } else { - out <- function(object) { - force(i_est) - unname(lavaan::lav_model_get_parameters(object@Model, type = "user")[i_est]) - } - } - return(out) - } - #' @title Fix a User Parameter To a #' Value and Refit a Model diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index 21556283..757e063a 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/ci_bound_ur_i.R \name{ci_bound_ur} \alias{ci_bound_ur} +\alias{gen_est_i} \title{Find a Likelihood-Based Confidence Bound By Root Finding} \usage{ @@ -22,6 +23,8 @@ ci_bound_ur( uniroot_maxiter = 1000, use_callr = TRUE ) + +gen_est_i(i, sem_out, standardized = FALSE) } \arguments{ \item{sem_out}{The fit object. @@ -29,10 +32,17 @@ Currently supports \link[lavaan:lavaan-class]{lavaan::lavaan} objects only.} \item{func}{A function that receives -a lavaan object and returns a scalar.} +a lavaan object and returns a scalar. +This function is to be used by +\code{\link[=gen_userp]{gen_userp()}} and so there are +special requirement on it. +Alternatively, it can be the output +of \code{\link[=gen_est_i]{gen_est_i()}}.} \item{...}{Optional arguments to be -passed to \code{func}.} +passed to \code{func}. Usually not used +but included in case the function +has such arguments.} \item{level}{The level of confidence of the confidence interval. Default @@ -100,9 +110,21 @@ Default is 1000.} \verb{callr`` package will be used to do the search in a separate R process. Default is }TRUE\verb{. Should not set to }FALSE` if used in an interactive environment unless this is intentional.} + +\item{i}{The position of the target +parameter as appeared in the +parameter table of an lavaan object, +generated by +\code{\link[lavaan:lavParTable]{lavaan::parameterTable()}}.} + +\item{standardized}{If \code{TRUE}, the +standardized estimate is to be +retrieved. Default is \code{FALSE}. +Only support \code{"std.all"} for now.} } \value{ -A list with the following elements: +The function \code{\link[=ci_bound_ur]{ci_bound_ur()}} returns +a list with the following elements: \itemize{ \item \code{bound}: The bound found. \item \code{optimize_out}: THe output of the @@ -123,6 +145,15 @@ determining the interval internally. user-defined parameter when determining the interval internally. } + +The function \code{\link[=gen_est_i]{gen_est_i()}} returns +a special function can inspects the +\code{Model} slot (and \code{implied} slot +if necessary) of a modified \code{lavaan} +object and return the parameter +estimate. This function is to be used +by \code{\link[=ci_bound_ur]{ci_bound_ur()}} or +\code{\link[=gen_sem_out_userp]{gen_sem_out_userp()}}. } \description{ Find the lower or upper @@ -135,7 +166,7 @@ using \code{\link[=uniroot]{uniroot()}}. \details{ This function is called xby \code{\link[=ci_bound_ur_i]{ci_bound_ur_i()}}. This function is -exported later because it is a +exported because it is a stand-alone function that can be used directly for any function that receives a lavaan object and returns @@ -160,23 +191,25 @@ syntax. } \examples{ -# TODO: -# - Update the example - +library(lavaan) data(simple_med) dat <- simple_med - mod <- " m ~ x y ~ m " - fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) - -out1l <- ci_bound_ur_i(i = 1, - sem_out = fit_med, - which = "lbound") +parameterTable(fit_med) +# Create a function to get the second parameter +est_i <- gen_est_i(i = 2, sem_out = fit_med) +# Find the lower bound of the likelihood-based confidence interval +# of the second parameter. +# user_callr should be TRUE or omitted in read research. +out1l <- ci_bound_ur(sem_out = fit_med, + func = est_i, + which = "lbound", + use_callr = FALSE) out1l } diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index 9b1e5877..32be6646 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -241,9 +241,7 @@ parameters with cautions. } \examples{ -# TODO: -# - Update the example - +library(lavaan) data(simple_med) dat <- simple_med @@ -253,7 +251,7 @@ m ~ x y ~ m " -fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) +fit_med <- sem(mod, simple_med, fixed.x = FALSE) out1l <- ci_bound_ur_i(i = 1, sem_out = fit_med, From e9e7472aae5010c153ca023ab34b00b9091e21d9 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 20:15:25 +0800 Subject: [PATCH 24/68] The method name is stored in the output Tests and build_site() passed. --- R/ci_bound_ur_i.R | 3 ++- R/ci_bound_wn_i.R | 3 ++- R/print_cibound.R | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index a07bb4ac..8a90b0cf 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -412,7 +412,8 @@ ci_bound_ur_i <- function(i = NULL, } out <- list(bound = bound, diag = diag, - call = match.call()) + call = match.call(), + method_name = "Root Finding") class(out) <- c("cibound", class(out)) out } diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index c850eacd..9cd06ecd 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -615,7 +615,8 @@ ci_bound_wn_i <- function(i = NULL, } out <- list(bound = bound, diag = diag, - call = match.call()) + call = match.call(), + method_name = "Wu-Neale-2012") class(out) <- c("cibound", class(out)) out } diff --git a/R/print_cibound.R b/R/print_cibound.R index 062fda7c..9cd01ad7 100644 --- a/R/print_cibound.R +++ b/R/print_cibound.R @@ -47,7 +47,7 @@ print.cibound <- function(x, digits = 5, ...) { call_org <- x$call out_diag <- x$diag - ci_method <- switch(out_diag$method, wn = "Wu-Neale-2012") + ci_method <- x$method_name if (is.null(out_diag$standardized)) { std <- "No" } else { From f2d77ccb851f3bbeff5be4e8010cb28cfffbd5cf Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 20:17:57 +0800 Subject: [PATCH 25/68] Change the title of doc of ci_bound_wn_i --- R/ci_bound_wn_i.R | 5 +++-- man/ci_bound_wn_i.Rd | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 9cd06ecd..c4e7cd07 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -1,6 +1,7 @@ -#' @title Likelihood-based Confidence Bound For One parameter +#' @title Likelihood-based Confidence Bound By Wu-Neale-2012 #' -#' @description Find the lower or upper bound of the likelihood-based +#' @description User the method proposed by Wu and Neale +#' (2012) to find the lower or upper bound of the likelihood-based #' confidence interval (LBCI) for one parameter in a structural #' equation model fitted in [lavaan::lavaan()]. #' diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index 3cb4f9f5..5cafd733 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ci_bound_wn_i.R \name{ci_bound_wn_i} \alias{ci_bound_wn_i} -\title{Likelihood-based Confidence Bound For One parameter} +\title{Likelihood-based Confidence Bound By Wu-Neale-2012} \usage{ ci_bound_wn_i( i = NULL, @@ -139,7 +139,8 @@ A detailed and organized output can be printed by the default print method (\code{\link[=print.cibound]{print.cibound()}}). } \description{ -Find the lower or upper bound of the likelihood-based +User the method proposed by Wu and Neale +(2012) to find the lower or upper bound of the likelihood-based confidence interval (LBCI) for one parameter in a structural equation model fitted in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. } From c108321cc0868e7354250aebbcf20117d9a9eada Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 20:18:01 +0800 Subject: [PATCH 26/68] Fix a typo --- man/ci_bound_ur.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index 757e063a..c29339f6 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -35,7 +35,7 @@ Currently supports a lavaan object and returns a scalar. This function is to be used by \code{\link[=gen_userp]{gen_userp()}} and so there are -special requirement on it. +special requirements on it. Alternatively, it can be the output of \code{\link[=gen_est_i]{gen_est_i()}}.} From b16c908352b2d1bcaf01900886567d580da700cb Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 20:30:37 +0800 Subject: [PATCH 27/68] Factor out the lines to call ci_bound_wn_i() Tests passed. --- R/ci_i_one.R | 199 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 116 insertions(+), 83 deletions(-) diff --git a/R/ci_i_one.R b/R/ci_i_one.R index 1dbf45b2..13210336 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -54,7 +54,8 @@ #' [lavaan::lavaan-class] outputs only. #' #' @param method The approach to be used. Default is `"wn"` -#' (Wu-Neale-2012 Method), the only supported method. +#' (Wu-Neale-2012 Method). Another method is "ur", +#' root finding by [stats::uniroot()]. #' #' @param standardized Logical. Whether the bound of the LBCI of the #' standardized solution is to be searched. Default is `FALSE`. @@ -124,7 +125,7 @@ ci_i_one <- function(i, which = NULL, sem_out, - method = "wn", + method = c("wn", "ur"), standardized = FALSE, robust = "none", sf_full = NA, @@ -165,91 +166,24 @@ ci_i_one <- function(i, } if (method == "wn") { - # Wu-Neale-2012 method. - # The only method supported for now. - ## Attempt 1 - wald_ci_start <- !standardized - std_method_i <- "internal" - b_time <- system.time(b <- try(suppressWarnings(ci_bound_wn_i(i, - sem_out = sem_out, - which = which, - standardized = standardized, - sf = sf, - sf2 = sf2, - std_method = std_method_i, - wald_ci_start = wald_ci_start, - ...)), silent = TRUE)) - ## If "internal" failed, switches to "lavaan". - if (inherits(b, "try-error")) { - std_method_i <- "lavaan" - b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, - sem_out = sem_out, - which = which, - standardized = standardized, - sf = sf, - sf2 = sf2, - std_method = std_method_i, - ...))) - } - attempt_lb_var <- 0 - # Attempt 2 - if (b$diag$status != 0) { - ## Successively reduce the positive lower bounds for free variances - lb_se_k0 <- 10 - lb_prop0 <- .11 - lb_prop1 <- .01 - lb_propi <- lb_prop0 - while ((lb_propi > lb_prop1) & (b$diag$status != 0)) { - attempt_lb_var <- attempt_lb_var + 1 - lb_propi <- lb_propi - .01 - b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, - sem_out = sem_out, - which = which, - standardized = standardized, - sf = sf, - sf2 = sf2, - std_method = std_method_i, - lb_prop = lb_propi, - lb_se_k = lb_se_k0, - ...))) - } - } - # Attempt 3 - attempt_more_times <- 0 - if (b$diag$status != 0) { - # Try k more times - # Successively change the tolerance for convergence - ki <- try_k_more_times - fxi <- 1 - fti <- 1 - while ((ki > 0) & (b$diag$status != 0)) { - attempt_more_times <- attempt_more_times + 1 - ki <- ki - 1 - fxi <- fxi * .1 - if (ki > 0) { - fti <- fti * .1 - } else { - # Try hard in the last attempt - fti <- 0 - } - b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, - sem_out = sem_out, - which = which, - standardized = standardized, - sf = sf, - sf2 = sf2, - std_method = std_method_i, - xtol_rel_factor = fxi, - ftol_rel_factor = fti, - lb_prop = lb_propi, - lb_se_k = lb_se_k0, - ...))) - } - } + b_out <- ci_i_one_wn(i = i, + which = which, + sem_out = sem_out, + standardized = standardized, + sf = sf, + sf2 = sf2, + try_k_more_times = try_k_more_times, + ...) } if (method == "nm") { stop("The method 'nm' is no longer supported.") } + + b <- b_out$b + b_time <- b_out$b_time + attempt_lb_var <- b_out$attempt_lb_var + attempt_more_times <- b_out$attempt_more_times + # MAY-FIX: # Should not name the elements based on the bound (lower/upper). # But this is not an issue for now. @@ -275,3 +209,102 @@ ci_i_one <- function(i, } out } + +#' @noRd + +ci_i_one_wn <- function(i, + which = c("lbound", "ubound"), + sem_out, + standardized = FALSE, + sf, + sf2, + try_k_more_times = 0, + ...) { + # Wu-Neale-2012 method. + # The only method supported for now. + ## Attempt 1 + wald_ci_start <- !standardized + std_method_i <- "internal" + b_time <- system.time(b <- try(suppressWarnings(ci_bound_wn_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + wald_ci_start = wald_ci_start, + ...)), silent = TRUE)) + ## If "internal" failed, switches to "lavaan". + if (inherits(b, "try-error")) { + std_method_i <- "lavaan" + b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + ...))) + } + attempt_lb_var <- 0 + # Attempt 2 + if (b$diag$status != 0) { + ## Successively reduce the positive lower bounds for free variances + lb_se_k0 <- 10 + lb_prop0 <- .11 + lb_prop1 <- .01 + lb_propi <- lb_prop0 + while ((lb_propi > lb_prop1) & (b$diag$status != 0)) { + attempt_lb_var <- attempt_lb_var + 1 + lb_propi <- lb_propi - .01 + b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + lb_prop = lb_propi, + lb_se_k = lb_se_k0, + ...))) + } + } + # Attempt 3 + attempt_more_times <- 0 + if (b$diag$status != 0) { + # Try k more times + # Successively change the tolerance for convergence + ki <- try_k_more_times + fxi <- 1 + fti <- 1 + while ((ki > 0) && (b$diag$status != 0)) { + attempt_more_times <- attempt_more_times + 1 + ki <- ki - 1 + fxi <- fxi * .1 + if (ki > 0) { + fti <- fti * .1 + } else { + # Try hard in the last attempt + fti <- 0 + } + b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_wn_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + xtol_rel_factor = fxi, + ftol_rel_factor = fti, + lb_prop = lb_propi, + lb_se_k = lb_se_k0, + ...))) + } + } + out <- list(b = b, + b_time = b_time, + attempt_lb_var = attempt_lb_var, + attempt_more_times = attempt_more_times) + return(out) + } + From 2203c3c8cc0b8a5911f09f2c77ed31b2ac836253 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 20:53:45 +0800 Subject: [PATCH 28/68] Update ci_i_one for ur Tests passed. --- R/ci_i_one.R | 53 +++++++++++++++++++++++ man/ci_i_one.Rd | 5 ++- tests/testthat/test-ci_i_one_std_pa_ur.R | 32 ++++++++++++++ tests/testthat/test-ci_i_one_ustd_pa_ur.R | 31 +++++++++++++ 4 files changed, 119 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-ci_i_one_std_pa_ur.R create mode 100644 tests/testthat/test-ci_i_one_ustd_pa_ur.R diff --git a/R/ci_i_one.R b/R/ci_i_one.R index 13210336..3260ab59 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -175,6 +175,17 @@ ci_i_one <- function(i, try_k_more_times = try_k_more_times, ...) } + if (method == "ur") { + if (robust == "satorra.2000") { + stop("Method 'ur' does not yet support robust LBCI.") + } + b_out <- ci_i_one_ur(i = i, + which = which, + sem_out = sem_out, + standardized = standardized, + try_k_more_times = try_k_more_times, + ...) + } if (method == "nm") { stop("The method 'nm' is no longer supported.") } @@ -308,3 +319,45 @@ ci_i_one_wn <- function(i, return(out) } +#' @noRd + +ci_i_one_ur <- function(i, + which = c("lbound", "ubound"), + sem_out, + standardized = FALSE, + sf, + sf2, + try_k_more_times = 0, + ...) { + # Root finding by uniroot + ## Rarely need to try more than once. + std_method_i <- "internal" + b_time <- system.time(b <- try(suppressWarnings(ci_bound_ur_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + ...)), silent = TRUE)) + ## If "internal" failed, switches to "lavaan". + if (inherits(b, "try-error")) { + std_method_i <- "lavaan" + b_time <- b_time + system.time(b <- suppressWarnings(ci_bound_ur_i(i, + sem_out = sem_out, + which = which, + standardized = standardized, + sf = sf, + sf2 = sf2, + std_method = std_method_i, + ...))) + } + attempt_lb_var <- 0 + attempt_more_times <- 0 + out <- list(b = b, + b_time = b_time, + attempt_lb_var = attempt_lb_var, + attempt_more_times = attempt_more_times) + return(out) + } + diff --git a/man/ci_i_one.Rd b/man/ci_i_one.Rd index 5f044f6a..dadc46e3 100644 --- a/man/ci_i_one.Rd +++ b/man/ci_i_one.Rd @@ -8,7 +8,7 @@ ci_i_one( i, which = NULL, sem_out, - method = "wn", + method = c("wn", "ur"), standardized = FALSE, robust = "none", sf_full = NA, @@ -30,7 +30,8 @@ found. Must be \code{"lbound"} or \code{"ubound"}.} \link[lavaan:lavaan-class]{lavaan::lavaan} outputs only.} \item{method}{The approach to be used. Default is \code{"wn"} -(Wu-Neale-2012 Method), the only supported method.} +(Wu-Neale-2012 Method). Another method is "ur", +root finding by \code{\link[stats:uniroot]{stats::uniroot()}}.} \item{standardized}{Logical. Whether the bound of the LBCI of the standardized solution is to be searched. Default is \code{FALSE}.} diff --git a/tests/testthat/test-ci_i_one_std_pa_ur.R b/tests/testthat/test-ci_i_one_std_pa_ur.R new file mode 100644 index 00000000..90d13711 --- /dev/null +++ b/tests/testthat/test-ci_i_one_std_pa_ur.R @@ -0,0 +1,32 @@ +skip_on_cran() +library(testthat) +library(semlbci) + +# Fit the model + +library(lavaan) + +data(simple_med) +dat <- simple_med +mod <- +" +m ~ x +y ~ m +" +fit <- lavaan::sem(mod, simple_med, fixed.x = FALSE) + +# Find the LBCIs + +ciperc <- .96 + +out1l <- ci_i_one(1, npar = 5, which = "lbound", sem_out = fit, method = "ur", + ciperc = ciperc, + standardized = TRUE, + opts = list(use_callr = FALSE)) + +# Check with known results + +test_that("Check with know results", { + expect_equal(round(unname(out1l$bounds["lbound"]), 2), .13) + }) + diff --git a/tests/testthat/test-ci_i_one_ustd_pa_ur.R b/tests/testthat/test-ci_i_one_ustd_pa_ur.R new file mode 100644 index 00000000..03d92517 --- /dev/null +++ b/tests/testthat/test-ci_i_one_ustd_pa_ur.R @@ -0,0 +1,31 @@ +skip_on_cran() +library(testthat) +library(semlbci) + +# Fit the model + +library(lavaan) + +data(simple_med) +dat <- simple_med +mod <- +" +m ~ x +y ~ m +" +fit <- lavaan::sem(mod, simple_med, fixed.x = FALSE) + +# Find the LBCIs + +ciperc <- .96 + +out1l <- ci_i_one(1, npar = 5, which = "lbound", sem_out = fit, method = "ur", + ciperc = ciperc, + opts = list(use_callr = FALSE)) + +# Check with known results + +test_that("Check with know results", { + expect_equal(round(unname(out1l$bounds["lbound"]), 2), .79) + }) + From 187c666d0d8d523ab2c0094d15e22a335a8ec798 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 21:18:22 +0800 Subject: [PATCH 29/68] Fix a bug in ci_i_one when adapted for ur --- R/ci_i_one.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/ci_i_one.R b/R/ci_i_one.R index 3260ab59..e85191c3 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -133,9 +133,7 @@ ci_i_one <- function(i, sem_out_name = NULL, try_k_more_times = 0, ...) { - if (!(which %in% c("lbound", "ubound"))) { - stop("Must be 'lbound' or 'ubound' for the 'which' argument.") - } + method <- match.arg(method) # It should be the job of the calling function to check whether it is # appropriate to use the robust method. if (tolower(robust) == "satorra.2000") { From 42b36874155b6d4002cb2e96c67ae71b5959a265 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 21:18:35 +0800 Subject: [PATCH 30/68] Update semlbci for ur Tests and checks passed. --- R/semlbci.R | 6 ++-- man/semlbci.Rd | 6 ++-- tests/testthat/test-semlbci_lavaan_sem_ur.R | 40 +++++++++++++++++++++ 3 files changed, 46 insertions(+), 6 deletions(-) create mode 100644 tests/testthat/test-semlbci_lavaan_sem_ur.R diff --git a/R/semlbci.R b/R/semlbci.R index effae885..75eac6ee 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -71,8 +71,8 @@ #' @param standardized If `TRUE`, the LBCI is for the standardized estimates. #' #' @param method The method to be used to search for the confidence -#' bounds. Currently only `"wn"` (Wu-Neale-2012), the default, is -#' supported. +#' bounds. Supported methods are`"wn"` (Wu-Neale-2012), the default, +#' and `"ur"` (root finding by [stats::uniroot()]). #' #' @param robust Whether the LBCI based on robust likelihood ratio #' test is to be found. Only `"satorra.2000"` in [lavaan::lavTestLRT()] @@ -168,7 +168,7 @@ semlbci <- function(sem_out, remove_intercepts = TRUE, ciperc = .95, standardized = FALSE, - method = "wn", + method = c("wn", "ur"), robust = c("none", "satorra.2000"), try_k_more_times = 2, semlbci_out = NULL, diff --git a/man/semlbci.Rd b/man/semlbci.Rd index 7888da6a..db7d3cf7 100644 --- a/man/semlbci.Rd +++ b/man/semlbci.Rd @@ -12,7 +12,7 @@ semlbci( remove_intercepts = TRUE, ciperc = 0.95, standardized = FALSE, - method = "wn", + method = c("wn", "ur"), robust = c("none", "satorra.2000"), try_k_more_times = 2, semlbci_out = NULL, @@ -56,8 +56,8 @@ interval.} \item{standardized}{If \code{TRUE}, the LBCI is for the standardized estimates.} \item{method}{The method to be used to search for the confidence -bounds. Currently only \code{"wn"} (Wu-Neale-2012), the default, is -supported.} +bounds. Supported methods are\code{"wn"} (Wu-Neale-2012), the default, +and \code{"ur"} (root finding by \code{\link[stats:uniroot]{stats::uniroot()}}).} \item{robust}{Whether the LBCI based on robust likelihood ratio test is to be found. Only \code{"satorra.2000"} in \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} diff --git a/tests/testthat/test-semlbci_lavaan_sem_ur.R b/tests/testthat/test-semlbci_lavaan_sem_ur.R new file mode 100644 index 00000000..5490f637 --- /dev/null +++ b/tests/testthat/test-semlbci_lavaan_sem_ur.R @@ -0,0 +1,40 @@ +skip("Test parallel processing: Test in interactive sections") + +library(testthat) +library(semlbci) + +# lavaan example: sem() + +library(lavaan) +model <- ' + # latent variable definitions + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + a*y2 + b*y3 + c*y4 + dem65 =~ y5 + a*y6 + b*y7 + c*y8 + + # regressions + dem60 ~ ind60 + dem65 ~ ind60 + dem60 + + # residual correlations + y1 ~~ y5 + y2 ~~ y4 + y6 + y3 ~~ y7 + y4 ~~ y8 + y6 ~~ y8 +' + +fit <- sem(model, data = PoliticalDemocracy) +# summary(fit, fit.measures = TRUE) + +p_table <- parameterTable(fit) +i_free <- which(p_table$free > 0) + +fit_lbci_parallel <- semlbci(fit, pars = i_free[9:11], parallel = TRUE, ncpus = 3, method = "ur") +fit_lbci_no_parallel <- semlbci(fit, pars = i_free[9:11], parallel = FALSE, ncpus = 3, method = "ur") + +test_that("Compare parallel and non-parallel results", { + expect_true(all.equal(data.frame(fit_lbci_parallel[12:14, -c(18, 19)]), + data.frame(fit_lbci_no_parallel[12:14, -c(18, 19)]), + check_attributes = FALSE)) +}) From 764a7d60024efd8e6495c8f8db4ca5eb99e016dd Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 21:23:56 +0800 Subject: [PATCH 31/68] Amend an internal note --- R/ci_bound_ur_i.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 8a90b0cf..4cc77eb5 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -306,7 +306,10 @@ ci_bound_ur_i <- function(i = NULL, status <- 0 # Check convergence - # TODO: + # NOTE: + # - Not necessary to check the code + # because the validity of the bound + # can be determined by the LR test. # - Find the status code of uniroot # - Need to be done in the call to uniroot() # if (out$status < 0) { From d505f3b7d8c61555b1c9bba45a4b600a2d2bf801 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sun, 26 May 2024 21:30:23 +0800 Subject: [PATCH 32/68] Fix a tolerance argument --- R/ci_bound_ur_i.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 4cc77eb5..36f973ce 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -289,7 +289,6 @@ ci_bound_ur_i <- function(i = NULL, func = est_i_func, level = ciperc, which = which, - tol = p_tol, uniroot_maxiter = 500) ur_opts <- utils::modifyList(ur_opts, opts) From 581cfeaa130a1c39e0fe5d264082c65b733abf4c Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 00:24:55 +0800 Subject: [PATCH 33/68] Auto satorra.2000 for ur Tests passed --- R/semlbci.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/semlbci.R b/R/semlbci.R index 75eac6ee..e7e49a19 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -189,6 +189,20 @@ semlbci <- function(sem_out, robust <- match.arg(robust) sem_out_name <- deparse(substitute(sem_out)) + # Use satorra.2000 automatically if + # - a scaled test is used and + # - the method is "ur" + + scaled <- any(names(lavaan::lavInspect(sem_out, "test")) %in% + c("satorra.bentler", + "yuan.bentler", + "yuan.bentler.mplus", + "mean.var.adjusted", + "scaled.shifted")) + if (scaled && (method == "ur")) { + robust <- "satorra.2000" + } + # Check sem_out if (check_fit) { sem_out_check <- check_sem_out(sem_out = sem_out, robust = robust) From aff6ba626b8a1c924bcde8ba43549904aec6d652 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 01:58:13 +0800 Subject: [PATCH 34/68] satorra.2000 is now supported in ur Tests, checks, build_site() passed --- R/ci_bound_ur_i.R | 29 +++++++++-- R/ci_i_one.R | 8 +-- man/ci_bound_ur.Rd | 8 +++ man/ci_i_one.Rd | 4 +- .../testthat/test-semlbci_lavaan_sem_ur_rb.R | 40 ++++++++++++++ .../test-ur_ci_bound_ur_i_rb_ustd_1.R | 48 +++++++++++++++++ .../test-ur_ci_bound_ur_rb_mg_ustd_1.R | 51 ++++++++++++++++++ .../testthat/test-ur_ci_bound_ur_rb_ustd_1.R | 52 +++++++++++++++++++ 8 files changed, 229 insertions(+), 11 deletions(-) create mode 100644 tests/testthat/test-semlbci_lavaan_sem_ur_rb.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_i_rb_ustd_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_rb_mg_ustd_1.R create mode 100644 tests/testthat/test-ur_ci_bound_ur_rb_ustd_1.R diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 36f973ce..2ab16ff8 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -500,6 +500,13 @@ ci_bound_ur_i <- function(i = NULL, #' May include other function in the #' future. #' +#' @param lrt_method The method used in +#' [lavaan::lavTestLRT()]. Default is +#' `"default"`. It is automatically set +#' to `"satorra.2000"` and cannot be +#' overridden if a scaled test statistic +#' is requested in `sem_out`. +#' #' @param tol The tolerance used in #' [uniroot()], default is .005. #' @@ -608,6 +615,7 @@ ci_bound_ur <- function(sem_out, interval = NULL, progress = FALSE, method = "uniroot", + lrt_method = "default", tol = .0005, # This is the tolerance in x, not in y root_target = c("chisq", "pvalue"), d = 5, @@ -621,8 +629,17 @@ ci_bound_ur <- function(sem_out, # - Call add_func() to generate a modified lavaan object. # - Call sem_out_userp_run() to fix to a value - # TODO: - # - Support satorra.2000 + # satorra.2000 is used automatically and cannot be overridden + scaled <- any(names(lavaan::lavInspect(sem_out, "test")) %in% + c("satorra.bentler", + "yuan.bentler", + "yuan.bentler.mplus", + "mean.var.adjusted", + "scaled.shifted")) + if (scaled) { + lrt_method <- "satorra.2000" + } + which <- match.arg(which) root_target <- match.arg(root_target) # Only support uniroot() for now @@ -658,7 +675,9 @@ ci_bound_ur <- function(sem_out, sem_out_x <- sem_out_userp_run(target = x, object = fit_i, global_ok = global_ok) - lrt0 <- lavaan::lavTestLRT(sem_out_x, sem_out) + lrt0 <- lavaan::lavTestLRT(sem_out_x, + sem_out, + method = lrt_method) cname <- switch(root_target, pvalue = "Pr(>Chisq)", chisq = "Chisq diff") @@ -761,7 +780,9 @@ ci_bound_ur <- function(sem_out, out_root <- optimize_out$root sem_out_final <- sem_out_userp_run(target = out_root, object = fit_i) - lrt_final <- lavaan::lavTestLRT(sem_out_final, sem_out) + lrt_final <- lavaan::lavTestLRT(sem_out_final, + sem_out, + method = lrt_method) out <- list(bound = out_root, optimize_out = optimize_out, sem_out_bound = sem_out_final, diff --git a/R/ci_i_one.R b/R/ci_i_one.R index e85191c3..5a9c6506 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -64,7 +64,9 @@ #' test is to be found. Only `"satorra.2000"` in #' [lavaan::lavTestLRT()] is supported for now. If `"none"``, the #' default, then likelihood ratio test based on maximum likelihood -#' estimation will be used. +#' estimation will be used. For "ur", `"satorra.2000"` is +#' automatically used if a scaled test statistic is requested +#' in `sem_out`. #' #' @param sf_full A list with the scaling and shift factors. Ignored #' if `robust` is `"none"`. If `robust` is `"satorra.2000"` and @@ -174,9 +176,7 @@ ci_i_one <- function(i, ...) } if (method == "ur") { - if (robust == "satorra.2000") { - stop("Method 'ur' does not yet support robust LBCI.") - } + # satorra.2000 is turned on automatically for ur b_out <- ci_i_one_ur(i = i, which = which, sem_out = sem_out, diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index c29339f6..a74b31d8 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -15,6 +15,7 @@ ci_bound_ur( interval = NULL, progress = FALSE, method = "uniroot", + lrt_method = "default", tol = 5e-04, root_target = c("chisq", "pvalue"), d = 5, @@ -71,6 +72,13 @@ be \code{"uniroot"}, the default, for now. May include other function in the future.} +\item{lrt_method}{The method used in +\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}. Default is +\code{"default"}. It is automatically set +to \code{"satorra.2000"} and cannot be +overridden if a scaled test statistic +is requested in \code{sem_out}.} + \item{tol}{The tolerance used in \code{\link[=uniroot]{uniroot()}}, default is .005.} diff --git a/man/ci_i_one.Rd b/man/ci_i_one.Rd index dadc46e3..885a55ad 100644 --- a/man/ci_i_one.Rd +++ b/man/ci_i_one.Rd @@ -38,9 +38,7 @@ standardized solution is to be searched. Default is \code{FALSE}.} \item{robust}{Whether the LBCI based on robust likelihood ratio test is to be found. Only \code{"satorra.2000"} in -\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} is supported for now. If `"none"``, the -default, then likelihood ratio test based on maximum likelihood -estimation will be used.} +\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} is supported for now. If \verb{"none"``, the default, then likelihood ratio test based on maximum likelihood estimation will be used. For "ur", }"satorra.2000"\verb{is automatically used if a scaled test statistic is requested in}sem_out`.} \item{sf_full}{A list with the scaling and shift factors. Ignored if \code{robust} is \code{"none"}. If \code{robust} is \code{"satorra.2000"} and diff --git a/tests/testthat/test-semlbci_lavaan_sem_ur_rb.R b/tests/testthat/test-semlbci_lavaan_sem_ur_rb.R new file mode 100644 index 00000000..80ca7029 --- /dev/null +++ b/tests/testthat/test-semlbci_lavaan_sem_ur_rb.R @@ -0,0 +1,40 @@ +skip("Test parallel processing: Test in interactive sections") + +library(testthat) +library(semlbci) + +# lavaan example: sem() + +library(lavaan) +model <- ' + # latent variable definitions + ind60 =~ x1 + x2 + x3 + dem60 =~ y1 + a*y2 + b*y3 + c*y4 + dem65 =~ y5 + a*y6 + b*y7 + c*y8 + + # regressions + dem60 ~ ind60 + dem65 ~ ind60 + dem60 + + # residual correlations + y1 ~~ y5 + y2 ~~ y4 + y6 + y3 ~~ y7 + y4 ~~ y8 + y6 ~~ y8 +' + +fit <- sem(model, data = PoliticalDemocracy, test = "satorra.bentler") +# summary(fit, fit.measures = TRUE) + +p_table <- parameterTable(fit) +i_free <- which(p_table$free > 0) + +fit_lbci_parallel <- semlbci(fit, pars = i_free[9:10], parallel = TRUE, ncpus = 3, method = "ur") +fit_lbci_no_parallel <- semlbci(fit, pars = i_free[9:10], parallel = FALSE, ncpus = 3, method = "ur") + +test_that("Compare parallel and non-parallel results", { + expect_true(all.equal(data.frame(fit_lbci_parallel[12:14, -c(18, 19)]), + data.frame(fit_lbci_no_parallel[12:14, -c(18, 19)]), + check_attributes = FALSE)) +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_i_rb_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_i_rb_ustd_1.R new file mode 100644 index 00000000..87ff67b8 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_i_rb_ustd_1.R @@ -0,0 +1,48 @@ +skip_on_cran() + +library(testthat) +library(semlbci) + +# Fit the model + +library(lavaan) + +data(simple_med) +dat <- simple_med +mod <- +" +m ~ a*x +y ~ b*m +ab := a*b +" +fit <- lavaan::sem(mod, simple_med, fixed.x = FALSE, test = "satorra.bentler") + +## One group + +test_that("ci_bound_ur: One group, unstandardized, satorra.2000", { + +# Test one bound is enough + +system.time( +ci_lb <- ci_bound_ur_i(i = 2, + sem_out = fit, + which = "lbound", + verbose = TRUE) +) +# system.time( +# ci_ub <- ci_bound_ur_i(i = 9, +# sem_out = fit, +# which = "ubound", +# verbose = TRUE) +# ) +expect_true(grepl("satorra.2000", + attr(ci_lb$diag$history$lrt, "head"), + fixed = TRUE)) +expect_equal(round(1 - ci_lb$diag$ciperc_final, 2), + .05, + tolerance = 1e-3) +# expect_equal(round(1 - ci_ub$diag$ciperc_final, 2), +# .05, +# tolerance = 1e-3) + +}) \ No newline at end of file diff --git a/tests/testthat/test-ur_ci_bound_ur_rb_mg_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_rb_mg_ustd_1.R new file mode 100644 index 00000000..30f3e523 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_rb_mg_ustd_1.R @@ -0,0 +1,51 @@ +skip_on_cran() + +# Ready + +library(testthat) +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 + visual ~~ a*textual + visual ~~ b*speed + textual ~~ d*speed + ab := a*b' +fit_gp <- sem(HS.model, data = HolzingerSwineford1939, + group = "school", + group.equal = "loadings", + test = "satorra.bentler") + +## Two groups + +test_that("ci_bound_ur: Two groups, unstandardized, satorra.2000", { + +# Test one bound is enough + +est_i <- gen_est_i(i = 46, sem_out = fit_gp) +# system.time( +# ci_lb <- ci_bound_ur(sem_out = fit_gp, +# func = est_i, +# which = "lbound", +# progress = FALSE, +# use_callr = FALSE) +# ) +system.time( +ci_ub <- ci_bound_ur(sem_out = fit_gp, + func = est_i, + which = "ubound", + progress = FALSE, + use_callr = FALSE) +) +expect_true(grepl("satorra.2000", + attr(ci_ub$lrt, "head"), + fixed = TRUE)) +# expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) +expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) + +}) diff --git a/tests/testthat/test-ur_ci_bound_ur_rb_ustd_1.R b/tests/testthat/test-ur_ci_bound_ur_rb_ustd_1.R new file mode 100644 index 00000000..56570c39 --- /dev/null +++ b/tests/testthat/test-ur_ci_bound_ur_rb_ustd_1.R @@ -0,0 +1,52 @@ +skip_on_cran() + +library(testthat) +library(semlbci) + +# Fit the model + +library(lavaan) + +data(simple_med) +dat <- simple_med +mod <- +" +m ~ a*x +y ~ b*m +ab := a*b +" +fit <- lavaan::sem(mod, simple_med, fixed.x = FALSE, test = "satorra.bentler") + +## One group + +test_that("ci_bound_ur: One group, unstandardized, satorra.2000", { + +# Test one bound is enough + +est_i <- gen_est_i(i = 2, sem_out = fit) +system.time( +ci_lb <- ci_bound_ur(sem_out = fit, + func = est_i, + which = "lbound", + progress = FALSE, + user_callr = FALSE) +) +# system.time( +# ci_ub <- ci_bound_ur(sem_out = fit, +# func = est_i, +# which = "ubound", +# progress = FALSE, +# user_callr = FALSE) +# ) + +expect_true(grepl("satorra.2000", + attr(ci_lb$lrt, "head"), + fixed = TRUE)) +expect_equal(round(ci_lb$lrt[2, "Pr(>Chisq)"], 2), + .05, + tolerance = 1e-3) +# expect_equal(round(ci_ub$lrt[2, "Pr(>Chisq)"], 2), +# .05, +# tolerance = 1e-3) + +}) \ No newline at end of file From 912266a81c48c859dc907f02a7c4eda7b484de74 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 02:03:36 +0800 Subject: [PATCH 35/68] Update to 0.10.4.2 --- DESCRIPTION | 2 +- NEWS.md | 15 ++++++++++++++- README.md | 2 +- 3 files changed, 16 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8a6d381d..12262d82 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.1 +Version: 0.10.4.2 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 18503c72..1373f8f2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,17 @@ -# semlbci 0.10.4.1 +# semlbci 0.10.4.2 + +## New Feature + +- Add the method `"ur"` for forming the + LBCI. It uses root finding without + derivatives. It is inefficient before + a model with equality constraint is + fitted in each iteration. However, it + may be able to find the bound for a + parameter when the `"wn"` method + cannot. It also supports robust LBCI + using Satorra (2000) chi-square + difference test. (0.10.4.2) ## Miscellaneous diff --git a/README.md b/README.md index 422aa47c..56f712c6 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.1, updated on 2024-05-25, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.2, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From b15fba6b4f51840ce28d90fa3b7b9730bec46471 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 20:44:01 +0800 Subject: [PATCH 36/68] 0.10.4.3: Add load balancing option to semlbci Tests, checks, and build_site() passed. --- DESCRIPTION | 2 +- NEWS.md | 6 +- R/semlbci.R | 13 +- R/semlbci.html | 896 +++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 2 +- man/semlbci.Rd | 8 +- 6 files changed, 922 insertions(+), 5 deletions(-) create mode 100644 R/semlbci.html diff --git a/DESCRIPTION b/DESCRIPTION index 12262d82..412350fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.2 +Version: 0.10.4.3 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 1373f8f2..6a4fa09b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.2 +# semlbci 0.10.4.3 ## New Feature @@ -17,6 +17,10 @@ - Suppressed a harmless warning in a test. (0.10.4.1) +- Added the option to use load balancing + when calling `semlbci()` with + `use_pbapply` set to `TRUE`. Enabled + by default. (0.10.4.3) # semlbci 0.10.4 diff --git a/R/semlbci.R b/R/semlbci.R index e7e49a19..e506e8e2 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -106,6 +106,11 @@ #' progress bar when finding the intervals. Default is `TRUE`. #' Ignored if `pbapply` is not installed. #' +#' @param loadbalancing Whether load +#' balancing is used when `parallel` +#' is `TRUE` and `use_pbapply` is +#' `TRUE`. +#' #' @author Shu Fai Cheung #' #' @references @@ -176,7 +181,8 @@ semlbci <- function(sem_out, ..., parallel = FALSE, ncpus = 2, - use_pbapply = TRUE) { + use_pbapply = TRUE, + loadbalancing = TRUE) { if (!inherits(sem_out, "lavaan")) { stop("sem_out is not a supported object.") } @@ -317,6 +323,11 @@ semlbci <- function(sem_out, envir = environment()) if (requireNamespace("pbapply", quietly = TRUE) && use_pbapply) { + if (loadbalancing) { + pboptions_old <- pbapply::pboptions(use_lb = TRUE) + # Restore pboptions on exit + on.exit(pbapply::pboptions(pboptions_old)) + } # Use pbapply args_final <- utils::modifyList(list(...), list(npar = npar, diff --git a/R/semlbci.html b/R/semlbci.html new file mode 100644 index 00000000..a5429773 --- /dev/null +++ b/R/semlbci.html @@ -0,0 +1,896 @@ + + + + + + + + + + + + + + + +semlbci.R + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + +

@title Likelihood-Based Confidence +Interval

+

@description Find the likelihood-based +confidence intervals (LBCIs) for selected free parameters in an SEM +output.

+

@details [semlbci()] finds the +positions of the selected parameters in the parameter table and then +calls [ci_i_one()] once for each of them. For the technical details, +please see [ci_i_one()] and the functions it calls to find a confidence +bound, currently [ci_bound_wn_i()]. [ci_bound_wn_i()] uses the approach +proposed by Wu and Neale (2012) and illustrated by Pek and Wu +(2015).

+

It supports updating an output of [semlbci()] by setting +semlbci_out. This allows forming LBCIs for some parameters +after those for some others have been formed.

+

If possible, parallel processing should be used (see +parallel and ncpus), especially for a model +with many parameters.

+

If the search for some of the confidence bounds failed, with +NA for the bounds, try increasing +try_k_more_times.

+

The SEM output will first be checked by [check_sem_out()] to see +whether the model and the estimation method are supported. To skip this +test (e.g., for testing or experimenting with some models and +estimators), set check_fit to FALSE.

+

Examples and technical details can be found at Cheung and Pesigan +(2023), the website of the semlbci package (https://sfcheung.github.io/semlbci/), and the technical +appendices at (https://sfcheung.github.io/semlbci/articles/).

+

It currently supports [lavaan::lavaan-class] outputs only.

+

@return A semlbci-class +object similar to the parameter table generated by +[lavaan::parameterEstimates()], with the LBCIs for selected parameters +added. Diagnostic information, if requested, will be included in the +attributes. See [print.semlbci()] for options available.

+

@param sem_out The SEM output. +Currently supports [lavaan::lavaan-class] outputs only.

+

@param pars The positions of the +parameters for which the LBCIs are to be searched. Use the position as +appeared on the parameter tables of the sem_out. If +NULL, the default, then LBCIs for all free parameters will +be searched. Can also be a vector of strings to indicate the parameters +on the parameter table. The parameters should be specified in +[lavaan::lavaan()] syntax. The vector of strings will be converted by +[syntax_to_i()] to parameter positions. See [syntax_to_i()] on how to +specify the parameters.

+

@param include_user_pars Logical. +Whether all user-defined parameters are automatically included when +pars is not set. Default is TRUE. If +pars is explicitly set, this argument will be ignored.

+

@param remove_variances Logical. +Whether variances and error variances will be removed. Default is +TRUE, removing all variances and error variances even if +specified in pars.

+

@param remove_intercepts Logical. +Whether intercepts will be removed. Default is TRUE, +removing all intercepts (parameters with operator ~1). +Intercepts are not yet supported in standardized solution and so will +always be removed if standardized = TRUE.

+

@param ciperc The proportion of +coverage for the confidence interval. Default is .95, requesting a 95 +percent confidence interval.

+

@param standardized If +TRUE, the LBCI is for the standardized estimates.

+

@param method The method to be used to +search for the confidence bounds. Supported methods are"wn" +(Wu-Neale-2012), the default, and "ur" (root finding by +[stats::uniroot()]).

+

@param robust Whether the LBCI based on +robust likelihood ratio test is to be found. Only +"satorra.2000" in [lavaan::lavTestLRT()] is supported for +now, implemented by the method proposed by Falk (2018). If +"none", the default, then likelihood ratio test based on +maximum likelihood estimation will be used.

+

@param try_k_more_times How many more +times to try if failed. Default is 2.

+

@param semlbci_out An +semlbci-class object. If provided, parameters already with +LBCIs formed will be excluded from pars.

+

@param check_fit If TRUE +(default), the input (sem_out) will be checked by +[check_sem_out()]. If not supported, an error will be raised. If +FALSE, the check will be skipped and the LBCIs will be +searched even for a model or parameter not supported. Set to +TRUE only for testing.

+

@param … Arguments to be passed to +[ci_bound_wn_i()].

+

@param parallel If TRUE, +will use parallel processing to do the search.

+

@param ncpus The number of workers, if +parallel is TRUE. Default is 2. This number +should not be larger than the number CPU cores.

+

@param use_pbapply If TRUE +and pbapply is installed, [pbapply::pbapply()] will be used +to display a progress bar when finding the intervals. Default is +TRUE. Ignored if pbapply is not installed.

+

@param loadbalancing Whether load +balancing is used when parallel is TRUE and +use_pbapply is TRUE.

+

@author Shu Fai Cheung https://orcid.org/0000-0002-9871-9448

+

@references

+

Cheung, S. F., & Pesigan, I. J. A. (2023). semlbci: An R +package for forming likelihood-based confidence intervals for parameter +estimates, correlations, indirect effects, and other derived parameters. +Structural Equation Modeling: A Multidisciplinary Journal. +Advance online publication.

+

Falk, C. F. (2018). Are robust standard errors the best approach for +interval estimation with nonnormal data in structural equation modeling? +Structural Equation Modeling: A Multidisciplinary Journal, +25(2), 244-266.

+

Pek, J., & Wu, H. (2015). Profile likelihood-based confidence +intervals and regions for structural equation models. Psychometrika, +80(4), 1123-1145.

+

Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for +a bounded parameter. Behavior Genetics, 42(6), 886-898.

+

Pritikin, J. N., Rappaport, L. M., & Neale, M. C. (2017). +Likelihood-based confidence intervals for a parameter with an upper or +lower bound. Structural Equation Modeling: A Multidisciplinary +Journal, 24(3), 395-401.

+

@seealso [print.semlbci()], +[confint.semlbci()], [ci_i_one()], [ci_bound_wn_i()]

+

@examples

+

library(lavaan) mod <- ” m ~ ax y ~ bm ab := a * b ” +fit_med <- sem(mod, simple_med, fixed.x = FALSE) p_table <- +parameterTable(fit_med) p_table lbci_med <- semlbci(fit_med, pars = +c(“m ~ x”, “y ~ m”, “ab :=”)) lbci_med

+

@export

+
semlbci <- function(sem_out,
+                    pars = NULL,
+                    include_user_pars = TRUE,
+                    remove_variances = TRUE,
+                    remove_intercepts = TRUE,
+                    ciperc = .95,
+                    standardized = FALSE,
+                    method = c("wn", "ur"),
+                    robust = c("none", "satorra.2000"),
+                    try_k_more_times = 2,
+                    semlbci_out = NULL,
+                    check_fit = TRUE,
+                    ...,
+                    parallel = FALSE,
+                    ncpus = 2,
+                    use_pbapply = TRUE,
+                    loadbalancing = TRUE) {
+    if (!inherits(sem_out, "lavaan")) {
+        stop("sem_out is not a supported object.")
+      }
+    if (!is.null(semlbci_out)) {
+        if (!inherits(semlbci_out, "semlbci")) {
+            stop("semlbci_out is not an output of semlbci().")
+          }
+      }
+    method <- match.arg(method)
+    robust <- match.arg(robust)
+    sem_out_name <- deparse(substitute(sem_out))
+
+    # Use satorra.2000 automatically if
+    # - a scaled test is used and
+    # - the method is "ur"
+
+    scaled <- any(names(lavaan::lavInspect(sem_out, "test")) %in%
+                        c("satorra.bentler",
+                          "yuan.bentler",
+                          "yuan.bentler.mplus",
+                          "mean.var.adjusted",
+                          "scaled.shifted"))
+    if (scaled && (method == "ur")) {
+        robust <- "satorra.2000"
+      }
+
+    # Check sem_out
+    if (check_fit) {
+        sem_out_check <- check_sem_out(sem_out = sem_out, robust = robust)
+        if (sem_out_check > 0) {
+            msg <- paste0(paste(attr(sem_out_check, "info"), collapse = "\n"), "\n")
+            warning(msg, immediate. = TRUE)
+          }
+        if (sem_out_check < 0) {
+            msg <- paste0(paste(attr(sem_out_check, "info"), collapse = "\n"), "\n")
+            stop(msg)
+          }
+      }
+
+    ptable <- as.data.frame(lavaan::parameterTable(sem_out))
+    pars_lbci_yes <- rep(FALSE, nrow(ptable))
+    if (!is.null(semlbci_out)) {
+        # Check whether semlbci_out and sem_out match
+        tmp0 <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")]
+        tmp1 <- as.data.frame(semlbci_out)[, c("id", "lhs", "op", "rhs", "group", "label")]
+        if (!identical(tmp0, tmp1)) {
+            stop("semblci_out and the parameter table of sem_out do not match.")
+          }
+        # Find pars with both lbci_lb and lbci_ub
+        pars_lbci_yes <- !sapply(semlbci_out$lbci_lb, is.na) &
+                         !sapply(semlbci_out$lbci_ub, is.na)
+      }
+    i <- ptable$free > 0
+    i_id <- ptable$id
+    i_id_free <- i_id[i]
+    i_id_user <- i_id[(ptable$free == 0) & (ptable$op == ":=")]
+    # pars must be the row numbers as in the lavaan parameterTable.
+    if (!is.null(pars)) {
+        # Parameters supplied
+        if (is.character(pars)) {
+            # Convert syntax to row numbers.
+            pars <- syntax_to_i(pars, sem_out)
+          }
+        if (standardized) {
+            # Always exclude variances fixed in the standardized solution
+            pars <- remove_v1(pars, sem_out)
+          }
+        # Remove parameters already with LBCIs in semlbci_out.
+        pars <- pars[!pars %in% i_id[pars_lbci_yes]]
+        # Ids in the vector of free parameters
+        i_selected <- i_id[pars]
+      } else {
+        # Start with all free parameters
+        pars <- i_id_free
+        if (standardized) {
+            # Intercepts and means not supported for standardized solution
+            remove_intercepts <- TRUE
+            # Always exclude variances fixed in the standardized solution
+            pars <- remove_v1(pars, sem_out)
+            # Include parameters free in the standardized solution,
+            # e.g., fixed loadings.
+            pars <- sort(unique(c(pars, free_in_std(i_id, sem_out))))
+          }
+        if (include_user_pars && length(i_id_user) > 0) {
+            pars <- c(pars, i_id_user)
+          }
+        if (remove_variances) {
+            pars <- remove_variances(pars, sem_out)
+          }
+        if (remove_intercepts) {
+            pars <- remove_variances(pars, sem_out)
+          }
+        # Remove parameters already with LBCIs in semlbci_out.
+        pars <- pars[!pars %in% i_id[pars_lbci_yes]]
+        # Ids in the vector of free parameters
+        i_selected <- i_id[pars]
+      }
+    if (length(pars) == 0) {
+        if (is.null(semlbci_out)) {
+            stop("The number of parameters selected is zero.")
+          } else {
+            warning("No parameter selected. semlbci_out returned.")
+            return(semlbci_out)
+          }
+      }
+    npar <- sum(i)
+    # KEEP for reference: environment(set_constraint) <- parent.frame()
+    if (method == "wn") {
+        f_constr <- eval(set_constraint(sem_out = sem_out, ciperc = ciperc),
+                        envir = parent.frame())
+      } else {
+        f_constr <- NULL
+      }
+
+    # Compute the scaling factors
+    if (robust == "satorra.2000") {
+        sf_full_list <- lapply(pars,
+                               scaling_factor3,
+                               sem_out = sem_out,
+                               standardized = standardized,
+                               std_method = "internal",
+                               sem_out_name = sem_out_name)
+      } else {
+        sf_full_list <- rep(NA, length(pars))
+      }
+
+    if (parallel) {
+        # Parallel
+        cl <- parallel::makeCluster(ncpus)
+        # Rebuild the environment
+        pkgs <- .packages()
+        pkgs <- rev(pkgs)
+        parallel::clusterExport(cl, "pkgs", envir = environment())
+        parallel::clusterEvalQ(cl, {sapply(pkgs,
+                        function(x) library(x, character.only = TRUE))
+                      })
+        parallel::clusterExport(cl, ls(envir = parent.frame()),
+                                       envir = environment())
+        if (requireNamespace("pbapply", quietly = TRUE) &&
+            use_pbapply) {
+            if (loadbalancing) {
+                pboptions_old <- pbapply::pboptions(use_lb = TRUE)
+                # Restore pboptions on exit
+                on.exit(pbapply::pboptions(pboptions_old))
+              }
+            # Use pbapply
+            args_final <- utils::modifyList(list(...),
+                                    list(npar = npar,
+                                        sem_out = sem_out,
+                                        standardized = standardized,
+                                        debug = FALSE,
+                                        f_constr = f_constr,
+                                        method = method,
+                                        ciperc = ciperc,
+                                        robust = robust,
+                                        try_k_more_times = try_k_more_times,
+                                        sem_out_name = sem_out_name))
+            pars2 <- rep(pars, each = 2)
+            sf_full_list2 <- rep(sf_full_list, each = 2)
+            which2 <- rep(c("lbound", "ubound"), times = length(pars))
+            plist <- mapply(function(x, y, z) list(i = x, sf_full = y, which = z),
+                            x = pars2, y = sf_full_list2, z = which2,
+                            SIMPLIFY = FALSE)
+            tmpfct <- function(x) {
+                force(args_final)
+                args_final1 <- utils::modifyList(args_final, x)
+                do.call(semlbci::ci_i_one, args_final1)
+              }
+            out_raw2 <- pbapply::pblapply(plist,
+                                          tmpfct,
+                                          cl = cl)
+          } else {
+            # No progress bar
+            args_final <- utils::modifyList(list(...),
+                                    list(npar = npar,
+                                        sem_out = sem_out,
+                                        standardized = standardized,
+                                        debug = FALSE,
+                                        f_constr = f_constr,
+                                        method = method,
+                                        ciperc = ciperc,
+                                        robust = robust,
+                                        try_k_more_times = try_k_more_times,
+                                        sem_out_name = sem_out_name))
+            pars2 <- rep(pars, each = 2)
+            sf_full_list2 <- rep(sf_full_list, each = 2)
+            which2 <- rep(c("lbound", "ubound"), times = length(pars))
+            out_raw2 <- parallel::clusterMap(cl,
+                              semlbci::ci_i_one,
+                              i = pars2,
+                              sf_full = sf_full_list2,
+                              which = which2,
+                              MoreArgs = args_final,
+                              SIMPLIFY = FALSE)
+          }
+        parallel::stopCluster(cl)
+      } else {
+        # Serial
+        # Progress bar not support when ran in serial.
+        args_final <- utils::modifyList(list(...),
+                                list(npar = npar,
+                                    sem_out = sem_out,
+                                    standardized = standardized,
+                                    debug = FALSE,
+                                    f_constr = f_constr,
+                                    method = method,
+                                    ciperc = ciperc,
+                                    robust = robust,
+                                    try_k_more_times = try_k_more_times,
+                                    sem_out_name = sem_out_name))
+        pars2 <- rep(pars, each = 2)
+        sf_full_list2 <- rep(sf_full_list, each = 2)
+        which2 <- rep(c("lbound", "ubound"), times = length(pars))
+        if (requireNamespace("pbapply", quietly = TRUE) &&
+            use_pbapply) {
+              out_raw2 <- pbapply::pbmapply(
+                            ci_i_one,
+                            i = pars2,
+                            sf_full = sf_full_list2,
+                            which = which2,
+                            MoreArgs = args_final,
+                            SIMPLIFY = FALSE)
+            } else {
+              out_raw2 <- mapply(
+                            ci_i_one,
+                            i = pars2,
+                            sf_full = sf_full_list2,
+                            which = which2,
+                            MoreArgs = args_final,
+                            SIMPLIFY = FALSE)
+            }
+      }
+    tmpfct2 <- function(x, y) {
+        out <- mapply(c, x, y, SIMPLIFY = FALSE)
+        out$method <- out$method[[1]]
+        out$sf_full <- out$sf_full[[1]]
+        out
+      }
+    tmp1 <- seq(1, 2 * length(pars), 2)
+    tmp2 <- tmp1 + 1
+    out_raw <- mapply(tmpfct2,
+                      out_raw2[tmp1],
+                      out_raw2[tmp2],
+                      SIMPLIFY = FALSE)
+    out <- do.call(rbind, lapply(out_raw, function(x) x$bounds))
+    if (is.null(semlbci_out)) {
+        # Build the output
+        out_p <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")]
+        if (standardized) {
+            pstd <- lavaan::standardizedSolution(sem_out)
+            if (lavaan::lavTech(sem_out, "ngroups") == 1) {
+                pstd$group <- 1
+              }
+            pstd$group[pstd$op == ":="] <- 0
+            out_p <- merge(out_p, pstd[, c("lhs", "op", "rhs", "group", "est.std")],
+                    by = c("lhs", "op", "rhs", "group"), all.x = TRUE, sort = FALSE)
+          } else {
+            out_p$est <- ptable[, c("est")]
+          }
+        out_p$lbci_lb <- NA
+        out_p$lbci_ub <- NA
+      } else {
+        # Use existing output
+        out_p <- semlbci_out
+      }
+
+    out_p[i_selected, "lbci_lb"] <- out[, 1]
+    out_p[i_selected, "lbci_ub"] <- out[, 2]
+
+    # Collect diagnostic info
+    if (is.null(semlbci_out)) {
+        # Create the holder
+        q <- length(i_id)
+        lb_diag <- as.list(rep(NA, q))
+        ub_diag <- as.list(rep(NA, q))
+        lb_time <- as.numeric(rep(NA, q))
+        ub_time <- as.numeric(rep(NA, q))
+        lb_out <- as.list(rep(NA, q))
+        ub_out <- as.list(rep(NA, q))
+        ci_method <- as.character(rep(NA, q))
+        scaling_factor <- as.list(rep(NA, q))
+      } else {
+        # Retrieve from existing output
+        q <- length(i_id)
+        lb_diag <- attr(semlbci_out, "lb_diag")
+        ub_diag <- attr(semlbci_out, "ub_diag")
+        lb_time <- attr(semlbci_out, "lb_time")
+        ub_time <- attr(semlbci_out, "ub_time")
+        lb_out <- attr(semlbci_out, "lb_out")
+        ub_out <- attr(semlbci_out, "ub_out")
+        ci_method <- attr(semlbci_out, "ci_method")
+        scaling_factor <- attr(semlbci_out, "scaling_factor")
+      }
+    # Update the output
+    lb_diag[pars] <- lapply(out_raw, function(x) x$diags$lb_diag)
+    ub_diag[pars] <- lapply(out_raw, function(x) x$diags$ub_diag)
+    lb_time[pars] <- sapply(out_raw, function(x) x$times$lb_time)
+    ub_time[pars] <- sapply(out_raw, function(x) x$times$ub_time)
+    lb_out[pars] <- lapply(out_raw, function(x) x$ci_bound_i_out$lb_out)
+    ub_out[pars] <- lapply(out_raw, function(x) x$ci_bound_i_out$ub_out)
+    ci_method[pars] <- sapply(out_raw, function(x) x$method)
+    scaling_factor[pars] <- lapply(out_raw, function(x) x$sf_full)
+    p_names <- sapply(pars, i_to_name, sem_out = sem_out)
+    names(lb_diag)[pars] <- p_names
+    names(ub_diag)[pars] <- p_names
+    names(lb_time)[pars] <- p_names
+    names(ub_time)[pars] <- p_names
+    names(lb_out)[pars] <- p_names
+    names(ub_out)[pars] <- p_names
+    names(ci_method)[pars] <- p_names
+    names(scaling_factor)[pars] <- p_names
+
+    attr(out_p, "lb_diag") <- lb_diag
+    attr(out_p, "ub_diag") <- ub_diag
+    attr(out_p, "lb_time") <- lb_time
+    attr(out_p, "ub_time") <- ub_time
+    attr(out_p, "lb_out") <- lb_out
+    attr(out_p, "ub_out") <- ub_out
+    attr(out_p, "ci_method") <- ci_method
+    attr(out_p, "scaling_factor") <- scaling_factor
+    attr(out_p, "call") <- match.call()
+
+    # Append diagnostic info
+
+    out_p[pars, "status_lb"] <- sapply(lb_diag[pars], function(x) x$status)
+    out_p[pars, "status_ub"] <- sapply(ub_diag[pars], function(x) x$status)
+    out_p[pars, "ci_org_lb"] <- sapply(lb_diag[pars], function(x) x$ci_org_limit)
+    out_p[pars, "ci_org_ub"] <- sapply(ub_diag[pars], function(x) x$ci_org_limit)
+    out_p[pars, "ratio_lb"] <- sapply(lb_diag[pars], function(x) x$ci_limit_ratio)
+    out_p[pars, "ratio_ub"] <- sapply(ub_diag[pars], function(x) x$ci_limit_ratio)
+    out_p[pars, "post_check_lb"] <-
+                            sapply(lb_diag[pars], function(x) x$fit_post_check)
+    out_p[pars, "post_check_ub"] <-
+                            sapply(ub_diag[pars], function(x) x$fit_post_check)
+    out_p[pars, "time_lb"] <- as.numeric(lb_time[pars])
+    out_p[pars, "time_ub"] <- as.numeric(ub_time[pars])
+    out_p[pars, "cl_lb"] <- sapply(lb_diag[pars], function(x) x$ciperc_final)
+    out_p[pars, "cl_ub"] <- sapply(ub_diag[pars], function(x) x$ciperc_final)
+    out_p[pars, "method"] <- ci_method[pars]
+    if (robust != "none") {
+        out_p[pars, "robust"] <- robust
+      }
+
+    class(out_p) <- c("semlbci", class(out_p))
+    out_p
+  }
+ + + + +
+ + + + + + + + + + + + + + + diff --git a/README.md b/README.md index 56f712c6..cd75e41b 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.2, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.3, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/semlbci.Rd b/man/semlbci.Rd index db7d3cf7..22895c80 100644 --- a/man/semlbci.Rd +++ b/man/semlbci.Rd @@ -20,7 +20,8 @@ semlbci( ..., parallel = FALSE, ncpus = 2, - use_pbapply = TRUE + use_pbapply = TRUE, + loadbalancing = TRUE ) } \arguments{ @@ -90,6 +91,11 @@ cores.} is installed, \code{\link[pbapply:pbapply]{pbapply::pbapply()}} will be used to display a progress bar when finding the intervals. Default is \code{TRUE}. Ignored if \code{pbapply} is not installed.} + +\item{loadbalancing}{Whether load +balancing is used when \code{parallel} +is \code{TRUE} and \code{use_pbapply} is +\code{TRUE}.} } \value{ A \code{semlbci}-class object similar to the parameter table From 0b5c5d908cd1e9527f379da48b739e3fbc309ec2 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 21:55:21 +0800 Subject: [PATCH 37/68] Update set_constraint() to handle lavaan error --- R/set_constraint.R | 85 +++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 28 deletions(-) diff --git a/R/set_constraint.R b/R/set_constraint.R index d4e499f1..930031be 100644 --- a/R/set_constraint.R +++ b/R/set_constraint.R @@ -91,31 +91,46 @@ set_constraint <- function(sem_out, ciperc = .95) { eq_out <- sem_out@Model@ceq.function(param) eq_jac <- sem_out@Model@con.jac if (lav_warn) { - fit2 <- lavaan::lavaan( + fit2 <- tryCatch(lavaan::lavaan( slotOptions = slot_opt3, slotParTable = slot_pat2, slotModel = slot_mod3, slotSampleStats = slot_smp2, - slotData = slot_dat2) + slotData = slot_dat2), + error = function(e) e) } else { - suppressWarnings(fit2 <- lavaan::lavaan( + fit2 <- tryCatch(suppressWarnings(lavaan::lavaan( slotOptions = slot_opt3, slotParTable = slot_pat2, slotModel = slot_mod3, slotSampleStats = slot_smp2, - slotData = slot_dat2)) - } - if (lav_warn) { - fit2_gradient <- rbind(lavaan::lavTech(fit2, "gradient")) - fit2_jacobian <- rbind(eq_jac, - lavaan::lavTech(fit2, "gradient")) - } else { - suppressWarnings(fit2_gradient <- - rbind(lavaan::lavTech(fit2, "gradient"))) - suppressWarnings(fit2_jacobian <- - rbind(eq_jac, - lavaan::lavTech(fit2, "gradient"))) + slotData = slot_dat2)), + error = function(e) e) } + is_error <- inherits(fit2, "error") + if (is_error) { + fit2_gradient <- rbind(rep(-Inf, length(param))) + fit2_jacobian <- rbind(eq_jac, + rep(-Inf, length(param))) + out <- list(objective = Inf, + gradient = fit2_gradient, + constraints = Inf, + jacobian = fit2_jacobian, + parameterTable = NA) + return(out) + } else { + if (lav_warn) { + fit2_gradient <- rbind(lavaan::lavTech(fit2, "gradient")) + fit2_jacobian <- rbind(eq_jac, + lavaan::lavTech(fit2, "gradient")) + } else { + fit2_gradient <- tryCatch(suppressWarnings(rbind(lavaan::lavTech(fit2, "gradient"))), + error = function(e) rep(-Inf, length(param))) + suppressWarnings(fit2_jacobian <- + rbind(eq_jac, + fit2_gradient)) + } + } list( objective = lavaan::lavTech(fit2, "optim")$fx, gradient = fit2_gradient, @@ -139,29 +154,43 @@ set_constraint <- function(sem_out, ciperc = .95) { } slot_mod3 <- lavaan::lav_model_set_parameters(slot_mod2, param) if (lav_warn) { - fit2 <- lavaan::lavaan( + fit2 <- tryCatch(lavaan::lavaan( slotOptions = slot_opt3, slotParTable = slot_pat2, slotModel = slot_mod3, slotSampleStats = slot_smp2, - slotData = slot_dat2) + slotData = slot_dat2), + error = function(e) e) } else { - suppressWarnings(fit2 <- lavaan::lavaan( + fit2 <- tryCatch(suppressWarnings(lavaan::lavaan( slotOptions = slot_opt3, slotParTable = slot_pat2, slotModel = slot_mod3, slotSampleStats = slot_smp2, - slotData = slot_dat2)) - } - if (lav_warn) { - fit2_gradient <- rbind(lavaan::lavTech(fit2, "gradient")) - fit2_jacobian <- rbind(lavaan::lavTech(fit2, "gradient")) - } else { - suppressWarnings(fit2_gradient <- - rbind(lavaan::lavTech(fit2, "gradient"))) - suppressWarnings(fit2_jacobian <- - rbind(lavaan::lavTech(fit2, "gradient"))) + slotData = slot_dat2)), + error = function(e) e) } + is_error <- inherits(fit2, "error") + if (is_error) { + fit2_gradient <- rbind(rep(-Inf, length(param))) + fit2_jacobian <- rbind(rep(-Inf, length(param))) + out <- list(objective = Inf, + gradient = fit2_gradient, + constraints = Inf, + jacobian = fit2_jacobian, + parameterTable = NA) + return(out) + } else { + if (lav_warn) { + fit2_gradient <- rbind(lavaan::lavTech(fit2, "gradient")) + fit2_jacobian <- rbind(lavaan::lavTech(fit2, "gradient")) + } else { + fit2_gradient <- tryCatch(suppressWarnings(rbind(lavaan::lavTech(fit2, "gradient"))), + error = function(e) rep(-Inf, length(param))) + suppressWarnings(fit2_jacobian <- + rbind(fit2_gradient)) + } + } list( objective = lavaan::lavTech(fit2, "optim")$fx, gradient = fit2_gradient, From 153f41c805b5b408e47120a6bb63a00ed7fc3ac1 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 21:55:45 +0800 Subject: [PATCH 38/68] Fix a bug when all lbs are NA Tests passed. --- R/print_semlbci.R | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/R/print_semlbci.R b/R/print_semlbci.R index bd5ce9ca..50aa5172 100644 --- a/R/print_semlbci.R +++ b/R/print_semlbci.R @@ -195,21 +195,21 @@ print.semlbci <- function(x, out$label <- NULL } class(out) <- "data.frame" - out$lbci_lb <- formatC(out$lbci_lb, digits, format = "f") + out$lbci_lb <- formatC(out$lbci_lb, digits, format = "f", mode = "double") if ("est.std" %in% colnames(x)) { standardized <- TRUE - out$est.std <- formatC(out$est.std, digits, format = "f") + out$est.std <- formatC(out$est.std, digits, format = "f", mode = "double") } else { standardized <- FALSE - out$est <- formatC(out$est, digits, format = "f") + out$est <- formatC(out$est, digits, format = "f", mode = "double") } - out$lbci_ub <- formatC(out$lbci_ub, digits, format = "f") - out$ci_org_lb <- formatC(out$ci_org_lb, digits, format = "f") - out$ci_org_ub <- formatC(out$ci_org_ub, digits, format = "f") - out$ratio_lb <- formatC(out$ratio_lb, digits, format = "f") - out$ratio_ub <- formatC(out$ratio_ub, digits, format = "f") - out$cl_lb <- formatC(out$cl_lb, digits, format = "f") - out$cl_ub <- formatC(out$cl_ub, digits, format = "f") + out$lbci_ub <- formatC(out$lbci_ub, digits, format = "f", mode = "double") + out$ci_org_lb <- formatC(out$ci_org_lb, digits, format = "f", mode = "double") + out$ci_org_ub <- formatC(out$ci_org_ub, digits, format = "f", mode = "double") + out$ratio_lb <- formatC(out$ratio_lb, digits, format = "f", mode = "double") + out$ratio_ub <- formatC(out$ratio_ub, digits, format = "f", mode = "double") + out$cl_lb <- formatC(out$cl_lb, digits, format = "f", mode = "double") + out$cl_ub <- formatC(out$cl_ub, digits, format = "f", mode = "double") call_org <- attr(out, "call") if (drop_no_lbci) { out <- out[!is.na(out$status_lb), ] @@ -699,7 +699,8 @@ format_ratio <- function(object, where <- match.arg(where) tmp <- formatC(as.numeric(object), digits = digits, - format = "f") + format = "f", + mode = "double") tmp2 <- tmp if (where == "left") { tmp2[which(!flag)] <- paste0(" ", tmp[which(!flag)]) From f08c8ab35003f7cfeb13ca71133447a171cba21a Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 23:28:50 +0800 Subject: [PATCH 39/68] Delete semlbci.html --- R/semlbci.html | 896 ------------------------------------------------- 1 file changed, 896 deletions(-) delete mode 100644 R/semlbci.html diff --git a/R/semlbci.html b/R/semlbci.html deleted file mode 100644 index a5429773..00000000 --- a/R/semlbci.html +++ /dev/null @@ -1,896 +0,0 @@ - - - - - - - - - - - - - - - -semlbci.R - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - -

@title Likelihood-Based Confidence -Interval

-

@description Find the likelihood-based -confidence intervals (LBCIs) for selected free parameters in an SEM -output.

-

@details [semlbci()] finds the -positions of the selected parameters in the parameter table and then -calls [ci_i_one()] once for each of them. For the technical details, -please see [ci_i_one()] and the functions it calls to find a confidence -bound, currently [ci_bound_wn_i()]. [ci_bound_wn_i()] uses the approach -proposed by Wu and Neale (2012) and illustrated by Pek and Wu -(2015).

-

It supports updating an output of [semlbci()] by setting -semlbci_out. This allows forming LBCIs for some parameters -after those for some others have been formed.

-

If possible, parallel processing should be used (see -parallel and ncpus), especially for a model -with many parameters.

-

If the search for some of the confidence bounds failed, with -NA for the bounds, try increasing -try_k_more_times.

-

The SEM output will first be checked by [check_sem_out()] to see -whether the model and the estimation method are supported. To skip this -test (e.g., for testing or experimenting with some models and -estimators), set check_fit to FALSE.

-

Examples and technical details can be found at Cheung and Pesigan -(2023), the website of the semlbci package (https://sfcheung.github.io/semlbci/), and the technical -appendices at (https://sfcheung.github.io/semlbci/articles/).

-

It currently supports [lavaan::lavaan-class] outputs only.

-

@return A semlbci-class -object similar to the parameter table generated by -[lavaan::parameterEstimates()], with the LBCIs for selected parameters -added. Diagnostic information, if requested, will be included in the -attributes. See [print.semlbci()] for options available.

-

@param sem_out The SEM output. -Currently supports [lavaan::lavaan-class] outputs only.

-

@param pars The positions of the -parameters for which the LBCIs are to be searched. Use the position as -appeared on the parameter tables of the sem_out. If -NULL, the default, then LBCIs for all free parameters will -be searched. Can also be a vector of strings to indicate the parameters -on the parameter table. The parameters should be specified in -[lavaan::lavaan()] syntax. The vector of strings will be converted by -[syntax_to_i()] to parameter positions. See [syntax_to_i()] on how to -specify the parameters.

-

@param include_user_pars Logical. -Whether all user-defined parameters are automatically included when -pars is not set. Default is TRUE. If -pars is explicitly set, this argument will be ignored.

-

@param remove_variances Logical. -Whether variances and error variances will be removed. Default is -TRUE, removing all variances and error variances even if -specified in pars.

-

@param remove_intercepts Logical. -Whether intercepts will be removed. Default is TRUE, -removing all intercepts (parameters with operator ~1). -Intercepts are not yet supported in standardized solution and so will -always be removed if standardized = TRUE.

-

@param ciperc The proportion of -coverage for the confidence interval. Default is .95, requesting a 95 -percent confidence interval.

-

@param standardized If -TRUE, the LBCI is for the standardized estimates.

-

@param method The method to be used to -search for the confidence bounds. Supported methods are"wn" -(Wu-Neale-2012), the default, and "ur" (root finding by -[stats::uniroot()]).

-

@param robust Whether the LBCI based on -robust likelihood ratio test is to be found. Only -"satorra.2000" in [lavaan::lavTestLRT()] is supported for -now, implemented by the method proposed by Falk (2018). If -"none", the default, then likelihood ratio test based on -maximum likelihood estimation will be used.

-

@param try_k_more_times How many more -times to try if failed. Default is 2.

-

@param semlbci_out An -semlbci-class object. If provided, parameters already with -LBCIs formed will be excluded from pars.

-

@param check_fit If TRUE -(default), the input (sem_out) will be checked by -[check_sem_out()]. If not supported, an error will be raised. If -FALSE, the check will be skipped and the LBCIs will be -searched even for a model or parameter not supported. Set to -TRUE only for testing.

-

@param … Arguments to be passed to -[ci_bound_wn_i()].

-

@param parallel If TRUE, -will use parallel processing to do the search.

-

@param ncpus The number of workers, if -parallel is TRUE. Default is 2. This number -should not be larger than the number CPU cores.

-

@param use_pbapply If TRUE -and pbapply is installed, [pbapply::pbapply()] will be used -to display a progress bar when finding the intervals. Default is -TRUE. Ignored if pbapply is not installed.

-

@param loadbalancing Whether load -balancing is used when parallel is TRUE and -use_pbapply is TRUE.

-

@author Shu Fai Cheung https://orcid.org/0000-0002-9871-9448

-

@references

-

Cheung, S. F., & Pesigan, I. J. A. (2023). semlbci: An R -package for forming likelihood-based confidence intervals for parameter -estimates, correlations, indirect effects, and other derived parameters. -Structural Equation Modeling: A Multidisciplinary Journal. -Advance online publication.

-

Falk, C. F. (2018). Are robust standard errors the best approach for -interval estimation with nonnormal data in structural equation modeling? -Structural Equation Modeling: A Multidisciplinary Journal, -25(2), 244-266.

-

Pek, J., & Wu, H. (2015). Profile likelihood-based confidence -intervals and regions for structural equation models. Psychometrika, -80(4), 1123-1145.

-

Wu, H., & Neale, M. C. (2012). Adjusted confidence intervals for -a bounded parameter. Behavior Genetics, 42(6), 886-898.

-

Pritikin, J. N., Rappaport, L. M., & Neale, M. C. (2017). -Likelihood-based confidence intervals for a parameter with an upper or -lower bound. Structural Equation Modeling: A Multidisciplinary -Journal, 24(3), 395-401.

-

@seealso [print.semlbci()], -[confint.semlbci()], [ci_i_one()], [ci_bound_wn_i()]

-

@examples

-

library(lavaan) mod <- ” m ~ ax y ~ bm ab := a * b ” -fit_med <- sem(mod, simple_med, fixed.x = FALSE) p_table <- -parameterTable(fit_med) p_table lbci_med <- semlbci(fit_med, pars = -c(“m ~ x”, “y ~ m”, “ab :=”)) lbci_med

-

@export

-
semlbci <- function(sem_out,
-                    pars = NULL,
-                    include_user_pars = TRUE,
-                    remove_variances = TRUE,
-                    remove_intercepts = TRUE,
-                    ciperc = .95,
-                    standardized = FALSE,
-                    method = c("wn", "ur"),
-                    robust = c("none", "satorra.2000"),
-                    try_k_more_times = 2,
-                    semlbci_out = NULL,
-                    check_fit = TRUE,
-                    ...,
-                    parallel = FALSE,
-                    ncpus = 2,
-                    use_pbapply = TRUE,
-                    loadbalancing = TRUE) {
-    if (!inherits(sem_out, "lavaan")) {
-        stop("sem_out is not a supported object.")
-      }
-    if (!is.null(semlbci_out)) {
-        if (!inherits(semlbci_out, "semlbci")) {
-            stop("semlbci_out is not an output of semlbci().")
-          }
-      }
-    method <- match.arg(method)
-    robust <- match.arg(robust)
-    sem_out_name <- deparse(substitute(sem_out))
-
-    # Use satorra.2000 automatically if
-    # - a scaled test is used and
-    # - the method is "ur"
-
-    scaled <- any(names(lavaan::lavInspect(sem_out, "test")) %in%
-                        c("satorra.bentler",
-                          "yuan.bentler",
-                          "yuan.bentler.mplus",
-                          "mean.var.adjusted",
-                          "scaled.shifted"))
-    if (scaled && (method == "ur")) {
-        robust <- "satorra.2000"
-      }
-
-    # Check sem_out
-    if (check_fit) {
-        sem_out_check <- check_sem_out(sem_out = sem_out, robust = robust)
-        if (sem_out_check > 0) {
-            msg <- paste0(paste(attr(sem_out_check, "info"), collapse = "\n"), "\n")
-            warning(msg, immediate. = TRUE)
-          }
-        if (sem_out_check < 0) {
-            msg <- paste0(paste(attr(sem_out_check, "info"), collapse = "\n"), "\n")
-            stop(msg)
-          }
-      }
-
-    ptable <- as.data.frame(lavaan::parameterTable(sem_out))
-    pars_lbci_yes <- rep(FALSE, nrow(ptable))
-    if (!is.null(semlbci_out)) {
-        # Check whether semlbci_out and sem_out match
-        tmp0 <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")]
-        tmp1 <- as.data.frame(semlbci_out)[, c("id", "lhs", "op", "rhs", "group", "label")]
-        if (!identical(tmp0, tmp1)) {
-            stop("semblci_out and the parameter table of sem_out do not match.")
-          }
-        # Find pars with both lbci_lb and lbci_ub
-        pars_lbci_yes <- !sapply(semlbci_out$lbci_lb, is.na) &
-                         !sapply(semlbci_out$lbci_ub, is.na)
-      }
-    i <- ptable$free > 0
-    i_id <- ptable$id
-    i_id_free <- i_id[i]
-    i_id_user <- i_id[(ptable$free == 0) & (ptable$op == ":=")]
-    # pars must be the row numbers as in the lavaan parameterTable.
-    if (!is.null(pars)) {
-        # Parameters supplied
-        if (is.character(pars)) {
-            # Convert syntax to row numbers.
-            pars <- syntax_to_i(pars, sem_out)
-          }
-        if (standardized) {
-            # Always exclude variances fixed in the standardized solution
-            pars <- remove_v1(pars, sem_out)
-          }
-        # Remove parameters already with LBCIs in semlbci_out.
-        pars <- pars[!pars %in% i_id[pars_lbci_yes]]
-        # Ids in the vector of free parameters
-        i_selected <- i_id[pars]
-      } else {
-        # Start with all free parameters
-        pars <- i_id_free
-        if (standardized) {
-            # Intercepts and means not supported for standardized solution
-            remove_intercepts <- TRUE
-            # Always exclude variances fixed in the standardized solution
-            pars <- remove_v1(pars, sem_out)
-            # Include parameters free in the standardized solution,
-            # e.g., fixed loadings.
-            pars <- sort(unique(c(pars, free_in_std(i_id, sem_out))))
-          }
-        if (include_user_pars && length(i_id_user) > 0) {
-            pars <- c(pars, i_id_user)
-          }
-        if (remove_variances) {
-            pars <- remove_variances(pars, sem_out)
-          }
-        if (remove_intercepts) {
-            pars <- remove_variances(pars, sem_out)
-          }
-        # Remove parameters already with LBCIs in semlbci_out.
-        pars <- pars[!pars %in% i_id[pars_lbci_yes]]
-        # Ids in the vector of free parameters
-        i_selected <- i_id[pars]
-      }
-    if (length(pars) == 0) {
-        if (is.null(semlbci_out)) {
-            stop("The number of parameters selected is zero.")
-          } else {
-            warning("No parameter selected. semlbci_out returned.")
-            return(semlbci_out)
-          }
-      }
-    npar <- sum(i)
-    # KEEP for reference: environment(set_constraint) <- parent.frame()
-    if (method == "wn") {
-        f_constr <- eval(set_constraint(sem_out = sem_out, ciperc = ciperc),
-                        envir = parent.frame())
-      } else {
-        f_constr <- NULL
-      }
-
-    # Compute the scaling factors
-    if (robust == "satorra.2000") {
-        sf_full_list <- lapply(pars,
-                               scaling_factor3,
-                               sem_out = sem_out,
-                               standardized = standardized,
-                               std_method = "internal",
-                               sem_out_name = sem_out_name)
-      } else {
-        sf_full_list <- rep(NA, length(pars))
-      }
-
-    if (parallel) {
-        # Parallel
-        cl <- parallel::makeCluster(ncpus)
-        # Rebuild the environment
-        pkgs <- .packages()
-        pkgs <- rev(pkgs)
-        parallel::clusterExport(cl, "pkgs", envir = environment())
-        parallel::clusterEvalQ(cl, {sapply(pkgs,
-                        function(x) library(x, character.only = TRUE))
-                      })
-        parallel::clusterExport(cl, ls(envir = parent.frame()),
-                                       envir = environment())
-        if (requireNamespace("pbapply", quietly = TRUE) &&
-            use_pbapply) {
-            if (loadbalancing) {
-                pboptions_old <- pbapply::pboptions(use_lb = TRUE)
-                # Restore pboptions on exit
-                on.exit(pbapply::pboptions(pboptions_old))
-              }
-            # Use pbapply
-            args_final <- utils::modifyList(list(...),
-                                    list(npar = npar,
-                                        sem_out = sem_out,
-                                        standardized = standardized,
-                                        debug = FALSE,
-                                        f_constr = f_constr,
-                                        method = method,
-                                        ciperc = ciperc,
-                                        robust = robust,
-                                        try_k_more_times = try_k_more_times,
-                                        sem_out_name = sem_out_name))
-            pars2 <- rep(pars, each = 2)
-            sf_full_list2 <- rep(sf_full_list, each = 2)
-            which2 <- rep(c("lbound", "ubound"), times = length(pars))
-            plist <- mapply(function(x, y, z) list(i = x, sf_full = y, which = z),
-                            x = pars2, y = sf_full_list2, z = which2,
-                            SIMPLIFY = FALSE)
-            tmpfct <- function(x) {
-                force(args_final)
-                args_final1 <- utils::modifyList(args_final, x)
-                do.call(semlbci::ci_i_one, args_final1)
-              }
-            out_raw2 <- pbapply::pblapply(plist,
-                                          tmpfct,
-                                          cl = cl)
-          } else {
-            # No progress bar
-            args_final <- utils::modifyList(list(...),
-                                    list(npar = npar,
-                                        sem_out = sem_out,
-                                        standardized = standardized,
-                                        debug = FALSE,
-                                        f_constr = f_constr,
-                                        method = method,
-                                        ciperc = ciperc,
-                                        robust = robust,
-                                        try_k_more_times = try_k_more_times,
-                                        sem_out_name = sem_out_name))
-            pars2 <- rep(pars, each = 2)
-            sf_full_list2 <- rep(sf_full_list, each = 2)
-            which2 <- rep(c("lbound", "ubound"), times = length(pars))
-            out_raw2 <- parallel::clusterMap(cl,
-                              semlbci::ci_i_one,
-                              i = pars2,
-                              sf_full = sf_full_list2,
-                              which = which2,
-                              MoreArgs = args_final,
-                              SIMPLIFY = FALSE)
-          }
-        parallel::stopCluster(cl)
-      } else {
-        # Serial
-        # Progress bar not support when ran in serial.
-        args_final <- utils::modifyList(list(...),
-                                list(npar = npar,
-                                    sem_out = sem_out,
-                                    standardized = standardized,
-                                    debug = FALSE,
-                                    f_constr = f_constr,
-                                    method = method,
-                                    ciperc = ciperc,
-                                    robust = robust,
-                                    try_k_more_times = try_k_more_times,
-                                    sem_out_name = sem_out_name))
-        pars2 <- rep(pars, each = 2)
-        sf_full_list2 <- rep(sf_full_list, each = 2)
-        which2 <- rep(c("lbound", "ubound"), times = length(pars))
-        if (requireNamespace("pbapply", quietly = TRUE) &&
-            use_pbapply) {
-              out_raw2 <- pbapply::pbmapply(
-                            ci_i_one,
-                            i = pars2,
-                            sf_full = sf_full_list2,
-                            which = which2,
-                            MoreArgs = args_final,
-                            SIMPLIFY = FALSE)
-            } else {
-              out_raw2 <- mapply(
-                            ci_i_one,
-                            i = pars2,
-                            sf_full = sf_full_list2,
-                            which = which2,
-                            MoreArgs = args_final,
-                            SIMPLIFY = FALSE)
-            }
-      }
-    tmpfct2 <- function(x, y) {
-        out <- mapply(c, x, y, SIMPLIFY = FALSE)
-        out$method <- out$method[[1]]
-        out$sf_full <- out$sf_full[[1]]
-        out
-      }
-    tmp1 <- seq(1, 2 * length(pars), 2)
-    tmp2 <- tmp1 + 1
-    out_raw <- mapply(tmpfct2,
-                      out_raw2[tmp1],
-                      out_raw2[tmp2],
-                      SIMPLIFY = FALSE)
-    out <- do.call(rbind, lapply(out_raw, function(x) x$bounds))
-    if (is.null(semlbci_out)) {
-        # Build the output
-        out_p <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")]
-        if (standardized) {
-            pstd <- lavaan::standardizedSolution(sem_out)
-            if (lavaan::lavTech(sem_out, "ngroups") == 1) {
-                pstd$group <- 1
-              }
-            pstd$group[pstd$op == ":="] <- 0
-            out_p <- merge(out_p, pstd[, c("lhs", "op", "rhs", "group", "est.std")],
-                    by = c("lhs", "op", "rhs", "group"), all.x = TRUE, sort = FALSE)
-          } else {
-            out_p$est <- ptable[, c("est")]
-          }
-        out_p$lbci_lb <- NA
-        out_p$lbci_ub <- NA
-      } else {
-        # Use existing output
-        out_p <- semlbci_out
-      }
-
-    out_p[i_selected, "lbci_lb"] <- out[, 1]
-    out_p[i_selected, "lbci_ub"] <- out[, 2]
-
-    # Collect diagnostic info
-    if (is.null(semlbci_out)) {
-        # Create the holder
-        q <- length(i_id)
-        lb_diag <- as.list(rep(NA, q))
-        ub_diag <- as.list(rep(NA, q))
-        lb_time <- as.numeric(rep(NA, q))
-        ub_time <- as.numeric(rep(NA, q))
-        lb_out <- as.list(rep(NA, q))
-        ub_out <- as.list(rep(NA, q))
-        ci_method <- as.character(rep(NA, q))
-        scaling_factor <- as.list(rep(NA, q))
-      } else {
-        # Retrieve from existing output
-        q <- length(i_id)
-        lb_diag <- attr(semlbci_out, "lb_diag")
-        ub_diag <- attr(semlbci_out, "ub_diag")
-        lb_time <- attr(semlbci_out, "lb_time")
-        ub_time <- attr(semlbci_out, "ub_time")
-        lb_out <- attr(semlbci_out, "lb_out")
-        ub_out <- attr(semlbci_out, "ub_out")
-        ci_method <- attr(semlbci_out, "ci_method")
-        scaling_factor <- attr(semlbci_out, "scaling_factor")
-      }
-    # Update the output
-    lb_diag[pars] <- lapply(out_raw, function(x) x$diags$lb_diag)
-    ub_diag[pars] <- lapply(out_raw, function(x) x$diags$ub_diag)
-    lb_time[pars] <- sapply(out_raw, function(x) x$times$lb_time)
-    ub_time[pars] <- sapply(out_raw, function(x) x$times$ub_time)
-    lb_out[pars] <- lapply(out_raw, function(x) x$ci_bound_i_out$lb_out)
-    ub_out[pars] <- lapply(out_raw, function(x) x$ci_bound_i_out$ub_out)
-    ci_method[pars] <- sapply(out_raw, function(x) x$method)
-    scaling_factor[pars] <- lapply(out_raw, function(x) x$sf_full)
-    p_names <- sapply(pars, i_to_name, sem_out = sem_out)
-    names(lb_diag)[pars] <- p_names
-    names(ub_diag)[pars] <- p_names
-    names(lb_time)[pars] <- p_names
-    names(ub_time)[pars] <- p_names
-    names(lb_out)[pars] <- p_names
-    names(ub_out)[pars] <- p_names
-    names(ci_method)[pars] <- p_names
-    names(scaling_factor)[pars] <- p_names
-
-    attr(out_p, "lb_diag") <- lb_diag
-    attr(out_p, "ub_diag") <- ub_diag
-    attr(out_p, "lb_time") <- lb_time
-    attr(out_p, "ub_time") <- ub_time
-    attr(out_p, "lb_out") <- lb_out
-    attr(out_p, "ub_out") <- ub_out
-    attr(out_p, "ci_method") <- ci_method
-    attr(out_p, "scaling_factor") <- scaling_factor
-    attr(out_p, "call") <- match.call()
-
-    # Append diagnostic info
-
-    out_p[pars, "status_lb"] <- sapply(lb_diag[pars], function(x) x$status)
-    out_p[pars, "status_ub"] <- sapply(ub_diag[pars], function(x) x$status)
-    out_p[pars, "ci_org_lb"] <- sapply(lb_diag[pars], function(x) x$ci_org_limit)
-    out_p[pars, "ci_org_ub"] <- sapply(ub_diag[pars], function(x) x$ci_org_limit)
-    out_p[pars, "ratio_lb"] <- sapply(lb_diag[pars], function(x) x$ci_limit_ratio)
-    out_p[pars, "ratio_ub"] <- sapply(ub_diag[pars], function(x) x$ci_limit_ratio)
-    out_p[pars, "post_check_lb"] <-
-                            sapply(lb_diag[pars], function(x) x$fit_post_check)
-    out_p[pars, "post_check_ub"] <-
-                            sapply(ub_diag[pars], function(x) x$fit_post_check)
-    out_p[pars, "time_lb"] <- as.numeric(lb_time[pars])
-    out_p[pars, "time_ub"] <- as.numeric(ub_time[pars])
-    out_p[pars, "cl_lb"] <- sapply(lb_diag[pars], function(x) x$ciperc_final)
-    out_p[pars, "cl_ub"] <- sapply(ub_diag[pars], function(x) x$ciperc_final)
-    out_p[pars, "method"] <- ci_method[pars]
-    if (robust != "none") {
-        out_p[pars, "robust"] <- robust
-      }
-
-    class(out_p) <- c("semlbci", class(out_p))
-    out_p
-  }
- - - - -
- - - - - - - - - - - - - - - From 57eabeff6326ce8b20311b9a1fef523b5c5b7136 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 23:41:49 +0800 Subject: [PATCH 40/68] Improve the error handler --- R/ci_bound_wn_i.R | 108 +++++++++++++++++++++++++++++++++++---------- R/set_constraint.R | 12 ++++- 2 files changed, 95 insertions(+), 25 deletions(-) diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index c4e7cd07..c2d7764e 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -142,6 +142,12 @@ #' for free variances. Default is 3, the estimate minus 3 standard #' error. If negative, the lower bound is set using `lb_prop`. #' +#' @param try_harder If error occurred +#' in the optimization, how many more +#' times to try. In each new attempt, +#' the starting values will be randomly +#' jittered. Default is 0. +#' #' @param ... Optional arguments. Not used. #' #' @references @@ -205,6 +211,7 @@ ci_bound_wn_i <- function(i = NULL, ftol_rel_factor = 1, lb_prop = .05, lb_se_k = 3, + try_harder = 0, ...) { k <- switch(which, lbound = 1, @@ -311,7 +318,7 @@ ci_bound_wn_i <- function(i = NULL, } start0 <- lavaan::parameterTable(sem_out) # The function to be minimized. - lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2) { + lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { start1 <- start0 start1[start1$free > 0, "est"] <- param sem_out2 <- sem_out @@ -357,13 +364,22 @@ ci_bound_wn_i <- function(i = NULL, } start0 <- lavaan::parameterTable(sem_out) # The function to be minimized. - lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2) { - std0 <- std_lav(param, sem_out) - k * std0[i_std] + lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { + std0 <- tryCatch(std_lav(param, sem_out), + error = function(e) e) + if (inherits(std0, "error")) { + if (stop_on_error) { + stop("Error in std_lav().") + } else { + return(Inf) + } + } else { + return(k * std0[i_std]) + } } } # The gradient of the function to be minimized - lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2) { + lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { lavaan::lav_func_gradient_complex( lbci_b_f, param, sem_out = sem_out, debug = debug, lav_warn = lav_warn, @@ -381,11 +397,21 @@ ci_bound_wn_i <- function(i = NULL, # Get the name of the defined parameter i_name <- p_table[i, "label"] # The function to be minimized. - lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2) { - k * sem_out@Model@def.function(param)[i_name] + lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { + out <- tryCatch(k * sem_out@Model@def.function(param)[i_name], + error = function(e) e) + if (inherits(out, "error")) { + if (stop_on_error) { + stop("Error in cmoputing user-parameter(s).") + } else { + return(Inf) + } + } else { + return(out) + } } # The gradient of the function to be minimized - lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2) { + lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { lavaan::lav_func_gradient_complex( lbci_b_f, param, sem_out = sem_out, debug = debug, lav_warn = lav_warn, @@ -401,7 +427,7 @@ ci_bound_wn_i <- function(i = NULL, } else { # The function to be minimized. # force() may not be needed but does not harm to keep them. - lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2) { + lbci_b_f <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { force(k) force(i_in_free) k * param[i_in_free] @@ -409,7 +435,7 @@ ci_bound_wn_i <- function(i = NULL, # The gradient of the function to be minimized grad_c <- rep(0, npar) grad_c[i_in_free] <- k - lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2) { + lbci_b_grad <- function(param, sem_out, debug, lav_warn, sf, sf2, stop_on_error = FALSE) { grad_c } } @@ -473,19 +499,55 @@ ci_bound_wn_i <- function(i = NULL, "maxeval" = 500, "print_level" = 0), opts) - out <- nloptr::nloptr( - x0 = xstart, - eval_f = lbci_b_f, - lb = fit_lb, - ub = fit_ub, - eval_grad_f = lbci_b_grad, - eval_g_eq = f_constr, - opts = opts_final, - sem_out = sem_out, - lav_warn = FALSE, - debug = FALSE, - sf = sf, - sf2 = sf2) + try_harder <- as.integer(max(try_harder, 0)) + try_harder_count <- 0 + xstart_i <- xstart + while(try_harder_count <= try_harder) { + out <- tryCatch(nloptr::nloptr( + x0 = xstart_i, + eval_f = lbci_b_f, + lb = fit_lb, + ub = fit_ub, + eval_grad_f = lbci_b_grad, + eval_g_eq = f_constr, + opts = opts_final, + sem_out = sem_out, + lav_warn = FALSE, + debug = FALSE, + sf = sf, + sf2 = sf2, + stop_on_error = TRUE), + error = function(e) e) + if (inherits(out, "error")) { + xstart_i <- stats::runif(length(xstart_i), + min = -2, + max = 2) * xstart_i + try_harder_count <- try_harder_count + 1 + } else { + try_harder_count <- Inf + } + } + + # Failed after try harder k times + + if (inherits(out, "error")) { + opts_error <- utils::modifyList(opts_final, + list("maxeval" = 1)) + out <- nloptr::nloptr(x0 = xstart, + eval_f = lbci_b_f, + lb = fit_lb, + ub = fit_ub, + eval_grad_f = lbci_b_grad, + eval_g_eq = f_constr, + opts = opts_error, + sem_out = sem_out, + lav_warn = FALSE, + debug = FALSE, + sf = sf, + sf2 = sf2, + stop_on_error = TRUE) + } + # Process the results diff --git a/R/set_constraint.R b/R/set_constraint.R index 930031be..20cd658c 100644 --- a/R/set_constraint.R +++ b/R/set_constraint.R @@ -81,7 +81,8 @@ set_constraint <- function(sem_out, ciperc = .95) { debug = FALSE, lav_warn = FALSE, sf = 1, - sf2 = 0) { + sf2 = 0, + stop_on_error = FALSE) { target <- fmin + sf * (qcrit - sf2) / (2 * n) if (debug) { cat(ls()) @@ -109,6 +110,9 @@ set_constraint <- function(sem_out, ciperc = .95) { } is_error <- inherits(fit2, "error") if (is_error) { + if (stop_on_error) { + stop("Error in evaluating the constraint(s).") + } fit2_gradient <- rbind(rep(-Inf, length(param))) fit2_jacobian <- rbind(eq_jac, rep(-Inf, length(param))) @@ -146,7 +150,8 @@ set_constraint <- function(sem_out, ciperc = .95) { debug = FALSE, lav_warn = FALSE, sf = 1, - sf2 = 0) { + sf2 = 0, + stop_on_error = FALSE) { target <- fmin + sf * (qcrit - sf2) / (2 * n) if (debug) { cat(ls()) @@ -172,6 +177,9 @@ set_constraint <- function(sem_out, ciperc = .95) { } is_error <- inherits(fit2, "error") if (is_error) { + if (stop_on_error) { + stop("Error in evaluating the constraint(s).") + } fit2_gradient <- rbind(rep(-Inf, length(param))) fit2_jacobian <- rbind(rep(-Inf, length(param))) out <- list(objective = Inf, From f74ae32840c5d7b41203b73bd7cb0c3ccf721163 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 23:41:58 +0800 Subject: [PATCH 41/68] Update doc --- man/ci_bound_wn_i.Rd | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index 5cafd733..cb41f7f9 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -28,6 +28,7 @@ ci_bound_wn_i( ftol_rel_factor = 1, lb_prop = 0.05, lb_se_k = 3, + try_harder = 5, ... ) } @@ -124,6 +125,12 @@ negative.} for free variances. Default is 3, the estimate minus 3 standard error. If negative, the lower bound is set using \code{lb_prop}.} +\item{try_harder}{If error occurred +in the optimization, how many more +times to try. In each new attempt, +the starting values will be randomly +jittered. Default is 5.} + \item{...}{Optional arguments. Not used.} } \value{ From a1f4d9d3c57cd971dae42651d36d8c7a9802b6df Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Mon, 27 May 2024 23:43:48 +0800 Subject: [PATCH 42/68] Update to 0.10.4.4 Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- README.md | 2 +- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 412350fa..ff7325d0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.3 +Version: 0.10.4.4 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 6a4fa09b..03c6beec 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.3 +# semlbci 0.10.4.4 ## New Feature @@ -21,6 +21,9 @@ when calling `semlbci()` with `use_pbapply` set to `TRUE`. Enabled by default. (0.10.4.3) +- Add error handlers in the output + of `set_constraints()` and + `ci_bound_wn_i()`. (0.10.4.4) # semlbci 0.10.4 diff --git a/README.md b/README.md index cd75e41b..7a43d069 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.3, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.4, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 62026a00802d8933d86e40f94fed4e5ad1def9e9 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 18:56:48 +0800 Subject: [PATCH 43/68] Update ci_bound_wn_i.Rd --- man/ci_bound_wn_i.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index cb41f7f9..b40823da 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -28,7 +28,7 @@ ci_bound_wn_i( ftol_rel_factor = 1, lb_prop = 0.05, lb_se_k = 3, - try_harder = 5, + try_harder = 0, ... ) } @@ -129,7 +129,7 @@ error. If negative, the lower bound is set using \code{lb_prop}.} in the optimization, how many more times to try. In each new attempt, the starting values will be randomly -jittered. Default is 5.} +jittered. Default is 0.} \item{...}{Optional arguments. Not used.} } From 5872ab9fb95c3a25858d757982653e90612749c9 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 18:57:42 +0800 Subject: [PATCH 44/68] Make sure the bound is numeric, even if NA. Tests and checks passed. --- R/ci_bound_ur_i.R | 2 +- R/ci_bound_wn_i.R | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 2ab16ff8..66c52ed8 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -297,7 +297,7 @@ ci_bound_ur_i <- function(i = NULL, # Process the results - bound <- out$bound + bound <- as.numeric(out$bound) bound_unchecked <- bound # Initialize the status code diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index c2d7764e..1868510a 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -550,8 +550,8 @@ ci_bound_wn_i <- function(i = NULL, # Process the results - - bound <- k * out$objective + ## Need as.numeric() to handle NA + bound <- as.numeric(k * out$objective) bound_unchecked <- bound # Initialize the status code From 4a06f05246ad3d53e4e8cda8f2f762a4f6228b84 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 18:57:51 +0800 Subject: [PATCH 45/68] Update to 0.10.4.5 --- DESCRIPTION | 2 +- NEWS.md | 6 +++++- README.md | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ff7325d0..35aa3a6e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.4 +Version: 0.10.4.5 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 03c6beec..33338f0f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.4 +# semlbci 0.10.4.5 ## New Feature @@ -24,6 +24,10 @@ - Add error handlers in the output of `set_constraints()` and `ci_bound_wn_i()`. (0.10.4.4) +- Revised `ci_bound_wn_i()` and + `ci_bound_ur_i()` to make + sure the bound is a numeric object, + even if `NA`. (0.10.4.5) # semlbci 0.10.4 diff --git a/README.md b/README.md index 7a43d069..be4c12ad 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.4, updated on 2024-05-27, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.5, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From ed1435c84786f513daacbcb7cc2d81eb552f3a4e Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 19:23:21 +0800 Subject: [PATCH 46/68] Disable some attempts by default. If the first attempt failed, the additional attempts rarely help --- R/ci_i_one.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/ci_i_one.R b/R/ci_i_one.R index 5a9c6506..1af8c0cb 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -228,6 +228,10 @@ ci_i_one_wn <- function(i, sf, sf2, try_k_more_times = 0, + lb_se_k0 = 10, + lb_prop0 = .11, + lb_prop1 = .01, + try_lb = FALSE, ...) { # Wu-Neale-2012 method. # The only method supported for now. @@ -257,11 +261,8 @@ ci_i_one_wn <- function(i, } attempt_lb_var <- 0 # Attempt 2 - if (b$diag$status != 0) { + if ((b$diag$status != 0) && try_lb) { ## Successively reduce the positive lower bounds for free variances - lb_se_k0 <- 10 - lb_prop0 <- .11 - lb_prop1 <- .01 lb_propi <- lb_prop0 while ((lb_propi > lb_prop1) & (b$diag$status != 0)) { attempt_lb_var <- attempt_lb_var + 1 @@ -283,6 +284,9 @@ ci_i_one_wn <- function(i, if (b$diag$status != 0) { # Try k more times # Successively change the tolerance for convergence + if (!try_lb) { + lb_propi <- 1e-3 + } ki <- try_k_more_times fxi <- 1 fti <- 1 From 52f0220c29f72036e1bed689b2198506cc22c2f3 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 19:31:37 +0800 Subject: [PATCH 47/68] Change the default of try_k_more_times = 0. Tests and checks passed. --- R/semlbci.R | 2 +- man/semlbci.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/semlbci.R b/R/semlbci.R index e506e8e2..9b7af6fb 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -175,7 +175,7 @@ semlbci <- function(sem_out, standardized = FALSE, method = c("wn", "ur"), robust = c("none", "satorra.2000"), - try_k_more_times = 2, + try_k_more_times = 0, semlbci_out = NULL, check_fit = TRUE, ..., diff --git a/man/semlbci.Rd b/man/semlbci.Rd index 22895c80..adffe3bd 100644 --- a/man/semlbci.Rd +++ b/man/semlbci.Rd @@ -14,7 +14,7 @@ semlbci( standardized = FALSE, method = c("wn", "ur"), robust = c("none", "satorra.2000"), - try_k_more_times = 2, + try_k_more_times = 0, semlbci_out = NULL, check_fit = TRUE, ..., From 093ae205505b8790a55988b3350aee9a04f67a7f Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 19:33:25 +0800 Subject: [PATCH 48/68] Update to 0.10.4.6 --- DESCRIPTION | 2 +- NEWS.md | 23 ++++++++++++++++++++++- README.md | 2 +- 3 files changed, 24 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 35aa3a6e..ae16a8e3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.5 +Version: 0.10.4.6 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 33338f0f..67f6a41d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.5 +# semlbci 0.10.4.6 ## New Feature @@ -29,6 +29,27 @@ sure the bound is a numeric object, even if `NA`. (0.10.4.5) +## (Possibly) Breaking Changes + +- This may or may not be a breaking + changes. The default of + `try_k_more_times` in `semlbci()` was + changed from 2 to 0. These additional + attempts rarely help but usually + increase processing time + unnecessarily. (0.10.4.6) +- Disabled further attempts in + the `wn` method by default + as they rarely help but they usually + increase + the processing time unnecessarily. + If necessary, one of the set of + attempts, successfully lower the + lower limits of variances can be + enabled again by setting `try_lb` + to `TRUE` when calling `semlbci()` + (0.10.4.6) + # semlbci 0.10.4 ## New Feature diff --git a/README.md b/README.md index be4c12ad..c91710ba 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.5, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.6, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From e979f946177a4309b971265eeb8efa2a7b40f699 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 20:37:01 +0800 Subject: [PATCH 49/68] 0.10.4.7: Speed up some examples Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/ci_bound_ur_i.R | 16 ++++++++-------- README.md | 2 +- man/ci_bound_ur.Rd | 4 +++- man/ci_bound_ur_i.Rd | 10 +++++----- 6 files changed, 22 insertions(+), 17 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ae16a8e3..5db8b944 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.6 +Version: 0.10.4.7 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 67f6a41d..7af50aaf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.6 +# semlbci 0.10.4.7 ## New Feature @@ -28,6 +28,9 @@ `ci_bound_ur_i()` to make sure the bound is a numeric object, even if `NA`. (0.10.4.5) +- Speed up the examples of + `ci_bound_ur_i()` and `ci_bound_ur()`. + (0.10.4.7) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 66c52ed8..86975add 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -229,20 +229,20 @@ #' library(lavaan) #' data(simple_med) #' dat <- simple_med -#' #' mod <- #' " #' m ~ x #' y ~ m #' " -#' #' fit_med <- sem(mod, simple_med, fixed.x = FALSE) -#' +#' # Remove `opts` in real cases. +#' # The options are added just to speed up the example #' out1l <- ci_bound_ur_i(i = 1, #' sem_out = fit_med, -#' which = "lbound") +#' which = "lbound", +#' opts = list(use_callr = FALSE, +#' interval = c(0.8277, 0.8278))) #' out1l -#' #' @export ci_bound_ur_i <- function(i = NULL, @@ -590,17 +590,17 @@ ci_bound_ur_i <- function(i = NULL, #' " #' fit_med <- lavaan::sem(mod, simple_med, fixed.x = FALSE) #' parameterTable(fit_med) - #' # Create a function to get the second parameter #' est_i <- gen_est_i(i = 2, sem_out = fit_med) - #' # Find the lower bound of the likelihood-based confidence interval #' # of the second parameter. #' # user_callr should be TRUE or omitted in read research. +#' # Remove interval in read research. It is added to speed up the example. #' out1l <- ci_bound_ur(sem_out = fit_med, #' func = est_i, #' which = "lbound", -#' use_callr = FALSE) +#' use_callr = FALSE, +#' interval = c(.39070, .39075)) #' out1l #' #' @rdname ci_bound_ur diff --git a/README.md b/README.md index c91710ba..696f2794 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.6, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.7, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index a74b31d8..2de05388 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -214,10 +214,12 @@ est_i <- gen_est_i(i = 2, sem_out = fit_med) # Find the lower bound of the likelihood-based confidence interval # of the second parameter. # user_callr should be TRUE or omitted in read research. +# Remove interval in read research. It is added to speed up the example. out1l <- ci_bound_ur(sem_out = fit_med, func = est_i, which = "lbound", - use_callr = FALSE) + use_callr = FALSE, + interval = c(.39070, .39075)) out1l } diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index 32be6646..148672cf 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -244,20 +244,20 @@ parameters with cautions. library(lavaan) data(simple_med) dat <- simple_med - mod <- " m ~ x y ~ m " - fit_med <- sem(mod, simple_med, fixed.x = FALSE) - +# Remove `opts` in real cases. +# The options are added just to speed up the example out1l <- ci_bound_ur_i(i = 1, sem_out = fit_med, - which = "lbound") + which = "lbound", + opts = list(use_callr = FALSE, + interval = c(0.8277, 0.8278))) out1l - } \references{ Wu, H., & Neale, M. C. (2012). From 318b0905d7039bbd110a96f0989af6f6843b308b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Tue, 28 May 2024 21:18:55 +0800 Subject: [PATCH 50/68] 0.10.4.8: Precompute the interval in ci_bound_ur_i() Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 +++- R/ci_bound_ur_i.R | 57 ++++++++++++++++++++++++++++++++++++++++---- README.md | 2 +- man/ci_bound_ur_i.Rd | 7 ++++++ 5 files changed, 65 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5db8b944..faa2e250 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.7 +Version: 0.10.4.8 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 7af50aaf..e3d2c15f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.7 +# semlbci 0.10.4.8 ## New Feature @@ -31,6 +31,9 @@ - Speed up the examples of `ci_bound_ur_i()` and `ci_bound_ur()`. (0.10.4.7) +- Precompute the interval in + `ci_bound_ur_i()` before calling + `ci_bound_ur()`. (0.10.4.8) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 86975add..152783f6 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -207,6 +207,12 @@ #' function. Included consistency in the #' interface. #' +#' @param d A value used to determine +#' the width of the interval in the +#' initial search. Larger this value, +#' *narrow* the interval. Default is 5. +#' Used by [ci_bound_ur()]. +#' #' @param ... Optional arguments. Not #' used. #' @@ -268,15 +274,55 @@ ci_bound_ur_i <- function(i = NULL, ftol_rel_factor = 1, # Not used by ur lb_prop = .05, # Not used by ur lb_se_k = 3, # Not used by ur + d = 5, ...) { # Basic info - est <- lavaan::parameterEstimates(sem_out, ci = TRUE) - i_est <- est[i, "est"] - i_org_ci_limit <- switch(which, - lbound = est[i, "ci.lower"], - ubound = est[i, "ci.upper"]) + # Check if the parameter is a user-defined parameter + p_table <- lavaan::parameterTable(sem_out) + i_op <- p_table[i, "op"] + # The id in the vector of free parameters + i_in_free <- p_table[i, "free"] + + # Get original point estimate and CI + if (standardized) { + ## Standardized solution + p_est <- lavaan::standardizedSolution(sem_out, + type = "std.all", + se = TRUE, + zstat = FALSE, + pvalue = FALSE, + ci = TRUE, + level = ciperc, + remove.eq = FALSE, + remove.ineq = FALSE, + remove.def = FALSE, + output = "data.frame") + i_est <- p_est[i, "est.std"] + i_org_ci_limit <- switch(which, + lbound = p_est[i, "ci.lower"], + ubound = p_est[i, "ci.upper"]) + } else { + ## Unstandardized solution + p_est <- lavaan::parameterEstimates(sem_out, + se = TRUE, + ci = TRUE, + level = ciperc, + zstat = FALSE, + fmi = FALSE, + rsquare = TRUE, + output = "data.frame") + i_est <- p_est[i, "est"] + i_org_ci_limit <- switch(which, + lbound = p_est[i, "ci.lower"], + ubound = p_est[i, "ci.upper"]) + } + + # Initial interval to search + a <- abs(i_org_ci_limit - i_est) / d + interval0 <- c(i_org_ci_limit - a, i_org_ci_limit + a) + npar <- lavaan::lavTech(sem_out, "npar") # Generate the user-parameter function @@ -289,6 +335,7 @@ ci_bound_ur_i <- function(i = NULL, func = est_i_func, level = ciperc, which = which, + interval = interval0, uniroot_maxiter = 500) ur_opts <- utils::modifyList(ur_opts, opts) diff --git a/README.md b/README.md index 696f2794..864506e1 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.7, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.8, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index 148672cf..3e474414 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -29,6 +29,7 @@ ci_bound_ur_i( ftol_rel_factor = 1, lb_prop = 0.05, lb_se_k = 3, + d = 5, ... ) } @@ -145,6 +146,12 @@ interface.} function. Included consistency in the interface.} +\item{d}{A value used to determine +the width of the interval in the +initial search. Larger this value, +\emph{narrow} the interval. Default is 5. +Used by \code{\link[=ci_bound_ur]{ci_bound_ur()}}.} + \item{...}{Optional arguments. Not used.} } From ddfdb77fe7a8690c46698f0ad075edeb8426d528 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 29 May 2024 19:21:01 +0800 Subject: [PATCH 51/68] Replace close() by kill() and rename r1 to rs Tests, checks, and build_site() passed --- R/ci_bound_ur_i.R | 14 +++++++------- R/ci_bound_ur_i_helpers.R | 12 ++++++------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 152783f6..9bed643c 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -735,10 +735,10 @@ ci_bound_ur <- function(sem_out, out1 - y_target } if (use_callr) { - on.exit(try(r1$close(), silent = TRUE)) - r1 <- callr::r_session$new() + on.exit(try(rs$kill(), silent = TRUE)) + rs <- callr::r_session$new() if (progress) { - optimize_out <- r1$call(function(f, + optimize_out <- rs$call(function(f, interval, alpha, root_target, @@ -767,16 +767,16 @@ ci_bound_ur <- function(sem_out, trace = uniroot_trace, maxiter = uniroot_maxiter)) cat("\nSearch started ...\n") - while (r1$poll_process(500) != "ready") { - rtime <- r1$get_running_time()["total"] + while (rs$poll_process(500) != "ready") { + rtime <- rs$get_running_time()["total"] # TODO: # - Need to handle time longer than 1 mins. cat("\r", "Time spent: ", round(rtime, 2), " sec.", spe = "") } cat("\nSearch finished. Finalize the results ... \n") - optimize_out <- r1$read()$result + optimize_out <- rs$read()$result } else { - optimize_out <- r1$run(function(f, + optimize_out <- rs$run(function(f, interval, alpha, root_target, diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 3fe06f9d..8a48ef40 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -135,7 +135,7 @@ sem_out_userp_run <- function(target, control = list(), seed = NULL, global_ok = FALSE) { - on.exit(try(r1$close(), silent = TRUE)) + on.exit(try(rs$kill(), silent = TRUE)) userp <- object$userp userp_name <- object$userp_name @@ -147,8 +147,8 @@ sem_out_userp_run <- function(target, if (global_ok) { # Disabled for now } else { - r1 <- callr::r_session$new() - out <- r1$run(function(target, + rs <- callr::r_session$new() + out <- rs$run(function(target, verbose, control, seed, @@ -238,12 +238,12 @@ add_func <- function(func, sem_out, userp_name = "semlbciuserp1234", fix = TRUE) { - on.exit(try(r1$close(), silent = TRUE)) + on.exit(try(rs$kill(), silent = TRUE)) userp <- gen_userp(func = func, sem_out = sem_out) # Create a child process - r1 <- callr::r_session$new() - fit_i <- r1$run(function(..., + rs <- callr::r_session$new() + fit_i <- rs$run(function(..., userp, userp_name) { assign(userp_name, From 415b234611ea666abc073bcb423a33b92370eac2 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 29 May 2024 19:22:14 +0800 Subject: [PATCH 52/68] Update to 0.10.4.9 --- DESCRIPTION | 2 +- NEWS.md | 4 +++- README.md | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index faa2e250..7687119e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.8 +Version: 0.10.4.9 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index e3d2c15f..cbd0fa37 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.8 +# semlbci 0.10.4.9 ## New Feature @@ -34,6 +34,8 @@ - Precompute the interval in `ci_bound_ur_i()` before calling `ci_bound_ur()`. (0.10.4.8) +- Use `kill()` instead of `close()` + in R sessions. (0.10.4.9) ## (Possibly) Breaking Changes diff --git a/README.md b/README.md index 864506e1..f0d42ba3 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.8, updated on 2024-05-28, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.9, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From ef45a2d49bc6b65682ebf919099a1a7d94093a0d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 29 May 2024 19:31:45 +0800 Subject: [PATCH 53/68] 0.10.4.10: Store bound_start and user_est Tests, checks, and build_site() passed --- DESCRIPTION | 2 +- NEWS.md | 6 +++++- R/ci_bound_ur_i.R | 11 ++++++----- README.md | 2 +- 4 files changed, 13 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7687119e..66334cc0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.9 +Version: 0.10.4.10 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index cbd0fa37..0cac897d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.9 +# semlbci 0.10.4.10 ## New Feature @@ -36,6 +36,10 @@ `ci_bound_ur()`. (0.10.4.8) - Use `kill()` instead of `close()` in R sessions. (0.10.4.9) +- Add `bound_start` and `user_est` + to the precomputed interval. + (0.10.4.10) + ## (Possibly) Breaking Changes diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 9bed643c..13b84c2d 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -322,6 +322,8 @@ ci_bound_ur_i <- function(i = NULL, # Initial interval to search a <- abs(i_org_ci_limit - i_est) / d interval0 <- c(i_org_ci_limit - a, i_org_ci_limit + a) + attr(interval0, "bound_start") <- i_org_ci_limit + attr(interval0, "user_est") <- i_est npar <- lavaan::lavTech(sem_out, "npar") @@ -704,15 +706,14 @@ ci_bound_ur <- function(sem_out, func = func, which = which, d = d) - bound_start <- attr(interval, "bound_start") - user_est <- attr(interval, "user_est") if (progress) { cat("\rInitial interval computed. ") } - } else { - bound_start <- NA - user_est <- NA } + bound_start <- attr(interval, "bound_start") + user_est <- attr(interval, "user_est") + bound_start <- ifelse(is.null(bound_start), NA, bound_start) + user_est <- ifelse(is.null(user_est), NA, user_est) if (method == "uniroot") { # Define the function for which to find the root lrtp_i <- function(x, diff --git a/README.md b/README.md index f0d42ba3..77e0a4a9 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.9, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.10, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 13e5bede9883b3f072788323e80d7c37b7843c5b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 29 May 2024 20:43:11 +0800 Subject: [PATCH 54/68] WIP: Try reusing R sessions --- R/ci_bound_ur_i.R | 36 +++++++++++++++++++++++++++++------- R/ci_bound_ur_i_helpers.R | 18 ++++++++++++------ man/ci_bound_ur.Rd | 9 ++++++++- 3 files changed, 49 insertions(+), 14 deletions(-) diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 13b84c2d..9d08b737 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -333,12 +333,16 @@ ci_bound_ur_i <- function(i = NULL, standardized = standardized) # Find the root + on.exit(try(rs$kill(), silent = TRUE), add = TRUE) + rs <- callr::r_session$new() ur_opts <- list(sem_out = sem_out, func = est_i_func, level = ciperc, which = which, interval = interval0, - uniroot_maxiter = 500) + uniroot_maxiter = 500, + use_callr = FALSE, + rs = rs) ur_opts <- utils::modifyList(ur_opts, opts) out <- do.call(ci_bound_ur, @@ -599,6 +603,12 @@ ci_bound_ur_i <- function(i = NULL, #' interactive environment unless this is #' intentional. #' +#' @param rs Optional. If set to +#' a persistent R process created by +#' `callr`, it will be used instead of +#' starting a new one, and it will not +#' be terminated on exit. +#' #' @return #' The function [ci_bound_ur()] returns #' a list with the following elements: @@ -671,7 +681,8 @@ ci_bound_ur <- function(sem_out, uniroot_extendInt = "yes", uniroot_trace = 0, uniroot_maxiter = 1000, - use_callr = TRUE) { + use_callr = TRUE, + rs = NULL) { # Internal Workflow # - Define the function that works on the lavaan object. @@ -719,10 +730,12 @@ ci_bound_ur <- function(sem_out, lrtp_i <- function(x, alpha, root_target = "pvalue", - global_ok = FALSE) { + global_ok = FALSE, + rs = NULL) { sem_out_x <- sem_out_userp_run(target = x, object = fit_i, - global_ok = global_ok) + global_ok = global_ok, + rs = rs) lrt0 <- lavaan::lavTestLRT(sem_out_x, sem_out, method = lrt_method) @@ -736,8 +749,11 @@ ci_bound_ur <- function(sem_out, out1 - y_target } if (use_callr) { - on.exit(try(rs$kill(), silent = TRUE)) - rs <- callr::r_session$new() + if (is.null(rs)) { + on.exit(try(rs$kill(), silent = TRUE), add = TRUE) + rs <- callr::r_session$new() + } + # May fix: Cannot pass an R session to another R session if (progress) { optimize_out <- rs$call(function(f, interval, @@ -811,11 +827,16 @@ ci_bound_ur <- function(sem_out, if (progress) { cat("\nSearch started ...\n") } + if (is.null(rs)) { + on.exit(try(rs$kill(), silent = TRUE), add = TRUE) + rs <- callr::r_session$new() + } optimize_out <- stats::uniroot(lrtp_i, interval = interval, alpha = lrt_alpha, root_target = root_target, global_ok = FALSE, + rs = rs, extendInt = uniroot_extendInt, tol = tol, trace = uniroot_trace, @@ -827,7 +848,8 @@ ci_bound_ur <- function(sem_out, } out_root <- optimize_out$root sem_out_final <- sem_out_userp_run(target = out_root, - object = fit_i) + object = fit_i, + rs = rs) lrt_final <- lavaan::lavTestLRT(sem_out_final, sem_out, method = lrt_method) diff --git a/R/ci_bound_ur_i_helpers.R b/R/ci_bound_ur_i_helpers.R index 8a48ef40..7676646e 100644 --- a/R/ci_bound_ur_i_helpers.R +++ b/R/ci_bound_ur_i_helpers.R @@ -134,8 +134,8 @@ sem_out_userp_run <- function(target, verbose = FALSE, control = list(), seed = NULL, - global_ok = FALSE) { - on.exit(try(rs$kill(), silent = TRUE)) + global_ok = FALSE, + rs = NULL) { userp <- object$userp userp_name <- object$userp_name @@ -147,7 +147,10 @@ sem_out_userp_run <- function(target, if (global_ok) { # Disabled for now } else { - rs <- callr::r_session$new() + if (is.null(rs)) { + on.exit(try(rs$kill(), silent = TRUE)) + rs <- callr::r_session$new() + } out <- rs$run(function(target, verbose, control, @@ -237,12 +240,15 @@ sem_out_userp_run <- function(target, add_func <- function(func, sem_out, userp_name = "semlbciuserp1234", - fix = TRUE) { - on.exit(try(rs$kill(), silent = TRUE)) + fix = TRUE, + rs = NULL) { userp <- gen_userp(func = func, sem_out = sem_out) # Create a child process - rs <- callr::r_session$new() + if (is.null(rs)) { + on.exit(try(rs$kill(), silent = TRUE)) + rs <- callr::r_session$new() + } fit_i <- rs$run(function(..., userp, userp_name) { diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index 2de05388..a5d01215 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -22,7 +22,8 @@ ci_bound_ur( uniroot_extendInt = "yes", uniroot_trace = 0, uniroot_maxiter = 1000, - use_callr = TRUE + use_callr = TRUE, + rs = NULL ) gen_est_i(i, sem_out, standardized = FALSE) @@ -119,6 +120,12 @@ Default is 1000.} interactive environment unless this is intentional.} +\item{rs}{Optional. If set to +a persistent R process created by +\code{callr}, it will be used instead of +starting a new one, and it will not +be terminated on exit.} + \item{i}{The position of the target parameter as appeared in the parameter table of an lavaan object, From c2f63149c9ae46af62a9d303a3ed3efb8e157771 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Wed, 29 May 2024 21:01:16 +0800 Subject: [PATCH 55/68] 0.10.4.11: Reuse R sessions to improve speed Tests, checks, and build_site() passed --- DESCRIPTION | 2 +- NEWS.md | 6 +++++- README.md | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 66334cc0..d5c6ed12 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.10 +Version: 0.10.4.11 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 0cac897d..a2228cbe 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.10 +# semlbci 0.10.4.11 ## New Feature @@ -39,6 +39,10 @@ - Add `bound_start` and `user_est` to the precomputed interval. (0.10.4.10) +- Modified several functions related to + `"ur"` method to have the option to + use an existing R session instead of + creating a new one. (0.10.4.11) ## (Possibly) Breaking Changes diff --git a/README.md b/README.md index 77e0a4a9..14256777 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.10, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.11, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 351e0d57eeff7e6970072915099467a76fe30b8a Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Thu, 30 May 2024 20:17:40 +0800 Subject: [PATCH 56/68] 0.10.4.12: Store error in search and show it in the printout. Tests passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/ci_bound_wn_i.R | 6 +++++- R/print_cibound.R | 10 ++++++++++ README.md | 2 +- 5 files changed, 21 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d5c6ed12..46d4f151 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.11 +Version: 0.10.4.12 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index a2228cbe..e51ec0e3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.11 +# semlbci 0.10.4.12 ## New Feature @@ -43,6 +43,9 @@ `"ur"` method to have the option to use an existing R session instead of creating a new one. (0.10.4.11) +- Store the error in the search and + display it in the printout. + (0.10.4.12) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 1868510a..24828c38 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -531,6 +531,7 @@ ci_bound_wn_i <- function(i = NULL, # Failed after try harder k times if (inherits(out, "error")) { + search_error <- as.character(out) opts_error <- utils::modifyList(opts_final, list("maxeval" = 1)) out <- nloptr::nloptr(x0 = xstart, @@ -546,6 +547,8 @@ ci_bound_wn_i <- function(i = NULL, sf = sf, sf2 = sf2, stop_on_error = TRUE) + } else { + search_error <- NULL } @@ -663,7 +666,8 @@ ci_bound_wn_i <- function(i = NULL, standardized = standardized, check_optimization = check_optimization, check_post_check = check_post_check, - check_level_of_confidence = check_level_of_confidence + check_level_of_confidence = check_level_of_confidence, + search_error = search_error ) if (verbose) { diag$history <- out diff --git a/R/print_cibound.R b/R/print_cibound.R index 9cd01ad7..47f03372 100644 --- a/R/print_cibound.R +++ b/R/print_cibound.R @@ -63,6 +63,16 @@ print.cibound <- function(x, digits = 5, ...) { ubound = "Upper Bound"))) cat(paste0("\nMethod:\t\t\t", ci_method)) cat(paste0("\nConfidence Level:\t", out_diag$ciperc)) + if (!is.null(out_diag$search_error)) { + cat(paste0("\nSearch Error Message:\n", out_diag$search_error, "\n")) + cat(paste0(rep("*", round(getOption("width") * .8)), collapse = "")) + cat("\n") + cat(strwrap(c("The search was terminated due to the error above.", + "The following lines should not be interpreted.")), + sep = "\n") + cat(paste0(rep("*", round(getOption("width") * .8)), collapse = "")) + cat("\n") + } cat(paste0("\nAchieved Level:\t\t", out_diag$ciperc_final)) cat(paste0("\nStandardized:\t\t", std)) cat(paste0("\nLikelihood-Based Bound:\t", diff --git a/README.md b/README.md index 14256777..5cbf1fb8 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.11, updated on 2024-05-29, [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.12, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 7e8639265370eb6280440a0bcf0fe9ca1667bd7f Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Thu, 30 May 2024 22:59:37 +0800 Subject: [PATCH 57/68] 0.10.4.13: Add get_cibound_statu_not_0(). Tests, checks, and build_site() passed. --- DESCRIPTION | 2 +- NAMESPACE | 1 + NEWS.md | 9 ++++++- R/get_cibound.R | 63 +++++++++++++++++++++++++++++++++++++++++++--- README.md | 2 +- man/get_cibound.Rd | 24 +++++++++++++++--- 6 files changed, 92 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 46d4f151..f0eb558e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.12 +Version: 0.10.4.13 Authors@R: c( person(given = "Shu Fai", diff --git a/NAMESPACE b/NAMESPACE index b3fd228a..27df2f36 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(gen_est_i) export(gen_sem_out_userp) export(gen_userp) export(get_cibound) +export(get_cibound_status_not_0) export(loglike_compare) export(loglike_point) export(loglike_quad_point) diff --git a/NEWS.md b/NEWS.md index e51ec0e3..2b474f25 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.12 +# semlbci 0.10.4.13 ## New Feature @@ -13,6 +13,13 @@ using Satorra (2000) chi-square difference test. (0.10.4.2) +- Add `get_cibound_status_not_0()`. It + checks the status of each bound in + a `semlbci` object, and returns as + a list the `cibound` objects of + bounds with status not equal to zero. + For diagnostic purpose. (0.10.4.13) + ## Miscellaneous - Suppressed a harmless warning in a diff --git a/R/get_cibound.R b/R/get_cibound.R index cbd034a1..18b3959b 100644 --- a/R/get_cibound.R +++ b/R/get_cibound.R @@ -3,11 +3,27 @@ #' @description Get the `cibound` output of a bound from #' a `semlbci` object, the output of [semlbci()]. #' -#' @details It returns the original output of [ci_bound_wn_i()] -#' for a bound. Usually for diagnosis. +#' @details The function [get_cibound()] +#' returns the original output of +#' [ci_bound_wn_i()] for a bound. +#' Usually for diagnosis. #' -#' @return A `cibound`-class object. See [ci_bound_wn_i()] +#' The function [get_cibound_status_not_0()] +#' checks the status code of each bound, +#' and returns the `cibound` outputs of +#' bounds with status code not equal to +#' zero (i.e., something wrong in the +#' search). Printing it can print the +#' diagnostic information for all bounds +#' that failed in the search. +#' +#' @return +#' [get_cibound()] returns a `cibound`-class object. See [ci_bound_wn_i()] #' for details. +#' [get_cibound_status_not_0()] returns a list of +#' `cibound`-class objects with `status` not equal +#' to zero. If all bounds have `status` equal to +#' zero, it returns an empty list. #' #' @param x The output of [semlbci()]. #' @@ -46,6 +62,7 @@ #' # bound of the LBCI for the indirect effect: #' get_cibound(lbci_med, row_id = 6, which = "ubound") #' +#' @rdname get_cibound #' @export get_cibound <- function(x, @@ -63,3 +80,43 @@ get_cibound <- function(x, } cb_out } + +#' @rdname get_cibound +#' @export + +get_cibound_status_not_0 <- function(x) { + status_not_0_lb <- status_not_0(x, which = "lbound") + status_not_0_ub <- status_not_0(x, which = "ubound") + if (any(status_not_0_lb)) { + out_lb <- lapply(which(status_not_0_lb), + get_cibound, + x = x, + which = "lbound") + } else { + out_lb <- list() + } + if (any(status_not_0_ub)) { + out_ub <- lapply(which(status_not_0_ub), + get_cibound, + x = x, + which = "ubound") + } else { + out_ub <- list() + } + c(out_lb, out_ub) + } + +#' @noRd + +status_not_0 <- function(x, which = c("lbound", "ubound")) { + which <- match.arg(which) + x_diag <- attr(x, switch(which, + lbound = "lb_diag", + ubound = "ub_diag")) + i <- sapply(x_diag, function(x) { + ifelse(length(x) > 1, + x$status != 0, + FALSE) + }) + i + } \ No newline at end of file diff --git a/README.md b/README.md index 5cbf1fb8..4657be99 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.12, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.13, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/get_cibound.Rd b/man/get_cibound.Rd index 2298ed81..f41c26a2 100644 --- a/man/get_cibound.Rd +++ b/man/get_cibound.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/get_cibound.R \name{get_cibound} \alias{get_cibound} +\alias{get_cibound_status_not_0} \title{A 'cibound' Output From a 'semlbci' Object} \usage{ get_cibound(x, row_id, which = c("lbound", "ubound")) + +get_cibound_status_not_0(x) } \arguments{ \item{x}{The output of \code{\link[=semlbci]{semlbci()}}.} @@ -17,16 +20,31 @@ may be omitted in the printout of \code{x}.} to be extracted. Either \verb{"lbound"`` or }"ubound"``.} } \value{ -A \code{cibound}-class object. See \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} +\code{\link[=get_cibound]{get_cibound()}} returns a \code{cibound}-class object. See \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} for details. +\code{\link[=get_cibound_status_not_0]{get_cibound_status_not_0()}} returns a list of +\code{cibound}-class objects with \code{status} not equal +to zero. If all bounds have \code{status} equal to +zero, it returns an empty list. } \description{ Get the \code{cibound} output of a bound from a \code{semlbci} object, the output of \code{\link[=semlbci]{semlbci()}}. } \details{ -It returns the original output of \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} -for a bound. Usually for diagnosis. +The function \code{\link[=get_cibound]{get_cibound()}} +returns the original output of +\code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} for a bound. +Usually for diagnosis. + +The function \code{\link[=get_cibound_status_not_0]{get_cibound_status_not_0()}} +checks the status code of each bound, +and returns the \code{cibound} outputs of +bounds with status code not equal to +zero (i.e., something wrong in the +search). Printing it can print the +diagnostic information for all bounds +that failed in the search. } \examples{ From ae88b3f1222d0621038f925f91de9c424166a65e Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Thu, 30 May 2024 23:03:29 +0800 Subject: [PATCH 58/68] 0.10.4.14: Fix some typos in doc --- DESCRIPTION | 2 +- NEWS.md | 5 +++-- R/ci_bound_ur_i.R | 6 +++--- R/ci_bound_wn_i.R | 2 +- R/ci_i_one.R | 2 +- R/get_cibound.R | 2 +- README.md | 2 +- man/ci_bound_ur.Rd | 7 +++++-- man/ci_bound_ur_i.Rd | 9 ++++++++- man/ci_bound_wn_i.Rd | 6 +++++- man/ci_i_one.Rd | 6 +++++- man/get_cibound.Rd | 2 +- 12 files changed, 35 insertions(+), 16 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f0eb558e..3b6b167e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.13 +Version: 0.10.4.14 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 2b474f25..51723a39 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.13 +# semlbci 0.10.4.14 ## New Feature @@ -53,7 +53,8 @@ - Store the error in the search and display it in the printout. (0.10.4.12) - +- Fixed some typos in doc. + (0.10.4.14) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_ur_i.R b/R/ci_bound_ur_i.R index 9d08b737..2f358938 100644 --- a/R/ci_bound_ur_i.R +++ b/R/ci_bound_ur_i.R @@ -178,7 +178,7 @@ #' #' @param std_method The method used to #' find the standardized solution. If -#' equal to `"lavaan"``, +#' equal to `"lavaan"`, #' [lavaan::standardizedSolution()] will #' be used. If equal to `"internal"`, an #' internal function will be used. The @@ -506,7 +506,7 @@ ci_bound_ur_i <- function(i = NULL, #' This provides the flexibility to find #' the bound for any function of the #' model parameter, even one that cannot -#' be easily coded in `lavaan`` model +#' be easily coded in `lavaan` model #' syntax. #' #' @param sem_out The fit object. @@ -596,7 +596,7 @@ ci_bound_ur_i <- function(i = NULL, #' Default is 1000. #' #' @param use_callr Whether the -#' `callr`` package will be used to +#' `callr` package will be used to #' do the search in a separate R #' process. Default is `TRUE`. Should #' not set to `FALSE` if used in an diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 24828c38..4fdf392b 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -115,7 +115,7 @@ #' status code and the bound is set to `NA`. Default is 5e-4. #' #' @param std_method The method used to find the standardized -#' solution. If equal to `"lavaan"``, +#' solution. If equal to `"lavaan"`, #' [lavaan::standardizedSolution()] will be used. If equal to #' `"internal"`, an internal function will be used. The `"lavaan"` #' method should work in all situations, but the `"internal"` method diff --git a/R/ci_i_one.R b/R/ci_i_one.R index 1af8c0cb..a66a5c1c 100644 --- a/R/ci_i_one.R +++ b/R/ci_i_one.R @@ -62,7 +62,7 @@ #' #' @param robust Whether the LBCI based on robust likelihood ratio #' test is to be found. Only `"satorra.2000"` in -#' [lavaan::lavTestLRT()] is supported for now. If `"none"``, the +#' [lavaan::lavTestLRT()] is supported for now. If `"none"`, the #' default, then likelihood ratio test based on maximum likelihood #' estimation will be used. For "ur", `"satorra.2000"` is #' automatically used if a scaled test statistic is requested diff --git a/R/get_cibound.R b/R/get_cibound.R index 18b3959b..2073b095 100644 --- a/R/get_cibound.R +++ b/R/get_cibound.R @@ -32,7 +32,7 @@ #' may be omitted in the printout of `x`. #' #' @param which The bound for which the [ci_bound_wn_i()] is -#' to be extracted. Either `"lbound"`` or `"ubound"``. +#' to be extracted. Either `"lbound"` or `"ubound"`. #' #' @author Shu Fai Cheung #' diff --git a/README.md b/README.md index 4657be99..ce5466c6 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.13, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.14, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/ci_bound_ur.Rd b/man/ci_bound_ur.Rd index a5d01215..05905725 100644 --- a/man/ci_bound_ur.Rd +++ b/man/ci_bound_ur.Rd @@ -116,7 +116,10 @@ number of iteration in the search. Default is 1000.} \item{use_callr}{Whether the -\verb{callr`` package will be used to do the search in a separate R process. Default is }TRUE\verb{. Should not set to }FALSE` if used in an +\code{callr} package will be used to +do the search in a separate R +process. Default is \code{TRUE}. Should +not set to \code{FALSE} if used in an interactive environment unless this is intentional.} @@ -201,7 +204,7 @@ directly through the \code{func} argument. This provides the flexibility to find the bound for any function of the model parameter, even one that cannot -be easily coded in `lavaan`` model +be easily coded in \code{lavaan} model syntax. } \examples{ diff --git a/man/ci_bound_ur_i.Rd b/man/ci_bound_ur_i.Rd index 3e474414..ec983226 100644 --- a/man/ci_bound_ur_i.Rd +++ b/man/ci_bound_ur_i.Rd @@ -124,7 +124,14 @@ bound is set to \code{NA}. Default is \item{std_method}{The method used to find the standardized solution. If -equal to \verb{"lavaan"``, [lavaan::standardizedSolution()] will be used. If equal to }"internal"\verb{, an internal function will be used. The }"lavaan"\verb{method should work in all situations, but the}"internal"\verb{method is usually much faster. Default is}"internal"`.} +equal to \code{"lavaan"}, +\code{\link[lavaan:standardizedSolution]{lavaan::standardizedSolution()}} will +be used. If equal to \code{"internal"}, an +internal function will be used. The +\code{"lavaan"} method should work in all +situations, but the \code{"internal"} +method is usually much faster. +Default is \code{"internal"}.} \item{bounds}{Ignored by this function. Included consistency in the diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index b40823da..1b3beee8 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -102,7 +102,11 @@ and \code{ciperc} is greater than this amount, a warning is set in the status code and the bound is set to \code{NA}. Default is 5e-4.} \item{std_method}{The method used to find the standardized -solution. If equal to \verb{"lavaan"``, [lavaan::standardizedSolution()] will be used. If equal to }"internal"\verb{, an internal function will be used. The }"lavaan"\verb{method should work in all situations, but the}"internal"\verb{method is usually much faster. Default is}"internal"`.} +solution. If equal to \code{"lavaan"}, +\code{\link[lavaan:standardizedSolution]{lavaan::standardizedSolution()}} will be used. If equal to +\code{"internal"}, an internal function will be used. The \code{"lavaan"} +method should work in all situations, but the \code{"internal"} method +is usually much faster. Default is \code{"internal"}.} \item{bounds}{Default is \code{""} and this function will set the lower bounds to \code{lb_var} for variances. Other valid values are those diff --git a/man/ci_i_one.Rd b/man/ci_i_one.Rd index 885a55ad..bc84a91b 100644 --- a/man/ci_i_one.Rd +++ b/man/ci_i_one.Rd @@ -38,7 +38,11 @@ standardized solution is to be searched. Default is \code{FALSE}.} \item{robust}{Whether the LBCI based on robust likelihood ratio test is to be found. Only \code{"satorra.2000"} in -\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} is supported for now. If \verb{"none"``, the default, then likelihood ratio test based on maximum likelihood estimation will be used. For "ur", }"satorra.2000"\verb{is automatically used if a scaled test statistic is requested in}sem_out`.} +\code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} is supported for now. If \code{"none"}, the +default, then likelihood ratio test based on maximum likelihood +estimation will be used. For "ur", \code{"satorra.2000"} is +automatically used if a scaled test statistic is requested +in \code{sem_out}.} \item{sf_full}{A list with the scaling and shift factors. Ignored if \code{robust} is \code{"none"}. If \code{robust} is \code{"satorra.2000"} and diff --git a/man/get_cibound.Rd b/man/get_cibound.Rd index f41c26a2..a9f20cd6 100644 --- a/man/get_cibound.Rd +++ b/man/get_cibound.Rd @@ -17,7 +17,7 @@ on the left, not the actual row number, because some rows may be omitted in the printout of \code{x}.} \item{which}{The bound for which the \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} is -to be extracted. Either \verb{"lbound"`` or }"ubound"``.} +to be extracted. Either \code{"lbound"} or \code{"ubound"}.} } \value{ \code{\link[=get_cibound]{get_cibound()}} returns a \code{cibound}-class object. See \code{\link[=ci_bound_wn_i]{ci_bound_wn_i()}} From f9349e02cd2d129254fd997aa7e90dd99d3ebb6d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Thu, 30 May 2024 23:17:16 +0800 Subject: [PATCH 59/68] 0.10.4.15: Improve the check of semlbci_out in semlbci() Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/semlbci.R | 4 ++-- README.md | 2 +- 4 files changed, 8 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3b6b167e..6af8a871 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.14 +Version: 0.10.4.15 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 51723a39..97fdcc7d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.14 +# semlbci 0.10.4.15 ## New Feature @@ -19,6 +19,9 @@ a list the `cibound` objects of bounds with status not equal to zero. For diagnostic purpose. (0.10.4.13) +- Make the test for the match between + `sem_out` and `semlbci_out` in + `semlbci()` more robust. (0.10.4.15) ## Miscellaneous diff --git a/R/semlbci.R b/R/semlbci.R index 9b7af6fb..15135406 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -228,8 +228,8 @@ semlbci <- function(sem_out, # Check whether semlbci_out and sem_out match tmp0 <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")] tmp1 <- as.data.frame(semlbci_out)[, c("id", "lhs", "op", "rhs", "group", "label")] - if (!identical(tmp0, tmp1)) { - stop("semblci_out and the parameter table of sem_out do not match.") + if (!identical(tmp0[order(tmp0$id), ], tmp1[order(tmp1$id), ])) { + stop("semlbci_out and the parameter table of sem_out do not match.") } # Find pars with both lbci_lb and lbci_ub pars_lbci_yes <- !sapply(semlbci_out$lbci_lb, is.na) & diff --git a/README.md b/README.md index ce5466c6..c0f2e1ae 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.14, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.15, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 0e88fb9285c4ab9eef815c5606fc381fc8b4c1d7 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Thu, 30 May 2024 23:30:56 +0800 Subject: [PATCH 60/68] 0.10.4.16: Minor fixes Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 10 ++++++---- R/semlbci.R | 7 ++++++- README.md | 2 +- 4 files changed, 14 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6af8a871..56ef6edb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.15 +Version: 0.10.4.16 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 97fdcc7d..3b69906e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.15 +# semlbci 0.10.4.16 ## New Feature @@ -19,9 +19,6 @@ a list the `cibound` objects of bounds with status not equal to zero. For diagnostic purpose. (0.10.4.13) -- Make the test for the match between - `sem_out` and `semlbci_out` in - `semlbci()` more robust. (0.10.4.15) ## Miscellaneous @@ -58,6 +55,11 @@ (0.10.4.12) - Fixed some typos in doc. (0.10.4.14) +- Made the test for the match between + `sem_out` and `semlbci_out` in + `semlbci()` more robust. (0.10.4.15) +- Fixed the order of the output when + `standardized` is `TRUE`. (0.10.4.16) ## (Possibly) Breaking Changes diff --git a/R/semlbci.R b/R/semlbci.R index 15135406..bb0320b9 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -228,7 +228,11 @@ semlbci <- function(sem_out, # Check whether semlbci_out and sem_out match tmp0 <- ptable[, c("id", "lhs", "op", "rhs", "group", "label")] tmp1 <- as.data.frame(semlbci_out)[, c("id", "lhs", "op", "rhs", "group", "label")] - if (!identical(tmp0[order(tmp0$id), ], tmp1[order(tmp1$id), ])) { + tmp0 <- tmp0[order(tmp0$id), ] + tmp1 <- tmp1[order(tmp1$id), ] + rownames(tmp0) <- NULL + rownames(tmp1) <- NULL + if (!identical(tmp0, tmp1)) { stop("semlbci_out and the parameter table of sem_out do not match.") } # Find pars with both lbci_lb and lbci_ub @@ -439,6 +443,7 @@ semlbci <- function(sem_out, pstd$group[pstd$op == ":="] <- 0 out_p <- merge(out_p, pstd[, c("lhs", "op", "rhs", "group", "est.std")], by = c("lhs", "op", "rhs", "group"), all.x = TRUE, sort = FALSE) + out_p <- out_p[order(out_p$id), ] } else { out_p$est <- ptable[, c("est")] } diff --git a/README.md b/README.md index c0f2e1ae..e77c96bc 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.15, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.16, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 28448b40cd26b27678ecdaa80b0f57f12d87481d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 31 May 2024 18:40:23 +0800 Subject: [PATCH 61/68] 0.10.4.17: Fix a bug in print.cibound() when the call is xxx:yyy() Tests passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/print_cibound.R | 2 ++ README.md | 2 +- 4 files changed, 8 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 56ef6edb..2f77e86f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.16 +Version: 0.10.4.17 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 3b69906e..a832a02a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.16 +# semlbci 0.10.4.17 ## New Feature @@ -60,6 +60,9 @@ `semlbci()` more robust. (0.10.4.15) - Fixed the order of the output when `standardized` is `TRUE`. (0.10.4.16) +- Fixed a bug in `print.cibound()` when + the call is of the form `xxx::yyy()`. + (0.10.4.17) ## (Possibly) Breaking Changes diff --git a/R/print_cibound.R b/R/print_cibound.R index 47f03372..79061780 100644 --- a/R/print_cibound.R +++ b/R/print_cibound.R @@ -88,6 +88,8 @@ print.cibound <- function(x, digits = 5, ...) { p_tol_call <- call_org$p_tol if (is.null(p_tol_call)) { ci_method <- as.character(call_org[[1]]) + # ci_method can be of the form xxx::yyy + ci_method <- ci_method[length(ci_method)] p_tol_call <- formals(ci_method)$p_tol } ciperc_diff <- abs(out_diag$ciperc - out_diag$ciperc_final) diff --git a/README.md b/README.md index e77c96bc..cb2dbe37 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.16, updated on 2024-05-30 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.17, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From cb4b668d1560010097b7e4a72c36d61078561889 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 31 May 2024 22:35:35 +0800 Subject: [PATCH 62/68] 0.10.4.18: Add fit_lb and fit_ub to ci_bound_wn_i() Test and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/ci_bound_wn_i.R | 31 +++++++++++++++++++++++++++++-- README.md | 2 +- man/ci_bound_wn_i.Rd | 14 ++++++++++++++ 5 files changed, 49 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2f77e86f..7524698c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.17 +Version: 0.10.4.18 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index a832a02a..fe8bcdd2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.17 +# semlbci 0.10.4.18 ## New Feature @@ -63,6 +63,9 @@ - Fixed a bug in `print.cibound()` when the call is of the form `xxx::yyy()`. (0.10.4.17) +- Added `fit_lb` and `fit_ub` arguments + to `ci_bound_wn_i()` for setting + the bounds. (0.10.4.18) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 4fdf392b..01d7221c 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -148,6 +148,18 @@ #' the starting values will be randomly #' jittered. Default is 0. #' +#' @param fit_lb The vector of lower +#' bounds of parameters. Default is +#' `-Inf`, setting the lower bounds to +#' `-Inf` for all parameters except for +#' free variances which are controlled +#' by `lb_var`. +#' +#' @param fit_ub The vector of upper +#' bounds of parameters. Default is +#' `+Inf`, setting the lower bounds to +#' `+Inf` for all parameters. +#' #' @param ... Optional arguments. Not used. #' #' @references @@ -212,6 +224,8 @@ ci_bound_wn_i <- function(i = NULL, lb_prop = .05, lb_se_k = 3, try_harder = 0, + fit_lb = -Inf, + fit_ub = +Inf, ...) { k <- switch(which, lbound = 1, @@ -452,8 +466,17 @@ ci_bound_wn_i <- function(i = NULL, xstart <- perturbation_factor * lavaan::coef(sem_out) } + # Get SEs. For bounds + p_table <- lavaan::parameterTable(sem_out) + se_free <- p_table[p_table$free > 0, "se"] + est_free <- p_table[p_table$free > 0, "est"] + # Set lower bounds - fit_lb <- rep(-Inf, npar) + if (fit_lb == -Inf) { + fit_lb <- rep(-Inf, npar) + } else if (length(fit_lb) == 1) { + fit_lb <- est_free - se_free * fit_lb + } if (isTRUE(identical(lb_var, -Inf))) { # Override lb_var = -Inf for free variances fit_lb[find_variance_in_free(sem_out)] <- find_variance_in_free_lb(sem_out, @@ -464,7 +487,11 @@ ci_bound_wn_i <- function(i = NULL, } # Set upper bounds - fit_ub <- rep(+Inf, npar) + if (fit_ub == -Inf) { + fit_ub <- rep(-Inf, npar) + } else if (length(fit_ub) == 1) { + fit_ub <- est_free + se_free * fit_ub + } # Need further testing on using lavaan bounds # if (!is.null(p_table$lower)) { diff --git a/README.md b/README.md index cb2dbe37..cf549f07 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.17, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.18, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index 1b3beee8..0fe7b8dc 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -29,6 +29,8 @@ ci_bound_wn_i( lb_prop = 0.05, lb_se_k = 3, try_harder = 0, + fit_lb = -Inf, + fit_ub = +Inf, ... ) } @@ -135,6 +137,18 @@ times to try. In each new attempt, the starting values will be randomly jittered. Default is 0.} +\item{fit_lb}{The vector of lower +bounds of parameters. Default is +\code{-Inf}, setting the lower bounds to +\code{-Inf} for all parameters except for +free variances which are controlled +by \code{lb_var}.} + +\item{fit_ub}{The vector of upper +bounds of parameters. Default is +\code{+Inf}, setting the lower bounds to +\code{+Inf} for all parameters.} + \item{...}{Optional arguments. Not used.} } \value{ From f7374b30075aaab1b0c0eaa4eb05d07882cbe908 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 31 May 2024 22:51:20 +0800 Subject: [PATCH 63/68] 0.10.4.19: Fix an issue with fit_lb and fit_ub when trying harder Tests passed --- DESCRIPTION | 2 +- NEWS.md | 4 ++-- R/ci_bound_wn_i.R | 7 +++++++ README.md | 2 +- 4 files changed, 11 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7524698c..e6ebd6b0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.18 +Version: 0.10.4.19 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index fe8bcdd2..c52c13b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.18 +# semlbci 0.10.4.19 ## New Feature @@ -65,7 +65,7 @@ (0.10.4.17) - Added `fit_lb` and `fit_ub` arguments to `ci_bound_wn_i()` for setting - the bounds. (0.10.4.18) + the bounds. (0.10.4.18, 0.10.4.19) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 01d7221c..85b68872 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -493,6 +493,12 @@ ci_bound_wn_i <- function(i = NULL, fit_ub <- est_free + se_free * fit_ub } + # For pmax() and pmin() + fit_lb_na <- fit_lb + fit_ub_na <- fit_ub + fit_lb_na[fit_lb_na == -Inf] <- NA + fit_ub_na[fit_ub_na == +Inf] <- NA + # Need further testing on using lavaan bounds # if (!is.null(p_table$lower)) { # fit_lb <- p_table$lower[p_table$free > 0] @@ -549,6 +555,7 @@ ci_bound_wn_i <- function(i = NULL, xstart_i <- stats::runif(length(xstart_i), min = -2, max = 2) * xstart_i + xstart_i <- pmin(pmax(xstart_i, fit_lb_na), fit_ub_na) try_harder_count <- try_harder_count + 1 } else { try_harder_count <- Inf diff --git a/README.md b/README.md index cf549f07..998147ec 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.18, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.19, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From 9ac15ba15d6bcc4977bbca0cbcee61183136525d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 1 Jun 2024 08:20:07 +0800 Subject: [PATCH 64/68] 0.10.4.20: Fixed a bug of std_lav with one-factor model Tests and checks passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++- R/ram_to_lav_mod.R | 23 +++++------ README.md | 2 +- tests/testthat/test-std_lav_one_factor.R | 51 ++++++++++++++++++++++++ 5 files changed, 68 insertions(+), 15 deletions(-) create mode 100644 tests/testthat/test-std_lav_one_factor.R diff --git a/DESCRIPTION b/DESCRIPTION index e6ebd6b0..0f3f48d5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.19 +Version: 0.10.4.20 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index c52c13b2..8838f711 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.19 +# semlbci 0.10.4.20 ## New Feature @@ -66,6 +66,9 @@ - Added `fit_lb` and `fit_ub` arguments to `ci_bound_wn_i()` for setting the bounds. (0.10.4.18, 0.10.4.19) +- Fixed a bug with `std_lav()` for + models with only one factor. + (0.10.4.20) ## (Possibly) Breaking Changes diff --git a/R/ram_to_lav_mod.R b/R/ram_to_lav_mod.R index 24211be8..3b902ce9 100644 --- a/R/ram_to_lav_mod.R +++ b/R/ram_to_lav_mod.R @@ -20,15 +20,14 @@ ram_to_lav_mod <- function(ram, lav_mod, standardized = FALSE) { ov_names <- rownames(lav_mod$theta) lv_names <- rownames(lav_mod$psi) lv_names <- lv_names[!(lv_names %in% ov_names)] - mA <- ram$A if (!is.null(lav_mod$lambda)) { # A to lambda - lav_mod$lambda[] <- 0 + lav_mod$lambda[is.numeric(lav_mod$lambda)] <- 0 lambda_rnames <- rownames(lav_mod$lambda) lambda_cnames <- colnames(lav_mod$lambda) - lav_mod$lambda <- mA[lambda_rnames, lambda_cnames] + lav_mod$lambda <- mA[lambda_rnames, lambda_cnames, drop = FALSE] lambda1 <- lambda_rnames[lambda_rnames %in% lambda_cnames] lav_mod$lambda[lambda1, ] <- 0 lav_mod$lambda[lambda1, lambda1] <- 1 @@ -36,18 +35,18 @@ ram_to_lav_mod <- function(ram, lav_mod, standardized = FALSE) { if (!is.null(lav_mod$beta)) { # A to beta - lav_mod$beta[] <- 0 + lav_mod$beta[is.numeric(lav_mod$beta)] <- 0 beta_names <- rownames(lav_mod$beta) - lav_mod$beta <- mA[beta_names, beta_names] + lav_mod$beta <- mA[beta_names, beta_names, drop = FALSE] } mS <- ram$S if (!is.null(lav_mod$theta)) { # S to theta - lav_mod$theta[] <- 0 + lav_mod$theta[is.numeric(lav_mod$theta)] <- 0 theta_names <- rownames(lav_mod$theta) - lav_mod$theta <- mS[theta_names, theta_names] + lav_mod$theta <- mS[theta_names, theta_names, drop = FALSE] if (standardized) { tmp <- diag(lav_mod$theta) lav_mod$theta <- stats::cov2cor(lav_mod$theta) @@ -57,9 +56,9 @@ ram_to_lav_mod <- function(ram, lav_mod, standardized = FALSE) { } if (!is.null(lav_mod$psi)) { # S to psi - lav_mod$psi[] <- 0 + lav_mod$psi[is.numeric(lav_mod$psi)] <- 0 psi_names <- rownames(lav_mod$psi) - lav_mod$psi <- mS[psi_names, psi_names] + lav_mod$psi <- mS[psi_names, psi_names, drop = FALSE] if (standardized) { tmp <- diag(lav_mod$psi) lav_mod$psi <- stats::cov2cor(lav_mod$psi) @@ -69,7 +68,7 @@ ram_to_lav_mod <- function(ram, lav_mod, standardized = FALSE) { if (!is.null(lav_mod$nu)) { # M to nu - lav_mod$nu[] <- 0 + lav_mod$nu[is.numeric(lav_mod$nu)] <- 0 nu_names <- rownames(lav_mod$nu) lav_mod$nu[] <- t(ram$M[, nu_names, drop = FALSE]) lav_mod$nu[lambda1] <- 0 @@ -77,9 +76,9 @@ ram_to_lav_mod <- function(ram, lav_mod, standardized = FALSE) { if (!is.null(lav_mod$alpha)) { # M to alpha - lav_mod$alpha[] <- 0 + lav_mod$alpha[is.numeric(lav_mod$alpha)] <- 0 alpha_names <- rownames(lav_mod$alpha) - lav_mod$alpha[] <- t(ram$M[, alpha_names, drop = FALSE]) + lav_mod$alpha[is.numeric(lav_mod$alpha)] <- t(ram$M[, alpha_names, drop = FALSE]) } lav_mod diff --git a/README.md b/README.md index 998147ec..3d1d5517 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.19, updated on 2024-05-31 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.20, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/tests/testthat/test-std_lav_one_factor.R b/tests/testthat/test-std_lav_one_factor.R new file mode 100644 index 00000000..a18023a8 --- /dev/null +++ b/tests/testthat/test-std_lav_one_factor.R @@ -0,0 +1,51 @@ +skip_on_cran() + +library(testthat) +library(semlbci) +library(lavaan) + +dat_cov <- matrix(c(1, .30, .40, + .30, 1, .20, + .40, .20, 1), 3, 3) +colnames(dat_cov) <- rownames(dat_cov) <- c("x1", "x2", "x3") +dat_mean <- c(1, 2, 3) +names(dat_mean) <- colnames(dat_cov) + +mod <- +" +f1 =~ x1 + x2 + x3 +" +fit <- lavaan::sem(mod, + sample.cov = dat_cov, + sample.nobs = 50) + +expect_no_error(std_lav(lavaan::coef(fit), fit)) + +mod <- +" +x1 ~ x2 + x3 +" +fit <- lavaan::sem(mod, + sample.cov = dat_cov, + sample.nobs = 50) +expect_no_error(std_lav(lavaan::coef(fit), fit)) + +mod <- +" +x1 ~ x2 + x3 +" +fit <- lavaan::sem(mod, + sample.cov = dat_cov, + sample.nobs = 50) +expect_no_error(std_lav(lavaan::coef(fit), fit)) + +mod <- +" +x1 ~ x2 + x3 +" +fit <- lavaan::sem(mod, + sample.cov = dat_cov, + sample.mean = dat_mean, + sample.nobs = 50, + meanstructure = TRUE) +expect_no_error(std_lav(lavaan::coef(fit), fit)) From 157aa0dc13cfde8c31a806476d01a857325fe0c2 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 1 Jun 2024 08:48:51 +0800 Subject: [PATCH 65/68] 0.10.4.21: Add timeout to ci_bound_wn_i --- DESCRIPTION | 2 +- NEWS.md | 6 +++- R/ci_bound_wn_i.R | 9 ++++- R/print_cibound.R | 3 ++ README.md | 2 +- man/ci_bound_wn_i.Rd | 6 ++++ .../test-ci_bound_wn_i_z_print_maxtime.R | 33 +++++++++++++++++++ 7 files changed, 57 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/test-ci_bound_wn_i_z_print_maxtime.R diff --git a/DESCRIPTION b/DESCRIPTION index 0f3f48d5..38bf0447 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.20 +Version: 0.10.4.21 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 8838f711..0611b8dd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.20 +# semlbci 0.10.4.21 ## New Feature @@ -69,6 +69,10 @@ - Fixed a bug with `std_lav()` for models with only one factor. (0.10.4.20) +- Add the `timeout` argument to + `ci_bound_wn_i()`, default to 300 + (300 seconds or 5 minutes). + (0.10.4.21) ## (Possibly) Breaking Changes diff --git a/R/ci_bound_wn_i.R b/R/ci_bound_wn_i.R index 85b68872..f535e475 100644 --- a/R/ci_bound_wn_i.R +++ b/R/ci_bound_wn_i.R @@ -160,6 +160,11 @@ #' `+Inf`, setting the lower bounds to #' `+Inf` for all parameters. #' +#' @param timeout The approximate +#' maximum time for the search, in +#' second. Default is 300 seconds +#' (5 minutes). +#' #' @param ... Optional arguments. Not used. #' #' @references @@ -226,6 +231,7 @@ ci_bound_wn_i <- function(i = NULL, try_harder = 0, fit_lb = -Inf, fit_ub = +Inf, + timeout = 300, ...) { k <- switch(which, lbound = 1, @@ -530,7 +536,8 @@ ci_bound_wn_i <- function(i = NULL, "xtol_rel" = 1.0e-5 * xtol_rel_factor, "ftol_rel" = 1.0e-5 * ftol_rel_factor, "maxeval" = 500, - "print_level" = 0), + "print_level" = 0, + "maxtime" = timeout), opts) try_harder <- as.integer(max(try_harder, 0)) try_harder_count <- 0 diff --git a/R/print_cibound.R b/R/print_cibound.R index 79061780..dce23599 100644 --- a/R/print_cibound.R +++ b/R/print_cibound.R @@ -117,6 +117,9 @@ print.cibound <- function(x, digits = 5, ...) { cat("\n-- Optimization Information --") cat(paste0("\nSolver Status:\t\t", out_diag$optim_status)) cat(paste0("\nConvergence Message:\t", out_diag$optim_message)) + if (any(grepl("NLOPT_MAXTIME_REACHED:", out_diag$optim_message))) { + cat("\n - Set 'timeout' to a larger value to increase maximum time.") + } cat(paste0("\nIterations:\t\t", out_diag$optim_iterations)) t_cond <- out_diag$optim_termination_conditions t_cond2 <- strsplit(t_cond, "\t")[[1]] diff --git a/README.md b/README.md index 3d1d5517..ea2a7595 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.20, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.21, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci diff --git a/man/ci_bound_wn_i.Rd b/man/ci_bound_wn_i.Rd index 0fe7b8dc..e13fca95 100644 --- a/man/ci_bound_wn_i.Rd +++ b/man/ci_bound_wn_i.Rd @@ -31,6 +31,7 @@ ci_bound_wn_i( try_harder = 0, fit_lb = -Inf, fit_ub = +Inf, + timeout = 300, ... ) } @@ -149,6 +150,11 @@ bounds of parameters. Default is \code{+Inf}, setting the lower bounds to \code{+Inf} for all parameters.} +\item{timeout}{The approximate +maximum time for the search, in +second. Default is 300 seconds +(5 minutes).} + \item{...}{Optional arguments. Not used.} } \value{ diff --git a/tests/testthat/test-ci_bound_wn_i_z_print_maxtime.R b/tests/testthat/test-ci_bound_wn_i_z_print_maxtime.R new file mode 100644 index 00000000..fa36c72a --- /dev/null +++ b/tests/testthat/test-ci_bound_wn_i_z_print_maxtime.R @@ -0,0 +1,33 @@ +skip_on_cran() + +library(testthat) +library(semlbci) + +# Fit the model + +library(lavaan) + +data(simple_med_mg) +dat <- simple_med_mg +mod <- +" +m ~ c(a1, a2)*x +y ~ c(b1, b2)*m +ab := a2*b2 +a1 == a2 +" +fit <- lavaan::sem(mod, simple_med_mg, fixed.x = FALSE, group = "gp") + +# Find the LBCIs + +ciperc <- .96 + +fn_constr0 <- set_constraint(fit, ciperc = ciperc) + +opts0 <- list() +opts0 <- list(ftol_rel = 1e-7, + maxtime = .01 + ) +time1l <- system.time(out1l <- ci_bound_wn_i(17, 16, sem_out = fit, f_constr = fn_constr0, which = "lbound", standardized = TRUE, ciperc = ciperc, opts = opts0, verbose = TRUE, wald_ci_start = FALSE, std_method = "internal")) + +expect_output(print(out1l), "timeout", fixed = TRUE) From 428d351beb9bc38284c6ba672e759a2f7b7d0df7 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 1 Jun 2024 09:17:54 +0800 Subject: [PATCH 66/68] 0.10.4.22: Add suggestion for failed search Tests passed. --- DESCRIPTION | 2 +- NEWS.md | 7 +++++-- R/print_semlbci.R | 8 ++++++-- README.md | 2 +- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 38bf0447..144858af 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.21 +Version: 0.10.4.22 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 0611b8dd..61408e7d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.21 +# semlbci 0.10.4.22 ## New Feature @@ -69,10 +69,13 @@ - Fixed a bug with `std_lav()` for models with only one factor. (0.10.4.20) -- Add the `timeout` argument to +- Added the `timeout` argument to `ci_bound_wn_i()`, default to 300 (300 seconds or 5 minutes). (0.10.4.21) +- In `print.semlbci()`, added + suggestions on what to do if some + bounds could not be found (0.10.4.22) ## (Possibly) Breaking Changes diff --git a/R/print_semlbci.R b/R/print_semlbci.R index 50aa5172..61b46934 100644 --- a/R/print_semlbci.R +++ b/R/print_semlbci.R @@ -298,7 +298,9 @@ print.semlbci <- function(x, msg <- c(msg, paste0("* ok_l, ok_u: Whether the search encountered any problem. ", "If no problem encountered, it is equal to 0. Any value ", - "other than 0 indicates something was wrong in the search.")) + "other than 0 indicates something was wrong in the search. ", + "Try running 'semlbci()' again, setting 'semlbci_out' to this output, ", + "and set 'try_k_more_times' to a positive number, e.g., 2 to 5.")) } if (standardized) { msg <- c(msg, @@ -562,7 +564,9 @@ print_semlbci_text <- function(x, tmp0 <- "- Status: " tmp <- paste0(tmp0, "Whether the search encountered any problem for the two bounds. ", "If no problem encountered, the code is 0 (displayed as 'OK'). Any value ", - "other than 0 indicates something was wrong in the search.") + "other than 0 indicates something was wrong in the search. ", + "Try running 'semlbci()' again, setting 'semlbci_out' to this output, ", + "and set 'try_k_more_times' to a positive number, e.g., 2 to 5.") tmp <- strwrap(tmp, indent = 0, exdent = nchar(tmp0)) diff --git a/README.md b/README.md index ea2a7595..7675ac27 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.21, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.22, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From d7d374d0b51796b472419132efcc9e1442a904f2 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 1 Jun 2024 10:20:51 +0800 Subject: [PATCH 67/68] 0.10.4.23: Use whitespace instead of tab in print.cibound Tests passed. --- DESCRIPTION | 2 +- NEWS.md | 5 ++++- R/print_cibound.R | 40 ++++++++++++++++++++-------------------- README.md | 2 +- 4 files changed, 26 insertions(+), 23 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 144858af..80b6fe6c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.22 +Version: 0.10.4.23 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index 61408e7d..de0137b8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.22 +# semlbci 0.10.4.23 ## New Feature @@ -76,6 +76,9 @@ - In `print.semlbci()`, added suggestions on what to do if some bounds could not be found (0.10.4.22) +- Use whitespace instead of tab to + align the output of `print.cibound()`. + (0.10.4.23) ## (Possibly) Breaking Changes diff --git a/R/print_cibound.R b/R/print_cibound.R index dce23599..3589f2f4 100644 --- a/R/print_cibound.R +++ b/R/print_cibound.R @@ -56,13 +56,13 @@ print.cibound <- function(x, digits = 5, ...) { lor <- out_diag$i_lor lor2 <- paste0(lor$lhs, " ", lor$op, " ", lor$rhs, " (group = ", lor$group, ", block = ", lor$block, ")") - cat(paste0("Target Parameter:\t", lor2)) - cat(paste0("\nPosition:\t\t", out_diag$i)) - cat(paste0("\nWhich Bound:\t\t", switch(out_diag$which, + cat(paste0( "Target Parameter: ", lor2)) + cat(paste0("\nPosition: ", out_diag$i)) + cat(paste0("\nWhich Bound: ", switch(out_diag$which, lbound = "Lower Bound", ubound = "Upper Bound"))) - cat(paste0("\nMethod:\t\t\t", ci_method)) - cat(paste0("\nConfidence Level:\t", out_diag$ciperc)) + cat(paste0("\nMethod: ", ci_method)) + cat(paste0("\nConfidence Level: ", out_diag$ciperc)) if (!is.null(out_diag$search_error)) { cat(paste0("\nSearch Error Message:\n", out_diag$search_error, "\n")) cat(paste0(rep("*", round(getOption("width") * .8)), collapse = "")) @@ -73,15 +73,15 @@ print.cibound <- function(x, digits = 5, ...) { cat(paste0(rep("*", round(getOption("width") * .8)), collapse = "")) cat("\n") } - cat(paste0("\nAchieved Level:\t\t", out_diag$ciperc_final)) - cat(paste0("\nStandardized:\t\t", std)) - cat(paste0("\nLikelihood-Based Bound:\t", + cat(paste0("\nAchieved Level: ", out_diag$ciperc_final)) + cat(paste0("\nStandardized: ", std)) + cat(paste0("\nLikelihood-Based Bound: ", ifelse(is.na(x$bound), "Not valid", round(x$bound, digits)))) - cat(paste0("\nWald Bound:\t\t", round(out_diag$ci_org_limit, digits))) - cat(paste0("\nPoint Estimate:\t\t", round(out_diag$est_org, digits))) - cat(paste0("\nRatio to Wald Bound:\t", ifelse(is.na(x$bound), "Not valid", + cat(paste0("\nWald Bound: ", round(out_diag$ci_org_limit, digits))) + cat(paste0("\nPoint Estimate: ", round(out_diag$est_org, digits))) + cat(paste0("\nRatio to Wald Bound: ", ifelse(is.na(x$bound), "Not valid", round(out_diag$ci_limit_ratio, digits)))) cat(paste0("\n\n-- Check --")) # Get p_tol in call @@ -93,12 +93,12 @@ print.cibound <- function(x, digits = 5, ...) { p_tol_call <- formals(ci_method)$p_tol } ciperc_diff <- abs(out_diag$ciperc - out_diag$ciperc_final) - cat(paste0("\nLevel achieved?\t\t", + cat(paste0("\nLevel achieved? ", ifelse(ciperc_diff <= p_tol_call, "Yes", "No"), " (Difference: ", formatC(ciperc_diff, digits = digits), ";", " Tolerance: ", p_tol_call, ")")) - cat(paste0("\nSolution admissible?\t", + cat(paste0("\nSolution admissible? ", ifelse(out_diag$fit_post_check, "Yes", "No"))) bound_unchecked <- out_diag$bound_unchecked if (is.na(bound_unchecked)) { @@ -111,16 +111,16 @@ print.cibound <- function(x, digits = 5, ...) { "Yes", "No") ) } - cat(paste0("\nDirection valid?\t", direct_valid)) + cat(paste0("\nDirection valid? ", direct_valid)) cat("\n") cat("\n-- Optimization Information --") - cat(paste0("\nSolver Status:\t\t", out_diag$optim_status)) - cat(paste0("\nConvergence Message:\t", out_diag$optim_message)) - if (any(grepl("NLOPT_MAXTIME_REACHED:", out_diag$optim_message))) { + cat(paste0("\nSolver Status: ", out_diag$optim_status)) + cat(paste0("\nConvergence Message: ", out_diag$optim_message)) + if (any(grepl("NLOPT_MAXTIME_REACHED: ", out_diag$optim_message))) { cat("\n - Set 'timeout' to a larger value to increase maximum time.") } - cat(paste0("\nIterations:\t\t", out_diag$optim_iterations)) + cat(paste0("\nIterations: ", out_diag$optim_iterations)) t_cond <- out_diag$optim_termination_conditions t_cond2 <- strsplit(t_cond, "\t")[[1]] t_cond2 <- gsub("maxeval: ", "maxeval: ", t_cond2) @@ -137,9 +137,9 @@ print.cibound <- function(x, digits = 5, ...) { cat("\n-- Parameter Estimates --\n") print(coef_c) - cat(paste0("\nBound before check:\t", + cat(paste0("\nBound before check: ", round(out_diag$bound_unchecked, digits))) - cat(paste0("\nStatus Code:\t\t", out_diag$status)) + cat(paste0("\nStatus Code: ", out_diag$status)) cat("\nCall: ") call_print <- call_org if (!is.name(call_print$f_constr)) { diff --git a/README.md b/README.md index 7675ac27..207187d7 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.22, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.23, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci From c5882563d13b25f53fbad7e687f12ba2920b9fb6 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Sat, 1 Jun 2024 11:05:12 +0800 Subject: [PATCH 68/68] 0.10.4.24: Intercepts are now removed if standardized = TRUE Tests passed. --- DESCRIPTION | 2 +- NEWS.md | 6 +++++- R/semlbci.R | 2 +- README.md | 2 +- 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 80b6fe6c..d4e51156 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semlbci Title: Likelihood-Based Confidence Interval in Structural Equation Models -Version: 0.10.4.23 +Version: 0.10.4.24 Authors@R: c( person(given = "Shu Fai", diff --git a/NEWS.md b/NEWS.md index de0137b8..74d271b1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semlbci 0.10.4.23 +# semlbci 0.10.4.24 ## New Feature @@ -79,6 +79,10 @@ - Use whitespace instead of tab to align the output of `print.cibound()`. (0.10.4.23) +- Fixed a bug with `semlbci()`. + Intercepts are now automatically + skipped if `standardized` is `TRUE`. + (0.10.4.24) ## (Possibly) Breaking Changes diff --git a/R/semlbci.R b/R/semlbci.R index bb0320b9..f52da08b 100644 --- a/R/semlbci.R +++ b/R/semlbci.R @@ -277,7 +277,7 @@ semlbci <- function(sem_out, pars <- remove_variances(pars, sem_out) } if (remove_intercepts) { - pars <- remove_variances(pars, sem_out) + pars <- remove_intercepts(pars, sem_out) } # Remove parameters already with LBCIs in semlbci_out. pars <- pars[!pars %in% i_id[pars_lbci_yes]] diff --git a/README.md b/README.md index 207187d7..4833be49 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![DOI](https://img.shields.io/badge/doi-10.1080/10705511.2023.2183860-blue.svg)](https://doi.org/10.1080/10705511.2023.2183860) -(Version 0.10.4.23, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) +(Version 0.10.4.24, updated on 2024-06-01 [release history](https://sfcheung.github.io/semlbci/news/index.html)) # semlbci