Merge pull request #15 from KaiAragaki/report

Report

NAMESPACE

@@ -14,6 +14,14 @@ S3method(qp_mark_outliers,data.frame)
 S3method(qp_mark_outliers,list)
 S3method(qp_remove_empty,data.frame)
 S3method(qp_remove_empty,list)
+S3method(qp_samples_all,data.frame)
+S3method(qp_samples_all,list)
+S3method(qp_samples_summary,data.frame)
+S3method(qp_samples_summary,list)
+S3method(qp_standards_all,data.frame)
+S3method(qp_standards_all,list)
+S3method(qp_standards_summary,data.frame)
+S3method(qp_standards_summary,list)
 S3method(qp_summarize,data.frame)
 S3method(qp_summarize,list)
 S3method(qp_tidy,character)
@@ -31,6 +39,7 @@ export(qp_mark_outliers)
 export(qp_plot_plate)
 export(qp_plot_standards)
 export(qp_remove_empty)
+export(qp_report)
 export(qp_summarize)
 export(qp_tidy)
 importFrom(rlang,.data)

R/color.R

@@ -0,0 +1,18 @@
+qp_pal <- grDevices::colorRampPalette(
+  c("darkseagreen1", "#A763A0", "#3D1452"),
+  bias = 0.9
+)(100)
+
+# Notes:
+# Abs vs apparent color
+# 0.1 - gray - between green and purple
+# 0.31 - around mediumorchid3
+# Let's call 0.5 the max since you shouldn't go too far above anyway
+
+abs_to_col <- function(abs, pal) {
+  scaled <- abs * 200
+  idx <- ifelse(scaled < 1, 1, scaled)
+  idx <- ifelse(idx > 100, 100, idx)
+  idx <- round(idx)
+  pal[idx]
+}

R/qp_dilute.R

@@ -1,8 +1,8 @@
 #' Calculate dilutions from predicted concentrations
 #'
 #' @param x A `data.frame` or `list` containing a `data.frame` named `qp` with
-#'   a column named `.pred_conc` or `.mean_pred_conc`. If both, will favor
-#'   `.mean_pred_conc`.
+#'   a column named `.pred_conc` or `.pred_conc_mean`. If both, will favor
+#'   `.pred_conc_mean`.
 #' @param target_conc Numeric vector. Target concentration in (mg/mL) protein.
 #'   If length == 1, recycled.
 #' @param target_vol Target volume in uL. If length == 1, recycled.
