From d9ebf36a6ccbeea7bee0926da4b491f15c365cff Mon Sep 17 00:00:00 2001 From: jmgirard Date: Sun, 27 Oct 2024 13:58:30 -0500 Subject: [PATCH] troubleshoot cran errors --- DESCRIPTION | 1 + NAMESPACE | 5 +- R/circumplex-package.R | 3 +- R/instrument_data.R | 16 + R/instrument_oop.R | 8 +- R/ssm_bootstrap.R | 2 +- R/{ssm_visualization.R => ssm_plot.R} | 302 +++++------------- R/ssm_table.R | 130 ++++++++ R/zzz.R | 13 - _pkgdown.yml | 2 + devel/plotting.R | 52 +++ man/anchors.Rd | 2 +- man/cais.Rd | 28 ++ man/html_render.Rd | 2 +- man/items.Rd | 2 +- man/norms.Rd | 2 +- man/scales.Rd | 2 +- man/ssm_plot_circle.Rd | 2 +- man/ssm_plot_contrast.Rd | 2 +- man/ssm_plot_curve.Rd | 2 +- man/ssm_table.Rd | 8 +- .../group-constrast-correlation-ssm.new.svg | 267 ++++++++++++++++ .../measure-contrast-ssm.new.svg | 284 ++++++++++++++++ tests/testthat/test-RcppExport.R.R | 2 +- tests/testthat/test-ssm_bootstrap.R | 6 +- vignettes/introduction-to-ssm-analysis.Rmd | 77 +++-- 26 files changed, 918 insertions(+), 304 deletions(-) rename R/{ssm_visualization.R => ssm_plot.R} (68%) create mode 100644 R/ssm_table.R delete mode 100644 R/zzz.R create mode 100644 devel/plotting.R create mode 100644 man/cais.Rd create mode 100644 tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.new.svg create mode 100644 tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.new.svg diff --git a/DESCRIPTION b/DESCRIPTION index 97a0d167..e014d6c7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,6 +36,7 @@ Imports: ggplot2 (>= 3.3.0), htmlTable (>= 1.13.3), Rcpp, + rlang, stats Suggests: covr (>= 3.5.0), diff --git a/NAMESPACE b/NAMESPACE index 4a9bf8bb..5601a7c4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,13 +33,10 @@ export(ssm_parameters) export(ssm_plot_circle) export(ssm_plot_contrast) export(ssm_plot_curve) -export(ssm_plot_scores) export(ssm_score) export(ssm_table) importFrom(Rcpp,sourceCpp) importFrom(ggplot2,ggsave) -importFrom(stats,cor) +importFrom(rlang,.data) importFrom(stats,quantile) -importFrom(stats,sd) -importFrom(stats,var) useDynLib(circumplex, .registration = TRUE) diff --git a/R/circumplex-package.R b/R/circumplex-package.R index 19cd7fb3..9d54a432 100644 --- a/R/circumplex-package.R +++ b/R/circumplex-package.R @@ -22,6 +22,7 @@ #' @importFrom Rcpp sourceCpp #' @useDynLib circumplex, .registration = TRUE ## usethis namespace: end -#' @importFrom stats cor quantile sd var +#' @importFrom rlang .data +#' @importFrom stats quantile #' @keywords internal "_PACKAGE" diff --git a/R/instrument_data.R b/R/instrument_data.R index f098a47e..bf3c5793 100644 --- a/R/instrument_data.R +++ b/R/instrument_data.R @@ -1,3 +1,19 @@ +#' Child and Adolescent Interpersonal Survey +#' +#' Information about the Child and Adolescent Interpersonal Survey (CAIS). +#' +#' @source Sodano, S. M., & Tracey, T. J. G. (2006). Interpersonal traits in +#' childhood: Development of the Child and Adolescent Interpersonal Survey. +#' *Journal of Personality Assessment, 87*(3), 317–329. +#' @source \doi{10.1207/s15327752jpa8703_12} +#' @keywords internal +#' @examples +#' instrument("cais") +#' summary(cais) +#' scales(cais, items = TRUE) +"cais" + + #' Circumplex Scales of Interpersonal Efficacy #' #' Information about the Circumplex Scales of Interpersonal Efficacy (CSIE). diff --git a/R/instrument_oop.R b/R/instrument_oop.R index 191597b2..98deb5c3 100644 --- a/R/instrument_oop.R +++ b/R/instrument_oop.R @@ -61,7 +61,7 @@ summary.circumplex_instrument <- function(object, scales = TRUE, anchors = TRUE, #' @family instrument functions #' @export #' @examples -#' instrument(csip) +#' instrument("csip") #' scales(csip) #' scales(csip, items = TRUE) scales <- function(x, items = FALSE) { @@ -97,7 +97,7 @@ scales <- function(x, items = FALSE) { #' @family instrument functions #' @export #' @examples -#' instrument(csip) +#' instrument("csip") #' items(csip) items <- function(x) { stopifnot(is_instrument(x)) @@ -130,7 +130,7 @@ items <- function(x) { #' @family instrument functions #' @export #' @examples -#' instrument(csip) +#' instrument("csip") #' anchors(csip) anchors <- function(x) { stopifnot(is_instrument(x)) @@ -158,7 +158,7 @@ anchors <- function(x) { #' @family instrument functions #' @export #' @examples -#' instrument(csip) +#' instrument("csip") #' norms(csip) norms <- function(x) { diff --git a/R/ssm_bootstrap.R b/R/ssm_bootstrap.R index 29bff585..9493b09e 100644 --- a/R/ssm_bootstrap.R +++ b/R/ssm_bootstrap.R @@ -76,6 +76,6 @@ quantile.circumplex_radian <- function(x, na.rm = TRUE, ...) { tx <- (x - mdn) %% (2 * pi) tx <- compare_pi(tx) class(tx) <- "numeric" - qtl <- quantile(x = tx, na.rm = na.rm, ...) + qtl <- stats::quantile(x = tx, na.rm = na.rm, ...) as_radian((qtl + mdn) %% (2 * pi)) } diff --git a/R/ssm_visualization.R b/R/ssm_plot.R similarity index 68% rename from R/ssm_visualization.R rename to R/ssm_plot.R index 2adcdc12..2c4dcc9a 100644 --- a/R/ssm_visualization.R +++ b/R/ssm_plot.R @@ -79,9 +79,9 @@ ssm_plot_circle <- function(ssm_object, df_plot[c("a_lci", "a_uci", "x_est", "y_est")], function(x) x * 10 / (2 * amax) ) - df_plot$Label <- factor( - df_plot$Label, - levels = unique(as.character(df_plot$Label)) + df_plot[["Label"]] <- factor( + df_plot[["Label"]], + levels = unique(as.character(df_plot[["Label"]])) ) # Remove profiles with low model fit (unless overrided) @@ -93,7 +93,7 @@ ssm_plot_circle <- function(ssm_object, } } - df_plot[["lnty"]] <- ifelse(df_plot$fit_est >= .70, "solid", "dotted") + df_plot[["lnty"]] <- ifelse(df_plot[["fit_est"]] >= .70, "solid", "dotted") p <- circle_base( @@ -109,10 +109,13 @@ ssm_plot_circle <- function(ssm_object, p <- p + ggforce::geom_arc_bar( data = df_plot, - ggplot2::aes( - x0 = 0, y0 = 0, - r0 = a_lci, r = a_uci, start = d_lci, end = d_uci, - linetype = lnty + mapping = ggplot2::aes( + x0 = 0, + y0 = 0, + r0 = .data$a_lci, + r = .data$a_uci, + start = .data$d_lci, + end = .data$d_uci ), fill = "cornflowerblue", color = "cornflowerblue", @@ -121,7 +124,10 @@ ssm_plot_circle <- function(ssm_object, ) + ggplot2::geom_point( data = df_plot, - ggplot2::aes(x = x_est, y = y_est), + mapping = ggplot2::aes( + x = .data$x_est, + y = .data$y_est + ), shape = 21, size = 3, color = "black", @@ -133,17 +139,28 @@ ssm_plot_circle <- function(ssm_object, p <- p + ggforce::geom_arc_bar( data = df_plot, - ggplot2::aes( - x0 = 0, y0 = 0, - r0 = a_lci, r = a_uci, start = d_lci, end = d_uci, - fill = Label, color = Label, linetype = lnty + mapping = ggplot2::aes( + x0 = 0, + y0 = 0, + r0 = .data$a_lci, + r = .data$a_uci, + start = .data$d_lci, + end = .data$d_uci, + fill = .data$Label, + color = .data$Label, + linetype = .data$lnty ), alpha = 0.4, linewidth = 1 ) + ggplot2::geom_point( data = df_plot, - ggplot2::aes(x = x_est, y = y_est, color = Label, fill = Label), + mapping = ggplot2::aes( + x = .data$x_est, + y = .data$y_est, + color = .data$Label, + fill = .data$Label + ), shape = 21, size = 3, color = "black" @@ -160,11 +177,15 @@ ssm_plot_circle <- function(ssm_object, } if (repel == TRUE) { - require("ggrepel") + requireNamespace("ggrepel") p <- p + ggrepel::geom_label_repel( data = df_plot, - ggplot2::aes(x = x_est, y = y_est, label = Label), + mapping = ggplot2::aes( + x = .data$x_est, + y = .data$y_est, + label = .data$Label + ), nudge_x = -8 - df_plot$x_est, direction = "y", hjust = 1, @@ -272,23 +293,31 @@ ssm_plot_curve <- function(ssm_object, ggplot2::geom_line( data = pred_df, mapping = ggplot2::aes( - x = Angle, - y = Score, - linetype = lnty, - color = Label + x = .data$Angle, + y = .data$Score, + linetype = .data$lnty, + color = .data$Label ), linewidth = 1.25 ) + # Connectors ggplot2::geom_line( data = score_df, - mapping = ggplot2::aes(x = Angle, y = Score, group = Label), + mapping = ggplot2::aes( + x = .data$Angle, + y = .data$Score, + group = .data$Label + ), color = "black" ) + # Points ggplot2::geom_point( data = score_df, - mapping = ggplot2::aes(x = Angle, y = Score, group = Label), + mapping = ggplot2::aes( + x = .data$Angle, + y = .data$Score, + group = .data$Label + ), color = "black" ) + ggplot2::scale_x_continuous( @@ -371,14 +400,11 @@ ssm_plot_contrast <- function(ssm_object, drop_xy = FALSE, p <- 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"), - axis.ticks.x = ggplot2::element_blank() + ggplot2::facet_wrap( + ~Parameter, + nrow = 1, + scales = "free", + labeller = ggplot2::label_parsed ) + ggplot2::geom_hline( yintercept = 0, @@ -386,23 +412,37 @@ ssm_plot_contrast <- function(ssm_object, drop_xy = FALSE, color = "darkgray" ) + ggplot2::geom_errorbar( - ggplot2::aes(x = "1", ymin = lci, ymax = uci), - linewidth = linesize, width = 0.15 + ggplot2::aes( + x = "1", + ymin = .data$lci, + ymax = .data$uci + ), + linewidth = linesize, + width = 0.15 ) + ggplot2::geom_point( - ggplot2::aes(x = "1", y = Difference, fill = sig), + ggplot2::aes( + x = "1", + y = .data$Difference, + fill = .data$sig + ), size = linesize * 3, stroke = linesize, shape = 21 ) + ggplot2::scale_fill_manual( - "Significant", + name = "Significant", 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 + 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"), + axis.ticks.x = ggplot2::element_blank() ) p @@ -423,7 +463,7 @@ circle_base <- function(angles, labels = NULL, amin = 0, ggplot2::scale_y_continuous(expand = c(0.10, 0)) + # Draw lowest circle ggforce::geom_circle( - ggplot2::aes(x0 = 0, y0 = 0, r = 5), + mapping = ggplot2::aes(x0 = 0, y0 = 0, r = 5), color = "gray50", fill = "white", linewidth = 1.5 @@ -474,189 +514,3 @@ circle_base <- function(angles, labels = NULL, amin = 0, size = fontsize / 2.8346438836889 ) } - -#' Create HTML table from SSM results or contrasts -#' -#' Take in the results of an SSM analysis and return an HTML table with the -#' desired formatting. -#' -#' @param ssm_object Required. The results output of `ssm_analyze()`. -#' @param caption A string to be displayed above the table (default = NULL). -#' @param xy A logical indicating whether the x-value and y-value parameters -#' should be included in the table as columns (default = TRUE). -#' @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 -#' \donttest{ -#' # Load example data -#' data("jz2017") -#' -#' # Create table of profile results -#' res <- ssm_analyze( -#' jz2017, -#' scales = 2:9, -#' measures = c("NARPD", "ASPD") -#' ) -#' ssm_table(res) -#' -#' # Create table of contrast results -#' res <- ssm_analyze( -#' jz2017, -#' scales = 2:9, -#' measures = c("NARPD", "ASPD"), -#' contrast = TRUE -#' ) -#' ssm_table(res) -#' } -#' -ssm_table <- function(ssm_object, caption = NULL, - drop_xy = FALSE, render = TRUE) { - - stopifnot(class(ssm_object) == "circumplex_ssm") - stopifnot(is_null_or_char(caption, n = 1)) - stopifnot(is_flag(drop_xy)) - stopifnot(is_flag(render)) - - df <- ssm_object$results - - # Create default caption - if (is.null(caption)) { - caption <- dcaption(ssm_object) - } - - # Format output data - 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(table_df)[[1]] <- ifelse( - test = ssm_object$details$contrast, - yes = "Contrast", - no = "Profile" - ) - - # Drop the x and y columns if requested - if (drop_xy) { - table_df <- table_df[, -c(3, 4)] - } - - # Format and render HTML table if requested - if (render) { - html_render(table_df, caption) - } - - table_df -} - -# Build the default caption for the ssm_table function -dcaption <- function(ssm_object) { - if (ssm_object$details$contrast) { - sprintf( - "%s-based Structural Summary Statistic Contrasts with %s CIs", - ssm_object$details$score_type, - str_percent(ssm_object$details$interval) - ) - } else { - sprintf( - "%s-based Structural Summary Statistics with %s CIs", - ssm_object$details$score_type, - str_percent(ssm_object$details$interval) - ) - } -} - -#' Format and render data frame as HTML table -#' -#' Format a data frame as an HTML table and render it to the web viewer. -#' -#' @param df A data frame to be rendered as an HTML table. -#' @param caption A string to be displayed above the table. -#' @param align A string indicating the alignment of the cells (default = "l"). -#' @param ... Other arguments to pass to \code{htmlTable}. -#' @return HTML syntax for the \code{df} table. -#' @family table functions -#' @export -html_render <- function(df, caption = NULL, align = "l", ...) { - - stopifnot(is_null_or_char(caption, n = 1)) - stopifnot(align %in% c("l", "c", "r")) - - t <- htmlTable::htmlTable( - df, - caption = caption, - align = align, - align.header = align, - rnames = FALSE, - css.cell = "padding-right: 1em; min-width: 3em; white-space: nowrap;", - ... - ) - print(t, type = "html") -} - - -#' @export -ssm_plot_scores <- function(x, - amin = NULL, - amax = NULL, - angle_labels = NULL, - linewidth = 1, - pointsize = 3, - ...) { - - # Get scores from SSM object - scores <- x$scores - # Reshape scores for plotting - scores_long <- tidyr::pivot_longer( - scores, - cols = dplyr::where(is.numeric), - names_to = "Scale", - values_to = "Score" - ) - # Get angles from SSM object - angles <- x$details$angles - if (is.null(amin)) amin <- pretty_min(scores_long$Score) - if (is.null(amax)) amax <- pretty_max(scores_long$Score) - scores_long$Angle <- rep(angles, times = nrow(scores_long) / length(angles)) - scores_long$Radian <- as_radian(as_degree(scores_long$Angle)) - scores_long$pr <- rescale( - scores_long$Score, - to = c(0, 5), - from = c(amin, amax) - ) - scores_long$px <- scores_long$pr * cos(scores_long$Radian) - scores_long$py <- scores_long$pr * sin(scores_long$Radian) - - p <- circle_base( - angles = angles, - amin = amin, - amax = amax, - labels = angle_labels - ) - - p + - ggplot2::geom_polygon( - data = scores_long, - mapping = ggplot2::aes(x = px, y = py, color = Label, linetype = Label), - fill = NA, - linewidth = linewidth - ) + - ggplot2::geom_point( - data = scores_long, - mapping = ggplot2::aes(x = px, y = py, color = Label), - size = pointsize - ) - -} diff --git a/R/ssm_table.R b/R/ssm_table.R new file mode 100644 index 00000000..4cea475d --- /dev/null +++ b/R/ssm_table.R @@ -0,0 +1,130 @@ +#' Create HTML table from SSM results or contrasts +#' +#' Take in the results of an SSM analysis and return an HTML table with the +#' desired formatting. +#' +#' @param ssm_object Required. The results output of `ssm_analyze()`. +#' @param caption A string to be displayed above the table (default = NULL). +#' @param drop_xy A logical indicating whether the x-value and y-value parameters +#' should be omitted from the output (default = FALSE). +#' @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 +#' \donttest{ +#' # Load example data +#' data("jz2017") +#' +#' # Create table of profile results +#' res <- ssm_analyze( +#' jz2017, +#' scales = 2:9, +#' measures = c("NARPD", "ASPD") +#' ) +#' ssm_table(res) +#' +#' # Create table of contrast results +#' res <- ssm_analyze( +#' jz2017, +#' scales = 2:9, +#' measures = c("NARPD", "ASPD"), +#' contrast = TRUE +#' ) +#' ssm_table(res) +#' } +#' +ssm_table <- function(ssm_object, caption = NULL, + drop_xy = FALSE, render = TRUE) { + + stopifnot(class(ssm_object) == "circumplex_ssm") + stopifnot(is_null_or_char(caption, n = 1)) + stopifnot(is_flag(drop_xy)) + stopifnot(is_flag(render)) + + df <- ssm_object$results + + # Create default caption + if (is.null(caption)) { + caption <- dcaption(ssm_object) + } + + # Format output data + 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(table_df)[[1]] <- ifelse( + test = ssm_object$details$contrast, + yes = "Contrast", + no = "Profile" + ) + + # Drop the x and y columns if requested + if (drop_xy) { + table_df <- table_df[, -c(3, 4)] + } + + # Format and render HTML table if requested + if (render) { + html_render(table_df, caption) + } + + table_df +} + +# Build the default caption for the ssm_table function +dcaption <- function(ssm_object) { + if (ssm_object$details$contrast) { + sprintf( + "%s-based Structural Summary Statistic Contrasts with %s CIs", + ssm_object$details$score_type, + str_percent(ssm_object$details$interval) + ) + } else { + sprintf( + "%s-based Structural Summary Statistics with %s CIs", + ssm_object$details$score_type, + str_percent(ssm_object$details$interval) + ) + } +} + +#' Format and render data frame as HTML table +#' +#' Format a data frame as an HTML table and render it to the web viewer. +#' +#' @param df A data frame to be rendered as an HTML table. +#' @param caption A string to be displayed above the table. +#' @param align A string indicating the alignment of the cells (default = "l"). +#' @param ... Other arguments to pass to \code{htmlTable}. +#' @return HTML syntax for the \code{df} table. +#' @family table functions +#' @export +html_render <- function(df, caption = NULL, align = "l", ...) { + + stopifnot(is_null_or_char(caption, n = 1)) + stopifnot(align %in% c("l", "c", "r")) + + t <- htmlTable::htmlTable( + df, + caption = caption, + align = align, + align.header = align, + rnames = FALSE, + css.cell = "padding-right: 1em; min-width: 3em; white-space: nowrap;", + ... + ) + print(t, type = "html") +} diff --git a/R/zzz.R b/R/zzz.R deleted file mode 100644 index 8c0482b9..00000000 --- a/R/zzz.R +++ /dev/null @@ -1,13 +0,0 @@ -## Quiet R CMD check about global variables -if (getRversion() >= "2.15.1") { - utils::globalVariables( - c( - "Group", "V5", ".row", "Contrast", "Measure", ".", "Difference", "Type", - "a_est", "a_lci", "a_uci", "circ_dist", "d_est", "d_lci", "d_uci", - "e_est", "e_lci", "e_uci", "est", "fit_lci", "fit_uci", "fit_est", "key", - "label", "lci", "octants", "quartile", "uci", "value", "x_est", "x_lci", - "x_uci", "y_est", "y_lci", "y_uci", "Scale", "Score", "Parameter", - "lnty", ".im", "Sample", "px", "py" - ) - ) -} diff --git a/_pkgdown.yml b/_pkgdown.yml index 16b9b09a..7c93af34 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -67,6 +67,8 @@ navbar: href: reference/index.html - text: Instruments menu: + - text: Child and Adolescent Interpersonal Survey + href: reference/cais.html - text: Circumplex Scales of Interpersonal Efficacy href: reference/csie.html - text: Circumplex Scales of Intergroup Goals diff --git a/devel/plotting.R b/devel/plotting.R new file mode 100644 index 00000000..6eea3afd --- /dev/null +++ b/devel/plotting.R @@ -0,0 +1,52 @@ +ssm_plot_scores <- function(x, + amin = NULL, + amax = NULL, + angle_labels = NULL, + linewidth = 1, + pointsize = 3, + ...) { + + # Get scores from SSM object + scores <- x$scores + # Reshape scores for plotting + scores_long <- tidyr::pivot_longer( + scores, + cols = dplyr::where(is.numeric), + names_to = "Scale", + values_to = "Score" + ) + # Get angles from SSM object + angles <- x$details$angles + if (is.null(amin)) amin <- pretty_min(scores_long$Score) + if (is.null(amax)) amax <- pretty_max(scores_long$Score) + scores_long$Angle <- rep(angles, times = nrow(scores_long) / length(angles)) + scores_long$Radian <- as_radian(as_degree(scores_long$Angle)) + scores_long$pr <- rescale( + scores_long$Score, + to = c(0, 5), + from = c(amin, amax) + ) + scores_long$px <- scores_long$pr * cos(scores_long$Radian) + scores_long$py <- scores_long$pr * sin(scores_long$Radian) + + p <- circle_base( + angles = angles, + amin = amin, + amax = amax, + labels = angle_labels + ) + + p + + ggplot2::geom_polygon( + data = scores_long, + mapping = ggplot2::aes(x = px, y = py, color = Label, linetype = Label), + fill = NA, + linewidth = linewidth + ) + + ggplot2::geom_point( + data = scores_long, + mapping = ggplot2::aes(x = px, y = py, color = Label), + size = pointsize + ) + +} \ No newline at end of file diff --git a/man/anchors.Rd b/man/anchors.Rd index 80f8e627..cf2bbaa2 100644 --- a/man/anchors.Rd +++ b/man/anchors.Rd @@ -18,7 +18,7 @@ anchors and each anchor's numerical value and text label. Anchors are the response options that respondants select from (e.g., 0 = No, 1 = Yes). } \examples{ -instrument(csip) +instrument("csip") anchors(csip) } \seealso{ diff --git a/man/cais.Rd b/man/cais.Rd new file mode 100644 index 00000000..1d295346 --- /dev/null +++ b/man/cais.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/instrument_data.R +\docType{data} +\name{cais} +\alias{cais} +\title{Child and Adolescent Interpersonal Survey} +\format{ +An object of class \code{circumplex_instrument} of length 5. +} +\source{ +Sodano, S. M., & Tracey, T. J. G. (2006). Interpersonal traits in +childhood: Development of the Child and Adolescent Interpersonal Survey. +\emph{Journal of Personality Assessment, 87}(3), 317–329. + +\doi{10.1207/s15327752jpa8703_12} +} +\usage{ +cais +} +\description{ +Information about the Child and Adolescent Interpersonal Survey (CAIS). +} +\examples{ +instrument("cais") +summary(cais) +scales(cais, items = TRUE) +} +\keyword{internal} diff --git a/man/html_render.Rd b/man/html_render.Rd index 95e495ec..dfef99f2 100644 --- a/man/html_render.Rd +++ b/man/html_render.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R +% Please edit documentation in R/ssm_table.R \name{html_render} \alias{html_render} \title{Format and render data frame as HTML table} diff --git a/man/items.Rd b/man/items.Rd index cdabcaf0..18e6e771 100644 --- a/man/items.Rd +++ b/man/items.Rd @@ -18,7 +18,7 @@ items and each item's number and text. The item ordering/numbering displayed here is the same ordering/numbering assumed by the \code{score()} function. } \examples{ -instrument(csip) +instrument("csip") items(csip) } \seealso{ diff --git a/man/norms.Rd b/man/norms.Rd index 5e15897d..a7253269 100644 --- a/man/norms.Rd +++ b/man/norms.Rd @@ -19,7 +19,7 @@ population, and source reference and hyperlink. If another normative data set exists that is not yet included in the package, please let us know. } \examples{ -instrument(csip) +instrument("csip") norms(csip) } \seealso{ diff --git a/man/scales.Rd b/man/scales.Rd index 1ac3ed84..4da6a882 100644 --- a/man/scales.Rd +++ b/man/scales.Rd @@ -20,7 +20,7 @@ Display the scales of a circumplex instrument including the total number of scales and each scale's abbreviation, hypothetical angle, and text label. } \examples{ -instrument(csip) +instrument("csip") scales(csip) scales(csip, items = TRUE) } diff --git a/man/ssm_plot_circle.Rd b/man/ssm_plot_circle.Rd index 141bbd75..fcfe13a4 100644 --- a/man/ssm_plot_circle.Rd +++ b/man/ssm_plot_circle.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R +% Please edit documentation in R/ssm_plot.R \name{ssm_plot_circle} \alias{ssm_plot_circle} \title{Create a Circular Plot of SSM Results} diff --git a/man/ssm_plot_contrast.Rd b/man/ssm_plot_contrast.Rd index f9369ae2..25f8e21d 100644 --- a/man/ssm_plot_contrast.Rd +++ b/man/ssm_plot_contrast.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R +% Please edit documentation in R/ssm_plot.R \name{ssm_plot_contrast} \alias{ssm_plot_contrast} \title{Create a Difference Plot of SSM Contrast Results} diff --git a/man/ssm_plot_curve.Rd b/man/ssm_plot_curve.Rd index 04da7ffb..6b8f909a 100644 --- a/man/ssm_plot_curve.Rd +++ b/man/ssm_plot_curve.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R +% Please edit documentation in R/ssm_plot.R \name{ssm_plot_curve} \alias{ssm_plot_curve} \title{Create a Curve Plot of SSM Results} diff --git a/man/ssm_table.Rd b/man/ssm_table.Rd index 96e36676..456b83fa 100644 --- a/man/ssm_table.Rd +++ b/man/ssm_table.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ssm_visualization.R +% Please edit documentation in R/ssm_table.R \name{ssm_table} \alias{ssm_table} \title{Create HTML table from SSM results or contrasts} @@ -11,11 +11,11 @@ ssm_table(ssm_object, caption = NULL, drop_xy = FALSE, render = TRUE) \item{caption}{A string to be displayed above the table (default = NULL).} +\item{drop_xy}{A logical indicating whether the x-value and y-value parameters +should be omitted from the output (default = FALSE).} + \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 diff --git a/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.new.svg b/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.new.svg new file mode 100644 index 00000000..23d5e56e --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/group-constrast-correlation-ssm.new.svg @@ -0,0 +1,267 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Δ + 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) + +Significant + + + + +FALSE +TRUE +group-constrast correlation ssm + + diff --git a/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.new.svg b/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.new.svg new file mode 100644 index 00000000..13cce5de --- /dev/null +++ b/tests/testthat/_snaps/ssm_visualization/measure-contrast-ssm.new.svg @@ -0,0 +1,284 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Δ + 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) + +Significant + + + + +FALSE +TRUE +measure-contrast ssm + + diff --git a/tests/testthat/test-RcppExport.R.R b/tests/testthat/test-RcppExport.R.R index 78911de0..5509ea78 100644 --- a/tests/testthat/test-RcppExport.R.R +++ b/tests/testthat/test-RcppExport.R.R @@ -28,7 +28,7 @@ test_that("Pairwise r is correct even with missing", { x[xidx] <- NA yidx <- sample(1:100, 10, replace = FALSE) y[yidx] <- NA - rcor <- cor(x, y, use = "pairwise.complete.obs") + rcor <- stats::cor(x, y, use = "pairwise.complete.obs") ccor <- pairwise_r(x, y) expect_equal(rcor, ccor) }) diff --git a/tests/testthat/test-ssm_bootstrap.R b/tests/testthat/test-ssm_bootstrap.R index 0d7e9382..69431944 100644 --- a/tests/testthat/test-ssm_bootstrap.R +++ b/tests/testthat/test-ssm_bootstrap.R @@ -1,7 +1,7 @@ test_that("Quantile for circular radians works", { a <- as_degree(0:180) b <- as_radian(a) - qb <- quantile(b) + qb <- stats::quantile(b) expect_s3_class(qb, "circumplex_radian") expect_equal(qb, as_radian(as_degree(c(0, 45, 90, 135, 180))), ignore_attr = TRUE) @@ -27,12 +27,12 @@ test_that("Quantile for circular radians works", { a <- as_degree(c(NA_real_, NA_real_, NA_real_)) b <- as_radian(a) - qb <- quantile(b) + qb <- stats::quantile(b) expect_true(is.na(qb)) a <- as_degree(c(0, 0, 30, 90, NA_real_)) b <- as_radian(a) c <- as_degree(c(0, 0, 30, 90)) d <- as_radian(c) - expect_equal(quantile(b), quantile(d)) + expect_equal(stats::quantile(b), stats::quantile(d)) }) diff --git a/vignettes/introduction-to-ssm-analysis.Rmd b/vignettes/introduction-to-ssm-analysis.Rmd index 64ba5fea..88deebed 100644 --- a/vignettes/introduction-to-ssm-analysis.Rmd +++ b/vignettes/introduction-to-ssm-analysis.Rmd @@ -93,29 +93,22 @@ The Structural Summary Method (SSM) is a technique for analyzing circumplex data ```{r column, echo = FALSE, fig.width = 7.5, fig.height = 4, out.width = "100%"} data("jz2017") -rmat <- jz2017 %>% - dplyr::select(NARPD, PA:NO) %>% - cor(method = "pearson") +rmat <- stats::cor(jz2017[c("NARPD", PANO())], method = "pearson") r <- rmat[2:9, 1] # Format data for plotting -dat_r <- tibble::tibble( - Scale = factor(c("PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO")), - r = r -) +dat_r <- data.frame(Scale = factor(PANO()), r = r) # Create column plot -ggplot2::ggplot(dat_r, ggplot2::aes(x = Scale, y = r)) + +ggplot2::ggplot(dat_r, ggplot2::aes(x = .data$Scale, y = .data$r)) + ggplot2::geom_hline(yintercept = 0, linewidth = 1.25, color = "darkgray") + ggplot2::geom_col(position = ggplot2::position_dodge(.9), fill = "red") + - ggplot2::scale_y_continuous( - limits = c(-0.02, 0.5) - ) + + ggplot2::scale_y_continuous(limits = c(-0.02, 0.5)) + ggplot2::labs(title = "Scores") + ggplot2::theme( axis.title = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_line(size = 1.0), - panel.grid.minor.y = ggplot2::element_line(size = 0.5), + panel.grid.major = ggplot2::element_line(linewidth = 1.0), + panel.grid.minor.y = ggplot2::element_line(linewidth = 0.5), panel.grid.minor.x = ggplot2::element_blank() ) ``` @@ -123,25 +116,22 @@ ggplot2::ggplot(dat_r, ggplot2::aes(x = Scale, y = r)) + Next, we can leverage the fact that these subscales have specific angular displacements in the circumplex model (and that 0 and 360 degrees are the same) to create a path diagram. ```{r path, echo = FALSE, fig.width = 7.5, fig.height = 4, out.width = "100%"} -dat_r <- tibble::tibble( - Scale = factor( - c("LM", "PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO"), - levels = c("PA", "BC", "DE", "FG", "HI", "JK", "LM", "NO") - ), - est = r[c(7, 1:8)], - Angle = c(0, octants()) -) %>% - dplyr::arrange(Angle) +dat_r <- data.frame( + Scale = factor(PANO()), + est = r, + Angle = octants() +) + +dat_r <- dat_r[order(dat_r$Angle), ] # Plot correlations as connected point ranges with 95% CI ranges -ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + +ggplot2::ggplot(dat_r, ggplot2::aes(x = .data$Angle, y = .data$est)) + ggplot2::geom_hline(yintercept = 0, linewidth = 1.25, color = "darkgray") + ggplot2::geom_point(size = 3, color = "red") + ggplot2::geom_path(linewidth = 1.25, color = "red") + ggplot2::geom_label(ggplot2::aes(label = Scale), nudge_y = 0.075) + ggplot2::scale_x_continuous( - limits = c(0, 360), - breaks = c(0, octants()), + breaks = octants(), expand = c(0.05, 0), labels = function(x) sprintf("%.0f\U00B0", x) ) + @@ -152,8 +142,8 @@ ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + ggplot2::theme( axis.title = ggplot2::element_blank(), plot.margin = ggplot2::unit(c(10, 30, 10, 10), "points"), - panel.grid.major = ggplot2::element_line(size = 1.0), - panel.grid.minor.y = ggplot2::element_line(size = 0.5), + panel.grid.major = ggplot2::element_line(linewidth = 1.0), + panel.grid.minor.y = ggplot2::element_line(linewidth = 0.5), panel.grid.minor.x = ggplot2::element_blank() ) ``` @@ -170,14 +160,13 @@ f <- function(x) { } # Plot correlations along with SSM cosine model -ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + +ggplot2::ggplot(dat_r, ggplot2::aes(x = .data$Angle, y = .data$est)) + ggplot2::geom_hline(yintercept = 0, linewidth = 1.25, color = "darkgray") + ggplot2::geom_point(size = 3) + ggplot2::geom_path(linewidth = 1.25) + - ggplot2::stat_function(fun = f, size = 2, color = "red") + + ggplot2::stat_function(fun = f, linewidth = 2, color = "red") + ggplot2::scale_x_continuous( - limits = c(0, 360), - breaks = c(0, octants()), + breaks = octants(), expand = c(0.01, 0), labels = function(x) sprintf("%.0f\U00B0", x) ) + @@ -188,8 +177,8 @@ ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + ggplot2::theme( axis.title = ggplot2::element_blank(), plot.margin = ggplot2::unit(c(10, 30, 10, 10), "points"), - panel.grid.major = ggplot2::element_line(size = 1.0), - panel.grid.minor.y = ggplot2::element_line(size = 0.5), + panel.grid.major = ggplot2::element_line(linewidth = 1.0), + panel.grid.minor.y = ggplot2::element_line(linewidth = 0.5), panel.grid.minor.x = ggplot2::element_blank() ) ``` @@ -201,18 +190,24 @@ where $S_i$ and $\theta_i$ are the score and angle on scale $i$, respectively, a ```{r residuals, echo = FALSE, fig.width = 7.5, fig.height = 4, out.width = "100%"} # Plot correlations as path, SSM cosine model, and differences -ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + +ggplot2::ggplot(dat_r, ggplot2::aes(x = .data$Angle, y = .data$est)) + ggplot2::geom_hline(yintercept = 0, linewidth = 1.25, color = "darkgray") + - ggplot2::stat_function(fun = f, size = 2, color = "gray20") + + ggplot2::stat_function(fun = f, linewidth = 2, color = "gray20") + ggplot2::geom_point(size = 5.5, color = "black") + ggplot2::geom_path(linewidth = 1.25, color = "black") + ggplot2::geom_segment( - ggplot2::aes(x = Angle, xend = Angle, y = est, yend = f(Angle)), - linewidth = 4, linetype = "solid", color = "red" + ggplot2::aes( + x = .data$Angle, + xend = .data$Angle, + y = .data$est, + yend = f(.data$Angle) + ), + linewidth = 4, + linetype = "solid", + color = "red" ) + ggplot2::scale_x_continuous( - limits = c(0, 360), - breaks = c(0, octants()), + breaks = octants(), expand = c(0.01, 0), labels = function(x) sprintf("%.0f\U00B0", x) ) + @@ -223,8 +218,8 @@ ggplot2::ggplot(dat_r, ggplot2::aes(x = Angle, y = est)) + ggplot2::theme( axis.title = ggplot2::element_blank(), plot.margin = ggplot2::unit(c(10, 30, 10, 10), "points"), - panel.grid.major = ggplot2::element_line(size = 1.0), - panel.grid.minor.y = ggplot2::element_line(size = 0.5), + panel.grid.major = ggplot2::element_line(linewidth = 1.0), + panel.grid.minor.y = ggplot2::element_line(linewidth = 0.5), panel.grid.minor.x = ggplot2::element_blank() ) ```