tests/testthat/test-demo-multiplebaseline_greyed.R

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

set.seed(65535)

n_sessions <- 80
n_targets <- 4
var_targets <- runif(n_targets,
  min = 0.1,
  max = 0.25
)
bl_targets <- runif(n_targets,
  min = 0,
  max = 0.2
)
pl_shifts <- runif(n_targets,
  min = 0.4,
  max = 0.8
)

pl_change <- c(15, 30, 45, 60)

session_target <- 0

main_data_frame <- data.frame(
  Session = numeric(0),
  Phase = character(0),
  Facet = character(0),
  Percentage = numeric(0),
  Target = character(0)
)

for (t in seq_len(n_sessions)) {
  session_target <- session_target + 1
  session_target <- ifelse(session_target > 4, 1, session_target)

  rel_var <- var_targets[session_target]
  rel_bl <- bl_targets[session_target]
  rel_pls <- pl_shifts[session_target]
  rel_plc <- pl_change[session_target]

  phase <- ifelse(t < rel_plc, "Baseline", "Intervention")
  phase_dummy <- ifelse(t < rel_plc, 0, 1)

  pct <- rel_bl + rel_pls * phase_dummy + rnorm(1, 0, rel_var)
  pct <- pct * 100

  pct <- ifelse(pct > 100, 100, pct)
  pct <- ifelse(pct < 0, 0, pct)

  data_frame_addendum <- data.frame(
    Session = t,
    Phase = phase,
    Facet = as.character(session_target),
    Percentage = pct,
    Target = "Main"
  )

  main_data_frame <- rbind(
    main_data_frame,
    data_frame_addendum
  )
}

main_data_frame$Therapist <- "Primary"

main_data_frame_backup <- main_data_frame

t <- 1

for (t in seq_len(n_targets)) {
  rel_facet <- as.character(t)
  rel_plc <- pl_change[t]
  rel_top <- rel_plc + (n_targets * 3)

  main_data_frame <- subset(
    main_data_frame,
    !(Facet == rel_facet &
      Session >= rel_plc &
      Session < rel_top)
  )
}

gen_session <- c(
  5, 6, 7, 8,
  17, 18, 19, 20,
  25, 26, 27, 28,
  37, 38, 39, 40,
  45, 46, 47, 48,
  57, 58, 59, 60,
  65, 66, 67, 68,
  77, 78, 79, 80
)

main_data_frame[main_data_frame$Session %in% gen_session, "Therapist"] <- "Generalization"

x_ticks <- c(1, (1:16) * 5)