@@ -21,7 +21,7 @@ qp_dilute <- function(x, ...) {
 #' @export
 qp_dilute.data.frame <- function(x, target_conc = NULL, target_vol = 15,
                                  remove_standards = FALSE, ...) {
-  check_has_cols(x, c(".pred_conc", ".mean_pred_conc"), type = "or")
+  check_has_cols(x, c(".pred_conc", ".pred_conc_mean"), type = "or")
 
   if (remove_standards || is.null(target_conc)) {
     check_has_cols(x, "sample_type")
@@ -36,7 +36,7 @@ qp_dilute.data.frame <- function(x, target_conc = NULL, target_vol = 15,
   }
 
   conc_col_name <- ifelse(
-    has_cols(x, ".mean_pred_conc"), ".mean_pred_conc", ".pred_conc"
+    has_cols(x, ".pred_conc_mean"), ".pred_conc_mean", ".pred_conc"
   )
 
   if (is.null(target_conc)) {
@@ -54,7 +54,8 @@ qp_dilute.data.frame <- function(x, target_conc = NULL, target_vol = 15,
 
   x |>
     dplyr::bind_cols(dils) |>
-    tidyr::unnest_wider("value")
+    tidyr::unnest_wider("value") |>
+    dplyr::mutate(.target_conc = target_conc, .target_vol = target_vol)
 }
 
 #' @rdname qp_dilute

R/qp_plot_plate.R

@@ -13,13 +13,16 @@ qp_plot_plate <- function(x, size = 15) {
   ggplot2::ggplot(x, ggplot2::aes(
     x = .data$.col,
     y = .data$.row,
-    color = .data$.abs
+    color = abs_to_col(.data$.abs, qp_pal)
   )) +
     ggplot2::geom_point(size = size) +
     ggplot2::geom_text(
-      ggplot2::aes(label = round(.data$.abs, 2)),
-      color = "black"
+      ggplot2::aes(
+        label = round(.data$.abs, 2),
+        color = ifelse(.data$.abs < 0.35, "black", "white")
+      ),
+      size = size / 3
     ) +
     ggplot2::scale_y_reverse() +
-    ggplot2::scale_color_gradient(low = "darkseagreen1", high = "mediumpurple3")
+    ggplot2::scale_color_identity()
 }

R/qp_report.R

@@ -1,3 +1,261 @@
-qp_report <- function(qp) {
-  ""
+#' Create a report for a protein quantificaiton experiment
+#'
+#' @param qp Likely the output from `qp` AND `qp_dilute`.
+#' @param output_file Character. The path of the file to export,
+#'   including `.html`
+#' @param other Generally used for Shiny application. Assumes a
+#'   named list of key-values that will be used to document report
+#'   parameters.
+#'
+#' @export
+#' @examples
+#' \dontrun{
+#' absorbances |>
+#'   qp() |>
+#'   qp_dilute() |>
+#'   qp_report(
+#'     "~/my_report.html",
+#'     other = list(key = "value") # Essentially metadata
+#'   )
+#' }
+qp_report <- function(qp, output_file, other = list()) {
+  rmarkdown::render(
+    system.file(
+      "rmarkdown/templates/quantify-protein-report/skeleton/skeleton.Rmd",
+      package = "qp"
+    ),
+    output_file = output_file,
+    params = list(qp = qp, other = other)
+  )
+}
+
+# Standards ----
+## All ----
+qp_standards_all <- function(x) {
+  UseMethod("qp_standards_all")
+}
+
+#' @export
+qp_standards_all.data.frame <- function(x) {
+  x <- add_coords_col(x)
+  table_data <- add_well_circles_plot_col(
+    x,
+    "standard",
+    c(".sample_name", ".abs", ".is_outlier", ".pred_conc", ".coord", ".conc"),
+    c(".sample_name", ".pred_conc", ".conc")
+  )
+  table_data |>
+    make_gt(35, 1, c(".abs", ".pred_conc", ".conc")) |>
+    gt::cols_label(
+      .sample_name = "Sample", .conc = "[Actual]",
+      .pred_conc = "[Predicted]", .abs = "Absorbance", gg = ""
+    )
+}
+
+#' @export
+qp_standards_all.list <- function(x) {
+  x$qp <- qp_standards_all.data.frame(x$qp)
+  x
+}
+
+## Summary ----
+qp_standards_summary <- function(x) {
+  UseMethod("qp_standards_summary")
+}
+
+#' @export
+qp_standards_summary.data.frame <- function(x) {
+  x <- add_coords_col(x)
+  table_data <- add_well_circles_plot_col(
+    x,
+    "standard",
+    c(".sample_name", ".pred_conc_mean", ".is_outlier", ".abs", ".coord"),
+    c(".sample_name", ".pred_conc_mean"),
+    summary = TRUE
+  )
+  table_data |>
+    make_gt(50, 2, ".pred_conc_mean") |>
+    gt::cols_label(
+      .sample_name = "Sample", .pred_conc_mean = "Concentration", gg = ""
+    )
+}
+
+#' @export
+qp_standards_summary.list <- function(x) {
+  x$qp <- qp_standards_summary.data.frame(x$qp)
+  x
+}
+
+
+# Samples -----
+## All ----
+qp_samples_all <- function(x) {
+  UseMethod("qp_samples_all")
+}
+
+#' @export
+qp_samples_all.data.frame <- function(x) {
+  x <- add_coords_col(x)
+  table_data <- add_well_circles_plot_col(
+    x,
+    "unknown",
+    c(".sample_name", ".abs", ".is_outlier", ".pred_conc", ".coord"),
+    group_vars = c(".sample_name", ".pred_conc")
+  )
+  table_data |>
+    make_gt(35, 1, c(".abs", ".pred_conc")) |>
+    gt::cols_label(
+      .sample_name = "Sample", .pred_conc = "[Predicted]",
+      .abs = "Absorbance", gg = ""
+    )
+}
+
+#' @export
+qp_samples_all.list <- function(x) {
+  x$qp <- qp_samples_all.data.frame(x$qp)
+  x
+}
+
+## Summary ----
+qp_samples_summary <- function(x) {
+  UseMethod("qp_samples_summary")
+}
+
+#' @export
+qp_samples_summary.data.frame <- function(x) {
+  x <- add_coords_col(x)
+  table_data <- add_well_circles_plot_col(
+    x,
+    "unknown",
+    c(".sample_name", ".pred_conc_mean", ".is_outlier", ".abs", ".coord"),
+    c(".sample_name", ".pred_conc_mean"),
+    summary = TRUE
+  )
+  table_data |>
+    make_gt(50, 2, ".pred_conc_mean") |>
+    gt::cols_label(
+      .sample_name = "Sample", .pred_conc_mean = "Concentration", gg = ""
+    )
+}
+
+#' @export
+qp_samples_summary.list <- function(x) {
+  x$qp <- qp_samples_summary.data.frame(x$qp)
+  x
+}
+
+make_well_circles_plot <- function(df) {
+  x <- seq_along(df$.abs)
+  y <- 1
+  if (nrow(df) == 1) {
+    size <- 120
+  } else {
+    size <- 200 / nrow(df)
+  }
+
+  well <- data.frame(x = x, y = y, color = abs_to_col(df$.abs, qp_pal))
+
+  text <- data.frame(
+    x = x, y = y, color = ifelse(df$.abs > 0.3, "white", "black"),
+    label = df$.coord
+  )
+
+  cross <- data.frame(
+    x = x, y = y, color = ifelse(df$.is_outlier, "red", "#FFFFFF00")
+  )
+
+  ggplot2::ggplot(
+    well, ggplot2::aes(.data$x, .data$y, color = .data$color)
+  ) +
+    ggplot2::geom_point(size = size, shape = 16) +
+    ggplot2::geom_text(
+      data = text, ggplot2::aes(label = .data$label), size = size / 2.5
+    ) +
+    ggplot2::geom_point(data = cross, shape = 4, size = size, stroke = 4) +
+    ggplot2::theme_void() +
+    ggplot2::coord_cartesian(clip = "off") +
+    ggplot2::scale_color_identity() +
+    ggplot2::theme(plot.margin = ggplot2::margin(0, 1.5, 0, 1.5, unit = "cm"))
+}
+
+add_well_circles_plot_col <- function(x,
+                                      sample_type,
+                                      select_vars,
+                                      group_vars,
+                                      summary = FALSE) {
+  x <- dplyr::filter(x, .data$sample_type == .env$sample_type)
+
+  x <- x |>
+    dplyr::select(dplyr::all_of(select_vars)) |>
+    dplyr::group_by(dplyr::across(dplyr::all_of(group_vars))) |>
+    tidyr::nest() |>
+    dplyr::mutate(gg = purrr::map(.data$data, make_well_circles_plot))
+
+  if (summary) {
+    x <- dplyr::select(x, -"data")
+  } else {
+    x <- x |>
+      tidyr::unnest(.data$data) |>
+      dplyr::select(-c(".is_outlier", ".coord"))
+  }
+
+  dplyr::ungroup(x)
+}
+
+add_coords_col <- function(x) {
+  x$.coord <- paste0(LETTERS[x$.row], x$.col)
+  x
+}
+
+make_gt <- function(x, well_img_height, well_img_aspect_ratio, cols_to_round) {
+  x |>
+    gt::gt() |>
+    gt::text_transform(
+      location = gt::cells_body(
+        columns = .data$gg
+      ),
+      fn = function(z) {
+        gt::ggplot_image(
+          x$gg,
+          height = gt::px(well_img_height),
+          aspect_ratio = well_img_aspect_ratio
+        )
+      }
+    ) |>
+    gt::fmt_number(
+      dplyr::all_of(cols_to_round),
+      n_sigfig = 2
+    )
+}
+
+dil_summary <- function(qp) {
+  check_has_cols(qp, c(
+    ".sample_name", ".pred_conc_mean", ".target_conc",
+    ".target_vol", "sample_type"
+  ))
+
+  qp |>
+    dplyr::summarize(
+      .by = c(
+        ".sample_name", ".pred_conc_mean", ".target_conc",
+        ".target_vol", "sample_type"
+      )
+    ) |>
+    qp_dilute() |>
+    dplyr::filter(.data$sample_type == "unknown") |>
+    dplyr::select(
+      Name = ".sample_name",
+      ".pred_conc_mean", ".target_conc",
+      `Final Vol` = ".target_vol",
+      `Sample to Add (uL)` = "sample_to_add",
+      `Diluent to Add (uL)` = "add_to"
+    ) |>
+    dplyr::mutate(
+      .target_conc = round(.data$.target_conc, 2),
+      .pred_conc_mean = round(.data$.pred_conc_mean, 2)
+    ) |>
+    dplyr::rename(
+      "[Target]" = .data$.target_conc,
+      "[Sample]" = .data$.pred_conc_mean
+    )
 }

R/qp_summarize.R

@@ -21,7 +21,7 @@ qp_summarize.data.frame <- function(x) {
   }
   x |>
     dplyr::summarize(
-      .mean_pred_conc = mean(.data$.pred_conc_mean, na.rm = TRUE),
+      .pred_conc_mean = mean(.data$.pred_conc_mean, na.rm = TRUE),
       .by = c(".sample_name", "sample_type")
     ) |>
     dplyr::arrange(.data$sample_type)

_pkgdown.yml

@@ -30,6 +30,7 @@ reference:
     - qp_summarize
     - qp_plot_plate
     - qp_plot_standards
+    - qp_report
   - title: "Data"
     contents:
     - absorbances