diff --git a/.github/workflows/run-rstudio.yml b/.github/workflows/run-rstudio.yml new file mode 100644 index 0000000..0b7034e --- /dev/null +++ b/.github/workflows/run-rstudio.yml @@ -0,0 +1,34 @@ +name: Run RStudio Locally (devel) + +on: + workflow_dispatch: # Allows manual trigger from GitHub UI + +jobs: + run-rstudio: + runs-on: self-hosted + + steps: + - name: Checkout devel branch + uses: actions/checkout@v3 + with: + ref: devel # Specify the devel branch + + - name: Pull latest base image (optional, ensures updates) + run: docker pull rocker/rstudio:latest + + - name: Build Docker image from devel branch + run: docker build -t local-rstudio:latest -f Dockerfile.rstudio . + + - name: Stop and Remove Previous RStudio Container + run: | + docker ps -q --filter "name=rstudio-container" | grep -q . && docker stop rstudio-container || true + docker ps -aq --filter "name=rstudio-container" | grep -q . && docker rm rstudio-container || true + + - name: Run New RStudio Server Container + run: | + docker run -d \ + -p 8787:8787 \ + --name rstudio-container local-rstudio:latest + + - name: Print Access URL + run: echo "RStudio Server running at http://localhost:8787/auth-sign-in?username=admin&password=admin" diff --git a/DESCRIPTION b/DESCRIPTION index 0a4879d..96aec46 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,7 +39,9 @@ Imports: SummarizedExperiment, TreeSummarizedExperiment, utils, - vegan + vegan, + SingleCellExperiment, + SummarizedExperiment Suggests: BiocStyle, knitr, diff --git a/Dockerfile b/Dockerfile index 577ab35..d931e43 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,14 +1,18 @@ -FROM bioconductor/bioconductor_docker:devel - +FROM bioconductor/bioconductor_docker:RELEASE_3_16 LABEL authors="giulio.benedetti@utu.fi" \ - description="Docker image containing the miaDash package in a bioconductor/bioconductor_docker:devel container." - + description="Docker image containing the miaDash package in a bioconductor/bioconductor_docker container." WORKDIR /home/rstudio/miadash - COPY --chown=rstudio:rstudio . /home/rstudio/miadash - RUN apt-get update && apt-get install -y libglpk-dev && apt-get clean && rm -rf /var/lib/apt/lists/* -ENV R_REMOTES_NO_ERRORS_FROM_WARNINGS=true +# Install BiocManager and update Bioconductor +RUN R -e "if (!require('BiocManager', quietly = TRUE)) install.packages('BiocManager', repos='https://cloud.r-project.org/'); BiocManager::install(ask=FALSE)" + +# Try to install iSEEtree from Bioconductor +RUN R -e "BiocManager::install('iSEEtree')" -RUN Rscript -e "devtools::install('.', dependencies = TRUE, repos = BiocManager::repositories(), build_vignettes = TRUE)" +# Install the package +RUN R -e "devtools::install('.', dependencies = TRUE, repos = BiocManager::repositories(), build_vignettes = FALSE)" + +# Set environment variable to avoid warnings becoming errors +ENV R_REMOTES_NO_ERRORS_FROM_WARNINGS=true diff --git a/Dockerfile.rstudio b/Dockerfile.rstudio new file mode 100644 index 0000000..e628c07 --- /dev/null +++ b/Dockerfile.rstudio @@ -0,0 +1,16 @@ +FROM rocker/rstudio:latest + +# Set default credentials for the rstudio user +ENV PASSWORD=admin + +# Install additional R packages (optional) +RUN R -e "install.packages(c('tidyverse', 'shiny', 'devtools', 'remotes'))" + +# Create a new user "admin" with password "admin" +RUN useradd -m -s /bin/bash admin && \ + echo "admin:admin" | chpasswd && \ + adduser admin sudo && \ + chown -R admin:admin /home/admin + +# Expose RStudio Server port +EXPOSE 8787 diff --git a/R/landing_page.R b/R/landing_page.R index 99b9f26..4966aa0 100644 --- a/R/landing_page.R +++ b/R/landing_page.R @@ -12,7 +12,7 @@ #' @rdname landing_page #' @importFrom shinydashboard dashboardPage dashboardHeader dashboardSidebar #' dashboardBody box -#' @importFrom htmltools HTML br tags div tagList +#' @importFrom htmltools HTML br tags div tagList span h4 h5 p hr #' @importFrom shinyjs disable #' @importFrom utils data .landing_page <- function(FUN, input, output, session) { @@ -24,10 +24,54 @@ dashboardPage( - dashboardHeader(disable = TRUE), + dashboardHeader( + title = div( + span("miaDash", style = "margin-right: 15px;"), + div( + style = "display: inline-block; margin-left: 10px;", + selectizeInput( + inputId = "global_experiment_selector", + label = NULL, + choices = c("Main" = "main"), + width = "200px", + options = list( + placeholder = "Select experiment" + ) + ) + ), + style = "display: flex; align-items: center;" + ), + titleWidth = 350 + ), dashboardSidebar(disable = TRUE), dashboardBody( - + + fluidRow( + id = "experiment_info", + style = "margin-bottom: 15px;", + div( + class = "col-md-12", + div( + class = "info-box bg-light-blue", + div( + class = "info-box-content", + span(class = "info-box-text", "Current Experiment"), + span( + class = "info-box-number", + textOutput("current_experiment_name", inline = TRUE) + ), + div( + style = "margin-top: 5px;", + htmlOutput("current_experiment_meta") + ) + ), + div( + class = "info-box-icon", + tags$i(class = "fa fa-flask") + ) + ) + ) + ), tags$head(tags$style(HTML(".btn-primary {color: white}"))), fluidRow(box(id = "import.panel", title = "Import", width = 4, @@ -70,6 +114,24 @@ label = "colTree:", placeholder = "col.tree", accept = c(".tree", ".tre")), div(style = "margin-top: -20px")), + + + + tabPanel(title = "Merged Data", value = "merged", br(), + fileInput(inputId = "merged_file", label = "Merged Dataset:", + accept = ".rds", placeholder = "merged_dataset.rds"), + selectInput(inputId = "agglomeration_levels", + label = "Auto-create experiments for taxonomic levels:", + choices = c("None", "All", "Custom"), + selected = "None"), + conditionalPanel( + condition = "input.agglomeration_levels == 'Custom'", + checkboxGroupInput(inputId = "custom_levels", + label = "Select levels:", + choices = c("Phylum", "Class", "Order", "Family", "Genus", "Species")) + )), + + tabPanel(title = "Foreign", value = "foreign", br(), @@ -109,31 +171,56 @@ box(id = "manipulate.panel", title = "Manipulate", width = 4, status = "primary", solidHeader = TRUE, collapsible = TRUE, + tabsetPanel(id = "manipulate", tabPanel(title = "Subset", value = "subset", br(), - radioButtons(inputId = "subkeep", label = "Keep:", choices = c("prevalent", "rare"), inline = TRUE), - + selectInput(inputId = "subassay", label = "Assay:", choices = NULL), - + sliderInput(inputId = "prevalence", value = 0, label = "Prevalence threshold:", step = 0.01, min = 0, max = 1), - + numericInput(inputId = "detection", value = 0, label = "Detection threshold:", min = 0, - step = 1)), + step = 1), + + # Move these elements inside the tabPanel + checkboxInput(inputId = "create_altexp", + label = "Create as alternative experiment", + value = FALSE), + + conditionalPanel( + condition = "input.create_altexp == true", + textInput(inputId = "altexp_name", + label = "Alternative experiment name:", + value = "") + ) + ), tabPanel(title = "Agglomerate", value = "agglomerate", - br(), - selectInput(inputId = "taxrank", - label = "Taxonomic rank:", choices = NULL)), + label = "Taxonomic rank:", choices = NULL), + + checkboxInput(inputId = "create_altexp", + label = "Create as alternative experiment", + value = FALSE), + + + conditionalPanel( + condition = "input.create_altexp == true", + textInput(inputId = "altexp_name", + label = "Alternative experiment name:", + value = "") + ) + + ), tabPanel(title = "Transform", value = "transform", br(), @@ -151,7 +238,35 @@ radioButtons(inputId = "margin", label = "Margin:", choices = c("samples", "features"), - inline = TRUE))), + inline = TRUE)), + + tabPanel(title = "Switch", value = "switch", br(), + selectInput( + inputId = "switch_experiment", + label = "Select experiment:", + choices = NULL + ), + + div( + id = "switch_experiment_info", + style = "margin-top: 15px; border: 1px solid #ddd; padding: 10px; border-radius: 5px; background-color: #f9f9f9;", + htmlOutput("switch_experiment_details") + ), + + div( + style = "margin-top: 15px; margin-bottom: 15px;", + p("The selected experiment will be used for all operations. Some panels may not be available depending on the experiment type.") + ), + + div( + style = "display: flex; justify-content: space-between;", + actionButton("do_switch", "Switch Experiment", class = "btn-primary"), + actionButton("refresh_experiments", "Refresh List", class = "btn-info", icon = icon("sync")) + ) + ), + + + ), actionButton("apply", "Apply", class = "btn-primary")), @@ -203,6 +318,59 @@ width = 4, status = "primary", solidHeader = TRUE, collapsible = TRUE, + div( + id = "viz_experiment_selector", + style = "border: 1px solid #ddd; border-radius: 5px; padding: 10px; margin-bottom: 15px; background-color: #f9f9f9;", + div( + style = "display: flex; justify-content: space-between; align-items: center;", + h4("Experiment Selection", style = "margin: 0;"), + div( + style = "text-align: right;", + actionButton("sync_experiment", "Sync with Current", + class = "btn-xs btn-info", + icon = icon("sync")) + ) + ), + div(style = "margin-top: 10px;"), + selectInput( + inputId = "experiment_choice", + label = "Experiment for Visualization:", + choices = c("Main" = "main"), + selected = "main" + ), + + + # Add experiment state management section + hr(), + div( + style = "margin-top: 10px;", + h5("Experiment Transitions", style = "margin-top: 0;"), + p("Panel configurations will be preserved when switching experiments.", + style = "font-size: 90%; margin-bottom: 10px;"), + checkboxInput(inputId = "remember_transitions", + label = "Remember my experiment transitions", + value = FALSE) + ), + div( + id = "experiment_history_panel", + style = "margin-top: 10px; max-height: 150px; overflow-y: auto; border: 1px solid #eee; padding: 5px; border-radius: 3px; display: none;", + h5("Transition History", style = "margin-top: 0;"), + uiOutput("experiment_history") + ), + + checkboxGroupInput( + inputId = "altexp_panels", + label = "Show in Panels:", + choices = c("Abundance Plot" = "AbundancePlot", + "Heatmap" = "ComplexHeatmapPlot", + "Data Table" = "RowDataTable"), + selected = "AbundancePlot" + ), + uiOutput("compatible_panels_info") + ), + + hr(), + selectInput(inputId = "panels", label = "Panels:", choices = c(default_panels, other_panels), multiple = TRUE, selected = c(default_panels)), @@ -229,6 +397,11 @@ disable("iSEE_INTERNAL_citation_info") # citation info rObjects <- reactiveValues(tse = NULL) + # Initialize experiment state management + rObjects$experiment_states <- .create_experiment_state_cache() + rObjects$experiment_history <- .create_history_tracker() + rObjects$panel_configurations <- .create_panel_config_storage() + rObjects$transition_preferences <- .create_transition_preferences() observe({ .print_message( @@ -250,15 +423,70 @@ }) .create_import_observers(input, rObjects) + .create_switch_observers(input, rObjects) .create_manipulate_observers(input, rObjects) .create_estimate_observers(input, rObjects) .update_observers(input, session, rObjects) + .create_experiment_state_observers(input, session, rObjects) .create_launch_observers(FUN, input, session, rObjects) .render_overview(output, rObjects) .render_download(output, rObjects) + + # Add in the output renderers section, after .render_download + output$experiment_history <- renderUI({ + history <- .get_history(rObjects$experiment_history) + if(length(history) == 0) { + return(p("No transitions recorded yet.", style = "font-style: italic; color: #777; text-align: center;")) + } + + history_items <- lapply(rev(history), function(item) { + time_ago <- difftime(Sys.time(), item$timestamp, units = "mins") + time_text <- if(time_ago < 1) { + "just now" + } else if(time_ago < 60) { + paste(round(time_ago), "min ago") + } else { + paste(round(time_ago/60), "hr ago") + } + + div( + class = "history-item", + style = "padding: 5px 0; border-bottom: 1px solid #eee;", + div( + span( + ifelse(item$from == "main", "Main", item$from), + style = "font-weight: bold;" + ), + " → ", + span( + ifelse(item$to == "main", "Main", item$to), + style = "font-weight: bold;" + ) + ), + div( + time_text, + style = "font-size: 80%; color: #777;" + ) + ) + }) + + do.call(tagList, history_items) + }) + # Also, adding an observer for the remember_transitions checkbox + observeEvent(input$remember_transitions, { + if (input$remember_transitions) { + # Show the history panel + shinyjs::show("experiment_history_panel") + } else { + # Hide the history panel + shinyjs::hide("experiment_history_panel") + } + }) + + invisible(NULL) # nocov end -} \ No newline at end of file +} diff --git a/R/miaDash.R b/R/miaDash.R index 16c870e..8b85973 100644 --- a/R/miaDash.R +++ b/R/miaDash.R @@ -24,20 +24,134 @@ #' @importFrom iSEE iSEE #' @importFrom utils packageVersion #' @importFrom htmltools tags +#' @importFrom SingleCellExperiment altExp altExpNames miaDash <- function() { addResourcePath("assets", system.file("assets", package = "miaDash")) - iSEE( + # Enhanced JavaScript for experiment switching + experiment_js <- " + window.iSEEApp = window.iSEEApp || {}; + + // Initialize panel tracking + window.iSEEApp.panels = {}; + + // Register panels when they're created + $(document).on('iSEE:panelCreated', function(event, panelId, panelType) { + window.iSEEApp.panels[panelId] = { + type: panelType, + config: {} + }; + }); + + // Track panel configuration changes + $(document).on('iSEE:panelSettingsChanged', function(event, panelId, settings) { + if (window.iSEEApp.panels[panelId]) { + window.iSEEApp.panels[panelId].config = settings; + Shiny.setInputValue('panel_config_changed', { + panel_id: panelId, + config: settings + }); + } + }); + + // Panel reconfiguration for experiment switching + window.iSEEApp.reconfigurePanels = function(experimentName) { + var expName = experimentName || $('#iSEE_INTERNAL_experiment_selector').val(); + + // For each panel in the current view + for (var panelId in window.iSEEApp.panels) { + var panelType = window.iSEEApp.panels[panelId].type; + + // Request panel-specific reconfiguration from server + Shiny.setInputValue('reconfigure_panel', { + panel_id: panelId, + panel_type: panelType, + experiment: expName + }); + + // Update experiment reference attribute if panel has it + $('.panel[data-panel-id=\"' + panelId + '\"]') + .attr('data-experiment', expName); + } + + // Show transition indicator + $('.experiment-transition-indicator').fadeIn(200).delay(500).fadeOut(200); + }; + + // Handle experiment selector changes + $(document).on('change', '#iSEE_INTERNAL_experiment_selector', function() { + var selectedExp = $(this).val(); + Shiny.setInputValue('iSEE_switch_experiment', selectedExp); + }); + + // Add keyboard shortcuts + $(document).keydown(function(e) { + // Alt+E to focus experiment selector + if (e.altKey && e.keyCode === 69) { // 'E' key + e.preventDefault(); + $('#iSEE_INTERNAL_experiment_selector').focus(); + } + + // Alt+Z for undo experiment switch + if (e.altKey && e.keyCode === 90) { // 'Z' key + e.preventDefault(); + $('#undo_experiment_switch').click(); + } + + // Alt+Y for redo experiment switch + if (e.altKey && e.keyCode === 89) { // 'Y' key + e.preventDefault(); + $('#redo_experiment_switch').click(); + } + }); + " + + # Custom CSS for experiment management UI + experiment_css <- " + .experiment-selector-container .selectize-control { + margin-bottom: 0; + } + .experiment-header-row { + width: 100%; + } + .experiment-transition-indicator { + position: absolute; + top: 0; + left: 0; + right: 0; + height: 3px; + background-color: #4CAF50; + display: none; + } + .experiment-management-container { + display: flex; + align-items: center; + justify-content: space-between; + width: 100%; + margin-bottom: 10px; + } + .current-experiment-info { + display: flex; + align-items: center; + } + .experiment-history-controls .btn-sm { + padding: 3px 6px; + font-size: 12px; + } + " + + return(iSEE( landingPage = .landing_page, appTitle = tags$div( paste0("Microbiome Analysis Dashboard - v", packageVersion("miaDash")), tags$img(src = "assets/mia_logo.png", height = "40px", style = "margin-left: 10px"), style = "cursor: pointer; font-weight: 500", - onclick = "window.location='https://miadash-microbiome.2.rahtiapp.fi/'") - - ) - + onclick = "window.location.href='https://miadash-microbiome.2.rahtiapp.fi/'; window.location.reload(true);" + ), + customJS = experiment_js, + customStyles = experiment_css + )) } #' @importFrom methods is @@ -49,33 +163,438 @@ miaDash <- function() { #' @importFrom TreeSummarizedExperiment rowLinks colLinks #' @importFrom mia taxonomyRanks #' @importFrom SummarizedExperiment rowData colData +#' @importFrom SummarizedExperiment altExp altExp<- altExpNames mainExpName #' @importFrom SingleCellExperiment reducedDims -.launch_isee <- function(FUN, initial, session, rObjects) { - +#' @importFrom htmltools tags tagList div hr icon +#' @importFrom shiny selectInput actionButton +.launch_isee <- function(FUN, initial, session, rObjects, input = NULL, initial_experiment = NULL) { # nocov start tse <- rObjects$tse + + # Determine experiment choice, with priority order: + # 1. Explicit initial_experiment parameter + # 2. Input$experiment_choice + # 3. Default to "main" + exp_name <- "main" + if (!is.null(initial_experiment) && initial_experiment != "") { + exp_name <- initial_experiment + } else if (!is.null(input) && !is.null(input$experiment_choice) && input$experiment_choice != "") { + exp_name <- input$experiment_choice + } + + # Get the current experiment based on selection + current_exp <- if(exp_name != "main") { + tryCatch({ + altExp(tse, exp_name) + }, error = function(e) { + # Handle case where the selected experiment doesn't exist + .print_message( + title = "Experiment Error:", + "The selected experiment could not be found. Defaulting to main experiment." + ) + exp_name <<- "main" # Reset exp_name to main + tse + }) + } else { + tse + } + + # Get stored panel configuration if available + if(exists("panel_configurations", rObjects) && + !is.null(rObjects$panel_configurations())) { + stored_config <- .get_panel_config( + rObjects$panel_configurations, exp_name, NULL) + + if(!is.null(stored_config)) { + # Use stored panel configuration if available + initial <- stored_config + } + } + + # Filter panels based on experiment type + if(exp_name != "main") { + # Define which panels are compatible with alternative experiments + altexp_panels <- c("RowDataTable", "ColumnDataTable", "AbundancePlot", + "AbundanceDensityPlot", "ComplexHeatmapPlot", + "ReducedDimensionPlot") + + # Only keep compatible panels + initial <- intersect(initial, altexp_panels) + + if(length(initial) == 0) { + # If no compatible panels remain, add a default one + initial <- c("AbundancePlot") + .print_message( + title = "Panel Compatibility Notice:", + "The selected panels are not compatible with alternative experiments.", + "Defaulting to AbundancePlot." + ) + } + } - initial <- lapply(initial, function(x) eval(parse(text = paste0(x, "()")))) - - initial <- .check_panel(tse, initial, "RowDataTable", rowData) - initial <- .check_panel(tse, initial, "ColumnDataTable", colData) - initial <- .check_panel(tse, initial, "RowTreePlot", rowLinks) - initial <- .check_panel(tse, initial, "AbundancePlot", taxonomyRanks) - initial <- .check_panel(tse, initial, "ReducedDimensionPlot", reducedDims) - initial <- .check_panel(tse, initial, "LoadingPlot", reducedDims) - initial <- .check_panel(tse, initial, "ColumnTreePlot", colLinks) + # Convert string panel names to actual panel objects with appropriate configuration + initial <- lapply(initial, function(x) { + if(is.character(x)) { + panel <- eval(parse(text = paste0(x, "()"))) + } else { + panel <- x + } + + # Configure panel based on experiment type + if(exp_name != "main") { + # Set experiment name for dimension reduction panels + if(inherits(panel, "DimensionReducedPanel") || + inherits(panel, "ReducedDimensionPlot")) { + # Use try-catch to handle any attribute setting errors + tryCatch({ + panel$ExperimentName <- exp_name + }, error = function(e) { + # Silently continue if attribute can't be set + }) + } + + # Handle visualization settings for alternative experiment panels + if(inherits(panel, "AbundancePlot") || + inherits(panel, "ComplexHeatmapPlot")) { + tryCatch({ + panel$ShowFeatureNames <- TRUE + if(grepl("^agglomerated_", exp_name)) { + panel$ShowAggregationLevel <- TRUE + } + }, error = function(e) { + # Silently continue if attributes can't be set + }) + } + } + + return(panel) + }) + + # Check if panels are compatible with the current experiment + initial <- .check_panel(tse, initial, "RowDataTable", rowData, exp_name) + initial <- .check_panel(tse, initial, "ColumnDataTable", colData, exp_name) + initial <- .check_panel(tse, initial, "RowTreePlot", rowLinks, exp_name) + initial <- .check_panel(tse, initial, "AbundancePlot", taxonomyRanks, exp_name) + initial <- .check_panel(tse, initial, "ReducedDimensionPlot", reducedDims, exp_name) + initial <- .check_panel(tse, initial, "LoadingPlot", reducedDims, exp_name) + initial <- .check_panel(tse, initial, "ColumnTreePlot", colLinks, exp_name) - FUN(SE = tse, INIT = initial)#, EXTRA = initial) + # Take a snapshot of initial state if state management is active + if(exists("experiment_states", rObjects)) { + .create_experiment_snapshot( + rObjects$experiment_states, + exp_name, + initial + ) + } - enable("iSEE_INTERNAL_organize_panels") # organize panels - enable("iSEE_INTERNAL_link_graph") # link graph - enable("iSEE_INTERNAL_export_content") # export content - enable("iSEE_INTERNAL_tracked_code") # tracked code - enable("iSEE_INTERNAL_panel_settings") # panel settings - enable("iSEE_INTERNAL_open_vignette") # open vignette - enable("iSEE_INTERNAL_session_info") # session info - enable("iSEE_INTERNAL_citation_info") # citation info + # Create experiment selector JavaScript for real-time switching + experiment_selector_js <- " + window.iSEEApp = window.iSEEApp || {}; + + // Initialize panel tracking + window.iSEEApp.panels = {}; + + // Register panels when they're created + $(document).on('iSEE:panelCreated', function(event, panelId, panelType) { + window.iSEEApp.panels[panelId] = { + type: panelType, + config: {} + }; + }); + + // Track panel configuration changes + $(document).on('iSEE:panelSettingsChanged', function(event, panelId, settings) { + if (window.iSEEApp.panels[panelId]) { + window.iSEEApp.panels[panelId].config = settings; + Shiny.setInputValue('panel_config_changed', { + panel_id: panelId, + config: settings + }); + } + }); + + // Panel reconfiguration for experiment switching + window.iSEEApp.reconfigurePanels = function(experimentName) { + var expName = experimentName || $('#iSEE_INTERNAL_experiment_selector').val(); + + // For each panel in the current view + for (var panelId in window.iSEEApp.panels) { + var panelType = window.iSEEApp.panels[panelId].type; + + // Request panel-specific reconfiguration from server + Shiny.setInputValue('reconfigure_panel', { + panel_id: panelId, + panel_type: panelType, + experiment: expName + }); + + // Update experiment reference attribute if panel has it + $('.panel[data-panel-id=\"' + panelId + '\"]') + .attr('data-experiment', expName); + } + + // Show transition indicator + $('.experiment-transition-indicator').fadeIn(200).delay(500).fadeOut(200); + }; + + // Handle experiment selector changes + $(document).on('change', '#iSEE_INTERNAL_experiment_selector', function() { + var selectedExp = $(this).val(); + Shiny.setInputValue('iSEE_switch_experiment', selectedExp); + }); + + // Add keyboard shortcuts + $(document).keydown(function(e) { + // Alt+E to focus experiment selector + if (e.altKey && e.keyCode === 69) { // 'E' key + e.preventDefault(); + $('#iSEE_INTERNAL_experiment_selector').focus(); + } + + // Alt+Z for undo experiment switch + if (e.altKey && e.keyCode === 90) { // 'Z' key + e.preventDefault(); + $('#undo_experiment_switch').click(); + } + + // Alt+Y for redo experiment switch + if (e.altKey && e.keyCode === 89) { // 'Y' key + e.preventDefault(); + $('#redo_experiment_switch').click(); + } + }); + " + + # Launch iSEE with the current experiment and validated panels + FUN( + SE = tse, + INIT = initial, + customJS = experiment_selector_js, + customCollapseBoxes = function(x, plot_name) { + # Add experiment selector in header + if (plot_name == 1) { + # Create experiment choices + all_experiments <- c("Main" = "main") + if(length(altExpNames(tse)) > 0) { + all_experiments <- c(all_experiments, + setNames(altExpNames(tse), paste("Alt:", altExpNames(tse)))) + } + + experiment_ui <- tags$div( + class = "experiment-management-container", + style = "display: flex; align-items: center; justify-content: space-between; width: 100%;", + # Left: current experiment info + tags$div( + class = "current-experiment-info", + tags$span( + class = "experiment-label", + style = "margin-right: 5px; font-weight: bold;", + "Experiment:" + ) + ), + # Center: experiment selector + tags$div( + class = "experiment-selector-wrapper", + style = "flex-grow: 1; max-width: 300px; margin: 0 10px;", + selectInput( + inputId = "iSEE_INTERNAL_experiment_selector", + label = NULL, + choices = all_experiments, + selected = exp_name, + width = "100%" + ), + # Transition indicator + tags$div( + class = "experiment-transition-indicator", + style = "position: absolute; top: 0; left: 0; right: 0; height: 3px; background-color: #4CAF50; display: none;" + ) + ), + # Right: history controls + tags$div( + class = "experiment-history-controls", + style = "display: flex;", + actionButton( + "undo_experiment_switch", + label = NULL, + icon = icon("undo"), + class = "btn-sm", + title = "Undo experiment switch (Alt+Z)", + style = "margin-right: 5px;" + ), + actionButton( + "redo_experiment_switch", + label = NULL, + icon = icon("redo"), + class = "btn-sm", + title = "Redo experiment switch (Alt+Y)" + ) + ) + ) + + return(tags$div( + class = "experiment-header-wrapper", + experiment_ui, + hr(style = "margin: 10px 0;"), + x + )) + } + return(x) + } + ) + + # Enable iSEE interface buttons + enable("iSEE_INTERNAL_organize_panels") + enable("iSEE_INTERNAL_link_graph") + enable("iSEE_INTERNAL_export_content") + enable("iSEE_INTERNAL_tracked_code") + enable("iSEE_INTERNAL_panel_settings") + enable("iSEE_INTERNAL_open_vignette") + enable("iSEE_INTERNAL_session_info") + enable("iSEE_INTERNAL_citation_info") invisible(NULL) # nocov end -} \ No newline at end of file +} + +# Helper function for safely checking panel compatibility +.check_panel_safe <- function(se, panel_list, panel_class, panel_fun) { + tryCatch({ + no_keep <- unlist(lapply(panel_list, function(x) inherits(x, panel_class))) + + if(any(no_keep)) { + # Check if the function can be applied to the experiment + result <- tryCatch({ + func_result <- panel_fun(se) + is.null(func_result) || isEmpty(func_result) + }, error = function(e) { + # If function fails, consider it incompatible + TRUE + }) + + if(result) { + panel_list <- panel_list[!no_keep] + warning("no valid ", as.character(substitute(panel_fun)), + " fields for ", panel_class, call. = FALSE) + } + } + + return(panel_list) + }, error = function(e) { + # If anything fails, return the original panel list + warning("Error checking compatibility for ", panel_class, + ": ", conditionMessage(e), call. = FALSE) + return(panel_list) + }) +} + +# Helper function to safely get experiment +# Replace the current .get_experiment function with: +.get_experiment <- function(tse, experiment_name) { + if(is.null(experiment_name) || experiment_name == "main") { + return(list( + experiment = tse, + name = "main", + is_main = TRUE + )) + } + + result <- tryCatch({ + # Try to get alternative experiment + alt_exp <- altExp(tse, experiment_name) + list( + experiment = alt_exp, + name = experiment_name, + is_main = FALSE + ) + }, error = function(e) { + # Return main experiment if alternative not found + .print_message( + title = "Experiment Not Found:", + paste("Could not find experiment:", experiment_name), + "Using the main experiment instead." + ) + list( + experiment = tse, + name = "main", + is_main = TRUE + ) + }) + + return(result) +} + +# Helper function to filter panels by experiment type +.filter_panels_by_experiment <- function(panels, compatible_panels) { + if(is.character(panels)) { + # If panels are character strings + filtered <- intersect(panels, compatible_panels) + if(length(filtered) == 0) { + return(compatible_panels[1]) # return at least one compatible panel + } + return(filtered) + } else { + # If panels are already objects + filtered <- panels[sapply(panels, function(p) { + any(sapply(compatible_panels, function(cp) inherits(p, cp))) + })] + if(length(filtered) == 0 && length(compatible_panels) > 0) { + return(list(eval(parse(text = paste0(compatible_panels[1], "()"))))) + } + return(filtered) + } +} + + +#' @importFrom shinyjs runjs +#' @importFrom SingleCellExperiment altExp +.handle_isee_experiment_switch <- function(session, input, output, se) { + # Monitor for experiment switch requests + observeEvent(input$iSEE_INTERNAL_switch_experiment, { + req(input$iSEE_INTERNAL_switch_experiment) + exp_name <- input$iSEE_INTERNAL_switch_experiment + + # Get the appropriate experiment + if (exp_name == "main") { + current_exp <- se + } else { + tryCatch({ + current_exp <- altExp(se, exp_name) + }, error = function(e) { + showNotification( + paste("Error switching to experiment:", exp_name), + type = "error" + ) + return(NULL) + }) + } + + if (!is.null(current_exp)) { + # Update all panels that support alternative experiments + panel_ids <- grep("^\\.panel\\d+$", names(input), value = TRUE) + for (panel_id in panel_ids) { + panel_type <- input[[paste0(panel_id, "Type")]] + + # Configure experiment-aware panels + if (panel_type %in% c("ReducedDimensionPlot", "AbundancePlot", + "ComplexHeatmapPlot", "RowDataTable")) { + panel_name <- gsub("^\\.panel(\\d+)$", "\\1", panel_id) + update_script <- sprintf( + "if(window.ShinySingleCellApp && + window.ShinySingleCellApp.panels['%s']) { + window.ShinySingleCellApp.panels['%s'].requestActiveExperiment('%s'); + }", + panel_name, panel_name, exp_name + ) + runjs(update_script) + } + } + + # Show confirmation + showNotification( + paste("Switched to experiment:", exp_name), + type = "message" + ) + } + }) +} diff --git a/R/observers.R b/R/observers.R index 371118e..1c43a8e 100644 --- a/R/observers.R +++ b/R/observers.R @@ -19,7 +19,18 @@ #' @importFrom S4Vectors DataFrame #' @importFrom biomformat read_biom #' @importFrom mia convertFromBIOM importMetaPhlAn -#' @importFrom TreeSummarizedExperiment TreeSummarizedExperiment +#' @importFrom TreeSummarizedExperiment TreeSummarizedExperiment mainExpName 'mainExpName<-' +#' @importFrom SingleCellExperiment altExp altExpNames +#' @importFrom SummarizedExperiment SummarizedExperiment +#' @importFrom SingleCellExperiment altExps altExps<- +#' @importFrom TreeSummarizedExperiment TreeSummarizedExperiment mainExpName 'mainExpName<-' colTree +#' @importFrom SingleCellExperiment altExp altExpNames reducedDimNames +#' @importFrom SingleCellExperiment altExps altExps<- +#' @importFrom htmltools tags tagList div h4 p hr icon +#' @importFrom shiny showNotification updateCheckboxGroupInput updateSelectInput +#' @importFrom shinyjs simulateClick +#' @importFrom mia taxonomyRanks +#' @importFrom htmltools HTML br tags div tagList .create_import_observers <- function(input, rObjects) { # nocov start @@ -111,6 +122,80 @@ invisible(NULL) } + + +#' @rdname create_observers +#' @importFrom mia taxonomyRanks +.create_merged_file_observers <- function(input, rObjects) { + observeEvent(input$merged_file, { + isolate({ + tryCatch({ + tse <- .process_merged_file(input$merged_file$datapath) + + if(input$agglomeration_levels == "All" && + length(taxonomyRanks(tse)) > 0) { + levels <- taxonomyRanks(tse) + } else if(input$agglomeration_levels == "Custom") { + levels <- input$custom_levels + } else { + levels <- character(0) + } + + if(length(levels) > 0) { + tse <- .create_agglomerated_experiments(tse, levels) + } + + rObjects$tse <- tse + + # Show success message + showNotification( + "Merged file successfully loaded", + type = "message" + ) + + }, error = function(e) { + .print_message( + title = "Error in merged file:", + e$message + ) + }) + }) + }) +} + + + +#' @rdname create_observers +.create_altexp_observers <- function(input, rObjects) { + observeEvent(input$add_altexp, { + isolate({ + req(input$alt_assay) + req(input$alt_name) + + # Create alternative experiment + alt_assay_list <- lapply(input$alt_assay$datapath, + function(x) as.matrix(read.csv(x, row.names = 1))) + names(alt_assay_list) <- gsub(".csv", "", input$alt_assay$name) + + alt_coldata <- .set_optarg(input$alt_coldata$datapath, + alternative = DataFrame(row.names = colnames(alt_assay_list[[1]])), + loader = read.csv, row.names = 1) + + alt_rowdata <- .set_optarg(input$alt_rowdata$datapath, + loader = read.csv, row.names = 1) + + alt_exp <- SummarizedExperiment( + assays = alt_assay_list, + colData = alt_coldata, + rowData = alt_rowdata + ) + + # Add to main experiment + altExp(rObjects$tse, input$alt_name) <- alt_exp + }) + }, ignoreInit = TRUE, ignoreNULL = FALSE) +} + #' @rdname create_observers #' @importFrom SummarizedExperiment assay #' @importFrom mia subsetByPrevalent subsetByRare agglomerateByRank @@ -134,21 +219,32 @@ fun_args <- list(x = rObjects$tse, assay.type = input$subassay, prevalence = input$prevalence, detection = input$detection) - rObjects$tse <- .update_tse(rObjects$tse, subset_fun, fun_args) - + # Handle altExp creation if checkbox is selected + if(input$create_altexp && input$altexp_name != "") { + altexp_object <- do.call(subset_fun, fun_args) + altExps(rObjects$tse)[[input$altexp_name]] <- altexp_object + showNotification(paste("Created alternative experiment:", input$altexp_name), + type = "message") + } else { + rObjects$tse <- .update_tse(rObjects$tse, subset_fun, fun_args) + } }) - } - - else if( input$manipulate == "agglomerate" ){ + } else if( input$manipulate == "agglomerate" ){ isolate({ fun_args <- list(x = rObjects$tse, rank = input$taxrank) - rObjects$tse <- .update_tse( - rObjects$tse, agglomerateByRank, fun_args - ) - + + # Handle altExp creation if checkbox is selected + if(input$create_altexp && input$altexp_name != "") { + altexp_object <- do.call(agglomerateByRank, fun_args) + altExps(rObjects$tse)[[input$altexp_name]] <- altexp_object + showNotification(paste("Created alternative experiment:", input$altexp_name), + type = "message") + } else { + rObjects$tse <- .update_tse(rObjects$tse, agglomerateByRank, fun_args) + } }) } else if( input$manipulate == "transform" ){ @@ -191,6 +287,213 @@ invisible(NULL) } + +#' @rdname create_observers +#' @importFrom SingleCellExperiment altExp altExpNames +#' @importFrom TreeSummarizedExperiment mainExpName 'mainExpName<-' +.create_switch_observers <- function(input, rObjects) { + observeEvent(input$do_switch, { + isolate({ + req(input$switch_experiment) + if(input$switch_experiment != mainExpName(rObjects$tse)) { + # Store the name of the current main experiment + mainExpName(rObjects$tse) <- input$switch_experiment + + # Show notification about the switch + showNotification( + paste0("Switched to experiment: ", input$switch_experiment), + type = "message" + ) + } + }) + }, ignoreInit = TRUE, ignoreNULL = TRUE) + + invisible(NULL) +} + + +#' @rdname create_observers +#' @importFrom shiny observeEvent isolate req showModal modalDialog removeModal actionButton modalButton +#' @importFrom htmltools tags p div strong +#' @importFrom shinyjs show hide +.create_experiment_state_observers <- function(input, session, rObjects) { + + # Check if already initialized and only initialize if needed + if(!exists("experiment_states", rObjects)) { + rObjects$experiment_states <- .create_experiment_state_cache() + rObjects$experiment_history <- .create_history_tracker() + rObjects$panel_configurations <- .create_panel_config_storage() + rObjects$transition_preferences <- .create_transition_preferences() + } + + # When an experiment is selected for switching + observeEvent(input$iSEE_switch_experiment, { + req(input$iSEE_switch_experiment) + isolate({ + current_exp <- mainExpName(rObjects$tse) + if(is.null(current_exp)) current_exp <- "main" + target_exp <- input$iSEE_switch_experiment + + # Only proceed if it's actually a different experiment + if(current_exp != target_exp) { + # Verify target experiment exists + if(target_exp != "main" && !(target_exp %in% altExpNames(rObjects$tse))) { + showNotification( + paste("Error: Experiment", target_exp, "not found."), + type = "error" + ) + return(NULL) + } + + # Check if confirmation is needed + if(.needs_confirmation(rObjects$transition_preferences, current_exp, target_exp)) { + .confirm_experiment_transition(session, rObjects, current_exp, target_exp) + } else { + # No confirmation needed, switch directly + .perform_experiment_switch(rObjects, current_exp, target_exp) + } + } + }) + }, ignoreInit = TRUE) + + # Observe panel configuration changes + observeEvent(input$panel_config_changed, { + req(input$panel_config_changed) + isolate({ + panel_data <- input$panel_config_changed + current_exp <- mainExpName(rObjects$tse) + if(is.null(current_exp)) current_exp <- "main" + + .save_panel_config( + rObjects$panel_configurations, + current_exp, + panel_data$panel_id, + panel_data$config + ) + }) + }, ignoreInit = TRUE) + + # For undo/redo history navigation + observeEvent(input$undo_experiment_switch, { + isolate({ + history <- .get_history(rObjects$experiment_history) + if(length(history) > 0) { + last_step <- history[[length(history)]] + .perform_experiment_switch(rObjects, + last_step$to, + last_step$from, + record_history = FALSE) + # Remove the last step from history + rObjects$experiment_history(history[-length(history)]) + } + }) + }, ignoreInit = TRUE) + + # Observer for the remember_transitions checkbox + observeEvent(input$remember_transitions, { + if (input$remember_transitions) { + # Show the history panel + shinyjs::show("experiment_history_panel") + } else { + # Hide the history panel + shinyjs::hide("experiment_history_panel") + } + }, ignoreInit = TRUE) + + invisible(NULL) +} + +# Helper functions for experiment state management + +#' @rdname utils +.confirm_experiment_transition <- function(session, rObjects, from_exp, to_exp) { + # Create a unique ID for the modal inputs to avoid conflicts + modal_id <- paste0("switch_", from_exp, "_to_", to_exp) + checkbox_id <- paste0("remember_choice_", modal_id) + confirm_id <- paste0("confirm_switch_", modal_id) + + showModal(modalDialog( + title = "Switch Experiment?", + p(paste0("Are you sure you want to switch from '", + ifelse(from_exp == "main", "Main Experiment", from_exp), + "' to '", + ifelse(to_exp == "main", "Main Experiment", to_exp), "'?")), + div( + tags$strong("Note:"), + "Your panel configurations will be preserved where possible." + ), + checkboxInput(checkbox_id, "Remember this choice", value = FALSE), + footer = tagList( + actionButton(confirm_id, "Switch", class = "btn-primary"), + modalButton("Cancel") + ) + )) + + # Use a one-time observer with the unique ID + observeEvent(input[[confirm_id]], { + isolate({ + # Remember user preference if requested + if(input[[checkbox_id]]) { + .save_transition_preference(rObjects$transition_preferences, from_exp, to_exp) + } + + # Perform the actual experiment switch + .perform_experiment_switch(rObjects, from_exp, to_exp) + + removeModal() + }) + }, once = TRUE) +} + +#' @rdname utils +#' @importFrom shiny showNotification +#' @importFrom shinyjs runjs +.perform_experiment_switch <- function(rObjects, from_exp, to_exp, record_history = TRUE) { + tryCatch({ + # 1. Create snapshot of current state + if(!is.null(rObjects$panel_configurations)) { + current_panel_config <- rObjects$panel_configurations()[[from_exp]] + if(!is.null(current_panel_config)) { + .create_experiment_snapshot( + rObjects$experiment_states, + from_exp, + current_panel_config + ) + } + } + + # 2. Switch the experiment + mainExpName(rObjects$tse) <- to_exp + + # 3. Record in history if needed + if(record_history && !is.null(rObjects$experiment_history)) { + .add_to_history(rObjects$experiment_history, from_exp, to_exp) + } + + # 4. Send update notification to UI + showNotification( + paste0("Switched to experiment: ", + ifelse(to_exp == "main", "Main Experiment", to_exp)), + type = "message" + ) + + # 5. Trigger panel reconfiguration in UI + runjs("if(window.iSEEApp && window.iSEEApp.reconfigurePanels) { window.iSEEApp.reconfigurePanels(); }") + }, error = function(e) { + # Handle any errors during the switch + showNotification( + paste("Error switching experiment:", e$message), + type = "error", + duration = 10 + ) + }) +} + + + + + + #' @rdname create_observers #' @importFrom stats as.formula #' @importFrom mia addAlpha runNMDS runRDA getDissimilarity @@ -296,6 +599,10 @@ invisible(NULL) } + + + + #' @rdname create_observers #' @importFrom SummarizedExperiment assayNames #' @importFrom mia taxonomyRanks @@ -304,31 +611,315 @@ # nocov start observe({ - - if( isS4(rObjects$tse) ){ + if(isS4(rObjects$tse)) { + # Get available alternative experiments + alt_exps <- altExpNames(rObjects$tse) + current_main <- mainExpName(rObjects$tse) + if(is.null(current_main)) current_main <- "main" + + # Create choices list for experiments + choices <- c("Main" = "main") + if(length(alt_exps) > 0) { + alt_choices <- setNames(alt_exps, paste("Alt:", alt_exps)) + choices <- c(choices, alt_choices) + } + + # Update experiment choice inputs + updateSelectInput(session, inputId = "experiment_choice", + choices = choices) + + # Update switch experiment dropdown + updateSelectInput(session, inputId = "switch_experiment", + choices = setNames(c("main", alt_exps), c("Main", alt_exps)), + selected = current_main) + + # Get current experiment based on mainExpName + current_exp <- if(current_main != "main" && current_main %in% alt_exps) { + altExp(rObjects$tse, current_main) + } else { + rObjects$tse + } + + # Update assay choices based on current experiment + updateSelectInput(session, inputId = "subassay", + choices = assayNames(current_exp)) + + updateSelectInput(session, inputId = "taxrank", + choices = taxonomyRanks(current_exp)) + + updateSelectInput(session, inputId = "assay.type", + choices = assayNames(current_exp)) + + updateSelectInput(session, inputId = "estimate.assay", + choices = assayNames(current_exp)) + + # Update numeric input based on current experiment dimensions + updateNumericInput(session, inputId = "ncomponents", + max = nrow(current_exp) - 1) + } + + }) + + + # Display experiment metadata for the current experiment + output$current_experiment_name <- renderText({ + if(isS4(rObjects$tse)) { + current_main <- mainExpName(rObjects$tse) + if(is.null(current_main)) current_main <- "main" + if(current_main == "main") { + return("Main Experiment") + } else { + return(paste("Alternative:", current_main)) + } + } else { + return("No Experiment Loaded") + } + }) + + output$current_experiment_meta <- renderUI({ + if(!isS4(rObjects$tse)) { + return(p("Please import a dataset first.")) + } - updateSelectInput(session, inputId = "subassay", - choices = assayNames(rObjects$tse)) + current_main <- mainExpName(rObjects$tse) + if(is.null(current_main)) current_main <- "main" - updateSelectInput(session, inputId = "taxrank", - choices = taxonomyRanks(rObjects$tse)) - - updateSelectInput(session, inputId = "assay.type", - choices = assayNames(rObjects$tse)) - - updateSelectInput(session, inputId = "estimate.assay", - choices = assayNames(rObjects$tse)) - - updateSelectInput(session, inputId = "estimate.assay", - choices = assayNames(rObjects$tse)) - - updateNumericInput(session, inputId = "ncomponents", - max = nrow(rObjects$tse) - 1) + exp_obj <- if(current_main != "main" && current_main %in% altExpNames(rObjects$tse)) { + altExp(rObjects$tse, current_main) + } else { + rObjects$tse + } + + meta <- list( + paste0(format(nrow(exp_obj), big.mark=","), " features"), + paste0(format(ncol(exp_obj), big.mark=","), " samples"), + paste0(length(assayNames(exp_obj)), " assays") + ) - } + if(inherits(exp_obj, "TreeSummarizedExperiment")) { + if(!is.null(rowTree(exp_obj))) { + meta <- c(meta, "rowTree: available") + } + if(!is.null(colTree(exp_obj))) { + meta <- c(meta, "colTree: available") + } + } + + if(inherits(exp_obj, "SingleCellExperiment") && + length(reducedDimNames(exp_obj)) > 0) { + meta <- c(meta, paste0(length(reducedDimNames(exp_obj)), + " reduced dimensions")) + } + + tags$ul( + style = "padding-left: 15px; margin-bottom: 0;", + lapply(meta, function(item) tags$li(item)) + ) + }) + + + # Observer for refreshing experiment list + observeEvent(input$refresh_experiments, { + if(isS4(rObjects$tse)) { + showNotification("Refreshing experiment list...", type = "message") + + # Get available alternative experiments + alt_exps <- altExpNames(rObjects$tse) + current_main <- mainExpName(rObjects$tse) + if(is.null(current_main)) current_main <- "main" + + # Create choices list for experiments + choices <- c("Main" = "main") + if(length(alt_exps) > 0) { + alt_choices <- setNames(alt_exps, paste("Alt:", alt_exps)) + choices <- c(choices, alt_choices) + } + + # Update experiment choice inputs + updateSelectInput(session, inputId = "experiment_choice", + choices = choices) + + # Update switch experiment dropdown + updateSelectInput(session, inputId = "switch_experiment", + choices = setNames(c("main", alt_exps), c("Main", alt_exps)), + selected = current_main) + + # Update global experiment selector if it exists + if(!is.null(input$global_experiment_selector)) { + updateSelectInput(session, inputId = "global_experiment_selector", + choices = choices, + selected = current_main) + } + } }) + # Observer for global experiment selector + observeEvent(input$global_experiment_selector, { + req(input$global_experiment_selector) + if(isS4(rObjects$tse) && + input$global_experiment_selector != mainExpName(rObjects$tse)) { + # Update the switch experiment selector to match + updateSelectInput(session, "switch_experiment", + selected = input$global_experiment_selector) + # Trigger the switch + simulateClick("do_switch") + } + }, ignoreInit = TRUE) + + # Observer to sync experiment selection + observeEvent(input$sync_experiment, { + if(isS4(rObjects$tse)) { + current_main <- mainExpName(rObjects$tse) + if(is.null(current_main)) current_main <- "main" + + updateSelectInput(session, "experiment_choice", + selected = current_main) + + showNotification( + paste("Visualization will use:", + ifelse(current_main == "main", "Main Experiment", current_main)), + type = "message" + ) + } + }) + + + + + + # Render experiment details for the switch panel + output$switch_experiment_details <- renderUI({ + req(input$switch_experiment) + + if(!isS4(rObjects$tse)) { + return(p("Please import a dataset first.")) + } + + exp_name <- input$switch_experiment + exp_obj <- if(exp_name != "main" && exp_name %in% altExpNames(rObjects$tse)) { + altExp(rObjects$tse, exp_name) + } else { + rObjects$tse + } + + divs <- list( + h4(ifelse(exp_name == "main", "Main Experiment", exp_name), + style = "margin-top: 0; color: #337ab7;"), + div( + style = "display: flex; justify-content: space-between; margin-bottom: 10px;", + div( + tags$strong("Type:"), + tags$span(class(exp_obj)[1]) + ), + div( + tags$strong("Dimensions:"), + tags$span(paste0(format(nrow(exp_obj), big.mark=","), " × ", + format(ncol(exp_obj), big.mark=","))) + ) + ) + ) + + # Add assays info + if(length(assayNames(exp_obj)) > 0) { + divs <- c(divs, list( + div( + tags$strong("Assays:"), + tags$span(paste(assayNames(exp_obj), collapse=", ")) + ) + )) + } + + # Add tree info + if(inherits(exp_obj, "TreeSummarizedExperiment")) { + tree_status <- c() + if(!is.null(rowTree(exp_obj))) { + tree_status <- c(tree_status, "rowTree") + } + if(!is.null(colTree(exp_obj))) { + tree_status <- c(tree_status, "colTree") + } + + if(length(tree_status) > 0) { + divs <- c(divs, list( + div( + tags$strong("Trees:"), + tags$span(paste(tree_status, collapse=", ")) + ) + )) + } + } + + # Add reduced dimension info + if(inherits(exp_obj, "SingleCellExperiment") && + length(reducedDimNames(exp_obj)) > 0) { + divs <- c(divs, list( + div( + tags$strong("Reduced Dimensions:"), + tags$span(paste(reducedDimNames(exp_obj), collapse=", ")) + ) + )) + } + + # Add compatible panels info + compatible_panels <- .get_compatible_panels_for_experiment(rObjects$tse, exp_name) + divs <- c(divs, list( + hr(style = "margin: 10px 0;"), + p(tags$strong("Compatible Panels:"), style = "margin-bottom: 5px;"), + tags$ul( + style = "padding-left: 15px; margin-bottom: 0;", + lapply(compatible_panels, function(panel) { + tags$li(panel) + }) + ) + )) + + do.call(tagList, divs) + }) + + # Show compatible panels for visualization + output$compatible_panels_info <- renderUI({ + req(input$experiment_choice) + + if(!isS4(rObjects$tse)) { + return(NULL) + } + + compatible_panels <- .get_compatible_panels_for_experiment( + rObjects$tse, input$experiment_choice) + + if(length(compatible_panels) == 0) { + return(div( + class = "alert alert-warning", + style = "margin-top: 10px; padding: 8px;", + icon("exclamation-triangle"), + "No compatible panels found for this experiment." + )) + } + + # Filter the panels selection to compatible ones + updateSelectInput(session, "panels", + choices = compatible_panels, + selected = intersect(input$panels, compatible_panels) + ) + + # Update checkbox options for alt experiments + alt_compatible <- c("AbundancePlot", "ComplexHeatmapPlot", "RowDataTable") + updateCheckboxGroupInput(session, "altexp_panels", + choices = setNames(alt_compatible, + c("Abundance Plot", "Heatmap", "Data Table")), + selected = intersect(input$altexp_panels, alt_compatible) + ) + + div( + class = "alert alert-info", + style = "margin-top: 10px; padding: 8px;", + p(tags$strong(length(compatible_panels)), " compatible panels found") + ) + }) + + + observeEvent(input$iSEE_INTERNAL_tour_steps, { introjs(session, options = list(steps = .landing_page_tour)) @@ -341,14 +932,70 @@ #' @rdname create_observers .create_launch_observers <- function(FUN, input, session, rObjects) { - # nocov start observeEvent(input$launch, { - - .launch_isee(FUN, input$panels, session, rObjects) - + # Save the experiment choice for iSEE + experiment_choice <- isolate(input$experiment_choice) + if(is.null(experiment_choice)) experiment_choice <- "main" + + # Ensure experiment states are initialized + if(!exists("experiment_states", rObjects)) { + rObjects$experiment_states <- .create_experiment_state_cache() + rObjects$experiment_history <- .create_history_tracker() + rObjects$panel_configurations <- .create_panel_config_storage() + rObjects$transition_preferences <- .create_transition_preferences() + } + + # Take snapshot of initial state + if(exists("experiment_states", rObjects)) { + current_panel_config <- isolate(input$panels) + .create_experiment_snapshot( + rObjects$experiment_states, + experiment_choice, + current_panel_config + ) + } + + # Launch iSEE with experiment information + .launch_isee( + FUN, + input$panels, + session, + rObjects, + input, + initial_experiment = experiment_choice + ) }, ignoreInit = TRUE, ignoreNULL = TRUE) # nocov end - invisible(NULL) -} \ No newline at end of file +} + +#' @rdname utils +.process_merged_file <- function(file_path) { + # Process the merged file and return a TreeSummarizedExperiment object + tse <- readRDS(file_path) + return(tse) +} + +#' @rdname utils +.create_agglomerated_experiments <- function(tse, levels) { + for(level in levels) { + alt_name <- paste0("agglom_", level) + agglom_tse <- agglomerateByRank(tse, rank = level) + altExps(tse)[[alt_name]] <- agglom_tse + } + return(tse) +} + +#' @rdname utils +.get_compatible_panels_for_experiment <- function(tse, exp_name) { + panels <- c("RowDataTable", "ColumnDataTable", "ReducedDimensionPlot", "ComplexHeatmapPlot") + if(inherits(tse, "TreeSummarizedExperiment")) { + panels <- c(panels, "RowTreePlot", "AbundancePlot", "RDAPlot", "AbundanceDensityPlot") + if(!is.null(colTree(tse))) { + panels <- c(panels, "ColumnTreePlot") + } + } + return(panels) +} + diff --git a/R/tour.R b/R/tour.R index 1fde05c..c6ea6f4 100644 --- a/R/tour.R +++ b/R/tour.R @@ -3,10 +3,13 @@ element="#import\\.panel", intro=paste( "First, you need to import a dataset from files. Several formats are", - "supported. Alternatively, you can experiment on miaDash with one of", + "supported, including alternative experiments that can be added to your main dataset.", + "Alternatively, you can experiment on miaDash with one of", "the ready-made mia datasets.", "