describe("MBL Greyed out Plot Style", {
  it("Should render as normal", {
    expect_no_error(
      scr_plot(
        subset(
          main_data_frame,
          Therapist == "Primary"
        ),
        aesthetics = var_map(
          x = Session,
          y = Percentage,
          p = Phase,
          facet = Facet
        ),
        mai = c(0.125, 0.375, 0.25, 0.25),
        omi = c(0.5, 0.25, 0.25, 0.25)
      ) |>
        scr_yoverride(
          c(-10, 100),
          ydelta = 25,
          yticks = c(0, 25, 50, 75, 100),
          ytickslabs = as.character(c(0, 25, 50, 75, 100))
        ) |>
        scr_xoverride(
          c(0, n_sessions),
          xticks = x_ticks
        ) |>
        scr_anno_rect(
          rects = list(
            "1" = list(
              x0 = pl_change[1],
              x1 = pl_change[1] + 11,
              y0 = -9,
              y1 = 100
            ),
            "2" = list(
              x0 = pl_change[2],
              x1 = pl_change[2] + 11,
              y0 = -9,
              y1 = 100
            ),
            "3" = list(
              x0 = pl_change[3],
              x1 = pl_change[3] + 11,
              y0 = -9,
              y1 = 100,
              color = "black",
              fill = "black"
            ),
            "4" = list(
              x0 = pl_change[4],
              x1 = pl_change[4] + 11,
              y0 = -9,
              y1 = 100
            )
          ),
          fill = "gray",
          color = "gray"
        ) |>
        scr_ylabel("Accuracy") |>
        scr_xlabel("Session",
          line = 2
        ) |>
        scr_lines() |>
        scr_points(
          pch = 23,
          cex = 2,
          fill = "white"
        ) |>
        scr_points(
          pch = 22,
          cex = 2,
          fill = "green",
          mapping = list(
            x = Session,
            y = Percentage
          ),
          data = subset(
            main_data_frame,
            Therapist == "Generalization"
          )
        ) |>
        scr_plines_mbd(
          lines = list(
            "A" = list(
              "1" = list(
                x1 = pl_change[1],
                y1 = 100,
                y2 = -30
              ),
              "2" = list(
                x1 = pl_change[2],
                y1 = 100,
                y2 = -30
              ),
              "3" = list(
                x1 = pl_change[3],
                y1 = 100,
                y2 = -30
              ),
              "4" = list(
                x1 = pl_change[4],
                y1 = 100,
                y2 = -10
              )
            )
          )
        ) |>
        scr_label_facet(
          cex = 1.25,
          adj = 1,
          y = 115,
          face = 2,
          x = 80,
          labels = list(
            "1" = list(
              label = "Participant 1"
            ),
            "2" = list(
              label = "Participant 2"
            ),
            "3" = list(
              label = "Participant 3"
            ),
            "4" = list(
              label = "Participant 4"
            )
          )
        ) |>
        scr_label_phase(
          facet = "1",
          cex = 1.125,
          adj = 0.5,
          y = 110,
          labels = list(
            "Baseline" = list(
              x = 7.5
            ),
            "Intervention" = list(
              x = 37.5
            )
          )
        ) |>
        scr_label_phase(
          facet = "1",
          cex = 1.125,
          adj = 0,
          y = 110,
          labels = list(
            "Errorless Training" = list(
              x = 35,
              y = 5,
              adj = 0
            )
          )
        ) |>
        scr_anno_arrows(
          facet = "1",
          length = 0.075,
          code = 1,
          color = "black",
          lty = 1,
          lwd = 1,
          arrows = list(
            "A" = list(
              x0 = 27,
              y0 = 5,
              x1 = 34,
              y1 = 5
            )
          )
        ) |>
        scr_legend(
          panel = "1",
          position = "bottomright",
          legend = c(
            "Independence",
            "Generalization Probe"
          ),
          col = c(
            "black",
            "black"
          ),
          pt_bg = c(
            "white",
            "green"
          ),
          lty = c(
            1,
            1
          ),
          pch = c(
            23,
            22
          ),
          bty = "n",
          pt_cex = 2.25,
          cex = 1.25,
          text_col = "black",
          horiz = FALSE,
          box_lty = 0
        ) |>
        print()
    )
  })

  it("Should specific to facet", {
    expect_no_error(
      scr_plot(
        subset(
          main_data_frame,
          Therapist == "Primary"
        ),
        aesthetics = var_map(
          x = Session,
          y = Percentage,
          p = Phase,
          facet = Facet
        ),
        mai = c(0.125, 0.375, 0.25, 0.25),
        omi = c(0.5, 0.25, 0.25, 0.25)
      ) |>
        scr_yoverride(
          c(-10, 100),
          ydelta = 25,
          yticks = c(0, 25, 50, 75, 100),
          ytickslabs = as.character(c(0, 25, 50, 75, 100))
        ) |>
        scr_xoverride(
          c(0, n_sessions),
          xticks = x_ticks
        ) |>
        scr_anno_rect(
          rects = list(
            "1" = list(
              x0 = pl_change[1],
              x1 = pl_change[1] + 11,
              y0 = -9,
              y1 = 100
            ),
            "2" = list(
              x0 = pl_change[2],
              x1 = pl_change[2] + 11,
              y0 = -9,
              y1 = 100
            ),
            "3" = list(
              x0 = pl_change[3],
              x1 = pl_change[3] + 11,
              y0 = -9,
              y1 = 100
            ),
            "4" = list(
              x0 = pl_change[4],
              x1 = pl_change[4] + 11,
              y0 = -9,
              y1 = 100
            )
          ),
          fill = "gray",
          color = "gray"
        ) |>
        scr_ylabel("Accuracy") |>
        scr_xlabel("Session",
          line = 2
        ) |>
        scr_lines() |>
        scr_points(
          pch = 23,
          cex = 2,
          fill = "white"
        ) |>
        scr_points(
          pch = 22,
          cex = 2,
          fill = "green",
          mapping = list(
            x = Session,
            y = Percentage
          ),
          data = subset(
            main_data_frame,
            Therapist == "Generalization"
          )
        ) |>
        scr_plines_mbd(
          lines = list(
            "A" = list(
              "1" = list(
                x1 = pl_change[1],
                y1 = 100,
                y2 = -30
              ),
              "2" = list(
                x1 = pl_change[2],
                y1 = 100,
                y2 = -30
              ),
              "3" = list(
                x1 = pl_change[3],
                y1 = 100,
                y2 = -30
              ),
              "4" = list(
                x1 = pl_change[4],
                y1 = 100,
                y2 = -10
              )
            )
          )
        ) |>
        scr_label_facet(
          cex = 1.25,
          adj = 1,
          y = 115,
          face = 2,
          x = 80,
          labels = list(
            "1" = list(
              label = "Participant 1"
            ),
            "2" = list(
              label = "Participant 2"
            ),
            "3" = list(
              label = "Participant 3"
            ),
            "4" = list(
              label = "Participant 4"
            )
          )
        ) |>
        scr_label_phase(
          facet = "1",
          cex = 1.125,
          adj = 0.5,
          y = 110,
          labels = list(
            "Baseline" = list(
              x = 7.5
            ),
            "Intervention" = list(
              x = 37.5
            )
          )
        ) |>
        scr_label_phase(
          facet = "1",
          cex = 1.125,
          adj = 0,
          y = 110,
          labels = list(
            "Errorless Training" = list(
              x = 35,
              y = 5,
              adj = 0
            )
          )
        ) |>
        scr_anno_arrows(
          facet = "1",
          length = 0.075,
          code = 1,
          color = "black",
          lty = 1,
          lwd = 1,
          arrows = list(
            "A" = list(
              x0 = 27,
              y0 = 5,
              x1 = 34,
              y1 = 5
            )
          )
        ) |>
        scr_legend(
          panel = "1",
          position = "bottomright",
          legend = c(
            "Independence",
            "Generalization Probe"
          ),
          col = c(
            "black",
            "black"
          ),
          pt_bg = c(
            "white",
            "green"
          ),
          lty = c(
            1,
            1
          ),
          pch = c(
            23,
            22
          ),
          bty = "n",
          pt_cex = 2.25,
          cex = 1.25,
          text_col = "black",
          horiz = FALSE,
          box_lty = 0
        ) |>
        print()
    )
  })
})