R/utils-render_report.R

In eyeris: Flexible, Extensible, & Reproducible Pupillometry Preprocessing

#' Render R Markdown report
#'
#' Renders an R Markdown file to HTML and cleans up the temporary file.
#'
#' @param rmd_f Path to the R Markdown file to render
#'
#' @return No return value; renders HTML report and removes temporary file
#'
#' @keywords internal
render_report <- function(rmd_f) {
  rmarkdown::render(rmd_f, output_format = "html_document")
  unlink(rmd_f)
}

#' Create eyeris report
#'
#' Generates a comprehensive HTML report for eyeris preprocessing results.
#'
#' @param eyeris An `eyeris` object containing preprocessing results
#' @param out Output directory for the report
#' @param plots Vector of plot file paths to include in the report
#' @param ... Additional parameters passed from bidsify
#'
#' @return Path to the generated R Markdown file
#'
#' @keywords internal
make_report <- function(eyeris, out, plots, ...) {
  # get extra subject params from bidsify.R
  params <- list(...)

  has_multiple_runs <- length(grep("run-\\d+", plots)) > 0

  # temp file
  rmd_f <- file.path(out, paste0("sub-", params$sub, ".Rmd"))

  report_date <- format(Sys.time(), "%B %d, %Y | %H:%M:%OS3")
  package_version <- as.character(
    utils::packageVersion("eyeris")
  )
  css <- system.file(
    file.path("rmarkdown", "css", "report.css"),
    package = "eyeris"
  )

  sticker_path <- system.file("figures", "sticker.png", package = "eyeris")

  run_ids <- get_block_numbers(eyeris)
  run_info <- paste(
    " - Runs: ",
    paste(paste0("0", as.character(run_ids)), collapse = ", "),
    "\n"
  )

  # eyeris report markdown content
  block_heatmaps_md <- "\n## Gaze Heatmaps\n\n"
  for (run_id in run_ids) {
    heatmap_path <- file.path(
      "source", "figures", sprintf("run-%02d", run_id),
      sprintf("run-%02d_gaze_heatmap.png", run_id)
    )
    if (file.exists(file.path(out, heatmap_path))) {
      block_heatmaps_md <- paste0(
        block_heatmaps_md,
        "### run-", sprintf("%02d", run_id), "\n\n",
        "![](", heatmap_path, ")\n\n"
      )
    }
  }

  content <- paste0(
    "---\n",
    "title: '`eyeris` report'\n",
    "date: '", report_date, "'\n",
    "output:\n",
    "  html_document:\n",
    "    df_print: paged\n",
    "    css: '", css, "'\n",
    "    toc: true\n",
    "    toc_float: true\n",
    "    toc_depth: 3\n",
    "    number_sections: false\n",
    "---\n\n",
    "\n\n<img src='", sticker_path, "' class='top-right-image'>",
    "\n\n---\n\n## Summary\n",
    " - Subject ID: ", params$sub, "\n",
    " - Session: ", params$ses, "\n",
    " - Task: ", params$task, "\n",
    run_info,
    " - BIDS Directory: ", out, "\n",
    " - Source `.asc` file: ", eyeris$file, "\n",
    " - [`eyeris` version](https://github.com/shawntz/eyeris): ",
    package_version, "\n",
    "\n\n<style type='text/css'>\n",
    "@import url('http://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/",
    "bootstrap.min.css');\n",
    "@import url('https://cdn.jsdelivr.net/npm/lightbox2/dist/css/",
    "lightbox.min.css');\n</style>\n",
    "\n## Preprocessing Summaries\n\n",
    save_progressive_summary_plots(eyeris = eyeris, out_dir = out),
    "\n\n## Preprocessed Data Previews\n\n",
    save_detrend_plots(eyeris = eyeris, out_dir = out),
    print_plots(plots), "\n",
    block_heatmaps_md,
    "\n\n---\n\n## EyeLink Header Metadata\n\n",
    make_md_table(eyeris$info), "\n",
    "\n\n---\n\n## `eyeris` call stack\n\n",
    make_md_table_multiline(format_call_stack(eyeris$params)), "\n",
    "\n\n---\n\n## Citation\n\n",
    "```{r citation, echo=FALSE, comment=NA}\n",
    "citation('eyeris')\n",
    "```\n\n\n\n\n\n"
  )

  writeLines(content, con = rmd_f)

  rmd_f
}

