Merge pull request #2 from michaelzehetleitner/fix/fitMetaDprime-wrapper

Fix fitMetaDprime dispatcher for non-numeric participant IDs

Author: ManuelRausch

R/fitMetaDprime.R

@@ -121,9 +121,10 @@ fitMetaDprime <- function(data, model="ML",  nInits = 5, nRestart = 3,
   ## ToDo: Namen anpassen
   outnames <- c("model", "participant", "dprime", "c", "metaD", "Ratio")
   # This function will be called for every combination of participant and model
-  call_fitfct <- function(X) {
-    cur_model <- model[X[1]]
-    cur_sbj <- X[2]
+  call_fitfct <- function(model_idx, participant_id) {
+    cur_model <- model[as.integer(model_idx)]
+    if (is.na(cur_model)) stop("Internal error: model index could not be resolved.")
+    cur_sbj <- participant_id
     participant <- NULL # to omit a note in R checks because of an unbound variable
     data_part <- subset(data, participant==cur_sbj)
     res <- int_fitMetaDprime(ratings=data_part$rating,
@@ -140,13 +141,11 @@ fitMetaDprime <- function(data, model="ML",  nInits = 5, nRestart = 3,
 
   # generate a list of fitting jobs to do and setup parallelization
   subjects <- unique(data$participant)
-  nJobs <- length(model)*length(subjects)
-  jobs <- expand.grid(model=1:length(model), sbj=subjects)
+  if (is.factor(subjects)) subjects <- as.character(subjects)
+  jobs <- expand.grid(model = seq_along(model), sbj = subjects, stringsAsFactors = FALSE)
+  nJobs <- nrow(jobs)
   if (.parallel) {
-    listjobs <- list()
-    for (i in 1:nrow(jobs)) {
-      listjobs[[i]] <- c(model = jobs[["model"]][i], sbj = jobs[["sbj"]][i])
-    }
+    listjobs <- split(jobs, seq_len(nJobs))
     if (is.null(n.cores)) n.cores <- min(nJobs, detectCores() - 1)
 
     cl <- makeCluster(type="SOCK", n.cores)
@@ -155,10 +154,12 @@ fitMetaDprime <- function(data, model="ML",  nInits = 5, nRestart = 3,
     # Following line ensures that the cluster is stopped even in cases of user
     # interrupt or errors
     on.exit(try(stopCluster(cl), silent = TRUE))
-    res <- clusterApplyLB(cl, listjobs, fun=call_fitfct)
+    res <- clusterApplyLB(cl, listjobs,
+                          fun=function(job) call_fitfct(job[["model"]], job[["sbj"]]))
     stopCluster(cl)
   } else {
-    res <- apply(X=jobs, 1, FUN=call_fitfct)
+    res <- lapply(seq_len(nJobs),
+                  function(i) call_fitfct(jobs$model[i], jobs$sbj[i]))
   }
   # bind list-outout together into data.frame
   res <- do.call(rbind, res)

tests/testthat/test-fitMetaDprime.R

@@ -0,0 +1,27 @@
+test_that("fitMetaDprime handles non-numeric participant IDs", {
+  dummy_data <- data.frame(
+    rating = factor(c("low", "high", "low", "high")),
+    stimulus = factor(c("S1", "S1", "S2", "S2")),
+    correct = c(1, 0, 1, 0),
+    participant = factor(c("p1", "p1", "p2", "p2"))
+  )
+
+  mocked_int_fit <- function(...) {
+    data.frame(
+      dprime = 1,
+      c = 0,
+      metaD = 1,
+      Ratio = 1
+    )
+  }
+
+  res <- with_mocked_bindings(
+    fitMetaDprime(dummy_data, model = "ML", nInits = 1, nRestart = 1, .parallel = FALSE),
+    int_fitMetaDprime = mocked_int_fit
+  )
+
+  expect_s3_class(res, "data.frame")
+  expect_equal(unique(res$model), "ML")
+  expect_equal(nrow(res), 2L)
+  expect_equal(sort(unique(res$participant)), c("p1", "p2"))
+})