version for CRAN

Author: jansteinfeld

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: tmt
 Type: Package
 Title: Estimation of the Rasch Model for Multistage Tests
-Version: 0.3.6-1
-Date: 2025-12-04
+Version: 0.3.6-4
+Date: 2025-12-05
 Authors@R: c(
   person(given = "Jan", 
          family = "Steinfeld", 
@@ -27,7 +27,7 @@ License: GPL-3
 LazyLoad: yes
 VignetteBuilder: knitr
 Depends:
-    R (>= 3.0)
+    R (>= 4.4.0)
 Encoding: UTF-8
 NeedsCompilation: yes
 Suggests:
@@ -41,7 +41,7 @@ Suggests:
 Imports:
   parallel,
   ggplot2,
-  Rcpp (>= 0.12.0),
+  Rcpp (>= 1.0.0),
   stats,
   rlang
 LinkingTo: Rcpp

NEWS.md

@@ -1,4 +1,4 @@
-# tmt 0.3.6-1
+# tmt 0.3.6-4
 * fixed testthat error 
 
 # tmt 0.3.6-0

R/helper_functions.R

@@ -1007,7 +1007,8 @@ thresholds_to_probs <- function(thres, opts = "mstdesign", row = TRUE){
 
   if (row) {
     if (nrow(thres)==1) {
-      thres_diff <- cbind(thres[1,,drop=FALSE],t(diff(thres)))
+      # thres_diff <- cbind(thres[1, , drop = FALSE], t(diff(thres)))
+      thres_diff <- thres[1, , drop = FALSE]
     } else {
       thres_diff <- cbind(thres[1,],t(diff(thres)))  
     }

R/raschmodel.mst.R

@@ -6,6 +6,9 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
     call <- call_intern
   }
   # ----------------------------
+  # diagnostic
+  # a0 <- Sys.time(); cat("Start:",format(a0,"%H:%M:%S")); flush.console()
+  # ----------------------------
   if(inherits(dat, "list") & "mstdesign" %in% class(dat)){
     mstdesign <- dat$mstdesign
     dat <- dat$data
@@ -24,13 +27,32 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
   if(!is.null(mstdesign)) {
     mstdesign_orig <- mstdesign  
   } 
+  # else {
+  #   mstdesign_orig <- mstdesign
+  # }
 
+  ################################################################################################
+  # todo: MST Design should be added for additional plot
+   # if (!any(colnames(dat) %in% "branching")) {
+   #   stop("branching design is required in the submitted data, with the column name 'branching'")
+   # }
+
+   # design <- dat[,"branching"]
+   # dat <- dat[,!colnames(dat) %in% "branching"]
+  ################################################################################################
   # preparing the submitted mst design
   designelements <- tmt_mstdesign(mstdesign = mstdesign, options = c("design","items"))
   items_design <- designelements$items
   cumulative <- ifelse(any(class(designelements$design)=="cumulative"),TRUE,FALSE)
   mstdesign <- apply(designelements$design,2,as.character)
+  # startmodules <-  designelements$start
+  # info_startval <- NULL
 
+  # if(nrow(startmodules)==1){
+  #   info_startval <- strsplit(startmodules[,"items_to"],",")[[1]]
+  # }
+
+
   names_dat <- colnames(dat)
 
   precondition <- NULL
@@ -51,6 +73,9 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
       cat("The following items are specified in the mstdesign, but not in the dataset: ")
       cat(items_design[!items_design %in% names_dat],"\n")
     }
+  #  if (length(status)!=0){
+  #    cat("The following items had to be excluded, due to (nearly) full '1' or '0' responses: ",status,"\n")
+  #  }  
     stop("It is necessary, that all Items in the dataset are also specified in the submitted mstdesign and vice versa! \nPlease update the design and the data.\n")
   }
 
@@ -106,6 +131,10 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
       cs <- colSums(dat[,names_dat] * weights, na.rm = TRUE)
       ws <- colSums(!is.na(dat[,names_dat]) * weights)
       start <- log(ws - cs) - log(cs)
+        # choose for start module informative starting values
+        # if(!is.null(info_startval)){
+        #   start[!names(start)%in%info_startval] <- 0
+        # }
     }
     start <- start[-i]
     desmat <- rbind(diag(1,nrow = length(start) ), -1)
@@ -116,6 +145,10 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
       cs <- colSums(dat[,names_dat] * weights, na.rm = TRUE)
       ws <- colSums(!is.na(dat[,names_dat]) * weights)
       start <- log(ws - cs) - log(cs)
+        # choose for start module informative starting values
+        # if(!is.null(info_startval)){
+        #   start[!names(start)%in%info_startval] <- 0
+        # }
     }
     start <- start[-1]
     desmat <- rbind(0,diag(1,nrow=length(start)))
