Skip to content

Commit

Permalink
update contrasts and tests
Browse files Browse the repository at this point in the history
  • Loading branch information
@jmgirard
jmgirard committed Oct 24, 2024
1 parent 24c3318 commit 5624b43
Show file tree
Hide file tree
Showing 11 changed files with 335 additions and 345 deletions.
1 change: 0 additions & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,7 +36,6 @@ Imports:
ggplot2 (>= 3.3.0),
htmlTable (>= 1.13.3),
Rcpp,
scales,
stats
Suggests:
covr (>= 3.5.0),
Expand Down
4 changes: 3 additions & 1 deletion NEWS.md
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
# circumplex (development version)

* Re-factor package to remove most dependencies
* Re-factor package to remove most external dependencies

* Breaking change: removed support for non-standard evaluation

* Breaking change: replaced model-based contrasts with test-based contrasts

# circumplex 0.3.10

## Minor improvements and fixes
Expand Down
153 changes: 60 additions & 93 deletions R/ssm_analysis.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,11 +19,10 @@
#' @param grouping Optional. Either `NULL` or a string that contains the column
#' name from `data` of the variable that indicates the group membership of
#' each observation.
#' @param contrast Optional. A string indicating what type of contrast to run.
#' Current options are "none" for no contrast, "model" to find SSM parameters
#' for the difference scores, or "test" to find the difference between the SSM
#' parameters. Note that only two groups or measures can be contrasted at a
#' time (default = "none").
#' @param contrast Optional. A logical indicating whether to output the
#' difference between two measures' or two groups' SSM parameters. Can only be
#' set to TRUE when there are exactly two measures and one group, one measure
#' and two groups, or no measures and two groups (default = FALSE).
#' @param boots Optional. A single positive whole number indicating how many
#' bootstrap resamples to use when estimating the confidence intervals
#' (default = 2000).
Expand Down Expand Up @@ -79,15 +78,15 @@
#' jz2017,
#' scales = c("PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO"),
#' grouping = "Gender",
#' contrast = "model"
#' contrast = TRUE
#' )
#'
#' # Single-group correlation-based SSM with contrast
#' ssm_analyze(
#' jz2017,
#' scales = c("PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO"),
#' measures = c("NARPD", "ASPD"),
#' contrast = "test"
#' contrast = TRUE
#' )
#'
#' # Multiple-group correlation-based SSM
Expand All @@ -104,12 +103,12 @@
#' scales = c("PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO"),
#' measures = "NARPD",
#' grouping = "Gender",
#' contrast = "test"
#' contrast = TRUE
#' )
#' }
#'
ssm_analyze <- function(data, scales, angles = octants(),
measures = NULL, grouping = NULL, contrast = "none",
measures = NULL, grouping = NULL, contrast = FALSE,
boots = 2000, interval = 0.95, listwise = TRUE,
measures_labels = NULL) {

Expand All @@ -123,13 +122,24 @@ ssm_analyze <- function(data, scales, angles = octants(),
stopifnot(length(scales) == length(angles))
stopifnot(is.null(measures) || is.character(measures))
stopifnot(is.null(grouping) || (is.character(grouping) && length(grouping) == 1))
stopifnot(tolower(contrast) %in% c("none", "test", "model"))
stopifnot(is.logical(contrast) && length(contrast) == 1)
stopifnot(is.numeric(boots) && boots > 0 && ceiling(boots) == floor(boots))
stopifnot(is.numeric(interval) && interval > 0 && interval < 1)
stopifnot(is.logical(listwise) && length(listwise) == 1)
stopifnot(is.null(measures_labels) || is.character(measures_labels))
stopifnot(is.null(measures_labels) || (length(measures_labels) == length(measures)))

if (contrast) {
n_measures <- length(measures)
n_groups <- ifelse(is.null(grouping), 1, nlevels(factor(data[[grouping]])))
group_mean_contrast <- n_measures == 0 && n_groups == 2
group_corr_contrast <- n_measures == 1 && n_groups == 2
measure_corr_contrast <- n_measures == 2 && n_groups == 1
if (!any(group_mean_contrast, group_corr_contrast, measure_corr_contrast)) {
stop("Contrast can only be TRUE when comparing 2 groups or 2 measures.")
}
}

# Convert angles from degrees to radians
angles <- as_radian(as_degree(angles))

Expand Down Expand Up @@ -194,27 +204,19 @@ ssm_analyze_means <- function(data, scales, angles, grouping, contrast,
n_groups <- nlevels(bs_input[[ncol(bs_input)]])
group_levels <- levels(bs_input[[ncol(bs_input)]])

# Check if more than one contrast is possible
if (contrast != "none" && n_groups != 2) {
stop(c(
"Only two groups can be contrasted at a time.\n\n Hint: Set ",
"contrast = 'none' or use a dichotomous grouping variable."
))
}

# Calculate mean observed scores
mat <- as.matrix(bs_input[scales_names])
grp <- as.integer(bs_input[[ncol(bs_input)]])
scores <- mean_scores(mat, grp, listwise)
colnames(scores) <- scales_names
if (contrast == "none") {
scores <- cbind(label = group_levels, as.data.frame(scores))
} else {
if (contrast) {
scores <- rbind(scores, scores[2, ] - scores[1, ])
scores <- cbind(
label = c(group_levels, paste0(group_levels[[2]], " - ", group_levels[[1]])),
as.data.frame(scores)
)
} else {
scores <- cbind(label = group_levels, as.data.frame(scores))
}

# Create function that will perform bootstrapping
Expand All @@ -240,19 +242,14 @@ ssm_analyze_means <- function(data, scales, angles, grouping, contrast,
)

# Select and label results
if (contrast == "none") {
row_data <- bs_output
row_labels <- group_levels
} else {
row_data <- bs_output[nrow(bs_output), ]
row_data[c("d_est", "d_lci", "d_uci")] <- lapply(
row_data[c("d_est", "d_lci", "d_uci")],
as_degree
row_labels <- group_levels
if (contrast) {
row_labels <- c(
row_labels,
paste0(group_levels[[2]], " - ", group_levels[[1]])
)
row_labels <- paste0(group_levels[[2]], " - ", group_levels[[1]])
}
results <- row_data
results$label <- row_labels
results <- cbind(label = row_labels, bs_output)

# Collect analysis details
details <- list(
Expand All @@ -261,8 +258,7 @@ ssm_analyze_means <- function(data, scales, angles, grouping, contrast,
listwise = listwise,
angles = as_degree(angles),
contrast = contrast,
score_type = "Mean",
results_type = ifelse(contrast == "none", "Profile", "Contrast")
score_type = "Mean"
)

# Create output ssm object
Expand Down Expand Up @@ -310,46 +306,38 @@ ssm_analyze_corrs <- function(data, scales, angles, measures, grouping,
n_measures <- length(measures)
n_groups <- nlevels(bs_input$Group)

# Check that this combination of arguments is executable
if (contrast != "none") {
contrast_measures <- (n_measures == 2 && n_groups == 1)
contrast_groups <- (n_measures == 1 && n_groups == 2)
valid_contrast <- contrast_measures || contrast_groups
if (valid_contrast == FALSE) {
stop(c(
"No valid contrasts were possible. To contrast measures, ensure ",
"there are 2 measures and no grouping variable. To contrast groups, ",
"ensure there is 1 measure and a dichotomous grouping variable."
))
# TODO: Enable contrasting more than two measures or groups?
}
}

# Get names of measures (using labels if provided)
if (is.null(measures_labels)) {
measure_labels <- measures_names
}

# Calculate observed scores (i.e., correlations)
# Calculate observed correlation scores
cs <- as.matrix(bs_input[scales_names])
mv <- as.matrix(bs_input[measures_names])
grp <- as.integer(bs_input[[ncol(bs_input)]])
scores <- corr_scores(cs, mv, grp, listwise)

# Format correlation data frame
colnames(scores) <- scales_names
group_levels <- levels(bs_input[[ncol(bs_input)]])
if (contrast) {
scores <- rbind(scores, scores[2, ] - scores[1, ])
}
scores <- as.data.frame(scores)
Group <- rep(unique(bs_input[[ncol(bs_input)]]), each = n_measures)
Group <- rep(group_levels, each = n_measures)
Measure <- rep(measure_labels, times = n_groups)
if (contrast && is.null(grouping)) {
Group <- c(Group, Group[[1]])
Measure <- c(Measure, paste0(Measure[[2]], " - ", Measure[[1]]))
} else if (contrast && !is.null(grouping)) {
Group <- c(Group, paste0(Group[[2]], " - ", Group[[1]]))
Measure <- c(Measure, Measure[[1]])
}
scores <- cbind(Group, Measure, scores)

# Create label variable
if (is.null(grouping)) {
scores$label <- Measure
} else {
scores$label <- paste0(Group, "_", Measure)
scores$label <- paste0(Measure, ": ", Group)
}

# Create function that will perform bootstrapping
bs_function <- function(.data, index, scales, measures, angles, contrast,
listwise, ...) {
Expand All @@ -375,51 +363,30 @@ ssm_analyze_corrs <- function(data, scales, angles, measures, grouping,
strata = bs_input$Group
)

group_names <- levels(bs_input$Group)
if (contrast == "none") {
row_data <- bs_output
grp_labels <- rep(group_names, each = n_measures)
msr_labels <- rep(measures_names, times = n_groups)
if (is.null(grouping)) {
lbl_labels <- msr_labels
} else {
lbl_labels <- paste0(grp_labels, "_", msr_labels)
}
results <- cbind(
Group = grp_labels,
Measure = msr_labels,
row_data,
label = lbl_labels
)
Group <- rep(group_levels, each = n_measures)
Measure <- rep(measure_labels, times = n_groups)
if (contrast && is.null(grouping)) {
Group <- c(Group, Group[[1]])
Measure <- c(Measure, paste0(Measure[[2]], " - ", Measure[[1]]))
} else if (contrast && !is.null(grouping)) {
Group <- c(Group, paste0(Group[[2]], " - ", Group[[1]]))
Measure <- c(Measure, Measure[[1]])
}
results <- cbind(Group, Measure, bs_output)
if (is.null(grouping)) {
results$label <- Measure
} else {
row_data <- bs_output[nrow(bs_output), ]
row_data[c("d_est", "d_lci", "d_uci")] <- lapply(
row_data[c("d_est", "d_lci", "d_uci")],
as_degree
)
if (contrast_measures) {
row_labels <- paste0(measures_names[[2]], " - ", measures_names[[1]])
} else if (contrast_groups) {
row_labels <- paste0(
measures_names[[1]],
": ",
group_names[[2]],
" - ",
group_names[[1]]
)
}
results <- cbind(label = row_labels, row_data)
results$label <- paste0(Measure, ": ", Group)
}

# Collect analysis details
details <- list(
boots = boots,
interval = interval,
listwise = listwise,
angles = as_degree(angles),
contrast = contrast,
score_type = "Correlation",
results_type = ifelse(contrast == "none", "Profile", "Contrast")
score_type = "Correlation"
)

# Create output ssm object
Expand Down
40 changes: 14 additions & 26 deletions R/ssm_bootstrap.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,28 +16,21 @@ ssm_bootstrap <- function(bs_input, bs_function, scales, measures = NULL,
...
)

# Reshape parameters from wide to long format --------------------------------
reshape_params <- function(v, suffix) {
# Convert vector to matrix
out <- matrix(v, ncol = 6, byrow = TRUE)
# Add column names
colnames(out) <- paste0(c("e_", "x_", "y_", "a_", "d_", "fit_"), suffix)
# Convert to data frame
as.data.frame(out)
}

# Extract point estimates from bootstrap results -----------------------------
bs_est <- reshape_params(bs_results$t0, suffix = "est")
bs_t <- bs_results$t
bs_t <- as.data.frame(bs_t)
colnames(bs_t) <- paste0("t", 1:ncol(bs_t))
colnames(bs_t) <- paste0(
c("e", "x", "y", "a", "d", "fit"),
rep(1:nrow(bs_est), each = 6)
)

# Set the units of the displacement results to radians -----------------------

if (contrast == "none" || contrast == "model") {
d_vars <- 1:(ncol(bs_t) / 6) * 6 - 1
} else if (contrast == "test") {
if (contrast) {
# Don't set to rad for contrasted d parameter (we want to allow negatives)
d_vars <- 1:((ncol(bs_t) - 6) / 6) * 6 - 1
} else {
d_vars <- 1:(ncol(bs_t) / 6) * 6 - 1
}
bs_t[d_vars] <- lapply(bs_t[d_vars], new_radian)

Expand All @@ -61,19 +54,14 @@ ssm_bootstrap <- function(bs_input, bs_function, scales, measures = NULL,
out
}

#
# Calculate SSM parameters per group (or parameter differences)
ssm_by_group <- function(scores, angles, contrast) {

# To model contrast, subtract scores then SSM --------------------------------
if (contrast == "model") {
scores <- rbind(scores, scores[2, ] - scores[1, ])
}

# Calculate parameters per group ---------------------------------------------

# Calculate SSM parameters per group
results <- group_parameters(scores, angles)

# To test contrast, SSM then subtract parameters -----------------------------
if (contrast == "test") {
# If contrasting, append SSM parameter differences
if (contrast) {
results <- c(results, param_diff(results[7:12], results[1:6]))
}

Expand Down
Loading

0 comments on commit 5624b43

Please sign in to comment.