From e02c65ebb1d191c890598d248b1582e69f8e402c Mon Sep 17 00:00:00 2001 From: Giulio Benedetti Date: Fri, 3 May 2024 18:04:37 +0300 Subject: [PATCH 1/2] Improve RDAPlot panel with data and selection params --- R/class-AbundancePlot.R | 9 ++- R/class-RDAPlot.R | 154 +++++++++++++++++++++++++++------------- R/class-RowTreePlot.R | 4 +- 3 files changed, 116 insertions(+), 51 deletions(-) diff --git a/R/class-AbundancePlot.R b/R/class-AbundancePlot.R index 8680494..0976ef8 100644 --- a/R/class-AbundancePlot.R +++ b/R/class-AbundancePlot.R @@ -106,8 +106,15 @@ setMethod(".fullName", "AbundancePlot", function(x) "Abundance plot") setMethod(".panelColor", "AbundancePlot", function(x) "#00E5EE") +#' @importFrom iSEE .getEncodedName +#' @importFrom shiny plotOutput +#' @importFrom shinyWidgets addSpinner setMethod(".defineOutput", "AbundancePlot", function(x) { - plotOutput(.getEncodedName(x)) + panel_name <- .getEncodedName(x) + addSpinner( + plotOutput(panel_name, height = paste0(slot(x, "PanelHeight"), "px")), + color=.panelColor(x) + ) }) #' @importFrom miaViz plotRowTree diff --git a/R/class-RDAPlot.R b/R/class-RDAPlot.R index 7334c05..327d5c3 100644 --- a/R/class-RDAPlot.R +++ b/R/class-RDAPlot.R @@ -52,14 +52,16 @@ setClassUnion("charlog", c("character", "logical")) #' @export setClass("RDAPlot", contains="Panel", - slots=c(add.ellipse="charlog", colour_by="character", vec.text="logical", add.vectors="logical")) + slots=c(dimred="character", add.ellipse="charlog", + colour_by="character", vec.text="logical", + add.vectors="logical")) #' @importFrom iSEE .singleStringError .validLogicalError #' @importFrom S4Vectors setValidity2 setValidity2("RDAPlot", function(x) { msg <- character(0) - msg <- .singleStringError(msg, x, fields="colour_by") + msg <- .singleStringError(msg, x, fields=c("dimred", "colour_by")) msg <- .validLogicalError(msg, x, fields=c("vec.text", "add.vectors")) @@ -73,6 +75,7 @@ setValidity2("RDAPlot", function(x) { #' @importFrom methods callNextMethod setMethod("initialize", "RDAPlot", function(.Object, ...) { args <- list(...) + args <- .emptyDefault(args, "dimred", "RDA") args <- .emptyDefault(args, "add.ellipse", "fill") args <- .emptyDefault(args, "colour_by", NA_character_) args <- .emptyDefault(args, "add.vectors", TRUE) @@ -87,34 +90,31 @@ RDAPlot <- function(...) { new("RDAPlot", ...) } -#' @importFrom iSEE .getEncodedName .selectInput.iSEE .checkboxInput.iSEE .conditionalOnCheckSolo +#' @importFrom iSEE .getEncodedName .selectInput.iSEE .numericInput.iSEE #' @importFrom methods slot -#' @importFrom SummarizedExperiment colData +#' @importFrom SingleCellExperiment reducedDimNames +setMethod(".defineDataInterface", "RDAPlot", function(x, se, select_info) { + panel_name <- .getEncodedName(x) + + list( + .selectInput.iSEE( + x, field="dimred", label="Reduced dimension", + choices=reducedDimNames(se), selected=slot(x, "dimred") + ) + ) + +}) + +#' @importFrom methods callNextMethod setMethod(".defineInterface", "RDAPlot", function(x, se, select_info) { - tab_name <- .getEncodedName(x) - # Define what parameters the user can adjust - collapseBox(paste0(tab_name, "_Visual"), - title="Visual parameters", - open=FALSE, - .selectInput.iSEE( - x, field="colour_by", label="Color by", - choices=names(colData(se)), selected=slot(x, "colour_by") - ), - .selectInput.iSEE( - x, field="add.ellipse", label="Ellipse style", - choices = c("fill", "colour", "FALSE"), selected=slot(x, "add.ellipse") - ), - .checkboxInput.iSEE( - x, field="add.vectors", label="Add vectors", value=slot(x, "add.vectors") - ), - .conditionalOnCheckSolo( - paste0(tab_name, "_add.vectors"), TRUE, - .checkboxInput.iSEE(x, field="vec.text", - label="Unboxed labels", - value=slot(x, "vec.text")) - ) + out <- callNextMethod() + list( + out[1], + .create_visual_box_for_rda(x, se), + out[-1] ) + }) #' @importFrom iSEE .getEncodedName .createProtectedParameterObservers @@ -125,7 +125,7 @@ setMethod(".createObservers", "RDAPlot", function(x, se, input, session, pObject .createProtectedParameterObservers( panel_name, - c("add.ellipse", "colour_by", "vec.text", "add.vectors"), + c("dimred", "add.ellipse", "colour_by", "vec.text", "add.vectors"), input=input, pObjects=pObjects, rObjects=rObjects ) @@ -137,49 +137,107 @@ setMethod(".fullName", "RDAPlot", function(x) "RDA plot") setMethod(".panelColor", "RDAPlot", function(x) "#CD5B45") #' @importFrom iSEE .getEncodedName +#' @importFrom shiny plotOutput +#' @importFrom shinyWidgets addSpinner setMethod(".defineOutput", "RDAPlot", function(x) { - plotOutput(.getEncodedName(x)) + panel_name <- .getEncodedName(x) + addSpinner( + plotOutput(panel_name, height = paste0(slot(x, "PanelHeight"), "px")), + color=.panelColor(x) + ) }) #' @importFrom iSEE .processMultiSelections .textEval #' @importFrom miaViz plotRowTree setMethod(".generateOutput", "RDAPlot", function(x, se, all_memory, all_contents) { - plot_env <- new.env() - plot_env$se <- se + panel_env <- new.env() - selected <- .processMultiSelections(x, all_memory, all_contents, plot_env) + all_cmds <- list() + args <- character(0) - # simplify this to plotRowTree - fn_call <- "gg <- %s(se" + all_cmds[["select"]] <- .processMultiSelections(x, all_memory, all_contents, panel_env) - args <- list() + if (is.null(panel_env[["col_selected"]])){ + panel_env[["se"]] <- se + } else { + panel_env[["se"]] <- se[ , unlist(panel_env[["col_selected"]])] + } + + args[["dimred"]] <- deparse(slot(x, "dimred")) args[["add.ellipse"]] <- deparse(slot(x, "add.ellipse")) args[["colour_by"]] <- deparse(slot(x, "colour_by")) args[["vec.text"]] <- deparse(slot(x, "vec.text")) args[["add.vectors"]] <- deparse(slot(x, "add.vectors")) - args <- paste(sprintf("%s=%s", names(args), unlist(args)), collapse=", ") - fn_call <- paste(fn_call, args, sep = ", ") - fn_call <- paste0(fn_call, ")") - fn_call <- paste(strwrap(fn_call, exdent=4), collapse="\n") + args <- sprintf("%s=%s", names(args), args) + args <- paste(args, collapse=", ") + fun_call <- sprintf("p <- miaViz::plotRDA(se, %s)", args) - plot_env$.customFUN <- function(se, ...) miaViz::plotRDA(se, "RDA", ...) - tmp_call <- sprintf(fn_call, ".customFUN") - .textEval(tmp_call, plot_env) + fun_cmd <- paste(strwrap(fun_call, width = 80, exdent = 4), collapse = "\n") + plot_out <- .textEval(fun_cmd, panel_env) + all_cmds[["fun"]] <- fun_cmd - commands <- sprintf(fn_call, "plotRDA") - - commands <- sub("^gg <- ", "", commands) # to avoid an unnecessary variable. - list(contents=plot_env$gg, commands=list(select=selected, plot=commands)) + list(commands=all_cmds, plot=plot_out, varname=NULL, contents=NULL) }) #' @importMethodsFrom iSEE .renderOutput #' @importFrom iSEE .getEncodedName .retrieveOutput #' @importFrom shiny renderPlot setMethod(".renderOutput", "RDAPlot", function(x, se, output, pObjects, rObjects) { - plot_name <- .getEncodedName(x) + panel_name <- .getEncodedName(x) force(se) # defensive programming to avoid difficult bugs due to delayed evaluation. - output[[plot_name]] <- renderPlot({ - .retrieveOutput(plot_name, se, pObjects, rObjects)$contents + + output[[panel_name]] <- renderPlot({ + .retrieveOutput(panel_name, se, pObjects, rObjects) }) + + callNextMethod() +}) + +#' @importFrom methods callNextMethod +setMethod(".hideInterface", "RDAPlot", function(x, field) { + if (field %in% c("SelectionHistory", "RowSelectionRestrict", + "RowSelectionDynamicSource", "RowSelectionSource")) { + TRUE + } else { + callNextMethod() + } +}) + +setMethod(".multiSelectionResponsive", "RDAPlot", function(x, dims = character(0)) { + if ("column" %in% dims) { + return(TRUE) + } + return(FALSE) }) + +#' @importFrom iSEE .getEncodedName .selectInput.iSEE .checkboxInput.iSEE +#' .conditionalOnCheckSolo +#' @importFrom methods slot +#' @importFrom SummarizedExperiment colData +.create_visual_box_for_rda <- function(x, se) { + panel_name <- .getEncodedName(x) + + # Define what parameters the user can adjust + collapseBox(paste0(panel_name, "_Visual"), + title="Visual parameters", + open=FALSE, + .selectInput.iSEE( + x, field="colour_by", label="Color by", + choices=names(colData(se)), selected=slot(x, "colour_by") + ), + .selectInput.iSEE( + x, field="add.ellipse", label="Ellipse style", + choices = c("fill", "colour", "FALSE"), selected=slot(x, "add.ellipse") + ), + .checkboxInput.iSEE( + x, field="add.vectors", label="Add vectors", value=slot(x, "add.vectors") + ), + .conditionalOnCheckSolo( + paste0(panel_name, "_add.vectors"), TRUE, + .checkboxInput.iSEE(x, field="vec.text", + label="Unboxed labels", + value=slot(x, "vec.text")) + ) + ) +} diff --git a/R/class-RowTreePlot.R b/R/class-RowTreePlot.R index 030048c..6428642 100644 --- a/R/class-RowTreePlot.R +++ b/R/class-RowTreePlot.R @@ -136,9 +136,9 @@ setMethod(".panelColor", "RowTreePlot", function(x) "#4EEE94") #' @importFrom shiny plotOutput #' @importFrom shinyWidgets addSpinner setMethod(".defineOutput", "RowTreePlot", function(x) { - plot_name <- .getEncodedName(x) + panel_name <- .getEncodedName(x) addSpinner( - plotOutput(plot_name, height = paste0(slot(x, "PanelHeight"), "px")), + plotOutput(panel_name, height = paste0(slot(x, "PanelHeight"), "px")), color=.panelColor(x) ) }) From b50304199823cf85fb767370702658e01cd88945 Mon Sep 17 00:00:00 2001 From: Giulio Benedetti Date: Fri, 3 May 2024 18:25:28 +0300 Subject: [PATCH 2/2] Add preliminary tests for RowTreePlot and RDAPlot --- tests/testthat/test-RDAPlot.R | 15 +++++++++++++++ tests/testthat/test-RowTreePlot.R | 15 +++++++++++++++ 2 files changed, 30 insertions(+) create mode 100644 tests/testthat/test-RDAPlot.R create mode 100644 tests/testthat/test-RowTreePlot.R diff --git a/tests/testthat/test-RDAPlot.R b/tests/testthat/test-RDAPlot.R new file mode 100644 index 0000000..4d74d48 --- /dev/null +++ b/tests/testthat/test-RDAPlot.R @@ -0,0 +1,15 @@ +test_that("RDAPlot", { + + panel <- RDAPlot() + + expect_identical(.fullName(panel), "RDA plot") + expect_identical(.panelColor(panel), "#CD5B45") + + expect_false(.multiSelectionResponsive(panel, "row")) + expect_true(.multiSelectionResponsive(panel, "column")) + + expect_contains(slotNames(panel), + c("dimred", "add.ellipse", "colour_by", + "vec.text", "add.vectors")) + +}) \ No newline at end of file diff --git a/tests/testthat/test-RowTreePlot.R b/tests/testthat/test-RowTreePlot.R new file mode 100644 index 0000000..917c5d7 --- /dev/null +++ b/tests/testthat/test-RowTreePlot.R @@ -0,0 +1,15 @@ +test_that("RowTreePlot", { + + panel <- RowTreePlot() + + expect_identical(.fullName(panel), "Row tree plot") + expect_identical(.panelColor(panel), "#4EEE94") + + expect_false(.multiSelectionResponsive(panel, "column")) + expect_true(.multiSelectionResponsive(panel, "row")) + + expect_contains(slotNames(panel), + c("layout", "add_legend", "edge_colour", "edge_colour_by", + "tip_colour", "tip_colour_by")) + +}) \ No newline at end of file