@@ -127,7 +160,7 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
       esf <- esf_mst_sum_vector(parlist = par_i, ojlist = oj_i, probs = probabilities_i, order = 0,
                                 minSolved = minSolved_i, maxSolved = maxSolved_i,
                                 minSolved_design = minSolved_stage_i, maxSolved_design = maxSolved_stage_i, cumulative = cumulative_i)[[1]]
-
+      #esf[(sum(minSolved_i) + 1):(sum(maxSolved_i) + 1)] <- log(esf[(sum(minSolved_i)+1):(sum(maxSolved_i)+1)])
       esf[(tail(minSolved_stage_i,n=1) + 1):(tail(maxSolved_stage_i,n=1) + 1)] <- log(esf[(tail(minSolved_stage_i,n=1) + 1):(tail(maxSolved_stage_i,n=1) + 1)])
       return( -sum( cs_i * unlist(par_i) ) - sum(rf_i  * esf) )
     }
@@ -181,8 +214,9 @@ raschmodel.mst <- function(dat, mstdesign = NULL, weights = NULL, start = NULL,
       out <- colSums(out[, drop = FALSE]) %*% desmat
       return(out)
     }
-    
-  # analytival hessian matrix
+    # esf[(sum(minSolved_i) + 1):(sum(maxSolved_i) + 1)] <- log(esf[(sum(minSolved_i)+1):(sum(maxSolved_i)+1)])
+
+  # # analytival hessian matrix
   ahessian <- function(par) {
       par_n <- c(desmat %*% par)
        par_i <- lapply(items_l, FUN = function(x){

R/sim.rm.R

@@ -8,7 +8,7 @@ sim.rm <- function(theta, b, seed = NULL){
   if (((length(theta) + length(b) )== 2) && !is.null(seed) && length(seed) != 2) {
 
     warning("It is necessary to set a seed for both theta and beta if no vector is passed. The specified seed was used for the theta parameters, the following is used for beta: ", seed + 1)
-
+    #> Warning: This is what a warning looks like
     seed_theta <- seed
     seed_beta <- seed + 1
   }
@@ -29,6 +29,8 @@ sim.rm <- function(theta, b, seed = NULL){
     seed_beta <- seed
   }
 
+  # cat("seed sim: ",seed)
+  
 	if(length(theta) == 1) {
     if(!is.null(seed_theta)) {
       set.seed(seed_theta)
@@ -42,6 +44,13 @@ sim.rm <- function(theta, b, seed = NULL){
     }
     b <- stats::rnorm(b, mean = 0, sd = 1)	
 	}
+	# if(!is.null(seed)){
+		# set.seed(seed)
+		# resp <- outer(theta, b, "-")
+		# p_exp <- exp(resp)
+		# prop_solve <- p_exp/(1 + p_exp)
+		# dat.resp <-(prop_solve > matrix(stats::runif(length(b)*length(theta)),length(theta),length(b)))*1
+	# } else {
 		resp <- outer(theta, b, "-")
 		p_exp <- exp(resp)
 		prop_solve <- p_exp/(1 + p_exp)

R/tmt_gmc.R

@@ -44,7 +44,13 @@ tmt_gmc <- function (object,
     if (is.null(yaxis)) {
       yaxis <- paste("item parameter for group: ", names(object$betapars_subgroup)[2], sep = "")
     }
+    #if (!is.null(drop) & !all(drop%in%colnames(object$fitob[[1]]$data))) {
+    #    stop("Only names in the vector 'drop' are permitted which are also in the data.")
+    #}
     if(!is.null(info)) info <- info[!names(info)%in%drop]
+    #if (!is.null(info) & !all(names(info) %in% colnames(object$data))) {
+    #    stop("Only names in the vector 'drop' are permitted which are also in the data.")
+    #}
  # ------------------------------------------------------
     subgroup_1 <- object$betapars_subgroup[[1]]
     subgroup_2 <- object$betapars_subgroup[[2]]

R/tmt_mstdesign.R

@@ -32,19 +32,64 @@ tmt_mstdesign <- function(mstdesign, options = c("design", "simulation", "module
   # some possible misspecification
   checinput <- strsplit(mstdesign,"\n")[[1]]
   checkinput <- gsub("\\s","",checinput)
+  # misspecified <- c("\\=[^:]|\\=[^~~]|[^~~=]|~=|~~|~|<~|\\*")
   # 2020-03-27 updated list
   misspecified <- "=:|=~~|~~=|~=|~~|<~|\\*|"
-  
+  # miss_list <- list()
+
+  # checkinput[gregexpr("=:",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("=~~",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("~~=",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("~=",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("~~",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("~",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("<~",checkinput, perl = TRUE)>0]
+  # checkinput[gregexpr("\\*",checkinput, perl = TRUE)>0]
+
+  # ein paar Beispiele ausprobieren
+  # checkinput[length(checkinput)+1] <- "das=:istErsterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das=~~istZweiterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das~~=istDritterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das~=istVierterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das~~istFuenfterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das~istSechsterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das<~istSiebterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+  # checkinput[length(checkinput)+1] <- "das*istAchterTest"
+  #   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
+  #   checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
+
   checlocation <- gregexpr(misspecified,checkinput, perl = TRUE)
   result_misspecified <- checkinput[unlist(lapply(checlocation,function(x) any(attr(x,"match.length")>0)))]
 
+  # gregexpr("\\+[^~]",checkinput)
+  # "~|\\+[^=]|\\+\\="
+
+  # 2020-03-27 fixed loop
+    # for(m in 1:length(misspecified)){
+    #   miss_list[[m]] <- grep(misspecified[m], checkinput, value = TRUE, perl = TRUE)
+    # }
+
   if (length(result_misspecified)>0) {
     stop("The submitted mstdesign is misspecified, please correct the following expression/s:\n",
       paste0(" - ",result_misspecified,collapse="\n")    
     )
   }
 
-  # ...................................................................................................
+# ...................................................................................................
 
   # clean mstdesign input:
   tmt.syntax <- mstdesign
@@ -65,11 +110,22 @@ tmt_mstdesign <- function(mstdesign, options = c("design", "simulation", "module
   # create list for the simulation function
   # -----------------------------------
   # number of modules & branches
-  
+
+  # für tmtd muss schon überprüft werden, ob es preconditions gibt...dann muss die Simulationsfunktion angepasst werden und die Info in das Design übernommen werden
+  # die Paths am besten reduzieren um die Einträge, dann gehen die übrigen Funktionen noch...Evtl. die Info in einer anderen Funktion aufbereiten und dann je nach Bedarf den output hinzufügen. Letztlich muss man allerdings darauf achten, dass die Anzahl der Zeilen dann bspw. im design-output um die preconditions ergänzt wird!!
+
+  # preconditions können mit ~ enden, aber auch mit +=...wie differenzieren? Müssen eingangs oben definiert werden?
+
+
+
   n.modules <- length(grep("=~",tmtd, fixed = TRUE))
+  # n.start <- length(grep("==",tmtd, fixed = TRUE))
   n.branches <- length(grep(":=",tmtd, fixed = TRUE))
+ 
+  # l.stages <- nchar(as.character(tmtd[grepl(":=",tmtd, fixed = TRUE)])) -
+  #               nchar( gsub("\\+", "", tmtd[grepl(":=",tmtd, perl = TRUE)]))
+  # n.stages <- max(l.stages)
   n.preconditions <- length(grep("==",tmtd)) # grep only '~'
-
   if (n.preconditions != 0) {
     c.preconditions <- grep("==",tmtd, value = TRUE)
     c.preconditions <- strsplit(c.preconditions,"==")
@@ -83,6 +139,7 @@ tmt_mstdesign <- function(mstdesign, options = c("design", "simulation", "module
   # ---------------------------
   preconditions_sim <- preconditions <- start <- simulation <- design <- items <- NULL
 
+
   modules <- hfun.modules(tmtd = tmtd, 
                             n.branches = n.branches, 
                             n.modules = n.modules)
@@ -93,6 +150,7 @@ tmt_mstdesign <- function(mstdesign, options = c("design", "simulation", "module
 
     if (any(av.preconditions$value%in%modules[,"from"])) stop("The operator '==' is now used for the definition of preconditions!\n * Please integrate the start module into the mst design and \n * start the function again.")
 
+    # nur bei der kumulativen verzweigung muss das Design entsprechend angepasst werden
     routing_type <- hfun.preconditionoperator(tmtd = tmtd, 
                                 preconditions = av.preconditions)
 
@@ -105,11 +163,60 @@ tmt_mstdesign <- function(mstdesign, options = c("design", "simulation", "module
       tmtd <- preconditions$tmtd
       n.branches <- nrow(preconditions$paths)
       preconditions_sim <- preconditions$precondition_matrix
+      # n.stages <- length(grep("module",colnames(preconditions$paths)))
     } 
 
   }
 
 
+
+
+
+
+  # 2020-05-21 added for probabilistic-cumulative designs
+#   branches <- tmtd[grepl(":=", tmtd, fixed = TRUE)]
+#   if (any(grepl("+=",branches)) {
+
+
+#   branches <- strsplit_storing(branches,":=")
+#   colnames(branches) <- c("path","operator_0", "path_original")
+#   branches <- strsplit_storing(variable = branches,
+#                                split = c("~","+=","+"),
+#                                cols = "path_original", 
+#                                new_names = c("module","operator"))
+
+#   i <- 1
+#   for (m in grep("module",colnames(branches),value=TRUE)){
+#     branches <- strsplit_storing(branches,"\\(|\\)",m, fixed = FALSE, new_names = paste0(c("module_","rule_"),i), store_operator = FALSE)
+#     i <- i + 1
+#   }
+#   # nun die rules durch die lenght der items ersetzen und dann jeweils um eines reduzieren
+#   items <- unlist(regmatches(modules[,"items"], gregexpr( "(?<=\\().+?(?=\\))", modules[,"items"], perl = TRUE)))
+#   possible_scores <- sapply(items,function(x) paste0("0:",length(strsplit(x,",")[[1]])) , simplify=TRUE,USE.NAMES=FALSE)
+#   modules_score <- cbind(modules[,"from"],possible_scores)
+#   colnames(modules_score) <- c("module","score")
+
+  
+#   for (o in seq(grep("rule",colnames(branches)))) {
+#     pos_module <- match(c(branches[,paste0("module_",o)]), modules_score[,"module"])
+#     branches[,paste0("rule_",o)] <- modules_score[,"score"][pos_module]
+#   }
+
+#   # nur für die mittleren Fälle
+#   cases <- grep("rule",colnames(branches), value = TRUE)
+#   cases <- cases[-length(cases)]
+  
+#   branches_expand <- expand.matrix(variable = branches,
+#                 names = cases)
+#   branches_expand <- branches_expand[,seq(grep(cases,colnames(branches_expand))+2)]
+  
+  
+#   operator_check <- rowSums(apply(branches_expand[,grep(cases, colnames(branches_expand))+1,drop=FALSE],2,function(x) x%in%"+="))
+#   branches_expand <- branches_expand[operator_check==length(cases),]
+  
+# }
+  
+
   if ("simulation" %in% options) simulation <- hfun.simulation(modules = modules,
                                                               tmtd = tmtd_sim,
                                                               preconditions = preconditions_sim)