Skip to content

Commit 3dd0da6

Browse files
jhelvyjhelvy
committed
encoding now works with saved designs
1 parent 2fc534d commit 3dd0da6

7 files changed

Lines changed: 442 additions & 208 deletions

File tree

‎R/choices.R‎

Lines changed: 24 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -161,27 +161,28 @@ simulate_utility_based_choices <- function(design, priors) {
161161
# Create optimization environment using the existing function
162162
opt_env <- setup_optimization_environment(
163163
profiles = profiles,
164-
method = "random", # Hard-code this so that the obsID vectors are correct
165-
time_start = Sys.time(), # Not important for choice simulation
164+
method = "random",
165+
time_start = Sys.time(),
166166
n_alts = design_params$n_alts,
167167
n_q = design_params$n_q,
168168
n_resp = design_params$n_resp,
169169
n_blocks = design_params$n_blocks,
170-
n_cores = 1, # Not used for choice simulation
171-
n_start = 1, # Not used for choice simulation
172-
max_iter = 1, # Not used for choice simulation
173-
priors = priors, # The new priors for choice simulation
170+
n_cores = 1,
171+
n_start = 1,
172+
max_iter = 1,
173+
priors = priors,
174174
no_choice = design_params$no_choice,
175175
label = design_params$label,
176-
balance_by = NULL, # Not used for choice simulation
177-
remove_dominant = FALSE, # Not needed for choice simulation
178-
dominance_types = NULL, # Not needed for choice simulation
179-
dominance_threshold = 0.8, # Not needed for choice simulation
180-
max_dominance_attempts = 1, # Not needed for choice simulation
181-
randomize_questions = TRUE, # Not used for choice simulation
182-
randomize_alts = TRUE, # Not used for choice simulation
183-
include_probs = FALSE, # Not used for choice simulation
184-
use_idefix = FALSE # Not used for choice simulation
176+
balance_by = NULL,
177+
remove_dominant = FALSE,
178+
dominance_types = NULL,
179+
dominance_threshold = 0.8,
180+
max_dominance_attempts = 1,
181+
randomize_questions = TRUE,
182+
randomize_alts = TRUE,
183+
include_probs = FALSE,
184+
use_idefix = FALSE,
185+
coding = design_params$coding %||% "standard"
185186
)
186187

187188
# Get design matrix from the design object
@@ -207,7 +208,8 @@ get_design_matrix_from_design_object <- function(design, opt_env) {
207208
# Get the regular profiles (excluding no-choice if present)
208209
regular_design <- design
209210
if (opt_env$no_choice) {
210-
regular_design <- design[design$profileID != 0, ]
211+
no_choice_id <- opt_env$n$profiles + 1
212+
regular_design <- design[design$profileID != no_choice_id, ]
211213
}
212214

213215
# Determine matrix dimensions
@@ -220,16 +222,16 @@ get_design_matrix_from_design_object <- function(design, opt_env) {
220222
# Fill matrix from profileID data
221223
for (obs in 1:n_questions) {
222224
obs_rows <- regular_design[regular_design$obsID == obs, ]
223-
obs_rows <- obs_rows[order(obs_rows$altID), ] # Ensure proper order
225+
obs_rows <- obs_rows[order(obs_rows$altID), ]
224226

225-
if (nrow(obs_rows) == n_alts) {
226-
design_matrix[obs, ] <- obs_rows$profileID
227-
} else {
227+
if (nrow(obs_rows) != n_alts) {
228228
stop(sprintf(
229-
"Inconsistent number of alternatives in observation %d",
230-
obs
229+
"Inconsistent number of alternatives in observation %d: expected %d, got %d",
230+
obs, n_alts, nrow(obs_rows)
231231
))
232232
}
233+
234+
design_matrix[obs, ] <- obs_rows$profileID
233235
}
234236

235237
return(design_matrix)

‎R/design.R‎

Lines changed: 7 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -1098,9 +1098,7 @@ compute_design_efficiency_metrics <- function(design) {
10981098
balance_details = balance_result$balance_metrics,
10991099
overlap_score = overlap_result$overall_overlap,
11001100
overlap_details = overlap_result$overlap_metrics,
1101-
profiles_used = length(unique(design_standard$profileID[
1102-
design_standard$profileID != 0
1103-
])),
1101+
profiles_used = length(unique(design_standard$profileID[design_standard$profileID != 0])),
11041102
profiles_available = max(design_standard$profileID, na.rm = TRUE)
11051103
))
11061104
}
@@ -1113,21 +1111,12 @@ compute_balance_metrics_internal <- function(design) {
11131111
# Get attribute columns (exclude no_choice if present)
11141112
atts <- setdiff(
11151113
names(design_standard),
1116-
c(
1117-
"respID",
1118-
"qID",
1119-
"altID",
1120-
"obsID",
1121-
"profileID",
1122-
"blockID",
1123-
"no_choice",
1124-
"prob"
1125-
)
1114+
c("respID", "qID", "altID", "obsID", "profileID", "blockID", "no_choice", "prob")
11261115
)
11271116

11281117
# Get counts of each individual attribute (handles NA from no-choice)
11291118
counts <- lapply(atts, function(attr) {
1130-
table(design_standard[[attr]], useNA = "no") # Exclude NA values
1119+
table(design_standard[[attr]], useNA = "no") # Exclude NA values
11311120
})
11321121
names(counts) <- atts
11331122

@@ -1154,16 +1143,7 @@ compute_overlap_metrics_internal <- function(design) {
11541143
# Get attribute columns (exclude no_choice if present)
11551144
atts <- setdiff(
11561145
names(design_standard),
1157-
c(
1158-
"respID",
1159-
"qID",
1160-
"altID",
1161-
"obsID",
1162-
"profileID",
1163-
"blockID",
1164-
"no_choice",
1165-
"prob"
1166-
)
1146+
c("respID", "qID", "altID", "obsID", "profileID", "blockID", "no_choice", "prob")
11671147
)
11681148

11691149
# Calculate overlap for each attribute
@@ -1173,10 +1153,7 @@ compute_overlap_metrics_internal <- function(design) {
11731153
names(overlap_counts) <- atts
11741154

11751155
# Calculate overlap metrics
1176-
overlap_metrics <- calculate_overlap_metrics(
1177-
overlap_counts,
1178-
design_standard
1179-
)
1156+
overlap_metrics <- calculate_overlap_metrics(overlap_counts, design_standard)
11801157

11811158
# Calculate overall overlap score (average of complete overlap rates)
11821159
overall_overlap <- mean(sapply(overlap_metrics, function(x) {
@@ -1232,7 +1209,8 @@ finalize_design_object <- function(design, design_result, opt_env) {
12321209
} else {
12331210
NULL
12341211
},
1235-
encoding = attr(design, "encoding") # NEW: store encoding type
1212+
encoding = attr(design, "encoding"),
1213+
coding = opt_env$coding
12361214
)
12371215

12381216
# Add D-error information (both null and prior-based)

‎R/encode.R‎

Lines changed: 12 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -51,12 +51,13 @@
5151
#' )
5252
#' head(design_dummy2)
5353
cbc_encode <- function(data, coding = NULL, refs = NULL) {
54-
# Check input class
55-
if (!inherits(data, c("cbc_design", "cbc_choices"))) {
56-
stop(
57-
"Input must be a cbc_design or cbc_choices object created by cbc_design() or cbc_choices()"
58-
)
59-
}
54+
# Validate and potentially reconstruct design object
55+
data <- validate_or_reconstruct(
56+
data,
57+
require_class = FALSE,
58+
allow_choices = TRUE,
59+
context = "cbc_encode()"
60+
)
6061

6162
# Get current encoding
6263
current_coding <- attr(data, "encoding") %||% "standard"
@@ -68,10 +69,7 @@ cbc_encode <- function(data, coding = NULL, refs = NULL) {
6869
message("Converting from standard to dummy encoding")
6970
} else {
7071
coding <- "standard"
71-
message(sprintf(
72-
"Converting from %s to standard encoding",
73-
current_coding
74-
))
72+
message(sprintf("Converting from %s to standard encoding", current_coding))
7573
}
7674
}
7775

@@ -222,9 +220,7 @@ encode_dummy <- function(data, categorical_structure) {
222220

223221
# Convert NA to 0 for no-choice rows
224222
if (has_no_choice) {
225-
encoded_data[[dummy_col_name]][is.na(encoded_data[[
226-
dummy_col_name
227-
]])] <- 0
223+
encoded_data[[dummy_col_name]][is.na(encoded_data[[dummy_col_name]])] <- 0
228224
}
229225
}
230226

@@ -278,16 +274,13 @@ encode_effects <- function(data, categorical_structure) {
278274
effects_col_name <- paste0(attr, level)
279275
# 1 for this level, -1 for reference, 0 for others
280276
encoded_data[[effects_col_name]] <- ifelse(
281-
data[[attr]] == level,
282-
1,
277+
data[[attr]] == level, 1,
283278
ifelse(data[[attr]] == reference_level, -1, 0)
284279
)
285280

286281
# Convert NA to 0 for no-choice rows
287282
if (has_no_choice) {
288-
encoded_data[[effects_col_name]][is.na(encoded_data[[
289-
effects_col_name
290-
]])] <- 0
283+
encoded_data[[effects_col_name]][is.na(encoded_data[[effects_col_name]])] <- 0
291284
}
292285
}
293286

@@ -384,26 +377,4 @@ update_reference_levels <- function(data, categorical_structure, refs) {
384377
data = data,
385378
categorical_structure = categorical_structure
386379
))
387-
}
388-
389-
is_dummy_coded <- function(data) {
390-
is_coded <- attr(data, "is_dummy_coded")
391-
if (is.null(is_coded)) {
392-
# If no attribute, try to infer from column names
393-
# Look for column names that suggest dummy coding (e.g., "qualityHigh", "brandB")
394-
categorical_structure <- attr(data, "categorical_structure")
395-
if (!is.null(categorical_structure)) {
396-
categorical_attrs <- names(categorical_structure)[
397-
sapply(categorical_structure, function(x) x$is_categorical)
398-
]
399-
400-
# Check if any original categorical column names are missing
401-
missing_categoricals <- setdiff(categorical_attrs, names(data))
402-
if (length(missing_categoricals) > 0) {
403-
return(TRUE) # Likely dummy-coded if original categorical columns are missing
404-
}
405-
}
406-
return(FALSE)
407-
}
408-
return(is_coded)
409-
}
380+
}

0 commit comments

Comments
 (0)