#' Create markdown table from dataframe
#'
#' Converts a dataframe into a markdown table.
#'
#' @param df The dataframe to convert
#'
#' @return A character string containing the markdown table content
#'
#' @keywords internal
make_md_table <- function(df) {
  md_table <- "| Property | Value |\n|----|----|\n"
  for (prop in colnames(df)) {
    val <- df[[1, prop]]
    md_table <- paste0(
      md_table,
      "| ",
      prop,
      " | ",
      val,
      " |\n"
    )
  }

  md_table
}

#' Create multiline markdown table from dataframe
#'
#' Converts a dataframe into a multiline markdown table.
#'
#' @param df The dataframe to convert
#'
#' @return A character string containing the markdown table content
#'
#' @keywords internal
make_md_table_multiline <- function(df) {
  md_table <- paste0("| ", paste(colnames(df), collapse = " | "), " |\n")
  md_table <- paste0(md_table, "|",
                     paste(rep("---", ncol(df)), collapse = "|"), "|\n")
  for (i in seq_len(nrow(df))) {
    row <- df[i, ]
    md_table <- paste0(
      md_table,
      "| ",
      paste(as.character(row), collapse = " | "),
      " |\n"
    )
  }
  md_table
}

#' Print plots in markdown format
#'
#' Generates markdown code to display plots in the report.
#'
#' @param plots Vector of plot file paths
#'
#' @return A character string containing markdown plot references
#'
#' @keywords internal
print_plots <- function(plots) {
  md_plots <- ""

  make_relative_path <- function(path) {
    gsub("^.*?(?=source/)", "", path, perl = TRUE)
  }

  # detect run dirs
  run_dirs <- plots |>
    dirname() |>
    unique() |>
    dirname() |>
    unique() |>
    list.dirs(full.names = TRUE, recursive = FALSE) |>
    unique()

  if (length(run_dirs) > 0) {
    for (run_dir in run_dirs) {
      run_plots <- list.files(run_dir, pattern = "*.jpg", full.names = TRUE)

      if (length(run_plots) > 0) {
        run_num <- sub(".*run-(\\d+).*$", "\\1", run_dir)

        md_plots <- paste0(
          md_plots,
          "### run-", run_num, "\n\n"
        )

        # sort by fig number if possible
        plot_fig_ids <- suppressWarnings(
          as.numeric(sub(".*_fig-(\\d+)_.*", "\\1", run_plots))
        )
        if (all(!is.na(plot_fig_ids))) {
          sorted_plot_paths <- run_plots[order(plot_fig_ids)]
        } else {
          sorted_plot_paths <- run_plots
        }

        placeholder_detected <- FALSE
        placeholder_patterns <- c(
          "no_data", "placeholder", "error", "No_data", "NoData"
        )
        if (length(sorted_plot_paths) == 1 || all(sapply(sorted_plot_paths,
          function(x) {
            any(
              grepl(
                paste(placeholder_patterns, collapse = "|"),
                x,
                ignore.case = TRUE
              )
            )
          }
        ))) {
          placeholder_detected <- TRUE
        }

        if (placeholder_detected) {
          md_plots <- paste0(
            md_plots, "> **No data available for this run.**\n\n"
          )
        }

        for (fig_path in sorted_plot_paths) {
          relative_fig_path <- make_relative_path(fig_path)
          md_plots <- paste0(md_plots, "![](", relative_fig_path, ")\n\n")
        }

        # Detrend diagnostics (unchanged)
        detrend_plot_path <- file.path(
          run_dir,
          paste0("run-", run_num, "_detrend.png")
        )
        detrend_exists <- file.exists(detrend_plot_path)
        if (detrend_exists) {
          md_plots <- paste0(
            md_plots,
            "### Detrend Diagnostics\n\n",
            "![](", make_relative_path(detrend_plot_path), ")\n\n"
          )
        }
      }
    }
    md_plots
  }
}

