R/observers_child.R

In iSEE: Interactive SummarizedExperiment Explorer

.panelRepopulated <- "Repopulated"
.panelReactivated <- "Reactivated"
.panelResaved <- "Resaved"
.panelNorender <- "Norender"

#' Child propagating observer
#'
#' This function sets up a central observer for regenerating all output based on
#' requests from \code{\link{.mark_panel_as_modified}}.
#' The observer will also decide whether child panels need to be regenerated
#' based on the panels that have been marked as modified.
#'
#' @param se A \linkS4class{SummarizedExperiment} object containing the current dataset.
#' @param session The Shiny session object from the server function.
#' @param pObjects An environment containing global parameters generated in the \code{\link{iSEE}} app.
#' @param rObjects A reactive list of values generated in the \code{\link{iSEE}} app.
#'
#' @return Observers are created in the server function in which this is called.
#' A \code{NULL} value is invisibly returned.
#'
#' @details
#' The architecture is that the other observers should request changes to panels via
#' \code{\link{.mark_panel_as_modified}} (or derivatives like \code{\link{.requestUpdate}}.
#' Once all of the requests are collated, the child propagating observer will run
#' to actually regenerate the modified panels via \code{\link{.generateOutput}}.
#' The output is cached in \code{pObjects$cached} for rapid re-use by the
#' \code{\link{.renderOutput}} functions via \code{\link{.retrieveOutput}}.
#'
#' We use this single-observer system to guarantee topological order of execution.
#' Previous attempts used observers to reactive variables to recurse through the multiple selection tree;
#' however, this would potentially hit the same node multiple times,
#' resulting in redundant execution of the same output generation.
#' An even more previous attempt moved output generation into \code{\link{.renderOutput}},
#' but this was even worse as it did not guarantee that \code{pObjects$contents} were regenerated for parents before children.
#'
#' When requesting a change to a panel \code{x}, the output is typically regenerated by \code{\link{.generateOutput}}.
#' The exception is when the requested mode has \dQuote{Norender} in which case regeneration is skipped.
#' This is useful in cases where the change involves an alteration of a selection that only affects children,
#' e.g., see \code{\link{.create_table_observers}}.
#'
#' We also have three different modes to determine what to do with that panel's children:
#' \itemize{
#' \item \dQuote{Repopulated}.
#' This is used when the population of points changes in \code{x},
#' usually due to restriction of selections from transmitters upstream of \code{x}.
#' Bumping may trigger replotting of the children of \code{x}, based on whether the type of selection they are receiving
#' (active, union, saved) is present in \code{x}.
#' It will also change the modification mode of the child to \dQuote{Repopulated} if it is selecting by restriction.
#' \item \dQuote{Reactivated}.
#' This is used when the current selection of points in \code{x} changes, e.g., due to changes in the lasso or brush.
#' It will trigger replotting of the children of \code{x} if they are receiving the active or union selection.
#' \item \dQuote{Resaved}.
#' This is used when the saved selection of points in \code{X} changes.
#' It will trigger replotting of the children of \code{x} if they are receiving the relevant saved or union selection.
#' }
#'
#' @author Aaron Lun
#'
#' @rdname INTERNAL_child_propagation_observer
#' @importFrom shiny observeEvent onFlushed
#' @importFrom igraph topo_sort adjacent_vertices
.create_child_propagation_observer <- function(se, session, pObjects, rObjects) {
    # nocov start
    if (!is.null(session)) {
        # Run this just in case we haven't triggered the observer below on start-up 
        # (in which case the app will refuse to respond to the # first user input).
        # This occasionally occurs for very well-behaved Panels that do not trigger
        # further changes to their 'input' fields upon initialization.
        onFlushed(function() pObjects$initialized <- TRUE, session=session)
    }

    observeEvent(rObjects$modified, {
        if (!isTRUE(pObjects$initialized)) { # Avoid running this on app start and double-generating output.
            pObjects$initialized <- TRUE
            rObjects$modified <- list()
            return(NULL)
        }

        modified <- rObjects$modified
        if (length(modified)==0L) { # Avoid recursion from the wiping.
            return(NULL)
        }
        rObjects$modified <- list()

        # Looping over panels in topological order, accumulating changes so that
        # we only ever call .generateOutput once. Note that we must loop over
        # `ordering` rather than `modified` to ensure that any children of earlier
        # panels are computing off up-to-date version of the parent panels. 
        graph <- pObjects$selection_links
        ordering <- names(topo_sort(graph, mode="out"))

        for (idx in seq_along(ordering)) {
            current_panel_name <- ordering[idx]
            if (!current_panel_name %in% names(modified)) {
                next
            }
            instance <- pObjects$memory[[current_panel_name]]

            status <- modified[[current_panel_name]]
            if (!.panelNorender %in% status) {
                # Generating self and marking it for re-rendering.
                .safe_reactive_bump(rObjects, paste0(current_panel_name, "_", .flagOutputUpdate))
                p.out <- .generateOutput(instance, se, all_memory=pObjects$memory, all_contents=pObjects$contents)
                pObjects$contents[[current_panel_name]] <- p.out$contents
                pObjects$cached[[current_panel_name]] <- p.out
            }

            # Setting up various parameters to decide how to deal with children.
            if (!length(status)) {
                next
            }
            re_populated <- .panelRepopulated %in% status
            re_active <- .panelReactivated %in% status
            re_saved <- .panelResaved %in% status

            children <- names(adjacent_vertices(graph, v=current_panel_name, mode="out")[[1]])
            if (!length(children)) {
                next
            }

            transmit_dim <- .multiSelectionDimension(instance)
            if (transmit_dim=="row") {
                type_field <- .selectRowType
                saved_field <- .selectRowSaved
            } else if (transmit_dim=="column") {
                type_field <- .selectColType
                saved_field <- .selectColSaved
            } else {
                return(NULL)
            }

            has_active <- .multiSelectionHasActive(instance)
            n_saved <- .any_saved_selection(instance, count=TRUE)
            has_saved <- n_saved > 0L

            # Looping over children and deciding whether they need to be
            # regenerated. This depends on the combination of what has changed in
            # 'current_panel' + what the child was using (active, saved or union).
            for (child in children) {
                child_instance <- pObjects$memory[[child]]
                select_mode <- child_instance[[type_field]]

                regenerate <- FALSE
                if (select_mode==.selectMultiActiveTitle) {
                    if (re_populated && has_active) {
                        regenerate <- TRUE
                    } else if (re_active) {
                        regenerate <- TRUE
                    }
                } else if (select_mode==.selectMultiSavedTitle) {
                    if (re_populated && has_saved) {
                        regenerate <- TRUE
                    } else if (re_saved) {
                        if (child_instance[[saved_field]] > n_saved) {
                            pObjects$memory[[child]][[saved_field]] <- 0L
                            regenerate <- TRUE
                        }
                    }
                } else if (select_mode==.selectMultiUnionTitle) {
                    if (re_populated && (has_active || has_saved)) {
                        regenerate <- TRUE
                    } else if (re_saved || re_active) {
                        regenerate <- TRUE
                    }
                }

                if (regenerate) {
                    # Implicit convertion to character(0), so as to trigger
                    # the call to .generateOutput later.
                    previous <- as.character(modified[[child]])

                    if (.multiSelectionRestricted(child_instance)) {
                        previous <- union(previous, .panelRepopulated)
                    }

                    # Wiping out selections in the child if receiving a new
                    # selection from the parent invalidates its own selections.
                    if (.multiSelectionInvalidated(child_instance)) {
                        if (.multiSelectionHasActive(child_instance)) {
                            pObjects$memory[[child]] <- .multiSelectionClear(pObjects$memory[[child]])
                            previous <- union(previous, .panelReactivated)
                        }
                        if (.any_saved_selection(child_instance)) {
                            pObjects$memory[[child]][[.multiSelectHistory]] <- list()
                            previous <- union(previous, .panelResaved)
                        }
                    }
                    modified[[child]] <- previous
                }

                # Updating the saved choice selectize for the child.  Note that
                # this is purely for the user, we've already updated the memory
                # if the change invalidated anything.
                if (re_saved) {
                    .safe_reactive_bump(rObjects, paste0(child, "_", .updateSavedChoices))
                }
            }
        }
    }, priority=-1L, ignoreInit=TRUE)
    # nocov end

    invisible(NULL)
}

#' Mark panel as modified
#'
#' Mark a panel as being modified, along with the modification mode that affects how the modification propagates to children.
#'
#' @param panel_name String containing the name of a panel.
#' @param mode Character vector of any length containing modification modes.
#' If empty, no change is propagated to the children.
#' @param rObjects A reactive list of values generated in the \code{\link{iSEE}} app.
#'
#' @return
#' \code{rObjects$modified} to include the new \code{mode} for \code{panel_name}.
#' A \code{NULL} is invisibly returned.
#'
#' @author Aaron Lun
#'
#' @seealso
#' \code{\link{.requestUpdate}} and \code{\link{.requestCleanUpdate}},
#' which call this function.
#'
#' @importFrom shiny isolate
#' @rdname INTERNAL_mark_panel_as_modified
.mark_panel_as_modified <- function(panel_name, mode, rObjects) {
    # Do NOT simplify to `rObjects$modified[[panel_name]] <-`,
    # as this performs an un-`isolate`d extraction that exposes
    # a potential infinite recursion bug.
    modified <- isolate(rObjects$modified)
    modified[[panel_name]] <- union(modified[[panel_name]], mode)
    rObjects$modified <- modified
    invisible(NULL)
}