Merge pull request #396 from lucdw/master

add check for autoregression in R code;internal func summary_trace
yrosseel · Nov 25, 2024 · f496be9 · f496be9
2 parents 35337b1 + b24f12d
commit f496be9
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 3 deletions.
diff --git a/R/lav_syntax_parser.R b/R/lav_syntax_parser.R
@@ -903,6 +903,15 @@ ldw_parse_model_string <- function(model.syntax = "", as.data.frame. = FALSE) {
         footer = tl[2L]
       )
     }
+       # check for variable regressed on itself
+    if (formul1$elem.text[opi] == "~" && formul1$elem.text[opi - 1L] == formul1$elem.text[nelem]) {
+        tl <- ldw_txtloc(modelsrc, formul1$elem.pos[opi])
+        lav_msg_stop(
+          gettext("a variable cannot be regressed on itself"),
+          tl[1L],
+          footer = tl[2L]
+        )
+      }
     # checks for valid names in lhs and rhs
     ldw_parse_check_valid_name(formul1, opi - 1L, modelsrc) # valid name lhs
     for (j in seq.int(opi + 1L, nelem)) { # valid names rhs

diff --git a/R/lav_syntax_parser_cr.R b/R/lav_syntax_parser_cr.R
@@ -63,7 +63,7 @@ ldw_parse_model_string_cr <- function(model.syntax = "",
                      tl[1L],
                      footer = tl[2L]
         )
-      } else if (flat[1L] == 34L) { # SPE_INVALIDNAME
+      } else if (flat[1L] == 34L) { # SPE_AUTOREGRESS
         lav_msg_stop(gettext("a variable cannot be regressed on itself"),
                      tl[1L],
                      footer = tl[2L]

diff --git a/R/lav_syntax_parser_r.R b/R/lav_syntax_parser_r.R
@@ -797,6 +797,9 @@ lav_parse_model_string_r <- function(model.syntax = "", as.data.frame. = FALSE)
     if (length(contsp) > 0L) {
       lav_local_msgcode(FALSE, 102L, formul1$elem.pos[contsp[1L]], msgenv)
     }
+    # check for variable regressed on itself
+    if (formul1$elem.text[opi] == "~" && formul1$elem.text[opi - 1L] == formul1$elem.text[nelem])
+            return(c(34L, formul1$elem.pos[opi] - 1L))
     # checks for valid names in lhs and rhs
     lav_parse_check_valid_name(formul1, opi - 1L, modelsrc, msgenv) # valid name lhs
     if (exists("error", envir = msgenv)) return(msgenv$error);
@@ -891,14 +894,14 @@ lav_parse_model_string_r <- function(model.syntax = "", as.data.frame. = FALSE)
       if (opi > 2 && rmei == 1L) {
         lhsmod <- lav_parse_get_modifier(
           formul1,
-          TRUE, opi, modelsrc, types
+          TRUE, opi, modelsrc, types, 0L, 0L, msgenv
         )
       }
       rhsmod <- list()
       if (nelem - opi > 1) {
         rhsmod <- lav_parse_get_modifier(
           formul1,
-          FALSE, opi, modelsrc, types, rme, rmeprev
+          FALSE, opi, modelsrc, types, rme, rmeprev, msgenv
         )
       }
       flat.fixed[idx] <- if (is.null(rhsmod$fixed)) {

diff --git a/R/ldw_trace.R b/R/ldw_trace.R
@@ -109,3 +109,18 @@ print_trace <- function(file = "", clean_after = (file != "")) {
   }
   if (clean_after) set_trace(NULL, TRUE)
 }
+
+summary_trace <- function(file = "", clean_after = FALSE) {
+  x <- get_trace()
+  temp <- new.env(parent = emptyenv())
+  for (x1 in x) {
+    nn <- length(x1$stack)
+    mm <- paste(x1$stack[nn], paste(x1$stack[seq_len(nn - 1L)], collapse = ">"), sep = "\t")
+    assign(mm, 1L + get0(mm, temp, ifnotfound = 0L), temp)
+  }
+  objects <- sort(ls(temp))
+  for (i in seq_along(objects)) {
+    cat(objects[i], get(objects[i], temp), "\n", file = file, append = TRUE)
+  }
+  if (clean_after) set_trace(NULL, TRUE)
+}