#' Save detrend plots for each block
#'
#' Generates and saves detrend diagnostic plots for each block in the eyeris
#' object.
#'
#' @param eyeris An `eyeris` object containing preprocessing results
#' @param out_dir Output directory for saving plots
#' @param preview_n Number of preview samples for plotting
#' @param plot_params Additional plotting parameters
#'
#' @return No return value; saves detrend plots to the specified directory
#'
#' @keywords internal
save_detrend_plots <- function(eyeris, out_dir, preview_n = 3,
                               plot_params = list()) {
  blocks <- names(eyeris$timeseries)

  for (block in blocks) {
    block_number <- sub("block_", "", block)
    run_id <- sprintf("run-%02d", as.numeric(block_number))
    run_dir <- file.path(out_dir, "source", "figures", run_id)
    detrend_path <- file.path(run_dir, paste0(run_id, "_detrend.png"))

    if (!dir.exists(run_dir)) {
      dir.create(run_dir, recursive = TRUE)
    }

    pupil_data <- eyeris$timeseries[[block]]

    # only proceed if detrended values exist
    if ("detrend_fitted_values" %in% names(pupil_data) &&
          any(grepl("_detrend$", names(pupil_data)))) {
      pupil_steps <- grep("^pupil_", names(pupil_data), value = TRUE)

      grDevices::jpeg(
        filename = detrend_path,
        width = 1850,
        height = 1500,
        res = 300
      )

      plot_detrend_overlay(
        pupil_data = pupil_data,
        pupil_steps = pupil_steps,
        preview_n = preview_n,
        plot_params = plot_params,
        suppress_prompt = TRUE
      )

      grDevices::dev.off()

      message(sprintf("[Saved] %s", detrend_path))
    } else {
      message(sprintf("[Skipped] No detrend data found for %s", run_id))
    }
  }
}

#' Create progressive preprocessing summary plot
#'
#' Internal function to create a comprehensive visualization showing the
#' progressive effects of preprocessing steps on pupil data. This plot displays
#' multiple preprocessing stages overlaid on the same time series, allowing
#' users to see how each step modifies the pupil signal.
#'
#' @param pupil_data A data frame containing pupil timeseries data with
#'   multiple preprocessing columns (e.g., `eyeris$timeseries$block_1`)
#' @param pupil_steps Character vector of column names containing pupil data
#'   at different preprocessing stages
#'   (e.g., `c("pupil_raw", "pupil_deblink", "pupil_detrend")`)
#' @param preview_n Number of columns for subplot layout. Defaults to `3`
#' @param plot_params Named list of additional parameters to forward to plotting
#'   functions. Defaults to `list()`
#' @param run_id Character string identifying the run/block (e.g., "run-01").
#'   Used for plot titles and file naming. Defaults to `"run-01"`
#' @param cex Character expansion factor for plot elements. Defaults to `2.0`
#'
#' @return NULL (invisibly). Creates a plot showing progressive preprocessing
#'   effects with multiple layers overlaid on the same time series
#'
#' @details
#' This function creates a two-panel visualization:
#' \itemize{
#'   \item Top panel: Overlaid time series showing progressive preprocessing
#'     effects with different colors for each step
#'   \item Bottom panel: Legend identifying each preprocessing step
#' }
#'
#' The plot excludes z-scored data (columns ending with "_z") and only
#' includes steps with sufficient valid data points (>100). Each preprocessing
#' step is displayed with a distinct color, making it easy to see how the
#' signal changes through the pipeline.
#'
#' @keywords internal
#'
#' @seealso \code{\link{plot.eyeris}}
make_prog_summary_plot <- function(pupil_data, pupil_steps,
                                   preview_n = 3, plot_params = list(),
                                   run_id = "run-01", cex = 2.0) {
  plot_steps <- pupil_steps[!grepl("_z$", pupil_steps)]

  time_range <- range(pupil_data$time_secs, na.rm = TRUE)
  start_idx <- which.min(abs(pupil_data$time_secs - time_range[1]))
  end_idx <- which.min(abs(pupil_data$time_secs - time_range[2]))

  time_subset <- pupil_data$time_secs[start_idx:end_idx]
  layer_data <- list()
  for (i in seq_along(plot_steps)) {
    step_data <- pupil_data[[plot_steps[i]]][start_idx:end_idx]
    valid_indices <- is.finite(step_data)
    if (sum(valid_indices) < 100) next
    layer_data[[i]] <- list(
      time = time_subset[valid_indices],
      signal = step_data[valid_indices],
      step_name = plot_steps[i]
    )
  }
  if (length(layer_data) < 2) {
    plot(NA,
      xlim = c(0, 1), ylim = c(0, 1), type = "n",
      xlab = "", ylab = "", main = paste("Insufficient data for", run_id)
    )
    text(0.5, 0.5, "Not enough preprocessing steps\nfor progressive summary",
      cex = 1.2, col = "red"
    )
    return()
  }

  all_signals <- unlist(lapply(layer_data, function(x) x$signal))
  y_range <- range(all_signals, na.rm = TRUE)
  x_range <- range(unlist(lapply(layer_data, function(x) x$time)), na.rm = TRUE)
  y_padding <- diff(y_range) * 0.25 + 1e-6
  x_padding <- diff(x_range) * 0.05 + 1e-6
  y_range <- y_range + c(-y_padding, y_padding)
  x_range <- x_range + c(-x_padding, x_padding)

  colorpal <- eyeris_color_palette()
  colors <- c("black", colorpal)
  n_layers <- length(layer_data)
  colors <- colors[seq_len(n_layers)]

  layout(matrix(1:2, nrow = 2), heights = c(7, 2))
  par(mar = c(4, 5, 4, 2))
  plot(NA,
    xlim = x_range, ylim = y_range, type = "n",
    xlab = "Time (seconds)", ylab = "Pupil Size",
    main = paste("Progressive Preprocessing Summary -", run_id),
    cex.main = cex, cex.lab = cex, cex.axis = cex,
    yaxt = "n", bty = "n"
  )
  axis(2, labels = FALSE)
  for (i in seq_along(layer_data)) {
    layer <- layer_data[[i]]
    time_offset <- layer$time + i * 0.1
    scale_factor <- 1 - i * 0.02
    signal_scaled <- layer$signal * scale_factor
    lines(time_offset, signal_scaled,
      col = colors[i], lwd = 4
    )
  }

  par(mar = c(0, 0, 0, 0))
  plot.new()
  step_names <- sapply(layer_data, function(x) {
    clean_name <- gsub("pupil_", "", x$step_name)
    clean_name <- gsub("_", " > ", clean_name)
    clean_name
  })
  legend("center",
    legend = step_names, col = colors, lwd = 2, cex = cex - 0.5,
    title = "Processing Steps", horiz = FALSE, bty = "n"
  )
  layout(1)
}

