Skip to content

Sample pca filtering #60

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
loguille wants to merge 3 commits into
base: main
Choose a base branch
from
+113 −118
Open

Sample pca filtering #60

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
52cd824
add a selector for PCA #52
loguille Apr 8, 2026
0efad9b
Change disposition of parameters for pca
loguille Apr 8, 2026
a073d1a
Change buttons label
loguille Apr 10, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
133 changes: 60 additions & 73 deletions R/interface_module_qc_metrics.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,39 +14,65 @@ interface_module_qc_metrics <- function(id, type) {
tagList(
fluidRow(
box(
title = "PCA",
title = "Parameters",
status = "primary",
width = 12,
solidHeader = TRUE,
collapsible = TRUE,
fluidRow(
column(
6,
selectInput(
inputId = NS(id, "selected_assay"),
choices = NULL,
label = "Select set"
)
),
column(
6,
selectInput(
inputId = NS(id, "selected_method"),
choices = c("nipals"),
label = "Select Reduction Method"
)
)
width = 4,
solidHeader = FALSE,
collapsible = FALSE,
selectInput(
inputId = NS(id, "assay_type"),
choices = c("samples", "features"),
label = "Select the assay type for representation",
selected = "samples"
),
Comment on lines +22 to +27
Copy link

Copilot AI Apr 10, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

interface_module_qc_metrics() receives a type argument (passed by interface_module_filtering_tab() as either "samples" or "features"), but the new assay_type selector is hard-coded to selected = "samples" and the type argument is otherwise unused. This makes the default PCA orientation inconsistent with the filtering tab type. Consider validating type via match.arg() and using it as the default selected value (or remove the type parameter entirely if it’s no longer intended to control the UI).

Copilot uses AI. Check for mistakes.
selectInput(
inputId = NS(id, "selected_assay"),
choices = NULL,
label = "Select set"
Copy link
Copy Markdown
Member

@leopoldguyot leopoldguyot Apr 8, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Select set for which to apply the dimension reduction

),
selectInput(
inputId = NS(id, "selected_method"),
choices = c("nipals", "ppca", "svdImpute"),
label = "Select Reduction Method"
),
selectInput(
inputId = NS(id, "pca_color"),
label = "Color by",
choices = NULL
),
checkboxInput(
inputId = NS(id, "scale"),
label = "Scale data",
value = TRUE
),
checkboxInput(
inputId = NS(id, "center"),
label = "Center data",
value = TRUE
),
checkboxInput(
inputId = NS(id, "show_legend"),
label = "Show Legend",
value = FALSE
),
fluidRow(
interface_module_pca_box(
NS(id, "features"),
title = "Features PCA"
),
interface_module_pca_box(
NS(id, "samples"),
title = "Samples PCA"
)
numericInput(
inputId = NS(id, "color_width"),
label = "Color value max length (chr)",
value = 10,
min = 5,
max = 30
)

),
box(
title = "PCA",
status = "primary",
width = 8,
solidHeader = FALSE,
collapsible = FALSE,
interface_module_pca_box(
NS(id, "features")
)
)
),
fluidRow(
Expand Down Expand Up @@ -75,48 +101,9 @@ interface_module_qc_metrics <- function(id, type) {
#' @importFrom shiny selectInput checkboxInput numericInput NS
#' @importFrom plotly plotlyOutput
#'
interface_module_pca_box <- function(id, title) {
box(
title = title,
status = "primary",
width = 6,
solidHeader = FALSE,
collapsible = FALSE,
sidebar = boxSidebar(
id = NS(id, "pca_sidebar"),
width = 50,
startOpen = FALSE,
selectInput(
inputId = NS(id, "pca_color"),
label = "Color by",
choices = NULL
),
checkboxInput(
inputId = NS(id, "scale"),
label = "Scale data",
value = TRUE
),
checkboxInput(
inputId = NS(id, "center"),
label = "Center data",
value = TRUE
),
checkboxInput(
inputId = NS(id, "show_legend"),
label = "Show Legend",
value = FALSE
),
numericInput(
inputId = NS(id, "color_width"),
label = "Color value max length (chr)",
value = 10,
min = 5,
max = 30
)
),
with_output_waiter(plotlyOutput(outputId = NS(id, "pca")),
html = waiter::spin_6(),
color = "transparent"
)
interface_module_pca_box <- function(id) {
with_output_waiter(plotlyOutput(outputId = NS(id, "pca")),
html = waiter::spin_6(),
color = "transparent"
)
}
Comment on lines +104 to 109
Copy link

Copilot AI Apr 10, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The roxygen documentation for interface_module_pca_box() is outdated: it still documents a title parameter and describes returning a box/boxSidebar, but the function now only returns the plotlyOutput wrapped with with_output_waiter(). Please update/remove the stale @param title and adjust the return description/import tags accordingly.

Copilot uses AI. Check for mistakes.
98 changes: 53 additions & 45 deletions R/server_module_qc_metrics.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ server_module_qc_metrics <- function(id, assays_to_process) {
choices = names(choices)
)
})

single_assay <- reactive({
req(input$selected_assay)
req(assays_to_process())
Expand All @@ -37,18 +38,36 @@ server_module_qc_metrics <- function(id, assays_to_process) {
assays_choices_vector()[input$selected_assay]
))
})
annotation_names <- reactive({
req(single_assay())
if (input$assay_type == "features") {
c("NULL", colnames(rowData(single_assay())))
} else {
c("NULL", colnames(colData(single_assay())))
}
})

observe({
req(single_assay())
req(annotation_names())
stopifnot(is(single_assay(), "SummarizedExperiment"))
updateSelectInput(session,
"pca_color",
choices = annotation_names(),
selected = "NULL"
)
})

server_module_pca_box(
id = "features",
single_assay = single_assay,
method = input$selected_method,
transpose = FALSE
)
server_module_pca_box(
id = "samples",
single_assay = single_assay,
method = input$selected_method,
transpose = TRUE
id = "features",
single_assay = single_assay,
method = reactive(input$selected_method),
pca_type = reactive(input$assay_type),
scale = reactive(input$scale),
center = reactive(input$center),
color = reactive(input$pca_color),
show_legend = reactive(input$show_legend),
color_width = reactive(input$color_width)
)

server_module_viz_box("viz_box", assays_to_process)
Expand All @@ -73,46 +92,35 @@ server_module_qc_metrics <- function(id, assays_to_process) {
#' @importFrom pcaMethods pca scores
#' @importFrom methods is
#'
server_module_pca_box <- function(id, single_assay, method, transpose) {
server_module_pca_box <- function(id, single_assay, method, pca_type, scale, center, show_legend, color, color_width) {
Copy link

Copilot AI Apr 10, 2026

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The roxygen documentation for server_module_pca_box() is now out of sync with the function signature and behavior (it still documents transpose and says only "nipals" is valid, but the function now takes pca_type, scale, center, show_legend, color, and color_width, and transpose is derived from pca_type()). Please update the @param entries to match the new arguments and semantics.

Copilot uses AI. Check for mistakes.
moduleServer(id, function(input, output, session) {
annotation_names <- reactive({
req(single_assay())
if (id == "features") {
c("NULL", colnames(rowData(single_assay())))
} else {
c("NULL", colnames(colData(single_assay())))
}
})

observe({
req(single_assay())
req(annotation_names())
stopifnot(is(single_assay(), "SummarizedExperiment"))
updateSelectInput(session,
"pca_color",
choices = annotation_names(),
selected = "NULL"
)
})
stopifnot(is.reactive(method))
stopifnot(is.reactive(pca_type))
stopifnot(is.reactive(scale))
stopifnot(is.reactive(center))
stopifnot(is.reactive(show_legend))
stopifnot(is.reactive(color))
stopifnot(is.reactive(color_width))


color_data <- reactive({
req(single_assay())
req(input$pca_color)
if (input$pca_color != "NULL") {
if (id == "features") {
df <- rowData(single_assay())[, input$pca_color, drop = FALSE]
req(color())
if (color() != "NULL") {
if (pca_type() == "features") {
df <- rowData(single_assay())[, color(), drop = FALSE]
} else {
df <- colData(single_assay())[, input$pca_color, drop = FALSE]
df <- colData(single_assay())[, color(), drop = FALSE]
}
if (is.character(df[, 1])) {
df[, 1] <- ifelse(nchar(df[, 1]) > input$color_width,
paste0(substr(df[, 1], 1, input$color_width), "..."), df[, 1]
df[, 1] <- ifelse(nchar(df[, 1]) > color_width(),
paste0(substr(df[, 1], 1, color_width()), "..."), df[, 1]
)
}
if (all(is.na(df))) {
df[, 1] <- "NA"
}
colnames(df) <- input$pca_color
colnames(df) <- color()
return(df)
}
})
Expand All @@ -124,18 +132,18 @@ server_module_pca_box <- function(id, single_assay, method, transpose) {
req(ncol(single_assay()) > 0L)
pcaMethods_wrapper(
single_assay(),
method = method,
transpose = transpose,
scale = input$scale,
center = input$center
method = method(),
transpose = pca_type() == "samples",
scale = scale(),
center = center()
)
})
dataframe <- reactive({
req(single_assay())
req(!is_empty_set(single_assay()))
req(ncol(single_assay()) > 0L)
req(pca_result())
if (input$pca_color == "NULL") {
if (color() == "NULL") {
as.data.frame(
data.frame(scores(pca_result()))
)
Expand Down Expand Up @@ -195,8 +203,8 @@ server_module_pca_box <- function(id, single_assay, method, transpose) {
component_name = "PCA quality control plot",
df = dataframe(),
pca_result = pca_result(),
color_name = input$pca_color,
show_legend = input$show_legend
color_name = color(),
show_legend = show_legend()
)
})
})
Expand Down
Loading