From 9ed0fab9e1ac5ea00d38ebf4484e442900906f36 Mon Sep 17 00:00:00 2001 From: jmgirard Date: Thu, 24 Oct 2024 20:59:46 -0500 Subject: [PATCH] finish refactoring --- NAMESPACE | 1 - R/ssm_analysis.R | 29 +- R/ssm_visualization.R | 211 ++++++-------- R/tidying_functions.R | 30 +- R/utils.R | 39 ++- man/html_render.Rd | 1 - man/ssm_analyze.Rd | 1 - man/ssm_append.Rd | 49 ---- man/ssm_parameters.Rd | 1 - man/ssm_plot.Rd | 3 +- man/ssm_plot_contrast.Rd | 23 +- man/ssm_score.Rd | 1 - man/ssm_table.Rd | 27 +- .../group-constrast-correlation-ssm.svg | 247 ++++++++++++++++ .../measure-contrast-ssm.svg | 264 ++++++++++++++++++ .../single-group-correlation-ssm.svg | 62 ++++ .../single-group-mean-ssm.svg | 62 ++++ tests/testthat/test-ssm_visualization.R | 56 ++-- tests/testthat/test-tidying_functions.R | 9 +- 19 files changed, 863 insertions(+), 253 deletions(-) delete mode 100644 man/ssm_append.Rd create mode 100644 tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.svg create mode 100644 tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.svg create mode 100644 tests/testthat/_snaps/ssm_visualization/single-group-correlation-ssm.svg create mode 100644 tests/testthat/_snaps/ssm_visualization/single-group-mean-ssm.svg diff --git a/NAMESPACE b/NAMESPACE index 3b765e1d..9f584c81 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,7 +29,6 @@ export(quadrants) export(scales) export(score) export(ssm_analyze) -export(ssm_append) export(ssm_parameters) export(ssm_plot) export(ssm_plot_scores) diff --git a/R/ssm_analysis.R b/R/ssm_analysis.R index b4f2d6b7..7980ce04 100644 --- a/R/ssm_analysis.R +++ b/R/ssm_analysis.R @@ -117,17 +117,16 @@ ssm_analyze <- function(data, scales, angles = octants(), # Validate arguments stopifnot(is.data.frame(data) || is.matrix(data)) - stopifnot(is.character(scales) || is.numeric(scales)) + stopifnot(is_var(scales)) stopifnot(is.numeric(angles)) stopifnot(length(scales) == length(angles)) - stopifnot(is.null(measures) || is.character(measures)) - stopifnot(is.null(grouping) || (is.character(grouping) && length(grouping) == 1)) - stopifnot(is.logical(contrast) && length(contrast) == 1) + stopifnot(is_null_or_var(measures)) + stopifnot(is_null_or_var(grouping, n = 1)) + stopifnot(is_flag(contrast)) 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))) + stopifnot(is_flag(listwise)) + stopifnot(is_null_or_char(measures_labels, n = length(measures))) if (contrast) { n_measures <- length(measures) @@ -450,14 +449,14 @@ ssm_parameters <- function(scores, angles = octants(), prefix = "", suffix = "", stopifnot(is.numeric(scores)) stopifnot(is.numeric(angles)) stopifnot(length(scores) == length(angles)) - stopifnot(is.character(prefix), length(prefix) == 1) - stopifnot(is.character(suffix), length(suffix) == 1) - stopifnot(is.character(e_label), length(e_label) == 1) - stopifnot(is.character(x_label), length(x_label) == 1) - stopifnot(is.character(y_label), length(y_label) == 1) - stopifnot(is.character(a_label), length(a_label) == 1) - stopifnot(is.character(d_label), length(d_label) == 1) - stopifnot(is.character(f_label), length(f_label) == 1) + stopifnot(is_char(prefix, n = 1)) + stopifnot(is_char(suffix, n = 1)) + stopifnot(is_char(e_label, n = 1)) + stopifnot(is_char(x_label, n = 1)) + stopifnot(is_char(y_label, n = 1)) + stopifnot(is_char(a_label, n = 1)) + stopifnot(is_char(d_label, n = 1)) + stopifnot(is_char(f_label, n = 1)) angles <- as_radian(as_degree(angles)) params <- ssm_parameters_cpp(scores, angles) diff --git a/R/ssm_visualization.R b/R/ssm_visualization.R index 98a56387..84f7cf0c 100644 --- a/R/ssm_visualization.R +++ b/R/ssm_visualization.R @@ -174,7 +174,6 @@ ssm_plot_circle <- function(.ssm_object, amax = NULL, ggplot2::scale_linetype_identity() + ggplot2::theme(legend.position = "none") } else { - results_type <- ifelse(.ssm_object$details$contrast, "Contrast", "Profile") p <- p + ggforce::geom_arc_bar( data = df_plot, @@ -194,8 +193,8 @@ ssm_plot_circle <- function(.ssm_object, amax = NULL, color = "black" ) + ggplot2::guides( - color = ggplot2::guide_legend(results_type), - fill = ggplot2::guide_legend(results_type) + color = ggplot2::guide_legend("Profile"), + fill = ggplot2::guide_legend("Profile") ) + ggplot2::theme( legend.text = ggplot2::element_text(size = legend_font_size), @@ -210,7 +209,7 @@ ssm_plot_circle <- function(.ssm_object, amax = NULL, ggrepel::geom_label_repel( data = df_plot, ggplot2::aes(x = x_est, y = y_est, label = label), - nudge_x = -25 - df_plot$x_est, + nudge_x = -8 - df_plot$x_est, direction = "y", hjust = 1, size = legend_font_size / 2.8346438836889 @@ -228,83 +227,83 @@ ssm_plot_circle <- function(.ssm_object, amax = NULL, #' contrast (e.g., between groups or measures). #' #' @param .ssm_object Required. The results output of \code{ssm_analyze}. -#' @param axislabel Optional. A string to label the y-axis (default = -#' "Difference"). -#' @param xy A logical determining whether the X-Value and Y-Value parameters -#' should be included in the plot (default = TRUE). -#' @param color Optional. A string corresponding to the color of the point range -#' (default = "red"). +#' @param drop_xy A logical determining whether the X-Value and Y-Value +#' parameters should be removed from the plot (default = FALSE). +#' @param sig_color Optional. A string corresponding to the color to use to +#' denote significant contrasts (default = "#fc8d62"). +#' @param ns_color Optional. A string corresponding to the color to use to +#' denote non-significant contrasts (default = "white"). #' @param linesize Optional. A positive number corresponding to the size of the #' point range elements in mm (default = 1.5). #' @param fontsize Optional. A positive number corresponding to the size of the #' axis labels, numbers, and facet headings in pt (default = 12). +#' @param ... Additional arguments will be ignored. #' @return A ggplot variable containing difference point-ranges faceted by SSM #' parameter. An interval that does not contain the value of zero has p<.05. -ssm_plot_contrast <- function(.ssm_object, axislabel = "Difference", - xy = TRUE, color = "red", linesize = 1.25, fontsize = 12) { +ssm_plot_contrast <- function(.ssm_object, drop_xy = FALSE, + sig_color = "#fc8d62", ns_color = "white", + linesize = 1.25, fontsize = 12, ...) { + + stopifnot(.ssm_object$details$contrast) # Prepare all estimates plabs <- c( e = expression(paste(Delta, " Elevation")), - x = expression(paste(Delta, " X-Value")), - y = expression(paste(Delta, " Y-Value")), + x = expression(paste(Delta, " X Value")), + y = expression(paste(Delta, " Y Value")), a = expression(paste(Delta, " Amplitude")), d = expression(paste(Delta, " Displacement")) ) pvals <- c("e", "x", "y", "a", "d") - res <- .ssm_object$results - + res <- .ssm_object$results[nrow(.ssm_object$results), ] + + plot_df <- + data.frame( + Parameter = factor(pvals, levels = pvals, labels = plabs), + Difference = c(res$e_est, res$x_est, res$y_est, res$a_est, res$d_est), + lci = c(res$e_lci, res$x_lci, res$y_lci, res$a_lci, res$d_lci), + uci = c(res$e_uci, res$x_uci, res$y_uci, res$a_uci, res$d_uci) + ) + + plot_df$sig <- sign(plot_df$lci) == sign(plot_df$uci) + # Drop x and y estimates if requested - if (xy == FALSE) { - res <- subset(res, select = -c(x_est, x_lci, x_uci, y_est, y_lci, y_uci)) - plabs <- plabs[-c(2, 3)] - pvals <- pvals[-c(2, 3)] + if (drop_xy) { + plot_df <- plot_df[-c(2, 3), ] } - # TODO: REFACTORING UNTIL HERE - NEXT SECTION IN PROGRESS - - res2 <- res - estcol <- c(res2$e_est, res2$x_est, res2$y_est, res2$a_est, res2$d_est) - ucicol <- c(res2$e_uci, res2$x_uci, res2$y_uci, res2$a_uci, res2$d_uci) - lcicol <- c(res2$e_lci, res2$x_lci, res2$y_lci, res2$a_lci, res2$d_lci) - labcol <- rep(res2$label, times = length(estcol)) - - # res <- - # res %>% - # dplyr::mutate( - # d_est = unclass(d_est), - # d_uci = unclass(ifelse(d_uci < d_lci && d_uci < 180, circ_dist(d_uci), d_uci)), - # d_lci = unclass(ifelse(d_lci > d_uci && d_lci > 180, circ_dist(d_lci), d_lci)) - # ) %>% - # dplyr::select(-fit_est) %>% - # tidyr::pivot_longer(cols = e_est:d_uci, names_to = "key", values_to = "value") %>% - # tidyr::extract(col = key, into = c("Parameter", "Type"), "(.)_(...)") %>% - # tidyr::pivot_wider(names_from = Type, values_from = value) %>% - # dplyr::rename(Difference = est, Contrast = label) %>% - # dplyr::mutate(Parameter = factor(Parameter, levels = pvals, labels = plabs)) - p <- - res %>% - ggplot2::ggplot() + + ggplot2::ggplot(plot_df) + ggplot2::theme_bw(base_size = fontsize) + ggplot2::theme( legend.position = "top", axis.text.x = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), panel.grid.major.x = ggplot2::element_blank(), - panel.grid.minor.y = ggplot2::element_line(linetype = "dashed") + panel.grid.minor.y = ggplot2::element_line(linetype = "dashed"), + axis.ticks.x = ggplot2::element_blank() ) + - ggplot2::geom_hline(yintercept = 0, linewidth = linesize, color = "darkgray") + - ggplot2::geom_point( - ggplot2::aes(x = Contrast, y = Difference), - size = linesize * 3, color = color + ggplot2::geom_hline( + yintercept = 0, + linewidth = linesize, + color = "darkgray" ) + ggplot2::geom_errorbar( - ggplot2::aes(x = Contrast, ymin = lci, ymax = uci), - linewidth = linesize, color = color, width = 0.1 + ggplot2::aes(x = "1", ymin = lci, ymax = uci), + linewidth = linesize, width = 0.1 ) + - ggplot2::labs(y = axislabel) + + ggplot2::geom_point( + ggplot2::aes(x = "1", y = Difference, fill = sig), + size = linesize * 3, + stroke = linesize, + shape = 21 + ) + + ggplot2::scale_fill_manual( + "Signficant", + values = c("TRUE" = sig_color, "FALSE" = ns_color) + ) + + ggplot2::labs(y = paste0("Contrast (", res$label, ")")) + ggplot2::facet_wrap(~Parameter, nrow = 1, scales = "free", labeller = ggplot2::label_parsed @@ -317,7 +316,7 @@ ssm_plot_contrast <- function(.ssm_object, axislabel = "Difference", circle_base <- function(angles, labels = NULL, amin = 0, amax = 0.5, fontsize = 12) { - if (is.null(labels)) labels <- sprintf("%d\u00B0", angles) + if (is.null(labels)) labels <- paste0(angles, "\u00B0") ggplot2::ggplot() + # Require plot to be square and remove default styling @@ -420,10 +419,13 @@ circle_base <- function(angles, labels = NULL, amin = 0, #' ssm_table(res) #' } #' -ssm_table <- function(.ssm_object, caption = NULL, xy = TRUE, render = TRUE) { - assert_that(is_provided(.ssm_object)) - assert_that(is.null(caption) || is.string(caption)) - assert_that(is.flag(xy), is.flag(render)) +ssm_table <- function(.ssm_object, caption = NULL, + drop_xy = FALSE, render = TRUE) { + + stopifnot(class(.ssm_object) == "circumplex_ssm") + stopifnot(is.null(caption) || (is.character(caption) && length(caption) == 1)) + stopifnot(is.logical(drop_xy) && length(drop_xy) == 1) + stopifnot(is.logical(render) && length(render) == 1) df <- .ssm_object$results @@ -433,38 +435,48 @@ ssm_table <- function(.ssm_object, caption = NULL, xy = TRUE, render = TRUE) { } # Format output data - df <- dplyr::transmute(df, - Label = label, - Elevation = sprintf("%.2f (%.2f, %.2f)", e_est, e_lci, e_uci), - `X-Value` = sprintf("%.2f (%.2f, %.2f)", x_est, x_lci, x_uci), - `Y-Value` = sprintf("%.2f (%.2f, %.2f)", y_est, y_lci, y_uci), - Amplitude = sprintf("%.2f (%.2f, %.2f)", a_est, a_lci, a_uci), - Displacement = sprintf("%.1f (%.1f, %.1f)", d_est, d_lci, d_uci), - Fit = sprintf("%.3f", fit_est) - ) + table_df <- + data.frame( + Profile = df$label, + Elevation = sprintf("%.2f (%.2f, %.2f)", df$e_est, df$e_lci, df$e_uci), + `X Value` = sprintf("%.2f (%.2f, %.2f)", df$x_est, df$x_lci, df$x_uci), + `Y Value` = sprintf("%.2f (%.2f, %.2f)", df$y_est, df$y_lci, df$y_uci), + Amplitude = sprintf("%.2f (%.2f, %.2f)", df$a_est, df$a_lci, df$a_uci), + Displacement = sprintf("%.1f (%.1f, %.1f)", df$d_est, df$d_lci, df$d_uci), + Fit = sprintf("%.3f", df$fit_est) + ) # Rename first column - colnames(df)[[1]] <- .ssm_object$details$results_type + colnames(table_df)[[1]] <- ifelse( + test = .ssm_object$details$contrast, + yes = "Contrast", + no = "Profile" + ) # Add delta symbol to column names if results are contrasts if (.ssm_object$details$contrast) { - colnames(df)[[2]] <- "Δ Elevation" - colnames(df)[[3]] <- "Δ X-Value" - colnames(df)[[4]] <- "Δ Y-Value" - colnames(df)[[5]] <- "Δ Amplitude" - colnames(df)[[6]] <- "Δ Displacement" - colnames(df)[[7]] <- "Δ Fit" + colnames(table_df) <- c( + "Contrast", + "Δ Elevation", + "Δ X Value", + "Δ Y Value", + "Δ Amplitude", + "Δ Displacement", + "Δ Fit" + ) } # Drop the x and y columns if requested - if (xy == FALSE) df <- df[, -c(3, 4)] - + if (drop_xy) { + table_df <- table_df[, -c(3, 4)] + } + # Format and render HTML table if requested if (render == TRUE) { - html_render(df, caption) + html_render(table_df, caption) } - df + table_df } # Build the default caption for the ssm_table function @@ -484,45 +496,6 @@ dcaption <- function(.ssm_object) { } } -#' Combine SSM tables -#' -#' Combine SSM tables by appending them as rows. -#' -#' @param .ssm_table A data frame from the \code{ssm_table()} function to be the -#' first row(s) of the combined table. -#' @param ... One or more additional data frames from the \code{ssm_table()} -#' function to be appended to \code{.ssm_table} in the order of input. -#' @param caption A string to be displayed above the table if rendered. -#' @param render A logical indicating whether the table should be displayed in -#' the RStudio viewer or web browser (default = TRUE). -#' @return A tibble containing the information for the HTML table. As a -#' side-effect, may also output the HTML table to the web viewer. -#' @family ssm functions -#' @family table functions -#' @export -#' @examples -#' data("jz2017") -#' res1 <- ssm_analyze(jz2017, PA:NO, octants()) -#' res2 <- ssm_analyze(jz2017, PA:NO, octants(), grouping = Gender) -#' tab1 <- ssm_table(res1, render = FALSE) -#' tab2 <- ssm_table(res2, render = FALSE) -#' ssm_append(tab1, tab2) -ssm_append <- function(.ssm_table, ..., caption = NULL, render = TRUE) { - - # TODO: Add more assertions - assert_that(is.flag(render)) - - # Bind the tibbles together by row - df <- dplyr::bind_rows(.ssm_table, ...) - - # Format and render HTML table if requested - if (render == TRUE) { - html_render(df, caption) - } - - df -} - #' Format and render data frame as HTML table #' #' Format a data frame as an HTML table and render it to the web viewer. @@ -536,9 +509,11 @@ ssm_append <- function(.ssm_table, ..., caption = NULL, render = TRUE) { #' @export html_render <- function(df, caption = NULL, align = "l", ...) { - # TODO: Add assertions + stopifnot(is_null_or_char(caption, n = 1)) + stopifnot(align %in% c("l", "c", "r")) - t <- htmlTable::htmlTable(df, + t <- htmlTable::htmlTable( + df, caption = caption, align = align, align.header = align, diff --git a/R/tidying_functions.R b/R/tidying_functions.R index 7431271a..9a3390bc 100644 --- a/R/tidying_functions.R +++ b/R/tidying_functions.R @@ -32,11 +32,11 @@ ipsatize <- function(data, items, na.rm = TRUE, prefix = "", suffix = "_i", append = TRUE) { stopifnot(is.data.frame(data) || is.matrix(data)) - stopifnot(is.character(items) || is.numeric(items)) - stopifnot(is.logical(na.rm) && length(na.rm) == 1) - stopifnot(is.character(prefix) && length(prefix) == 1) - stopifnot(is.character(suffix) && length(suffix) == 1) - stopifnot(is.logical(append) && length(append) == 1) + stopifnot(is_var(items)) + stopifnot(is_flag(na.rm)) + stopifnot(is_char(prefix, n = 1)) + stopifnot(is_char(suffix, n = 1)) + stopifnot(is_flag(append)) item_data <- data[items] item_names <- colnames(item_data) @@ -87,12 +87,12 @@ score <- function(data, items, instrument, na.rm = TRUE, prefix = "", suffix = "", append = TRUE) { stopifnot(is.data.frame(data) || is.matrix(data)) - stopifnot(is.character(items) || is.numeric(items)) + stopifnot(is_var(items)) stopifnot(class(instrument) == "circumplex_instrument") - stopifnot(is.logical(na.rm) && length(na.rm) == 1) - stopifnot(is.character(prefix) && length(prefix) == 1) - stopifnot(is.character(suffix) && length(suffix) == 1) - stopifnot(is.logical(append) && length(append) == 1) + stopifnot(is_flag(na.rm)) + stopifnot(is_char(prefix)) + stopifnot(is_char(suffix)) + stopifnot(is_flag(append)) item_data <- data[items] n_items <- length(items) @@ -159,14 +159,14 @@ norm_standardize <- function(data, scales, angles = octants(), instrument, sample = 1, prefix = "", suffix = "_z", append = TRUE) { stopifnot(is.data.frame(data) || is.matrix(data)) - stopifnot(is.character(scales) || is.numeric(scales)) + stopifnot(is_var(scales)) stopifnot(is.numeric(angles)) stopifnot(length(scales) == length(angles)) stopifnot(class(instrument) == "circumplex_instrument") - stopifnot(is.numeric(sample) && length(sample) == 1) - stopifnot(is.character(prefix) && length(prefix) == 1) - stopifnot(is.character(suffix) && length(suffix) == 1) - stopifnot(is.logical(append) && length(append) == 1) + stopifnot(is_num(sample, n = 1)) + stopifnot(is_char(prefix, n = 1)) + stopifnot(is_char(suffix, n = 1)) + stopifnot(is_flag(append)) key <- instrument$Norms[[1]] diff --git a/R/utils.R b/R/utils.R index c7d810eb..6df6e5ec 100644 --- a/R/utils.R +++ b/R/utils.R @@ -97,7 +97,6 @@ pretty_min <- function(v) { out } - rescale <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) { min_to <- to[1] max_to <- to[2] @@ -107,3 +106,41 @@ rescale <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE)) { (x - min_from) / (max_from - min_from) * (max_to - min_to) + min_to } + +# Assertions -------------------------------------------------------------- + +is_char <- function(x, n = NULL) { + if (is.null(n)) { + is.character(x) + } else { + is.character(x) && length(x) == n + } +} + +is_null_or_char <- function(x, n = NULL) { + is.null(x) || is_char(x, n = NULL) +} + +is_var <- function(x, n = NULL) { + if (is.null(n)) { + is.character(x) || is.numeric(x) + } else { + (is.character(x) || is.numeric(x)) && length(x) == n + } +} + +is_null_or_var <- function(x, n = NULL) { + is.null(x) || is_var(x, n) +} + +is_flag <- function(x) { + is.logical(x) && length(x) == 1 +} + +is_num <- function(x, n = NULL) { + if (is.null(n)) { + is.numeric(x) + } else { + is.numeric(x) && length(x) == n + } +} diff --git a/man/html_render.Rd b/man/html_render.Rd index 359b6ca0..95e495ec 100644 --- a/man/html_render.Rd +++ b/man/html_render.Rd @@ -23,7 +23,6 @@ Format a data frame as an HTML table and render it to the web viewer. } \seealso{ Other table functions: -\code{\link{ssm_append}()}, \code{\link{ssm_table}()} } \concept{table functions} diff --git a/man/ssm_analyze.Rd b/man/ssm_analyze.Rd index 41cfcc46..1c8ae2b7 100644 --- a/man/ssm_analyze.Rd +++ b/man/ssm_analyze.Rd @@ -138,7 +138,6 @@ ssm_analyze( } \seealso{ Other ssm functions: -\code{\link{ssm_append}()}, \code{\link{ssm_parameters}()}, \code{\link{ssm_plot}()}, \code{\link{ssm_score}()}, diff --git a/man/ssm_append.Rd b/man/ssm_append.Rd deleted file mode 100644 index 17ee06fa..00000000 --- a/man/ssm_append.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R -\name{ssm_append} -\alias{ssm_append} -\title{Combine SSM tables} -\usage{ -ssm_append(.ssm_table, ..., caption = NULL, render = TRUE) -} -\arguments{ -\item{.ssm_table}{A data frame from the \code{ssm_table()} function to be the -first row(s) of the combined table.} - -\item{...}{One or more additional data frames from the \code{ssm_table()} -function to be appended to \code{.ssm_table} in the order of input.} - -\item{caption}{A string to be displayed above the table if rendered.} - -\item{render}{A logical indicating whether the table should be displayed in -the RStudio viewer or web browser (default = TRUE).} -} -\value{ -A tibble containing the information for the HTML table. As a -side-effect, may also output the HTML table to the web viewer. -} -\description{ -Combine SSM tables by appending them as rows. -} -\examples{ -data("jz2017") -res1 <- ssm_analyze(jz2017, PA:NO, octants()) -res2 <- ssm_analyze(jz2017, PA:NO, octants(), grouping = Gender) -tab1 <- ssm_table(res1, render = FALSE) -tab2 <- ssm_table(res2, render = FALSE) -ssm_append(tab1, tab2) -} -\seealso{ -Other ssm functions: -\code{\link{ssm_analyze}()}, -\code{\link{ssm_parameters}()}, -\code{\link{ssm_plot}()}, -\code{\link{ssm_score}()}, -\code{\link{ssm_table}()} - -Other table functions: -\code{\link{html_render}()}, -\code{\link{ssm_table}()} -} -\concept{ssm functions} -\concept{table functions} diff --git a/man/ssm_parameters.Rd b/man/ssm_parameters.Rd index 07f6c018..d269a9d5 100644 --- a/man/ssm_parameters.Rd +++ b/man/ssm_parameters.Rd @@ -73,7 +73,6 @@ ssm_parameters(scores, prefix = "IIP_") \seealso{ Other ssm functions: \code{\link{ssm_analyze}()}, -\code{\link{ssm_append}()}, \code{\link{ssm_plot}()}, \code{\link{ssm_score}()}, \code{\link{ssm_table}()} diff --git a/man/ssm_plot.Rd b/man/ssm_plot.Rd index c4115cfb..eeab1d04 100644 --- a/man/ssm_plot.Rd +++ b/man/ssm_plot.Rd @@ -38,7 +38,7 @@ res <- ssm_analyze( jz2017, scales = 2:9, measures = c("NARPD", "ASPD"), - contrast = "test" + contrast = TRUE ) p <- ssm_plot(res) } @@ -49,7 +49,6 @@ ggsave Function for saving plots to image files. Other ssm functions: \code{\link{ssm_analyze}()}, -\code{\link{ssm_append}()}, \code{\link{ssm_parameters}()}, \code{\link{ssm_score}()}, \code{\link{ssm_table}()} diff --git a/man/ssm_plot_contrast.Rd b/man/ssm_plot_contrast.Rd index c6dd40cd..3db2d39d 100644 --- a/man/ssm_plot_contrast.Rd +++ b/man/ssm_plot_contrast.Rd @@ -6,30 +6,33 @@ \usage{ ssm_plot_contrast( .ssm_object, - axislabel = "Difference", - xy = TRUE, - color = "red", + drop_xy = FALSE, + sig_color = "#fc8d62", + ns_color = "white", linesize = 1.25, - fontsize = 12 + fontsize = 12, + ... ) } \arguments{ \item{.ssm_object}{Required. The results output of \code{ssm_analyze}.} -\item{axislabel}{Optional. A string to label the y-axis (default = -"Difference").} +\item{drop_xy}{A logical determining whether the X-Value and Y-Value +parameters should be removed from the plot (default = FALSE).} -\item{xy}{A logical determining whether the X-Value and Y-Value parameters -should be included in the plot (default = TRUE).} +\item{sig_color}{Optional. A string corresponding to the color to use to +denote significant contrasts (default = "#fc8d62").} -\item{color}{Optional. A string corresponding to the color of the point range -(default = "red").} +\item{ns_color}{Optional. A string corresponding to the color to use to +denote non-significant contrasts (default = "white").} \item{linesize}{Optional. A positive number corresponding to the size of the point range elements in mm (default = 1.5).} \item{fontsize}{Optional. A positive number corresponding to the size of the axis labels, numbers, and facet headings in pt (default = 12).} + +\item{...}{Additional arguments will be ignored.} } \value{ A ggplot variable containing difference point-ranges faceted by SSM diff --git a/man/ssm_score.Rd b/man/ssm_score.Rd index c292a34a..7a3d60bb 100644 --- a/man/ssm_score.Rd +++ b/man/ssm_score.Rd @@ -42,7 +42,6 @@ ssm_score( \seealso{ Other ssm functions: \code{\link{ssm_analyze}()}, -\code{\link{ssm_append}()}, \code{\link{ssm_parameters}()}, \code{\link{ssm_plot}()}, \code{\link{ssm_table}()} diff --git a/man/ssm_table.Rd b/man/ssm_table.Rd index 9fe5f4d9..aef7e5aa 100644 --- a/man/ssm_table.Rd +++ b/man/ssm_table.Rd @@ -4,7 +4,7 @@ \alias{ssm_table} \title{Create HTML table from SSM results or contrasts} \usage{ -ssm_table(.ssm_object, caption = NULL, xy = TRUE, render = TRUE) +ssm_table(.ssm_object, caption = NULL, drop_xy = FALSE, render = TRUE) } \arguments{ \item{.ssm_object}{The output of \code{ssm_profiles()} or @@ -12,11 +12,11 @@ ssm_table(.ssm_object, caption = NULL, xy = TRUE, render = TRUE) \item{caption}{A string to be displayed above the table (default = NULL).} -\item{xy}{A logical indicating whether the x-value and y-value parameters -should be included in the table as columns (default = TRUE).} - \item{render}{A logical indicating whether the table should be displayed in the RStudio viewer or web browser (default = TRUE).} + +\item{xy}{A logical indicating whether the x-value and y-value parameters +should be included in the table as columns (default = TRUE).} } \value{ A tibble containing the information for the HTML table. As a @@ -32,16 +32,19 @@ desired formatting. data("jz2017") # Create table of profile results -res <- ssm_analyze(jz2017, - scales = PA:NO, angles = octants(), - measures = c(NARPD, ASPD) +res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = c("NARPD", "ASPD") ) ssm_table(res) # Create table of contrast results -res <- ssm_analyze(jz2017, - scales = PA:NO, angles = octants(), - measures = c(NARPD, ASPD), contrast = "test" +res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = c("NARPD", "ASPD"), + contrast = TRUE ) ssm_table(res) } @@ -50,14 +53,12 @@ ssm_table(res) \seealso{ Other ssm functions: \code{\link{ssm_analyze}()}, -\code{\link{ssm_append}()}, \code{\link{ssm_parameters}()}, \code{\link{ssm_plot}()}, \code{\link{ssm_score}()} Other table functions: -\code{\link{html_render}()}, -\code{\link{ssm_append}()} +\code{\link{html_render}()} } \concept{ssm functions} \concept{table functions} diff --git a/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.svg b/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.svg new file mode 100644 index 00000000..18fab24d --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.svg @@ -0,0 +1,247 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Δ + Elevation + + + + + + + + + + +Δ + X Value + + + + + + + + + + +Δ + Y Value + + + + + + + + + + +Δ + Amplitude + + + + + + + + + + +Δ + Displacement + + +-30 +-20 +-10 +0 +10 + + + + + +-0.10 +-0.05 +0.00 + + + +-0.12 +-0.08 +-0.04 +0.00 + + + + +0.00 +0.04 +0.08 +0.12 + + + + +0.00 +0.05 +0.10 + + + +Contrast (NARPD: Male - Female) + +Signficant + + + + +FALSE +TRUE +group-constrast correlation ssm + + diff --git a/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.svg b/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.svg new file mode 100644 index 00000000..74edfcd9 --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.svg @@ -0,0 +1,264 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Δ + Elevation + + + + + + + + + + +Δ + X Value + + + + + + + + + + +Δ + Y Value + + + + + + + + + + +Δ + Amplitude + + + + + + + + + + +Δ + Displacement + + +-15 +-10 +-5 +0 + + + + +-0.08 +-0.06 +-0.04 +-0.02 +0.00 + + + + + +-0.06 +-0.04 +-0.02 +0.00 + + + + +0.00 +0.02 +0.04 +0.06 + + + + +0.000 +0.025 +0.050 +0.075 +0.100 +0.125 + + + + + + +Contrast (NARPD - ASPD) + +Signficant + + + + +FALSE +TRUE +measure-contrast ssm + + diff --git a/tests/testthat/_snaps/ssm_visualization/single-group-correlation-ssm.svg b/tests/testthat/_snaps/ssm_visualization/single-group-correlation-ssm.svg new file mode 100644 index 00000000..9a86fbab --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/single-group-correlation-ssm.svg @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + +0.20 + +0.40 + +90° + +135° + +180° + +225° + +270° + +315° + +360° + +45° + + +Profile + + +PARPD +single group correlation ssm + + diff --git a/tests/testthat/_snaps/ssm_visualization/single-group-mean-ssm.svg b/tests/testthat/_snaps/ssm_visualization/single-group-mean-ssm.svg new file mode 100644 index 00000000..9dfddab1 --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/single-group-mean-ssm.svg @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + +1.00 + +2.00 + +90° + +135° + +180° + +225° + +270° + +315° + +360° + +45° + + +Profile + + +All +single group mean ssm + + diff --git a/tests/testthat/test-ssm_visualization.R b/tests/testthat/test-ssm_visualization.R index 98471cee..6e9deb99 100644 --- a/tests/testthat/test-ssm_visualization.R +++ b/tests/testthat/test-ssm_visualization.R @@ -1,7 +1,6 @@ test_that("Single-group mean-based SSM plot is correct", { - #skip_if(getRversion() > "4.0.0") data("aw2009") - res <- ssm_analyze(aw2009, PA:NO, octants()) + res <- ssm_analyze(aw2009, scales = 1:8) p <- ssm_plot(res) # Test the output object @@ -13,9 +12,8 @@ test_that("Single-group mean-based SSM plot is correct", { }) test_that("Single-group correlation-based SSM plot is correct", { - #skip_if(getRversion() > "4.0.0") data("jz2017") - res <- ssm_analyze(jz2017, PA:NO, octants(), measures = PARPD) + res <- ssm_analyze(jz2017, scales = 2:9, measures = "PARPD") p <- ssm_plot(res) # Test the output object @@ -25,11 +23,12 @@ test_that("Single-group correlation-based SSM plot is correct", { }) test_that("Measure-contrast SSM plot is correct", { - #skip_if(getRversion() > "4.0.0") data("jz2017") - res <- ssm_analyze(jz2017, PA:NO, octants(), - measures = c(ASPD, NARPD), - contrast = "test" + res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = c("ASPD", "NARPD"), + contrast = TRUE ) p <- ssm_plot(res, xy = FALSE) @@ -40,11 +39,13 @@ test_that("Measure-contrast SSM plot is correct", { }) test_that("Group-contrast correlation-based SSM plot is correct", { - #skip_if(getRversion() > "4.0.0") data("jz2017") - res <- ssm_analyze(jz2017, PA:NO, octants(), - measures = NARPD, - grouping = Gender, contrast = "test" + res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = "NARPD", + grouping = "Gender", + contrast = TRUE ) p <- ssm_plot(res) @@ -56,38 +57,45 @@ test_that("Group-contrast correlation-based SSM plot is correct", { test_that("Removing plots with low fit works as expected", { data("jz2017") - - res <- ssm_analyze(jz2017, PA:NO, octants(), measures = OCPD) - expect_error(ssm_plot(res, lowfit = FALSE), "After removing profiles, *") + res <- ssm_analyze(jz2017, scales = 2:9, measures = "OCPD") + expect_error(ssm_plot(res, lowfit = FALSE)) }) test_that("SSM Table captions are correct", { data("jz2017") - - res <- ssm_analyze(jz2017, PA:NO, octants()) + res <- ssm_analyze(jz2017, scales = 2:9) expect_equal( dcaption(res), "Mean-based Structural Summary Statistics with 95% CIs" ) - res <- ssm_analyze(jz2017, PA:NO, octants(), - grouping = Gender, - contrast = "model" + res <- ssm_analyze( + jz2017, + scales = 2:9, + grouping = "Gender", + contrast = TRUE ) expect_equal( dcaption(res), "Mean-based Structural Summary Statistic Contrasts with 95% CIs" ) - res <- ssm_analyze(jz2017, PA:NO, octants(), measures = PARPD) + res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = "PARPD" + ) expect_equal( dcaption(res), "Correlation-based Structural Summary Statistics with 95% CIs" ) - res <- ssm_analyze(jz2017, PA:NO, octants(), - measures = PARPD, - grouping = Gender, contrast = "test" + res <- ssm_analyze( + jz2017, + scales = 2:9, + measures = "PARPD", + grouping = "Gender", + contrast = TRUE ) expect_equal( dcaption(res), diff --git a/tests/testthat/test-tidying_functions.R b/tests/testthat/test-tidying_functions.R index ea1c9bef..48cce944 100644 --- a/tests/testthat/test-tidying_functions.R +++ b/tests/testthat/test-tidying_functions.R @@ -1,5 +1,12 @@ test_that("ipsatize works", { - # TODO: Create test + data("raw_iipsc") + items <- 1:32 + datin <- ipsatize(raw_iipsc, items = items, append = FALSE) + datia <- ipsatize(raw_iipsc, items = items, append = TRUE) + expect_equal(ncol(datin), length(items)) + expect_equal(ncol(datia), ncol(raw_iipsc) + length(items)) + expect_equal(datin[[1]][1], -1.0) + expect_equal(datin[[2]][7], -0.5) }) test_that("score works", {