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

Merged
loguille merged 5 commits into from
Apr 16, 2026
Merged

Sample pca filtering #60

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 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
ce716dc
Change description of function
loguille Apr 15, 2026
c84a387
No longer box but plotly
loguille Apr 15, 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
139 changes: 62 additions & 77 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 dimension reduction type",
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 the set for dimension reduction"
),
selectInput(
inputId = NS(id, "selected_method"),
choices = c("nipals", "ppca", "svdImpute"),
label = "Select Dimension Reduction Method"
),
fluidRow(
interface_module_pca_box(
NS(id, "features"),
title = "Features PCA"
),
interface_module_pca_box(
NS(id, "samples"),
title = "Samples PCA"
)
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
)

),
box(
title = "Dimension Reduction",
status = "primary",
width = 8,
solidHeader = FALSE,
collapsible = FALSE,
interface_module_pca(
NS(id, "features")
)
)
),
fluidRow(
Expand All @@ -63,60 +89,19 @@ interface_module_qc_metrics <- function(id, type) {
)
}

#' PCA Box interface module
#' PCA plot interface module
#'
#' @param id module id
#' @param title title of the box
#' @return a box object that contains the UI for the pca module
#' @return a plotly for PCA
#' @rdname INTERNAL_interface_module_pca_box
#' @keywords internal
#'
#' @importFrom shinydashboardPlus box boxSidebar
#' @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 <- function(id) {
with_output_waiter(plotlyOutput(outputId = NS(id, "pca")),
html = waiter::spin_6(),
color = "transparent"
)
}
109 changes: 61 additions & 48 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 @@ -60,9 +79,14 @@ server_module_qc_metrics <- function(id, assays_to_process) {
#' @param id module id
#' @param single_assay a reactiveVal that contains the selected assay
#' @param method a character string specifying the PCA method to use
#' valid values are c("nipals")
#' @param transpose a boolean that specifies if the PCA should be transposed
#' TRUE for samples and FALSE for features
#' valid values are c("nipals", "ppca", "svdImpute")
#' @param pca_type sample or features
#' @param scale a boolean that specifies if the data should be scaled
#' @param center a boolen that specifies if the data should be centered
#' @param show_legend a boolean that specifies if the legend should be shown
#' @param color which metadata use for color
#' @param color_width how many letter display in the legend
#'
#' @return A shiny module server function that contains the PCA logic
#' @rdname INTERNAL_server_module_pca_box
#' @keywords internal
Expand All @@ -73,46 +97,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.
Copy link
Copy Markdown
Collaborator Author

@loguille loguille Apr 15, 2026

Choose a reason for hiding this comment

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

solve in future commit

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 +137,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 +208,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