In jtrampush/npsych.data: BrainWorkup Neuropsychological Report Writing Package
patient <- rmarkdown::metadata$patient
## load libraries
library(crosstalk)
library(dplyr)
library(gifski)
library(highcharter)
library(htmlwidgets)
library(knitr)
library(languageserver)
library(manipulateWidget)
library(revealjs)
library(svglite)
library(tibble)
library(vroom)
library(widgetframe)
library(xaringan)
library(xaringanExtra)
library(xaringanthemer)
library(tidyverse)
library(bwu)
## knitr options
options(htmltools.dir.version = FALSE)
knitr::opts_chunk$set(
fig.path = "figs/",
fig.width = 12,
fig.height = 4,
fig.asp = .5,
fig.retina = 3,
out.width = "100%",
fig.showtext = TRUE,
comment = NULL,
cache = FALSE,
cache.path = "cache/",
echo = FALSE,
message = FALSE,
warning = FALSE,
dev = c("svg", "svglite"),
hiline = TRUE
)
neuropsych <-
vroom::vroom(here::here(patient, "neuropsych.csv"), show_col_types = FALSE)
neurocog <-
vroom::vroom(here::here(patient, "neurocog.csv"), show_col_types = FALSE) |>
dplyr::filter(scale != "Orientation") |>
dplyr::filter(narrow != "Response Monitoring") |>
dplyr::filter(narrow != "Recognition Memory")
neurobehav <-
vroom::vroom(here::here(patient, "neurobehav.csv"), show_col_types = FALSE)
validity <-
vroom::vroom(here::here(patient, "validity.csv"), show_col_types = FALSE)
name: title
class: title-slide, center, middle
background-image: url(logo_usc_ksom_black.jpg)
background-position: bottom
background-repeat: no-repeat
background-size: 25%
background-color: var(--usc-black)
r rmarkdown::metadata$title
r rmarkdown::metadata$patient
r rmarkdown::metadata$author
r rmarkdown::metadata$institute
r rmarkdown::metadata$date
name: gauss-plot1
class: middle center
background-size: contain
Distribution of Scores: Population-level Interpretation
```{r gauss-plot1, fig.cap = "Performance classification of neuropsychological
test scores in the general population.", fig.retina = 3, fig.asp = 0.5,
out.width = "50%"}
knitr::include_graphics("plot_narrow.png", auto_pdf = TRUE)
---
class: left, middle, right top
background-color: var(--near-black)
class: background
background-image: url(logo_usc_ksom_black.jpg)
background-position: right top
background-repeat: repeat
background-size: 15%
background-color: var(--usc-black)
### Neurocognitive Evaluation
#### Summary of neuropsychological testing results
```r
## Level 1
## Domain scores
# 1. create mean z-scores for domain
ncog1 <- neurocog |>
dplyr::group_by(domain) |>
dplyr::summarize(mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
ncog1$mean_z <- round(ncog1$mean_z, 2L)
ncog1$mean_percentile <- round(ncog1$mean_percentile, 0L)
ncog1 <-
ncog1 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
ncog1 <- arrange(ncog1, desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
ncog_level1_status <- tibble(
name = ncog1$domain,
y = ncog1$mean_z,
y2 = ncog1$mean_percentile,
range = ncog1$range,
drilldown = tolower(name)
)
## Level 2
## Subdomain scores
## function to create second level of drilldown (subdomain scores)
ncog_level2_drill <-
lapply(unique(neurocog$domain), function(x_level) {
ncog2 <- subset(neurocog, neurocog$domain %in% x_level)
# same as above
ncog2 <-
ncog2 |>
dplyr::group_by(subdomain) |>
dplyr::summarize(mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
ncog2$mean_z <- round(ncog2$mean_z, 2L)
ncog2$mean_percentile <- round(ncog2$mean_percentile, 0L)
ncog2 <-
ncog2 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
ncog2 <- arrange(ncog2, desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
ncog_level2_status <- tibble(
name = ncog2$subdomain,
y = ncog2$mean_z,
y2 = ncog2$mean_percentile,
range = ncog2$range,
drilldown = tolower(paste(x_level, name, sep = "_"))
)
list(
id = tolower(x_level),
type = "column",
data = list_parse(ncog_level2_status)
)
})
## Level 3
## Narrow subdomains
## reuse function
ncog_level3_drill <-
lapply(unique(neurocog$domain), function(x_level) {
ncog2 <- subset(neurocog, neurocog$domain %in% x_level)
# reuse function but with y_level
lapply(unique(ncog2$subdomain), function(y_level) {
# 1. create mean z-scores for subdomain
# ncog3 becomes pronoun for domain
ncog3 <- subset(ncog2, ncog2$subdomain %in% y_level)
ncog3 <- ncog3 |>
dplyr::group_by(narrow) |>
dplyr::summarize(mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
ncog3$mean_z <- round(ncog3$mean_z, 2L)
ncog3$mean_percentile <- round(ncog3$mean_percentile, 0L)
ncog3 <-
ncog3 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
ncog3 <- arrange(ncog3, desc(mean_percentile))
ncog_level3_status <- tibble(
name = ncog3$narrow,
y = ncog3$mean_z,
y2 = ncog3$mean_percentile,
range = ncog3$range,
drilldown = tolower(paste(x_level, y_level, name, sep = "_"))
)
list(
id = tolower(paste(x_level, y_level, sep = "_")),
type = "column",
data = list_parse(ncog_level3_status)
)
})
}) |> unlist(recursive = FALSE)
## Level 4
## Scale scores
## reuse both functions
ncog_level4_drill <-
lapply(unique(neurocog$domain), function(x_level) {
ncog2 <- subset(neurocog, neurocog$domain %in% x_level)
lapply(unique(ncog2$subdomain), function(y_level) {
ncog3 <- subset(ncog2, ncog2$subdomain %in% y_level)
lapply(unique(ncog3$narrow), function(z_level) {
ncog4 <- subset(ncog3, ncog3$narrow %in% z_level)
ncog4 <-
ncog4 |>
dplyr::group_by(scale) |>
dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
ncog4$mean_z <- round(ncog4$mean_z, 2L)
ncog4$mean_percentile <- round(ncog4$mean_percentile, 0L)
ncog4 <-
ncog4 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
ncog4 <- arrange(ncog4, desc(mean_percentile))
ncog_level4_status <- tibble(
name = ncog4$scale,
y = ncog4$mean_z,
y2 = ncog4$mean_percentile,
range = ncog4$range
)
list(
id = tolower(paste(x_level, y_level, z_level, sep = "_")),
type = "column",
data = list_parse(ncog_level4_status)
)
})
}) |> unlist(recursive = FALSE)
}) |> unlist(recursive = FALSE)
theme_merge <- highcharter::hc_theme_merge(
highcharter::hc_theme_monokai(),
highcharter::hc_theme_darkunica()
)
# Tooltip
x <- c("Name", "Score", "Percentile", "Range")
y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}")
tt <- highcharter::tooltip_table(x, y)
## Create drilldown bar plot z-scores
plot1 <-
highcharter::highchart() |>
highcharter::hc_title(text = patient,
style = list(fontSize = "15px")) |>
highcharter::hc_add_series(
ncog_level1_status,
type = "bar",
name = "Neuropsychological Test Scores",
highcharter::hcaes(x = name, y = y)
) |>
highcharter::hc_xAxis(
type = "category",
title = list(text = "Scale"),
categories = .$name
) |>
highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"),
labels = list(format = "{value}")) |>
highcharter::hc_tooltip(pointFormat = tt,
useHTML = TRUE,
valueDecimals = 1) |>
highcharter::hc_plotOptions(series = list(
colorByPoint = TRUE,
allowPointSelect = TRUE,
dataLabels = TRUE
)) |>
highcharter::hc_drilldown(
allowPointDrilldown = TRUE,
series = c(ncog_level2_drill,
ncog_level3_drill,
ncog_level4_drill)
) |>
highcharter::hc_colorAxis(minColor = "red",
maxColor = "blue") |>
highcharter::hc_add_theme(theme_merge) |>
highcharter::hc_chart(style = list(fontFamily = "Cabin"),
backgroundColor = list("gray"))
plot1
class: left, middle, right top
background-color: var(--near-black)
class: background
background-image: url(logo_usc_ksom_black.jpg)
background-position: right top
background-repeat: repeat
background-size: 15%
background-color: var(--usc-black)
Behavioral/Emotional/Personality Functioning
Summary of self-report and observer-report scales from the PAI, CAARS, and CEFI
## Level 1
## Domain scores
# 1. create mean z-scores for domain
nbhv1 <- neurobehav |>
dplyr::group_by(domain) |>
dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
nbhv1$mean_z <- round(nbhv1$mean_z, 0L)
nbhv1$mean_percentile <- round(nbhv1$mean_percentile, 0L)
nbhv1 <-
nbhv1 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
nbhv1 <- arrange(nbhv1, desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
nbhv_level1_status <- tibble(
name = nbhv1$domain,
y = nbhv1$mean_z,
y2 = nbhv1$mean_percentile,
range = nbhv1$range,
drilldown = tolower(name)
)
## Level 2
## Subdomain scores
## function to create second level of drilldown (subdomain scores)
nbhv_level2_drill <-
lapply(unique(neurobehav$domain), function(x_level) {
nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level)
# same as above
nbhv2 <-
nbhv2 |>
dplyr::group_by(subdomain) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
nbhv2$mean_z <- round(nbhv2$mean_z, 0L)
nbhv2$mean_percentile <- round(nbhv2$mean_percentile, 0L)
nbhv2 <-
nbhv2 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
nbhv2 <- arrange(nbhv2, desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
nbhv_level2_status <- tibble(
name = nbhv2$subdomain,
y = nbhv2$mean_z,
y2 = nbhv2$mean_percentile,
range = nbhv2$range,
drilldown = tolower(paste(x_level, name, sep = "_"))
)
list(
id = tolower(x_level),
type = "column",
data = list_parse(nbhv_level2_status)
)
})
## Level 3
## Narrow subdomains
## reuse function
nbhv_level3_drill <-
lapply(unique(neurobehav$domain), function(x_level) {
nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level)
# reuse function but with y_level
lapply(unique(nbhv2$subdomain), function(y_level) {
# 1. create mean z-scores for subdomain
# nbhv3 becomes pronoun for domain
nbhv3 <- subset(nbhv2, nbhv2$subdomain %in% y_level)
nbhv3 <- nbhv3 |>
dplyr::group_by(narrow) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
nbhv3$mean_z <- round(nbhv3$mean_z, 0L)
nbhv3$mean_percentile <- round(nbhv3$mean_percentile, 0L)
nbhv3 <-
nbhv3 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
nbhv3 <- arrange(nbhv3, desc(mean_percentile))
nbhv_level3_status <- tibble(
name = nbhv3$narrow,
y = nbhv3$mean_z,
y2 = nbhv3$mean_percentile,
range = nbhv3$range,
drilldown = tolower(paste(x_level, y_level, name, sep = "_"))
)
list(
id = tolower(paste(x_level, y_level, sep = "_")),
type = "column",
data = list_parse(nbhv_level3_status)
)
})
}) |> unlist(recursive = FALSE)
## Level 4
## Scale scores
## reuse both functions
nbhv_level4_drill <-
lapply(unique(neurobehav$domain), function(x_level) {
nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level)
lapply(unique(nbhv2$subdomain), function(y_level) {
nbhv3 <- subset(nbhv2, nbhv2$subdomain %in% y_level)
lapply(unique(nbhv3$narrow), function(z_level) {
nbhv4 <- subset(nbhv3, nbhv3$narrow %in% z_level)
nbhv4 <-
nbhv4 |>
dplyr::group_by(scale) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
nbhv4$mean_z <- round(nbhv4$mean_z, 0L)
nbhv4$mean_percentile <- round(nbhv4$mean_percentile, 0L)
nbhv4 <-
nbhv4 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
nbhv4 <- arrange(nbhv4, desc(mean_percentile))
nbhv_level4_status <- tibble(
name = nbhv4$scale,
y = nbhv4$mean_z,
y2 = nbhv4$mean_percentile,
range = nbhv4$range
)
list(
id = tolower(paste(x_level, y_level, z_level, sep = "_")),
type = "column",
data = list_parse(nbhv_level4_status)
)
})
}) |> unlist(recursive = FALSE)
}) |> unlist(recursive = FALSE)
# Tooltip
x <- c("Name", "Score", "Percentile", "Range")
y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}")
tt <- highcharter::tooltip_table(x, y)
## Create drilldown bar plot zscores
plot2 <-
highcharter::highchart() |>
highcharter::hc_title(text = patient,
style = list(fontSize = "15px")) |>
highcharter::hc_add_series(
nbhv_level1_status,
type = "bar",
name = "Behavioral Rating Scales",
highcharter::hcaes(x = name, y = y)
) |>
highcharter::hc_xAxis(
type = "category",
title = list(text = "Scale"),
categories = .$name
) |>
highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"),
labels = list(format = "{value}")) |>
highcharter::hc_tooltip(pointFormat = tt,
useHTML = TRUE,
valueDecimals = 1) |>
highcharter::hc_plotOptions(series = list(
colorByPoint = TRUE,
allowPointSelect = TRUE,
dataLabels = TRUE
)) |>
highcharter::hc_drilldown(
allowPointDrilldown = TRUE,
series = c(nbhv_level2_drill,
nbhv_level3_drill,
nbhv_level4_drill)
) |>
highcharter::hc_colorAxis(minColor = "red",
maxColor = "blue") |>
highcharter::hc_add_theme(theme_merge) |>
highcharter::hc_chart(style = list(fontFamily = "Cabin"),
backgroundColor = list("gray"))
plot2
class: left, middle, right top
background-color: var(--near-black)
class: background
background-image: url(logo_usc_ksom_black.jpg)
background-position: right top
background-repeat: repeat
background-size: 15%
background-color: var(--usc-black)
Effort/Validity Testing
Summary of cognitive performance validity and ratings of symptom validity
## Level 1
## Domain scores
# 1. create mean z-scores for domain
val1 <-
validity |>
dplyr::group_by(domain) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
val1$mean_z <- round(val1$mean_z, 2L)
val1$mean_percentile <- round(val1$mean_percentile, 0L)
val1 <-
val1 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
val1 <- dplyr::arrange(val1, dplyr::desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
val_level1_status <- tibble::tibble(
name = val1$domain,
y = val1$mean_z,
y2 = val1$mean_percentile,
range = val1$range,
drilldown = tolower(name)
)
## Level 2
## Subdomain scores
## function to create second level of drilldown (subdomain scores)
val_level2_drill <-
lapply(unique(validity$domain), function(x_level) {
val2 <- subset(validity, validity$domain %in% x_level)
# same as above
val2 <-
val2 |>
dplyr::group_by(subdomain) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
val2$mean_z <- round(val2$mean_z, 2L)
val2$mean_percentile <- round(val2$mean_percentile, 0L)
val2 <-
val2 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
# 2. sort hi to lo
val2 <- dplyr::arrange(val2, dplyr::desc(mean_percentile))
# 3. create tibble with new column with domain name lowercase
val_level2_status <- tibble::tibble(
name = val2$subdomain,
y = val2$mean_z,
y2 = val2$mean_percentile,
range = val2$range,
drilldown = tolower(paste(x_level, name, sep = "_"))
)
list(
id = tolower(x_level),
type = "column",
data = list_parse(val_level2_status)
)
})
## Level 3
## Narrow subdomains
## reuse function
val_level3_drill <-
lapply(unique(validity$domain), function(x_level) {
val2 <- subset(validity, validity$domain %in% x_level)
# reuse function but with y_level
lapply(unique(val2$subdomain), function(y_level) {
# 1. create mean z-scores for subdomain
# val3 becomes pronoun for domain
val3 <- subset(val2, val2$subdomain %in% y_level)
val3 <-
val3 |>
dplyr::group_by(narrow) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
val3$mean_z <- round(val3$mean_z, 2L)
val3$mean_percentile <- round(val3$mean_percentile, 0L)
val3 <-
val3 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
val3 <- dplyr::arrange(val3, dplyr::desc(mean_percentile))
val_level3_status <- tibble::tibble(
name = val3$narrow,
y = val3$mean_z,
y2 = val3$mean_percentile,
range = val3$range,
drilldown = tolower(paste(x_level, y_level, name, sep = "_"))
)
list(
id = tolower(paste(x_level, y_level, sep = "_")),
type = "column",
data = list_parse(val_level3_status)
)
})
}) |> unlist(recursive = FALSE)
## Level 4
## Scale scores
## reuse both functions
val_level4_drill <-
lapply(unique(validity$domain), function(x_level) {
val2 <- subset(validity, validity$domain %in% x_level)
lapply(unique(val2$subdomain), function(y_level) {
val3 <- subset(val2, val2$subdomain %in% y_level)
lapply(unique(val3$narrow), function(z_level) {
val4 <- subset(val3, val3$narrow %in% z_level)
val4 <-
val4 |>
dplyr::group_by(scale) |>
dplyr::summarize(
mean_z = mean(z),
mean_percentile = mean(percentile)) |>
dplyr::mutate(range = NA)
# round z-score to 1 decimal
val4$mean_z <- round(val4$mean_z, 2L)
val4$mean_percentile <- round(val4$mean_percentile, 0L)
val4 <-
val4 |>
dplyr::mutate(
range = dplyr::case_when(
mean_percentile >= 98 ~ "Exceptionally High",
mean_percentile %in% 91:97 ~ "Above Average",
mean_percentile %in% 75:90 ~ "High Average",
mean_percentile %in% 25:74 ~ "Average",
mean_percentile %in% 9:24 ~ "Low Average",
mean_percentile %in% 2:8 ~ "Below Average",
mean_percentile < 2 ~ "Exceptionally Low",
TRUE ~ as.character(range)
)
)
val4 <- dplyr::arrange(val4, dplyr::desc(mean_percentile))
val_level4_status <- tibble::tibble(
name = val4$scale,
y = val4$mean_z,
y2 = val4$mean_percentile,
range = val4$range
)
list(
id = tolower(paste(x_level, y_level, z_level, sep = "_")),
type = "column",
data = list_parse(val_level4_status)
)
})
}) |> unlist(recursive = FALSE)
}) |> unlist(recursive = FALSE)
# Tooltip
x <- c("Name", "Score", "Percentile", "Range")
y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}")
tt <- highcharter::tooltip_table(x, y)
## Create drilldown bar plot zscores
plot3 <-
highcharter::highchart() |>
highcharter::hc_title(text = patient,
style = list(fontSize = "15px")) |>
highcharter::hc_add_series(val_level1_status,
type = "bar",
name = "Effort/Validity Test Scores",
highcharter::hcaes(x = name, y = y)) |>
highcharter::hc_xAxis(
type = "category",
title = list(text = "Scale"),
categories = .$name
) |>
highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"),
labels = list(format = "{value}")) |>
highcharter::hc_tooltip(pointFormat = tt,
useHTML = TRUE,
valueDecimals = 1) |>
highcharter::hc_plotOptions(series = list(
colorByPoint = TRUE,
allowPointSelect = TRUE,
dataLabels = TRUE
)) |>
highcharter::hc_drilldown(
allowPointDrilldown = TRUE,
series = c(val_level2_drill,
val_level3_drill,
val_level4_drill)
) |>
highcharter::hc_colorAxis(minColor = "red",
maxColor = "blue") |>
highcharter::hc_add_theme(theme_merge) |>
highcharter::hc_chart(style = list(fontFamily = "Cabin"),
backgroundColor = list("gray"))
plot3
jtrampush/npsych.data documentation built on Feb. 25, 2025, 12:30 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
patient <- rmarkdown::metadata$patient
## load libraries library(crosstalk) library(dplyr) library(gifski) library(highcharter) library(htmlwidgets) library(knitr) library(languageserver) library(manipulateWidget) library(revealjs) library(svglite) library(tibble) library(vroom) library(widgetframe) library(xaringan) library(xaringanExtra) library(xaringanthemer) library(tidyverse) library(bwu) ## knitr options options(htmltools.dir.version = FALSE) knitr::opts_chunk$set( fig.path = "figs/", fig.width = 12, fig.height = 4, fig.asp = .5, fig.retina = 3, out.width = "100%", fig.showtext = TRUE, comment = NULL, cache = FALSE, cache.path = "cache/", echo = FALSE, message = FALSE, warning = FALSE, dev = c("svg", "svglite"), hiline = TRUE )
neuropsych <- vroom::vroom(here::here(patient, "neuropsych.csv"), show_col_types = FALSE) neurocog <- vroom::vroom(here::here(patient, "neurocog.csv"), show_col_types = FALSE) |> dplyr::filter(scale != "Orientation") |> dplyr::filter(narrow != "Response Monitoring") |> dplyr::filter(narrow != "Recognition Memory") neurobehav <- vroom::vroom(here::here(patient, "neurobehav.csv"), show_col_types = FALSE) validity <- vroom::vroom(here::here(patient, "validity.csv"), show_col_types = FALSE)
name: title class: title-slide, center, middle background-image: url(logo_usc_ksom_black.jpg) background-position: bottom background-repeat: no-repeat background-size: 25% background-color: var(--usc-black)
r rmarkdown::metadata$title
r rmarkdown::metadata$patient
r rmarkdown::metadata$author
r rmarkdown::metadata$institute
r rmarkdown::metadata$date
name: gauss-plot1 class: middle center background-size: contain
Distribution of Scores: Population-level Interpretation
```{r gauss-plot1, fig.cap = "Performance classification of neuropsychological test scores in the general population.", fig.retina = 3, fig.asp = 0.5, out.width = "50%"} knitr::include_graphics("plot_narrow.png", auto_pdf = TRUE)
--- class: left, middle, right top background-color: var(--near-black) class: background background-image: url(logo_usc_ksom_black.jpg) background-position: right top background-repeat: repeat background-size: 15% background-color: var(--usc-black) ### Neurocognitive Evaluation #### Summary of neuropsychological testing results ```r ## Level 1 ## Domain scores # 1. create mean z-scores for domain ncog1 <- neurocog |> dplyr::group_by(domain) |> dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) ncog1$mean_z <- round(ncog1$mean_z, 2L) ncog1$mean_percentile <- round(ncog1$mean_percentile, 0L) ncog1 <- ncog1 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo ncog1 <- arrange(ncog1, desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase ncog_level1_status <- tibble( name = ncog1$domain, y = ncog1$mean_z, y2 = ncog1$mean_percentile, range = ncog1$range, drilldown = tolower(name) )
## Level 2 ## Subdomain scores ## function to create second level of drilldown (subdomain scores) ncog_level2_drill <- lapply(unique(neurocog$domain), function(x_level) { ncog2 <- subset(neurocog, neurocog$domain %in% x_level) # same as above ncog2 <- ncog2 |> dplyr::group_by(subdomain) |> dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal ncog2$mean_z <- round(ncog2$mean_z, 2L) ncog2$mean_percentile <- round(ncog2$mean_percentile, 0L) ncog2 <- ncog2 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo ncog2 <- arrange(ncog2, desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase ncog_level2_status <- tibble( name = ncog2$subdomain, y = ncog2$mean_z, y2 = ncog2$mean_percentile, range = ncog2$range, drilldown = tolower(paste(x_level, name, sep = "_")) ) list( id = tolower(x_level), type = "column", data = list_parse(ncog_level2_status) ) })
## Level 3 ## Narrow subdomains ## reuse function ncog_level3_drill <- lapply(unique(neurocog$domain), function(x_level) { ncog2 <- subset(neurocog, neurocog$domain %in% x_level) # reuse function but with y_level lapply(unique(ncog2$subdomain), function(y_level) { # 1. create mean z-scores for subdomain # ncog3 becomes pronoun for domain ncog3 <- subset(ncog2, ncog2$subdomain %in% y_level) ncog3 <- ncog3 |> dplyr::group_by(narrow) |> dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal ncog3$mean_z <- round(ncog3$mean_z, 2L) ncog3$mean_percentile <- round(ncog3$mean_percentile, 0L) ncog3 <- ncog3 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) ncog3 <- arrange(ncog3, desc(mean_percentile)) ncog_level3_status <- tibble( name = ncog3$narrow, y = ncog3$mean_z, y2 = ncog3$mean_percentile, range = ncog3$range, drilldown = tolower(paste(x_level, y_level, name, sep = "_")) ) list( id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse(ncog_level3_status) ) }) }) |> unlist(recursive = FALSE)
## Level 4 ## Scale scores ## reuse both functions ncog_level4_drill <- lapply(unique(neurocog$domain), function(x_level) { ncog2 <- subset(neurocog, neurocog$domain %in% x_level) lapply(unique(ncog2$subdomain), function(y_level) { ncog3 <- subset(ncog2, ncog2$subdomain %in% y_level) lapply(unique(ncog3$narrow), function(z_level) { ncog4 <- subset(ncog3, ncog3$narrow %in% z_level) ncog4 <- ncog4 |> dplyr::group_by(scale) |> dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal ncog4$mean_z <- round(ncog4$mean_z, 2L) ncog4$mean_percentile <- round(ncog4$mean_percentile, 0L) ncog4 <- ncog4 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) ncog4 <- arrange(ncog4, desc(mean_percentile)) ncog_level4_status <- tibble( name = ncog4$scale, y = ncog4$mean_z, y2 = ncog4$mean_percentile, range = ncog4$range ) list( id = tolower(paste(x_level, y_level, z_level, sep = "_")), type = "column", data = list_parse(ncog_level4_status) ) }) }) |> unlist(recursive = FALSE) }) |> unlist(recursive = FALSE)
theme_merge <- highcharter::hc_theme_merge( highcharter::hc_theme_monokai(), highcharter::hc_theme_darkunica() )
# Tooltip x <- c("Name", "Score", "Percentile", "Range") y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}") tt <- highcharter::tooltip_table(x, y) ## Create drilldown bar plot z-scores plot1 <- highcharter::highchart() |> highcharter::hc_title(text = patient, style = list(fontSize = "15px")) |> highcharter::hc_add_series( ncog_level1_status, type = "bar", name = "Neuropsychological Test Scores", highcharter::hcaes(x = name, y = y) ) |> highcharter::hc_xAxis( type = "category", title = list(text = "Scale"), categories = .$name ) |> highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"), labels = list(format = "{value}")) |> highcharter::hc_tooltip(pointFormat = tt, useHTML = TRUE, valueDecimals = 1) |> highcharter::hc_plotOptions(series = list( colorByPoint = TRUE, allowPointSelect = TRUE, dataLabels = TRUE )) |> highcharter::hc_drilldown( allowPointDrilldown = TRUE, series = c(ncog_level2_drill, ncog_level3_drill, ncog_level4_drill) ) |> highcharter::hc_colorAxis(minColor = "red", maxColor = "blue") |> highcharter::hc_add_theme(theme_merge) |> highcharter::hc_chart(style = list(fontFamily = "Cabin"), backgroundColor = list("gray")) plot1
class: left, middle, right top background-color: var(--near-black) class: background background-image: url(logo_usc_ksom_black.jpg) background-position: right top background-repeat: repeat background-size: 15% background-color: var(--usc-black)
Behavioral/Emotional/Personality Functioning
Summary of self-report and observer-report scales from the PAI, CAARS, and CEFI
## Level 1 ## Domain scores # 1. create mean z-scores for domain nbhv1 <- neurobehav |> dplyr::group_by(domain) |> dplyr::summarize(mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) nbhv1$mean_z <- round(nbhv1$mean_z, 0L) nbhv1$mean_percentile <- round(nbhv1$mean_percentile, 0L) nbhv1 <- nbhv1 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo nbhv1 <- arrange(nbhv1, desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase nbhv_level1_status <- tibble( name = nbhv1$domain, y = nbhv1$mean_z, y2 = nbhv1$mean_percentile, range = nbhv1$range, drilldown = tolower(name) )
## Level 2 ## Subdomain scores ## function to create second level of drilldown (subdomain scores) nbhv_level2_drill <- lapply(unique(neurobehav$domain), function(x_level) { nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level) # same as above nbhv2 <- nbhv2 |> dplyr::group_by(subdomain) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal nbhv2$mean_z <- round(nbhv2$mean_z, 0L) nbhv2$mean_percentile <- round(nbhv2$mean_percentile, 0L) nbhv2 <- nbhv2 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo nbhv2 <- arrange(nbhv2, desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase nbhv_level2_status <- tibble( name = nbhv2$subdomain, y = nbhv2$mean_z, y2 = nbhv2$mean_percentile, range = nbhv2$range, drilldown = tolower(paste(x_level, name, sep = "_")) ) list( id = tolower(x_level), type = "column", data = list_parse(nbhv_level2_status) ) })
## Level 3 ## Narrow subdomains ## reuse function nbhv_level3_drill <- lapply(unique(neurobehav$domain), function(x_level) { nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level) # reuse function but with y_level lapply(unique(nbhv2$subdomain), function(y_level) { # 1. create mean z-scores for subdomain # nbhv3 becomes pronoun for domain nbhv3 <- subset(nbhv2, nbhv2$subdomain %in% y_level) nbhv3 <- nbhv3 |> dplyr::group_by(narrow) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal nbhv3$mean_z <- round(nbhv3$mean_z, 0L) nbhv3$mean_percentile <- round(nbhv3$mean_percentile, 0L) nbhv3 <- nbhv3 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) nbhv3 <- arrange(nbhv3, desc(mean_percentile)) nbhv_level3_status <- tibble( name = nbhv3$narrow, y = nbhv3$mean_z, y2 = nbhv3$mean_percentile, range = nbhv3$range, drilldown = tolower(paste(x_level, y_level, name, sep = "_")) ) list( id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse(nbhv_level3_status) ) }) }) |> unlist(recursive = FALSE)
## Level 4 ## Scale scores ## reuse both functions nbhv_level4_drill <- lapply(unique(neurobehav$domain), function(x_level) { nbhv2 <- subset(neurobehav, neurobehav$domain %in% x_level) lapply(unique(nbhv2$subdomain), function(y_level) { nbhv3 <- subset(nbhv2, nbhv2$subdomain %in% y_level) lapply(unique(nbhv3$narrow), function(z_level) { nbhv4 <- subset(nbhv3, nbhv3$narrow %in% z_level) nbhv4 <- nbhv4 |> dplyr::group_by(scale) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal nbhv4$mean_z <- round(nbhv4$mean_z, 0L) nbhv4$mean_percentile <- round(nbhv4$mean_percentile, 0L) nbhv4 <- nbhv4 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) nbhv4 <- arrange(nbhv4, desc(mean_percentile)) nbhv_level4_status <- tibble( name = nbhv4$scale, y = nbhv4$mean_z, y2 = nbhv4$mean_percentile, range = nbhv4$range ) list( id = tolower(paste(x_level, y_level, z_level, sep = "_")), type = "column", data = list_parse(nbhv_level4_status) ) }) }) |> unlist(recursive = FALSE) }) |> unlist(recursive = FALSE)
# Tooltip x <- c("Name", "Score", "Percentile", "Range") y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}") tt <- highcharter::tooltip_table(x, y) ## Create drilldown bar plot zscores plot2 <- highcharter::highchart() |> highcharter::hc_title(text = patient, style = list(fontSize = "15px")) |> highcharter::hc_add_series( nbhv_level1_status, type = "bar", name = "Behavioral Rating Scales", highcharter::hcaes(x = name, y = y) ) |> highcharter::hc_xAxis( type = "category", title = list(text = "Scale"), categories = .$name ) |> highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"), labels = list(format = "{value}")) |> highcharter::hc_tooltip(pointFormat = tt, useHTML = TRUE, valueDecimals = 1) |> highcharter::hc_plotOptions(series = list( colorByPoint = TRUE, allowPointSelect = TRUE, dataLabels = TRUE )) |> highcharter::hc_drilldown( allowPointDrilldown = TRUE, series = c(nbhv_level2_drill, nbhv_level3_drill, nbhv_level4_drill) ) |> highcharter::hc_colorAxis(minColor = "red", maxColor = "blue") |> highcharter::hc_add_theme(theme_merge) |> highcharter::hc_chart(style = list(fontFamily = "Cabin"), backgroundColor = list("gray")) plot2
class: left, middle, right top background-color: var(--near-black) class: background background-image: url(logo_usc_ksom_black.jpg) background-position: right top background-repeat: repeat background-size: 15% background-color: var(--usc-black)
Effort/Validity Testing
Summary of cognitive performance validity and ratings of symptom validity
## Level 1 ## Domain scores # 1. create mean z-scores for domain val1 <- validity |> dplyr::group_by(domain) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) val1$mean_z <- round(val1$mean_z, 2L) val1$mean_percentile <- round(val1$mean_percentile, 0L) val1 <- val1 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo val1 <- dplyr::arrange(val1, dplyr::desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase val_level1_status <- tibble::tibble( name = val1$domain, y = val1$mean_z, y2 = val1$mean_percentile, range = val1$range, drilldown = tolower(name) )
## Level 2 ## Subdomain scores ## function to create second level of drilldown (subdomain scores) val_level2_drill <- lapply(unique(validity$domain), function(x_level) { val2 <- subset(validity, validity$domain %in% x_level) # same as above val2 <- val2 |> dplyr::group_by(subdomain) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal val2$mean_z <- round(val2$mean_z, 2L) val2$mean_percentile <- round(val2$mean_percentile, 0L) val2 <- val2 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) # 2. sort hi to lo val2 <- dplyr::arrange(val2, dplyr::desc(mean_percentile)) # 3. create tibble with new column with domain name lowercase val_level2_status <- tibble::tibble( name = val2$subdomain, y = val2$mean_z, y2 = val2$mean_percentile, range = val2$range, drilldown = tolower(paste(x_level, name, sep = "_")) ) list( id = tolower(x_level), type = "column", data = list_parse(val_level2_status) ) })
## Level 3 ## Narrow subdomains ## reuse function val_level3_drill <- lapply(unique(validity$domain), function(x_level) { val2 <- subset(validity, validity$domain %in% x_level) # reuse function but with y_level lapply(unique(val2$subdomain), function(y_level) { # 1. create mean z-scores for subdomain # val3 becomes pronoun for domain val3 <- subset(val2, val2$subdomain %in% y_level) val3 <- val3 |> dplyr::group_by(narrow) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal val3$mean_z <- round(val3$mean_z, 2L) val3$mean_percentile <- round(val3$mean_percentile, 0L) val3 <- val3 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) val3 <- dplyr::arrange(val3, dplyr::desc(mean_percentile)) val_level3_status <- tibble::tibble( name = val3$narrow, y = val3$mean_z, y2 = val3$mean_percentile, range = val3$range, drilldown = tolower(paste(x_level, y_level, name, sep = "_")) ) list( id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse(val_level3_status) ) }) }) |> unlist(recursive = FALSE)
## Level 4 ## Scale scores ## reuse both functions val_level4_drill <- lapply(unique(validity$domain), function(x_level) { val2 <- subset(validity, validity$domain %in% x_level) lapply(unique(val2$subdomain), function(y_level) { val3 <- subset(val2, val2$subdomain %in% y_level) lapply(unique(val3$narrow), function(z_level) { val4 <- subset(val3, val3$narrow %in% z_level) val4 <- val4 |> dplyr::group_by(scale) |> dplyr::summarize( mean_z = mean(z), mean_percentile = mean(percentile)) |> dplyr::mutate(range = NA) # round z-score to 1 decimal val4$mean_z <- round(val4$mean_z, 2L) val4$mean_percentile <- round(val4$mean_percentile, 0L) val4 <- val4 |> dplyr::mutate( range = dplyr::case_when( mean_percentile >= 98 ~ "Exceptionally High", mean_percentile %in% 91:97 ~ "Above Average", mean_percentile %in% 75:90 ~ "High Average", mean_percentile %in% 25:74 ~ "Average", mean_percentile %in% 9:24 ~ "Low Average", mean_percentile %in% 2:8 ~ "Below Average", mean_percentile < 2 ~ "Exceptionally Low", TRUE ~ as.character(range) ) ) val4 <- dplyr::arrange(val4, dplyr::desc(mean_percentile)) val_level4_status <- tibble::tibble( name = val4$scale, y = val4$mean_z, y2 = val4$mean_percentile, range = val4$range ) list( id = tolower(paste(x_level, y_level, z_level, sep = "_")), type = "column", data = list_parse(val_level4_status) ) }) }) |> unlist(recursive = FALSE) }) |> unlist(recursive = FALSE)
# Tooltip x <- c("Name", "Score", "Percentile", "Range") y <- c("{point.name}", "{point.y}", "{point.y2}", "{point.range}") tt <- highcharter::tooltip_table(x, y) ## Create drilldown bar plot zscores plot3 <- highcharter::highchart() |> highcharter::hc_title(text = patient, style = list(fontSize = "15px")) |> highcharter::hc_add_series(val_level1_status, type = "bar", name = "Effort/Validity Test Scores", highcharter::hcaes(x = name, y = y)) |> highcharter::hc_xAxis( type = "category", title = list(text = "Scale"), categories = .$name ) |> highcharter::hc_yAxis(title = list(text = "Z-Score (M = 0, SD = 1)"), labels = list(format = "{value}")) |> highcharter::hc_tooltip(pointFormat = tt, useHTML = TRUE, valueDecimals = 1) |> highcharter::hc_plotOptions(series = list( colorByPoint = TRUE, allowPointSelect = TRUE, dataLabels = TRUE )) |> highcharter::hc_drilldown( allowPointDrilldown = TRUE, series = c(val_level2_drill, val_level3_drill, val_level4_drill) ) |> highcharter::hc_colorAxis(minColor = "red", maxColor = "blue") |> highcharter::hc_add_theme(theme_merge) |> highcharter::hc_chart(style = list(fontFamily = "Cabin"), backgroundColor = list("gray")) plot3
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.