When ready, click on the Upload button to import the", - "dataset as a TreeSummarizedExperiment object." + "dataset as a TreeSummarizedExperiment object.", + "

To add alternative experiments, use the Alternative Experiments tab", + "and click Add Alternative Experiment." ) ), data.frame( @@ -32,18 +35,23 @@ element="#visualise\\.panel", intro=paste( "Here you can select which panels to use to visualise the dataset.", + "You can switch between the main experiment and any alternative experiments using", + "the experiment selector.", "Check the iSEEtree catalogue", - "to find the right panel.

When ready, click the Launch", - "button to explore the dataset." + "to find the right panel.

Some panels may only be available for the main experiment.", + "When ready, click the Launch button to explore the dataset." ) ), data.frame( element="#output\\.panel", intro=paste( "Here you see the TreeSummarizedExperiment object you created.", - "Every time you press the Upload, Apply or Compute buttons, new", - "elements are added to the object.

You can download the", - "object as an RDS file by clicking the Download button." + "Every time you press the Upload, Apply, Compute, or Add Alternative Experiment buttons,", + "new elements are added to the object.", + "

Alternative experiments are stored within the main object and", + "can be accessed in the visualization panels.", + "

You can download the complete object (including alternative experiments)", + "as an RDS file by clicking the Download button." ) ) -) \ No newline at end of file +) diff --git a/R/utils.R b/R/utils.R index 18ae45c..0172ede 100644 --- a/R/utils.R +++ b/R/utils.R @@ -76,11 +76,14 @@ #' @rdname utils #' @importFrom S4Vectors isEmpty #' @importFrom methods is -.check_panel <- function(se, panel_list, panel_class, panel_fun, wtext) { - +#' @importFrom SingleCellExperiment altExp +.check_panel <- function(se, panel_list, panel_class, panel_fun, exp_name = "main") { + # Get the appropriate experiment + current_exp <- .get_experiment(se, exp_name) + no_keep <- unlist(lapply(panel_list, function(x) is(x, panel_class))) - if( any(no_keep) && (is.null(panel_fun(se)) || isEmpty(panel_fun(se))) ){ + if( any(no_keep) && (is.null(panel_fun(current_exp)) || isEmpty(panel_fun(current_exp))) ){ panel_list <- panel_list[!no_keep] warning("no valid ", as.character(substitute(panel_fun)), " fields for ", panel_class, call. = FALSE) @@ -89,6 +92,308 @@ return(panel_list) } + +#' @rdname utils +#' @importFrom methods is +#' @importFrom SummarizedExperiment colData rowData assays +.validate_merged_file <- function(tse) { + # Check class + if (!is(tse, "TreeSummarizedExperiment")) { + stop("File must contain a TreeSummarizedExperiment object") + } + + # Check for required components + if (nrow(tse) == 0 || ncol(tse) == 0) { + stop("TreeSummarizedExperiment object must contain data") + } + + if (length(assays(tse)) == 0) { + stop("TreeSummarizedExperiment object must contain at least one assay") + } + + # Check for sample consistency + sample_names <- colnames(tse) + if (is.null(sample_names) || any(duplicated(sample_names))) { + stop("Sample names must be unique and non-null") + } + + # Check alternative experiments if present + if (length(altExpNames(tse)) > 0) { + for (alt_name in altExpNames(tse)) { + alt_exp <- altExp(tse, alt_name) + if (!identical(colnames(tse), colnames(alt_exp))) { + stop(sprintf("Alternative experiment '%s' must have the same samples as main experiment", alt_name)) + } + } + } + + return(TRUE) +} + + +#' @rdname utils +.validate_altexp <- function(tse, altexp) { + # Check if samples match + if(!identical(colnames(tse), colnames(altexp))) { + stop("Alternative experiment must have same samples as main experiment") + } + return(TRUE) +} + +#' @rdname utils +.merge_experiments <- function(tse, altexp, name) { + if(.validate_altexp(tse, altexp)) { + altExp(tse, name) <- altexp + } + return(tse) +} + +#' @rdname utils +.create_agglomerated_experiments <- function(tse, levels) { + for(level in levels) { + alt_exp <- agglomerateByRank(tse, rank = level) + altExp(tse, paste0("agglomerated_", tolower(level))) <- alt_exp + } + return(tse) +} + +#' @rdname utils +.process_merged_file <- function(file_path) { + tse <- readRDS(file_path) + if(!is(tse, "TreeSummarizedExperiment")) { + stop("File must contain a TreeSummarizedExperiment object") + } + return(tse) +} + + +#' @rdname utils +#' @importFrom SingleCellExperiment altExp +.get_experiment <- function(se, exp_name) { + if(exp_name == "main" || is.null(exp_name)) { + return(se) + } else { + return(altExp(se, exp_name)) + } +} + + + +#' @rdname utils +#' @importFrom SingleCellExperiment altExpNames +#' @importFrom methods is +.detect_all_experiments <- function(se) { + result <- list( + main = "Main Experiment", + alt_exps = list() + ) + + if (is(se, "SingleCellExperiment") && length(altExpNames(se)) > 0) { + alt_exp_names <- altExpNames(se) + for (exp_name in alt_exp_names) { + alt_exp <- altExp(se, exp_name) + result$alt_exps[[exp_name]] <- list( + name = exp_name, + type = class(alt_exp)[1], + dims = dim(alt_exp), + assays = assayNames(alt_exp), + features = nrow(alt_exp) + ) + } + } + + if (is(se, "MultiAssayExperiment")) { + experiment_list <- experiments(se) + for (exp_name in names(experiment_list)) { + exp_obj <- experiment_list[[exp_name]] + result$alt_exps[[exp_name]] <- list( + name = exp_name, + type = class(exp_obj)[1], + dims = dim(exp_obj), + assays = if(is(exp_obj, "SummarizedExperiment")) assayNames(exp_obj) else NULL, + features = nrow(exp_obj) + ) + } + } + + return(result) +} + +#' @rdname utils +#' @importFrom SummarizedExperiment assayNames +#' @importFrom methods is +.get_experiment_metadata <- function(se, exp_name = "main") { + exp_obj <- .get_experiment(se, exp_name) + + metadata <- list( + name = exp_name, + type = class(exp_obj)[1], + dimensions = dim(exp_obj), + n_features = nrow(exp_obj), + n_samples = ncol(exp_obj), + assays = assayNames(exp_obj), + has_rowTree = !is.null(rowTree(exp_obj)), + has_colTree = !is.null(colTree(exp_obj)), + has_reducedDims = if(is(exp_obj, "SingleCellExperiment")) + length(reducedDimNames(exp_obj)) > 0 + else FALSE + ) + + return(metadata) +} + +#' @rdname utils +#' @importFrom methods is +.check_experiment_panel_compatibility <- function(se, exp_name, panel_class) { + # Define panel compatibility rules + compatibility_rules <- list( + "RowTreePlot" = function(exp) !is.null(rowTree(exp)), + "ColumnTreePlot" = function(exp) !is.null(colTree(exp)), + "ReducedDimensionPlot" = function(exp) { + is(exp, "SingleCellExperiment") && length(reducedDimNames(exp)) > 0 + }, + "LoadingPlot" = function(exp) { + is(exp, "SingleCellExperiment") && length(reducedDimNames(exp)) > 0 + }, + "RDAPlot" = function(exp) { + is(exp, "SingleCellExperiment") && + any(grepl("^RDA", reducedDimNames(exp))) + }, + "AbundancePlot" = function(exp) { + is(exp, "TreeSummarizedExperiment") && length(assayNames(exp)) > 0 + }, + "AbundanceDensityPlot" = function(exp) { + is(exp, "TreeSummarizedExperiment") && length(assayNames(exp)) > 0 + }, + "ComplexHeatmapPlot" = function(exp) length(assayNames(exp)) > 0, + "RowDataTable" = function(exp) ncol(rowData(exp)) > 0, + "ColumnDataTable" = function(exp) ncol(colData(exp)) > 0 + ) + + exp_obj <- .get_experiment(se, exp_name) + + if (!panel_class %in% names(compatibility_rules)) { + return(TRUE) # If no explicit rule, assume compatible + } + + return(compatibility_rules[[panel_class]](exp_obj)) +} + +#' @rdname utils +.get_compatible_panels_for_experiment <- function(se, exp_name) { + all_panels <- c(default_panels, other_panels) + compatible_panels <- c() + + for (panel in all_panels) { + if (.check_experiment_panel_compatibility(se, exp_name, panel)) { + compatible_panels <- c(compatible_panels, panel) + } + } + + return(compatible_panels) +} + +#' @rdname utils +.can_apply_operation_to_experiment <- function(operation, exp_name) { + if (exp_name == "main") { + return(TRUE) + } + + return(operation %in% altexp_compatible_functions) +} + +# Add after .can_apply_operation_to_experiment function but before default_panels + +#' @rdname utils +#' @importFrom shiny reactiveValues reactiveVal +.create_experiment_state_cache <- function() { + return(reactiveValues()) +} + +#' @rdname utils +.create_experiment_snapshot <- function(tse, exp_name, panel_config) { + return(list( + timestamp = Sys.time(), + panel_config = panel_config, + metadata = .get_experiment_metadata(tse, exp_name) + )) +} + +#' @rdname utils +.restore_experiment_state <- function(experiment_states, exp_name) { + if (exp_name %in% names(experiment_states)) { + return(experiment_states[[exp_name]]) + } + return(NULL) +} + +#' @rdname utils +.create_history_tracker <- function() { + return(reactiveVal(list())) +} + +#' @rdname utils +.add_to_history <- function(history_tracker, from_exp, to_exp) { + current_history <- history_tracker() + new_step <- list( + from = from_exp, + to = to_exp, + timestamp = Sys.time() + ) + history_tracker(c(current_history, list(new_step))) +} + +#' @rdname utils +.get_history <- function(history_tracker) { + return(history_tracker()) +} + +#' @rdname utils +.create_panel_config_storage <- function() { + return(reactiveVal(list())) +} + +#' @rdname utils +.save_panel_config <- function(config_storage, exp_name, panel_id, config) { + current_configs <- config_storage() + if (!exp_name %in% names(current_configs)) { + current_configs[[exp_name]] <- list() + } + current_configs[[exp_name]][[panel_id]] <- config + config_storage(current_configs) +} + +#' @rdname utils +.get_panel_config <- function(config_storage, exp_name, panel_id, default = NULL) { + current_configs <- config_storage() + if (exp_name %in% names(current_configs) && + panel_id %in% names(current_configs[[exp_name]])) { + return(current_configs[[exp_name]][[panel_id]]) + } + return(default) +} + +#' @rdname utils +.create_transition_preferences <- function() { + return(reactiveVal(character())) +} + +#' @rdname utils +.save_transition_preference <- function(prefs_storage, from_exp, to_exp) { + current_prefs <- prefs_storage() + key <- paste(from_exp, to_exp, sep = "_") + if (!(key %in% current_prefs)) { + prefs_storage(c(current_prefs, key)) + } +} + +#' @rdname utils +.needs_confirmation <- function(prefs_storage, from_exp, to_exp) { + current_prefs <- prefs_storage() + key <- paste(from_exp, to_exp, sep = "_") + return(!(key %in% current_prefs)) +} + #' @rdname utils default_panels <- c("RowDataTable", "ColumnDataTable", "RowTreePlot", "AbundancePlot", "AbundanceDensityPlot", "ReducedDimensionPlot", @@ -96,4 +401,23 @@ default_panels <- c("RowDataTable", "ColumnDataTable", "RowTreePlot", #' @rdname utils other_panels <- c("LoadingPlot", "ColumnTreePlot", "RDAPlot", "ColumnDataPlot", - "RowDataPlot") \ No newline at end of file + "RowDataPlot") + +#' @rdname utils +altexp_panels <- c("AbundancePlot", "ComplexHeatmapPlot", "RowDataTable") + +#' @rdname utils +altexp_compatible_functions <- c( + "agglomerateByRank", + "transformAssay", + "addAlpha", + "runPCA", + "runMDS", + "runNMDS", + "runRDA" +) + +#' @rdname utils +.filter_panels_by_experiment <- function(panels, allowed_panels) { + panels[panels %in% allowed_panels] +} diff --git a/tests/testthat/test-miaDash.R b/tests/testthat/test-miaDash.R index 463ca88..ae64bfb 100644 --- a/tests/testthat/test-miaDash.R +++ b/tests/testthat/test-miaDash.R @@ -1,5 +1,63 @@ test_that("outputs", { - expect_no_error(miaDash()) +}) + +test_that("launch_isee handles alternative experiments", { + # Create a mock TreeSummarizedExperiment with an alternative experiment + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)), + rowData = DataFrame(feature = paste0("feature", 1:3)), + colData = DataFrame(sample = paste0("sample", 1:4)) + ) + altExp(tse, "test_alt") <- alt_exp + + # Create mock objects needed for testing + rObjects <- new.env() + rObjects$tse <- tse + input <- new.env() + input$experiment_choice <- "main" + input$panels <- c("RowDataTable", "AbundancePlot") + session <- new.env() + # Test main experiment launch + expect_no_error( + .launch_isee( + FUN = function(SE, INIT) NULL, + initial = input$panels, + session = session, + rObjects = rObjects + ) + ) + + # Test alternative experiment launch + input$experiment_choice <- "test_alt" + expect_no_error( + .launch_isee( + FUN = function(SE, INIT) NULL, + initial = input$panels, + session = session, + rObjects = rObjects + ) + ) +}) + +test_that("miaDash handles missing alternative experiments gracefully", { + expect_no_error({ + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + rObjects <- new.env() + rObjects$tse <- tse + input <- new.env() + input$experiment_choice <- "nonexistent_alt" + session <- new.env() + + .launch_isee( + FUN = function(SE, INIT) NULL, + initial = c("RowDataTable"), + session = session, + rObjects = rObjects + ) + }) }) diff --git a/tests/testthat/test-observers.R b/tests/testthat/test-observers.R index 73ed317..cc70b29 100644 --- a/tests/testthat/test-observers.R +++ b/tests/testthat/test-observers.R @@ -1,5 +1,4 @@ test_that("observers", { - input <- new.env() rObjects <- new.env() FUN <- function(SE, INITIAL) invisible(NULL) @@ -18,5 +17,78 @@ test_that("observers", { launch_out <- .create_launch_observers(FUN, input, session = NULL, rObjects) expect_null(launch_out) +}) + +test_that("alternative experiment observers", { + input <- new.env() + rObjects <- new.env() + session <- new.env() + + # Mock the TreeSummarizedExperiment object + data("Tengeler2020", package = "mia") + rObjects$tse <- Tengeler2020 + + # Test altexp observer creation + altexp_out <- .create_altexp_observers(input, rObjects) + expect_null(altexp_out) + + # Test altexp import + input$alt_assay <- list( + datapath = system.file("extdata", "counts.csv", package = "miaDash"), + name = "counts.csv" + ) + input$alt_name <- "test_altexp" + input$add_altexp <- 1 + + # Test update observers with alternative experiments + input$experiment_choice <- "main" + session$output <- list() + session$updateSelectInput <- function(...) NULL + + expect_no_error( + .update_observers(input, session, rObjects) + ) +}) + +test_that("observers handle missing inputs gracefully", { + input <- new.env() + rObjects <- new.env() + + # Test with missing alternative experiment inputs + input$add_altexp <- 1 + expect_no_error( + .create_altexp_observers(input, rObjects) + ) + + # Test with invalid alternative experiment name + input$alt_assay <- list( + datapath = system.file("extdata", "counts.csv", package = "miaDash"), + name = "counts.csv" + ) + input$alt_name <- "" + expect_no_error( + .create_altexp_observers(input, rObjects) + ) +}) + +test_that("observers update UI elements correctly", { + input <- new.env() + rObjects <- new.env() + session <- new.env() + session$output <- list() + session$updateSelectInput <- function(...) NULL + + # Mock TreeSummarizedExperiment with alternative experiment + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)) + ) + altExp(tse, "test_alt") <- alt_exp + rObjects$tse <- tse + # Test UI updates + expect_no_error( + .update_observers(input, session, rObjects) + ) }) diff --git a/tests/testthat/test-outputs.R b/tests/testthat/test-outputs.R index cfd4772..33fa915 100644 --- a/tests/testthat/test-outputs.R +++ b/tests/testthat/test-outputs.R @@ -1,5 +1,4 @@ test_that("outputs", { - output <- new.env() rObjects <- new.env() @@ -9,5 +8,27 @@ test_that("outputs", { expect_null(overview_out) expect_null(download_out) expect_named(output, c("object", "download")) +}) + +test_that("outputs handle alternative experiments", { + output <- new.env() + rObjects <- new.env() + + # Create a mock TreeSummarizedExperiment with an alternative experiment + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)) + ) + altExp(tse, "test_alt") <- alt_exp + rObjects$tse <- tse + # Test that overview shows alternative experiments + overview_out <- .render_overview(output, rObjects) + expect_null(overview_out) + + # Test that download includes alternative experiments + download_out <- .render_download(output, rObjects) + expect_null(download_out) + expect_named(output, c("object", "download")) }) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index f35b4e0..59772be 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,5 +1,4 @@ test_that("utils", { - data("Tengeler2020", package = "mia") tse <- Tengeler2020 @@ -29,5 +28,93 @@ test_that("utils", { .check_panel(tse, panels, "ReducedDimensionPlot", reducedDims), 1 ) ) +}) + +test_that("alternative experiment utils", { + # Create test data + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + + # Create and add alternative experiment + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)), + rowData = DataFrame(feature = paste0("feature", 1:3)), + colData = DataFrame(sample = paste0("sample", 1:4)) + ) + altExp(tse, "test_alt") <- alt_exp + + # Test .get_experiment function + expect_identical(.get_experiment(tse, "main"), tse) + expect_identical(.get_experiment(tse, "test_alt"), alt_exp) + expect_identical(.get_experiment(tse, NULL), tse) + + # Test panel filtering + test_panels <- c("AbundancePlot", "RowTreePlot", "ComplexHeatmapPlot") + filtered_panels <- .filter_panels_by_experiment(test_panels, altexp_panels) + expect_true(all(filtered_panels %in% altexp_panels)) +}) + +test_that("panel checking with alternative experiments", { + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + + # Add alternative experiment + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)) + ) + altExp(tse, "test_alt") <- alt_exp + + panels <- c(RowDataTable(), AbundancePlot()) + + # Test panel checking for main experiment + main_panels <- .check_panel(tse, panels, "RowDataTable", rowData, "main") + expect_true(length(main_panels) > 0) + + # Test panel checking for alternative experiment + alt_panels <- .check_panel(tse, panels, "RowDataTable", rowData, "test_alt") + expect_true(length(alt_panels) > 0) +}) + +test_that("compatible functions for alternative experiments", { + # Test that all altexp_compatible_functions exist + for(func in altexp_compatible_functions) { + expect_true(exists(func, mode="function") || + exists(func, mode="character")) + } + + # Test that compatible functions can be applied to alternative experiments + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + alt_exp <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 4)) + ) + altExp(tse, "test_alt") <- alt_exp + + # Test transformAssay on alternative experiment + expect_no_error( + transformAssay(.get_experiment(tse, "test_alt"), + method = "relabundance", + assay.type = "counts") + ) +}) +test_that("merged file validation works", { + # Create valid test data + data("Tengeler2020", package = "mia") + tse <- Tengeler2020 + + # Should pass validation + expect_true(.validate_merged_file(tse)) + + # Test invalid cases + # Empty TSE + empty_tse <- TreeSummarizedExperiment() + expect_error(.validate_merged_file(empty_tse)) + + # Invalid alternative experiment + invalid_alt <- SummarizedExperiment( + assays = list(counts = matrix(1:12, nrow = 3, ncol = 2)) + ) + altExp(tse, "invalid") <- invalid_alt + expect_error(.validate_merged_file(tse)) })