Merge pull request #354 from lucdw/master

global switches warn/debug/verbose
yrosseel · May 29, 2024 · 6a3def8 · 6a3def8
2 parents 87b5bc6 + 66a9e73
commit 6a3def8
Show file tree

Hide file tree

Showing 86 changed files with 683 additions and 702 deletions.
diff --git a/R/ctr_informative_testing.R b/R/ctr_informative_testing.R
@@ -7,6 +7,11 @@ InformativeTesting <- function(model = NULL, data, constraints = NULL,
                                double.bootstrap.alpha = 0.05,
                                parallel = c("no", "multicore", "snow"),
                                ncpus = 1L, cl = NULL, verbose = FALSE, ...) {
+  if (!missing(verbose)) {
+    current.verbose <- lav_verbose()
+    if (lav_verbose(verbose)) 
+      on.exit(lav_verbose(current.verbose), TRUE)
+  }
   fit.B1 <- sem(model, ...,
     data = data,
     se   = "none",

diff --git a/R/ctr_pml_plrt.R b/R/ctr_pml_plrt.R
@@ -44,13 +44,12 @@ ctr_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
 
   # FIXME: se="none", test="none"??
   Options <- lavoptions
-  Options$verbose <- FALSE
   Options$se <- "none"
   Options$test <- "none"
   Options$baseline <- FALSE
   Options$h1 <- FALSE
   fittedSat <- lavaan(ModelSat,
-    slotOptions = Options,
+    slotOptions = Options, verbose = FALSE,
     slotSampleStats = lavsamplestats,
     slotData = lavdata, slotCache = lavcache
   )
@@ -85,7 +84,7 @@ ctr_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
   Options2$check.post <- FALSE
   Options2$check.vcov <- FALSE
   fittedSat2 <- lavaan(ModelSat2,
-    slotOptions = Options2,
+    slotOptions = Options2, verbose = FALSE,
     slotSampleStats = lavsamplestats,
     slotData = lavdata, slotCache = lavcache
   )

diff --git a/R/ctr_pml_plrt2.R b/R/ctr_pml_plrt2.R
@@ -44,13 +44,12 @@ ctr_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
 
   # FIXME: se="none", test="none"??
   Options <- lavoptions
-  Options$verbose <- FALSE
   Options$se <- "none"
   Options$test <- "none"
   Options$baseline <- FALSE
   Options$h1 <- FALSE
   fittedSat <- lavaan(ModelSat,
-    slotOptions = Options,
+    slotOptions = Options, verbose = FALSE,
     slotSampleStats = lavsamplestats,
     slotData = lavdata, slotCache = lavcache
   )
@@ -82,7 +81,7 @@ ctr_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
   Options2$optim.method <- "none"
   Options2$optim.force.converged <- TRUE
   fittedSat2 <- lavaan(ModelSat2,
-    slotOptions = Options2,
+    slotOptions = Options2, verbose = FALSE,
     slotSampleStats = lavsamplestats,
     slotData = lavdata, slotCache = lavcache
   )

diff --git a/R/lav_bootstrap.R b/R/lav_bootstrap.R
@@ -48,6 +48,11 @@ bootstrapLavaan <- function(object,
       "bollen.stine", "parametric", "yuan"
     )
   )
+  if (!missing(verbose)) {
+    current.verbose <- lav_verbose()
+    if (lav_verbose(verbose)) 
+      on.exit(lav_verbose(current.verbose), TRUE)
+  }
   if (type. == "nonparametric") {
     type. <- "ordinary"
   }
@@ -86,7 +91,6 @@ bootstrapLavaan <- function(object,
     lavpartable. = NULL,
     R = R,
     type = type.,
-    verbose = verbose,
     FUN = FUN,
     keep.idx = keep.idx,
     h0.rmsea = h0.rmsea,
@@ -95,13 +99,13 @@ bootstrapLavaan <- function(object,
 
   # new in 0.6-12: always warn for failed and nonadmissible runs
   nfailed <- length(attr(out, "error.idx")) # zero if NULL
-  if (nfailed > 0L && object@Options$warn) {
+  if (nfailed > 0L) {
     lav_msg_warn(gettextf(
       "%s bootstrap runs failed or did not converge.", nfailed))
   }
 
   notok <- length(attr(out, "nonadmissible")) # zero if NULL
-  if (notok > 0L && object@Options$warn) {
+  if (notok > 0L) {
      lav_msg_warn(gettextf(
       "%s bootstrap runs resulted in nonadmissible solutions.", notok))
   }
@@ -119,9 +123,7 @@ lav_bootstrap_internal <- function(object = NULL,
                                    lavpartable. = NULL,
                                    R = 1000L,
                                    type = "ordinary",
-                                   verbose = FALSE,
                                    FUN = "coef",
-                                   # warn            = -1L, # not used anymore!
                                    check.post = TRUE,
                                    keep.idx = FALSE,
                                    # return.boot     = FALSE,
@@ -172,7 +174,8 @@ lav_bootstrap_internal <- function(object = NULL,
   }
 
   # always shut off some options:
-  lavoptions$verbose <- FALSE
+  current.verbose <- lav_verbose()
+  if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose))
   lavoptions$check.start <- FALSE
   lavoptions$check.post <- FALSE
   lavoptions$optim.attempts <- 1L # can save a lot of time
@@ -345,15 +348,16 @@ lav_bootstrap_internal <- function(object = NULL,
         lavoptions = lavoptions
       )
     }
-
+    
     # verbose
-    if (verbose) cat("  ... bootstrap draw number:", sprintf("%4d", b))
+    lav_verbose(current.verbose) # reset if needed
+    if (lav_verbose()) cat("  ... bootstrap draw number:", sprintf("%4d", b))
     bootSampleStats <- try(lav_samplestats_from_data(
       lavdata       = newData,
       lavoptions    = lavoptions
     ), silent = TRUE)
     if (inherits(bootSampleStats, "try-error")) {
-      if (verbose) {
+      if (lav_verbose()) {
         cat("     FAILED: creating sample statistics\n")
         cat(bootSampleStats[1])
       }
@@ -384,7 +388,7 @@ lav_bootstrap_internal <- function(object = NULL,
       slotData = lavdata
     ))
     if (!fit.boot@optim$converged) {
-      if (verbose) cat("     FAILED: no convergence\n")
+      if (lav_verbose()) cat("     FAILED: no convergence\n")
       out <- as.numeric(NA)
       attr(out, "nonadmissible.flag") <- TRUE
       if (keep.idx) {
@@ -406,7 +410,7 @@ lav_bootstrap_internal <- function(object = NULL,
       out <- try(as.numeric(FUN(fit.boot, ...)), silent = TRUE)
     }
     if (inherits(out, "try-error")) {
-      if (verbose) cat("     FAILED: applying FUN to fit.boot\n")
+      if (lav_verbose()) cat("     FAILED: applying FUN to fit.boot\n")
       out <- as.numeric(NA)
       attr(out, "nonadmissible.flag") <- TRUE
       if (keep.idx) {
@@ -419,7 +423,7 @@ lav_bootstrap_internal <- function(object = NULL,
     admissible.flag <- suppressWarnings(lavInspect(fit.boot, "post.check"))
     attr(out, "nonadmissible.flag") <- !admissible.flag
 
-    if (verbose) {
+    if (lav_verbose()) {
       cat(
         "   OK -- niter = ",
         sprintf("%3d", fit.boot@optim$iterations), " fx = ",
@@ -485,7 +489,7 @@ lav_bootstrap_internal <- function(object = NULL,
 
   # this is adapted from the boot function in package boot
   RR <- R
-  if (verbose) {
+  if (lav_verbose()) {
     cat("\n")
   }
   res <- if (ncpus > 1L && (have_mc || have_snow)) {

diff --git a/R/lav_bootstrap_lrt.R b/R/lav_bootstrap_lrt.R
@@ -23,7 +23,11 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
     double.bootstrap %in% c("no", "FDB", "standard")
   )
   if (type == "nonparametric") type <- "ordinary"
-
+  if (!missing(verbose)) {
+    current.verbose <- lav_verbose()
+    if (lav_verbose(verbose)) 
+      on.exit(lav_verbose(current.verbose), TRUE)
+  }
   # check for conditional.x = TRUE
   if (h0@Model@conditional.x) {
     lav_msg_stop(gettext(
@@ -202,20 +206,21 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
     }
 
     # verbose
-    if (verbose) cat("  ... bootstrap draw number: ", b, "\n")
+    if (lav_verbose()) cat("  ... bootstrap draw number: ", b, "\n")
 
     # Get sample statistics
     bootSampleStats <- try(lav_samplestats_from_data(
       lavdata       = newData,
       lavoptions    = lavoptions
     ), silent = TRUE)
     if (inherits(bootSampleStats, "try-error")) {
-      if (verbose) cat("     FAILED: creating h0@SampleStats statistics\n")
+      if (lav_verbose()) cat("     FAILED: creating h0@SampleStats statistics\n")
       return(NULL)
     }
 
-    if (verbose) cat("  ... ... model h0: ")
-    h0@Options$verbose <- FALSE
+    if (lav_verbose()) cat("  ... ... model h0: ")
+    current.verbose2 <- lav_verbose()
+    if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose2), TRUE, FALSE)
     h0@Options$se <- "none"
     h0@Options$test <- "standard"
     h0@Options$baseline <- FALSE
@@ -228,19 +233,20 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
       slotSampleStats = bootSampleStats,
       slotData = data
     ))
+    lav_verbose(current.verbose2)
     if (!fit.h0@optim$converged) {
-      if (verbose) cat("     FAILED: no convergence\n")
+      if (lav_verbose()) cat("     FAILED: no convergence\n")
       return(NULL)
     }
-    if (verbose) {
+    if (lav_verbose()) {
       cat(
         "     ok -- niter = ", fit.h0@optim$iterations,
         " fx = ", fit.h0@optim$fx, "\n"
       )
     }
 
-    if (verbose) cat("  ... ... model h1: ")
-    h1@Options$verbose <- FALSE
+    if (lav_verbose()) cat("  ... ... model h1: ")
+    lav_verbose(FALSE)
     h1@Options$se <- "none"
     h1@Options$test <- "standard"
     h1@Options$baseline <- FALSE
@@ -253,17 +259,17 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
       slotSampleStats = bootSampleStats,
       slotData = data
     ))
-
+    lav_verbose(current.verbose2)
     if (!fit.h1@optim$converged) {
-      if (verbose) {
+      if (lav_verbose()) {
         cat(
           "     FAILED: no convergence -- niter = ", fit.h1@optim$iterations,
           " fx = ", fit.h1@optim$fx, "\n"
         )
       }
       return(NULL)
     }
-    if (verbose) {
+    if (lav_verbose()) {
       cat(
         "     ok -- niter = ", fit.h1@optim$iterations,
         " fx = ", fit.h1@optim$fx, "\n"
@@ -273,20 +279,20 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
     # store LRT
     if ((fit.h1@optim$fx - fit.h0@optim$fx) > sqrt(.Machine$double.eps)) {
       # if((fit.h1@optim$fx - fit.h0@optim$fx) > 0.0) {
-      if (verbose) {
+      if (lav_verbose()) {
         cat("  ... ... LRT  = <NA> h0 > h1, delta = ", fit.h1@optim$fx - fit.h0@optim$fx, "\n")
       }
       return(NULL)
     } else {
       lrt.boot <- abs(anova(fit.h1, fit.h0)$`Chisq diff`[2L])
-      if (verbose) {
+      if (lav_verbose()) {
         cat("  ... ... LRT  = ", lrt.boot, "\n")
       }
     }
 
     # double bootstrap
     if (double.bootstrap == "standard") {
-      if (verbose) cat("  ... ... calibrating p.value - ")
+      if (lav_verbose()) cat("  ... ... calibrating p.value - ")
 
       plugin.pvalue <- bootstrapLRT(
         h0 = fit.h0, h1 = fit.h1,
@@ -298,7 +304,7 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
         ncpus = ncpus, cl = cl,
         double.bootstrap = "no"
       )
-      if (verbose) cat(sprintf("%5.3f", plugin.pvalue), "\n")
+      if (lav_verbose()) cat(sprintf("%5.3f", plugin.pvalue), "\n")
       attr(lrt.boot, "plugin.pvalue") <- plugin.pvalue
     } else if (double.bootstrap == "FDB") {
       # Fast double bootstrap
@@ -315,7 +321,7 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
 
       LRT.2 <- attr(plugin.pvalue, "LRT")
 
-      if (verbose) cat("  ... ... LRT2 = ", LRT.2, "\n")
+      if (lav_verbose()) cat("  ... ... LRT2 = ", LRT.2, "\n")
       attr(lrt.boot, "LRT.2") <- LRT.2
     }
     lrt.boot
@@ -373,7 +379,7 @@ bootstrapLRT <- function(h0 = NULL, h1 = NULL, R = 1000L,
       attr(LRT.2, "error.idx") <- error.idx
     }
   } else {
-    if (verbose) {
+    if (lav_verbose()) {
       cat("Number of successful bootstrap draws:", (R -
         length(error.idx)), "\n")
     }

diff --git a/R/lav_bvmix.R b/R/lav_bvmix.R
@@ -16,8 +16,7 @@ lav_bvmix_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                       optim.method = "nlminb1", # 0.6-7
                                       optim.scale = 1.0,
                                       init.theta = NULL,
-                                      control = list(),
-                                      verbose = FALSE) {
+                                      control = list()) {
   if (is.null(fit.y1)) {
     fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
   }
@@ -42,7 +41,7 @@ lav_bvmix_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
 
   # optimize
   if (is.null(control$trace)) {
-    control$trace <- ifelse(verbose, 1, 0)
+    control$trace <- ifelse(lav_verbose(), 1, 0)
   }
 
   # init theta?

diff --git a/R/lav_bvord.R b/R/lav_bvord.R
@@ -49,7 +49,6 @@ lav_bvord_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                       zero.keep.margins = TRUE,
                                       zero.cell.warn = FALSE,
                                       zero.cell.flag = FALSE,
-                                      verbose = FALSE,
                                       optim.method = "nlminb2",
                                       optim.scale = 1.0,
                                       init.theta = NULL,
@@ -173,7 +172,7 @@ lav_bvord_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
 
   # optimize
   if (is.null(control$trace)) {
-    control$trace <- ifelse(verbose, 1, 0)
+    control$trace <- ifelse(lav_verbose(), 1, 0)
   }
 
   # init theta?

diff --git a/R/lav_bvreg.R b/R/lav_bvreg.R
@@ -127,8 +127,7 @@ lav_bvreg_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                       # optim.method = "none",
                                       optim.scale = 1,
                                       init.theta = NULL,
-                                      control = list(),
-                                      verbose = FALSE) {
+                                      control = list()) {
   if (is.null(fit.y1)) {
     fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
   }
@@ -160,7 +159,7 @@ lav_bvreg_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
 
   # optimize
   if (is.null(control$trace)) {
-    control$trace <- ifelse(verbose, 1, 0)
+    control$trace <- ifelse(lav_verbose(), 1, 0)
   }
 
   # init theta?

diff --git a/R/lav_constraints.R b/R/lav_constraints.R
@@ -1,6 +1,11 @@
 lav_constraints_parse <- function(partable = NULL, constraints = NULL,
                                   theta = NULL,
                                   debug = FALSE) {
+  if (!missing(debug)) {
+    current.debug <- lav_debug()
+    if (lav_debug(debug)) 
+      on.exit(lav_debug(current.debug), TRUE)
+  }
   # just in case we do not have a $free column in partable
   if (is.null(partable$free)) {
     partable$free <- seq_len(length(partable$lhs))

diff --git a/R/lav_cor.R b/R/lav_cor.R
@@ -86,7 +86,7 @@ lavCor <- function(object,
     } else {
       # check if all names in "ordered" occur in the dataset?
       missing.idx <- which(!ordered %in% NAMES)
-      if (length(missing.idx) > 0L) { # FIXme: warn = FALSE has no eff
+      if (length(missing.idx) > 0L) {
         lav_msg_warn(gettextf(
           "ordered variable(s): %s could not be found
           in the data and will be ignored",