tests/testthat/test-demo-faplotintegrity_extra.R

In miyamot0/fxl: 'fxl' Single Case Design Charting Package

set.seed(65535)

participants <- seq_len(3)

sessions_per_cond <- 4

ctrl_sim <- abs(rnorm(max(participants) * sessions_per_cond, 0, 0.125))
attn_sim <- abs(rnorm(max(participants) * sessions_per_cond, 1, 0.25))
dmnd_sim <- abs(rnorm(max(participants) * sessions_per_cond, 1, 0.25))
tang_sim <- abs(rnorm(max(participants) * sessions_per_cond, 0, 0.125))

data_frame <- data.frame(
  Participant = numeric(0),
  Condition = character(0),
  CTB = numeric(0),
  Session = numeric(0)
)

for (p in participants) {
  conditions <- c(
    rep("Control", sessions_per_cond),
    rep("Attention", sessions_per_cond),
    rep("Demand", sessions_per_cond),
    rep("Tangible", sessions_per_cond)
  )

  indices <- (p - 1) * sessions_per_cond + 1
  indices <- c(
    indices,
    indices + 1,
    indices + 2,
    indices + 3
  )

  rates <- c(
    ctrl_sim[indices],
    attn_sim[indices],
    dmnd_sim[indices],
    tang_sim[indices]
  )

  new_p <- data.frame(
    Participant = rep(p, sessions_per_cond * 4),
    Condition = conditions,
    CTB = rates
  )

  new_p_shuffled <- new_p[sample(1:nrow(new_p)), ]
  new_p_shuffled$Session <- 1:nrow(new_p)

  data_frame <- rbind(
    data_frame,
    new_p_shuffled
  )
}

data_frame$Integrity <- sample(
  70:100,
  nrow(data_frame),
  replace = TRUE
)

bar_styler <- function(data_frame, ...) {
  input_list <- list(...)

  local_frame <- input_list[["plot_frame"]]
  local_frame$col <- "orange"

  local_frame[local_frame$pct >= .95, "col"] <- "green"
  local_frame[local_frame$pct < .95 & local_frame$pct >= .80, "col"] <- "lightgreen"
  local_frame[local_frame$pct < .80, "col"] <- "orange"

  rect(local_frame$X - 0.25,
    0,
    local_frame$X + 0.25,
    local_frame$mod_y,
    col = local_frame$col
  )
}

describe("FA Plot with Integrity", {
  it("Should render as normal", {
    expect_no_error(
      scr_plot(
        data_frame,
        aesthetics = var_map(
          x = Session,
          y = CTB,
          p = Condition,
          facet = Participant
        ),
        mai = c(
          0.5,
          0.5,
          0.1,
          0.5
        ),
        omi = c(
          0.25,
          0.25,
          0.25,
          0.25
        )
      ) |>
        scr_yoverride(c(-.175, 5),
          yticks = c(0, 1, 2, 3, 4, 5),
          ytickslabs = c("0", "1", "2", "3", "4", "5")
        ) |>
        scr_xoverride(c(0.5, 16.5),
          xticks = 1:16,
          xtickslabs = as.character(1:16)
        ) |>
        scr_bar_support(
          color = rgb(.8, .8, .8, alpha = 1),
          guide_line = 80,
          guide_line_color = "blue",
          guide_line_type = 2,
          guide_line_size = 1,
          styler = bar_styler,
          label = "Procedural Fidelity",
          mapping = list(
            x = Session,
            y = Integrity
          )
        ) |>
        scr_lines(
          size = 1
        ) |>
        scr_points(
          cex = 2,
          pch = list(
            "Control" = 21,
            "Attention" = 22,
            "Demand" = 24,
            "Tangible" = 8
          ),
          fill = list(
            "Control" = "black",
            "Attention" = "white",
            "Demand" = "white",
            "Tangible" = "black"
          ),
          color = list(
            "Control" = "black",
            "Attention" = "black",
            "Demand" = "black",
            "Tangible" = "black"
          )
        ) |>
        scr_xlabel("Session") |>
        scr_ylabel("Combined Target Behavior (Per Minute)") |>
        scr_title("Analog Functional Analyses an Assocated Procedural Fidelity") |>
        scr_legend(
          panel = "3",
          position = list(
            x = 0.85,
            y = 4.75
          ), # Specify legend location
          legend = c(
            "Toy Play", # labels to include (ordered)
            "Attention",
            "Demand",
            "Tangible"
          ),
          col = c(
            "black", # color of markers (ordered)
            "black",
            "black",
            "black"
          ),
          bg = "white",
          pt_bg = c(
            "black", # color of markers (ordered)
            "white",
            "white",
            "black"
          ),
          lty = c(1, 1, 1, 1), # line types (ordered)
          pch = c(16, 22, 24, 8), # marker types (ordered)
          bty = "y", # remove border
          pt_cex = 2.25, # point size scale
          cex = 1.25, # text size scale
          text_col = "black", # text color
          horiz = FALSE, # list items vertically
          box_lty = 1
        ) |>
        print()
    )
  })
})