Merge pull request #47 from jhelvy/preserve-attributes

Preserve attributes and use standard encoding

Author: jhelvy

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: cbcTools
 Title: Design and Analyze Choice-Based Conjoint Experiments
-Version: 0.6.4
+Version: 0.7.0
 Maintainer: John Helveston <john.helveston@gmail.com>
 Authors@R: c(
     person(given   = "John",

NAMESPACE

@@ -1,5 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",cbc_choices)
+S3method("[",cbc_design)
+S3method("[",cbc_profiles)
+S3method("[<-",cbc_choices)
+S3method("[<-",cbc_design)
+S3method("[<-",cbc_profiles)
+S3method("names<-",cbc_choices)
+S3method("names<-",cbc_design)
+S3method("names<-",cbc_profiles)
 S3method(plot,cbc_power)
 S3method(print,cbc_choices)
 S3method(print,cbc_comparison)
@@ -13,6 +22,7 @@ export(cbc_choices)
 export(cbc_compare)
 export(cbc_decode)
 export(cbc_design)
+export(cbc_encode)
 export(cbc_inspect)
 export(cbc_power)
 export(cbc_priors)

NEWS.md

@@ -1,5 +1,11 @@
 # cbcTools (development version)
 
+# cbcTools 0.7.0
+
+- Re-configures the design encoding to use "standard" coding by default.
+- Reasoning for standard coding by default is for easier interpretation of summary metrics like balance and overlap.
+- New function `cbc_encode()` used to convert designs to dummy or effects coding.
+
 # cbcTools 0.6.4
 
 - Adds `balance_by` argument to force balanced sampling in designs with restricted or otherwise unbalanced levels across attributes.

R/choices.R

@@ -46,6 +46,9 @@ cbc_choices <- function(design, priors = NULL) {
         stop("design must be a cbc_design object created by cbc_design()")
     }
 
+    # Store original encoding
+    original_encoding <- attr(design, "encoding") %||% "standard"
+
     if (is.null(priors)) {
         # Simulate random choices
         result <- simulate_random_choices(design)
@@ -66,8 +69,8 @@ cbc_choices <- function(design, priors = NULL) {
         priors_used <- TRUE
     }
 
-    # Preserve encoding attributes
-    attr(result, "is_dummy_coded") <- attr(design, "is_dummy_coded")
+    # Preserve encoding and categorical structure attributes
+    attr(result, "encoding") <- original_encoding
     attr(result, "categorical_structure") <- attr(
         design,
         "categorical_structure"
@@ -158,27 +161,28 @@ simulate_utility_based_choices <- function(design, priors) {
     # Create optimization environment using the existing function
     opt_env <- setup_optimization_environment(
         profiles = profiles,
-        method = "random", # Hard-code this so that the obsID vectors are correct
-        time_start = Sys.time(), # Not important for choice simulation
+        method = "random",
+        time_start = Sys.time(),
         n_alts = design_params$n_alts,
         n_q = design_params$n_q,
         n_resp = design_params$n_resp,
         n_blocks = design_params$n_blocks,
-        n_cores = 1, # Not used for choice simulation
-        n_start = 1, # Not used for choice simulation
-        max_iter = 1, # Not used for choice simulation
-        priors = priors, # The new priors for choice simulation
+        n_cores = 1,
+        n_start = 1,
+        max_iter = 1,
+        priors = priors,
         no_choice = design_params$no_choice,
         label = design_params$label,
-        balance_by = NULL, # Not used for choice simulation
-        remove_dominant = FALSE, # Not needed for choice simulation
-        dominance_types = NULL, # Not needed for choice simulation
-        dominance_threshold = 0.8, # Not needed for choice simulation
-        max_dominance_attempts = 1, # Not needed for choice simulation
-        randomize_questions = TRUE, # Not used for choice simulation
-        randomize_alts = TRUE, # Not used for choice simulation
-        include_probs = FALSE, # Not used for choice simulation
-        use_idefix = FALSE # Not used for choice simulation
+        balance_by = NULL,
+        remove_dominant = FALSE,
+        dominance_types = NULL,
+        dominance_threshold = 0.8,
+        max_dominance_attempts = 1,
+        randomize_questions = TRUE,
+        randomize_alts = TRUE,
+        include_probs = FALSE,
+        use_idefix = FALSE,
+        coding = design_params$coding %||% "standard"
     )
 
     # Get design matrix from the design object
@@ -217,16 +221,16 @@ get_design_matrix_from_design_object <- function(design, opt_env) {
     # Fill matrix from profileID data
     for (obs in 1:n_questions) {
         obs_rows <- regular_design[regular_design$obsID == obs, ]
-        obs_rows <- obs_rows[order(obs_rows$altID), ] # Ensure proper order
+        obs_rows <- obs_rows[order(obs_rows$altID), ]
 
-        if (nrow(obs_rows) == n_alts) {
-            design_matrix[obs, ] <- obs_rows$profileID
-        } else {
+        if (nrow(obs_rows) != n_alts) {
             stop(sprintf(
-                "Inconsistent number of alternatives in observation %d",
-                obs
+                "Inconsistent number of alternatives in observation %d: expected %d, got %d",
+                obs, n_alts, nrow(obs_rows)
             ))
         }
+
+        design_matrix[obs, ] <- obs_rows$profileID
     }
 
     return(design_matrix)

R/compare.R

@@ -200,10 +200,10 @@ extract_comparison_data <- function(designs, design_names, metrics) {
     return(comparison_df)
 }
 
-# Extract structural metrics
 extract_structure_metrics <- function(design) {
     params <- attr(design, "design_params")
     summary_info <- attr(design, "design_summary")
+    encoding <- params$encoding %||% "standard"
 
     list(
         method = params$method,
@@ -216,7 +216,8 @@ extract_structure_metrics <- function(design) {
         profile_usage_pct = round(summary_info$profile_usage_rate * 100, 1),
         generation_time = round(params$time_elapsed_sec, 3),
         no_choice = params$no_choice,
-        labeled = !is.null(params$label)
+        labeled = !is.null(params$label),
+        encoding = encoding
     )
 }
 
@@ -242,30 +243,34 @@ extract_efficiency_metrics <- function(design) {
     return(result)
 }
 
-# Extract balance metrics
 extract_balance_metrics <- function(design) {
+    # Convert to standard encoding for accurate metrics
+    design_standard <- get_standard_encoding(design)
+
     summary_info <- attr(design, "design_summary")
 
     if (!is.null(summary_info$efficiency$balance_score)) {
         balance_score <- round(summary_info$efficiency$balance_score, 3)
     } else {
         # Compute on the fly if not available
-        balance_result <- compute_balance_metrics_internal(design)
+        balance_result <- compute_balance_metrics_internal(design_standard)
         balance_score <- round(balance_result$overall_balance, 3)
     }
 
     list(balance_score = balance_score)
 }
 
-# Extract overlap metrics
 extract_overlap_metrics <- function(design) {
+    # Convert to standard encoding for accurate metrics
+    design_standard <- get_standard_encoding(design)
+
     summary_info <- attr(design, "design_summary")
 
     if (!is.null(summary_info$efficiency$overlap_score)) {
         overlap_score <- round(summary_info$efficiency$overlap_score, 3)
     } else {
         # Compute on the fly if not available
-        overlap_result <- compute_overlap_metrics_internal(design)
+        overlap_result <- compute_overlap_metrics_internal(design_standard)
         overlap_score <- round(overlap_result$overall_overlap, 3)
     }
 

R/decode.R

@@ -0,0 +1,13 @@
+#' Convert dummy-coded CBC data back to categorical format
+#'
+#' This function is depreciated. Use `cbc_encode()` instead
+#'
+#' @param data A `cbc_design` or `cbc_choices` object with dummy-coded categorical variables
+#' @return The input object with categorical variables restored to their original format
+#' @export
+cbc_decode <- function(data) {
+    # v0.6.5
+    .Deprecated(
+        "This function was depreciated in v0.13.0; use the cbc_encode() function instead"
+    )
+}