#' Save progressive summary plots for each block
#'
#' Generates and saves progressive summary plots for each block in the eyeris
#' object.
#'
#' @param eyeris An `eyeris` object containing preprocessing results
#' @param out_dir Output directory for saving plots
#' @param preview_n Number of preview samples for plotting
#' @param plot_params Additional plotting parameters
#'
#' @return A character string containing markdown references to the saved plots
#'
#' @keywords internal
save_progressive_summary_plots <- function(eyeris, out_dir, preview_n = 3,
                                           plot_params = list()) {
  blocks <- names(eyeris$timeseries)
  md_content <- ""

  for (block in blocks) {
    block_number <- sub("block_", "", block)
    run_id <- sprintf("run-%02d", as.numeric(block_number))
    run_dir <- file.path(out_dir, "source", "figures", run_id)
    progressive_path <- file.path(
      run_dir, paste0(run_id, "_desc-progressive_summary.png")
    )

    if (!dir.exists(run_dir)) {
      dir.create(run_dir, recursive = TRUE)
    }

    pupil_data <- eyeris$timeseries[[block]]
    pupil_steps <- grep("^pupil_", names(pupil_data), value = TRUE)

    if (length(pupil_steps) < 2) {
      md_content <- paste0(
        md_content,
        "### ", run_id, "\n\n",
        "*Not enough preprocessing steps for progressive summary*\n\n"
      )
      next
    }

    grDevices::png(
      filename = progressive_path,
      width = 7000,
      height = 6000,
      res = 300
    )

    make_prog_summary_plot(
      pupil_data = pupil_data,
      pupil_steps = pupil_steps,
      preview_n = preview_n,
      plot_params = plot_params,
      run_id = run_id
    )

    grDevices::dev.off()

    relative_path <- gsub("^.*?(?=source/)", "", progressive_path, perl = TRUE)

    md_content <- paste0(
      md_content,
      "### ", run_id, "\n\n",
      "This visualization shows how the pupil timeseries changes across",
      "preprocessing steps. ", "Each layer represents a different",
      "preprocessing step, with the earliest step at the back ", "and the",
      "final step at the front (via a subtle horizontal offset effect).\n\n",
      "![](", relative_path, ")\n\n"
    )
  }

  md_content
}