Does anyone know why the shiny program can't output a flowchart drawn using the DiagrammeR package instead of an expression?

Question

I am looking to create a flowchart that depicts the allocation of an overall type I error (alpha) to each endpoint, with each endpoint further distributing alpha to each subgroup, similar to the style of the image provided below (figure 1). Additionally, after entering weights between 0-1 in a generated n*n dimensional table, I would like to produce a diagram similar to the green image shown below (figure 2). I would greatly appreciate it if someone could assist me with this issue.figure 1figure 2

Here is my code

library(shiny)
library(DT)
library(DiagrammeR)

ui <- fluidPage(
  titlePanel("Alpha Allocation"),
  sidebarLayout(
    sidebarPanel(
      numericInput("totalAlpha", "Total type I error:", min = 0, value = 0.05),
      numericInput("numEndpoints", "Select Number of Endpoints:", min = 1, value = 2),
      uiOutput("endpointInputs"),
      actionButton("submit", "Submit"),
      DTOutput("weightTable") # Table generated in the left sidebar
    ),
    mainPanel(
      DTOutput("alphaTable"),
      DiagrammeROutput("flowChart"),
      verbatimTextOutput("explanation") # Text output on the right for explanations
    )
  )
)
server <- function(input, output, session) {
  
  output$endpointInputs <- renderUI({
    num_endpoints <- input$numEndpoints
    lapply(1:num_endpoints, function(i) {
      tagList(
        numericInput(paste0("endpointAlpha", i), sprintf("Alpha Value for Endpoint %d:", i), 
                     value = input$totalAlpha / num_endpoints),
        checkboxInput(paste0("subgroup", i), "Add Subgroup under this Endpoint", value = FALSE),
        conditionalPanel(
          condition = sprintf("input.subgroup%d == true", i),
          numericInput(paste0("numSubgroups", i), "Number of Subgroups:", min = 1, value = 2, 
                       step = 1),
          uiOutput(paste0("subgroupInputs", i))
        )
      )
    })
  })
  
  # Dynamically generate subgroup weight input fields
  observeEvent(input$numEndpoints, {
    lapply(1:input$numEndpoints, function(i) {
      output[[paste0("subgroupInputs", i)]] <- renderUI({
        num_subgroups <- input[[paste0("numSubgroups", i)]]
        if(input[[paste0("subgroup", i)]]) {
          lapply(1:num_subgroups, function(j) {
            numericInput(paste0("weight", i, "_", j), sprintf("Alpha Weight for Subgroup %d:", j), 
                         value = 1/num_subgroups, min = 0, max = 1, step = 0.01)
          })
        }
      })
    })
  })
  
  rv <- reactiveValues(data = NULL, weights = NULL)
  
  observeEvent(input$submit, {
    num_endpoints <- input$numEndpoints
    hypothesis_count <- 0
    for (i in 1:num_endpoints) {
      if (input[[paste0("subgroup", i)]]) {
        hypothesis_count <- hypothesis_count + input[[paste0("numSubgroups", i)]]
      } else {
        hypothesis_count <- hypothesis_count + 1
      }
    }
    
    # Create an empty data frame
    rv$data <- matrix(NA_real_, nrow = hypothesis_count, ncol = hypothesis_count)
    colnames(rv$data) <- paste0("H", 1:hypothesis_count)
    rownames(rv$data) <- paste0("H", 1:hypothesis_count)
    
    output$weightTable <- renderDT({
      datatable(rv$data, editable = TRUE, options = list(paging = FALSE, searching = FALSE))
      }, server = FALSE)
    results <- data.frame(Endpoint = integer(), Subgroup = integer(), `Allocated Alpha`  = numeric())
    
    for(i in 1:num_endpoints) {
      endpoint_alpha <- input[[paste0("endpointAlpha", i)]]
      if(input[[paste0("subgroup", i)]]) {
        num_subgroups <- input[[paste0("numSubgroups", i)]]
        total_weight <- sum(sapply(1:num_subgroups, function(j) input[[paste0("weight", i, "_", j)]]))
        for(j in 1:num_subgroups) {
          subgroup_weight <- input[[paste0("weight", i, "_", j)]]
          results <- rbind(results, data.frame(Endpoint = i, Subgroup = j, `Allocated Alpha` = endpoint_alpha * subgroup_weight / total_weight))
        }
      } else {
        results <- rbind(results, data.frame(Endpoint = i, Subgroup = NA, `Allocated Alpha` = endpoint_alpha))
      }
    }
    
    output$alphaTable <- renderDT({ datatable(results) })
    
    # Create and display the flowchart
    output$flowChart <- renderDiagrammeR({
      create_flow_chart(input, num_endpoints, results)
    })
  })
  
  # Listen for table edit events
  proxy <- dataTableProxy('weightTable')
  
  observeEvent(input$weightTable_cell_edit, {
    info <- input$weightTable_cell_edit
    rv$data[info$row, info$col] <- as.numeric(info$value)
    
    # Check if the sum of each row exceeds 1
    for (i in 1:nrow(rv$data)) {
      rowSum <- sum(rv$data[i, ], na.rm = TRUE)
      if (rowSum > 1) {
        showModal(modalDialog(
          title = "Error",
          paste0("The sum of values in row ", i, " cannot exceed 1. Your current sum is: ", rowSum),
          easyClose = TRUE,
          footer = NULL
        ))
        rv$data[i, info$col] <- NA_real_ # Reset the value
        break
      }
    }
    
    # Update the explanation text on the right
    explanation_text <- sapply(1:nrow(rv$data), function(i) {
      row_values <- rv$data[i, ]
      non_na_indices <- which(!is.na(row_values))
      if (length(non_na_indices) > 0) {
        paste0("H", i, " allocates its Alpha value to ", paste(paste0("H", non_na_indices, " (", row_values[non_na_indices], ")", " weights"), collapse = ", "), ".")
      } else {
        ""
      }
    })
    
    output$explanation <- renderText({
      paste(explanation_text, collapse = "\n")
    })
  })
  
}

# Function to create the flowchart
create_flow_chart <- function(input, num_endpoints, results) {
  graph_script <- "digraph flowchart {"
  graph_script <- paste0(graph_script, "node [shape=box];")
  graph_script <- paste0(graph_script, "TotalAlpha [label='Total Alpha: ", input$totalAlpha, "'];")
  
  # Add endpoint nodes
  for (i in 1:num_endpoints) {
    alpha_val <- input[[paste0("endpointAlpha", i)]]
    graph_script <- paste0(graph_script, "Endpoint", i, " [label='Endpoint ", i, " (Alpha: ", alpha_val, ")'];")
  }
  
  # Edges from TotalAlpha to endpoints
  graph_script <- paste0(graph_script, "TotalAlpha -> {")
  for (i in 1:num_endpoints) {
    graph_script <- paste0(graph_script, " Endpoint", i)
  }
  graph_script <- paste0(graph_script, " };")
  
  # Add subgroup nodes and edges
  for (i in 1:num_endpoints) {
    if (input[[paste0("subgroup", i)]]) {
      num_subgroups <- input[[paste0("numSubgroups", i)]]
      for (j in 1:num_subgroups) {
        graph_script <- paste0(graph_script, "Subgroup", i, "_", j, " [label='Subgroup ", j, "'];")
      }
      graph_script <- paste0(graph_script, "Endpoint", i, " -> {")
      for (j in 1:num_subgroups) {
        graph_script <- paste0(graph_script, " Subgroup", i, "_", j)
      }
      graph_script <- paste0(graph_script, " };")
    }
  }
  
  graph_script <- paste0(graph_script, "}")
  
  # Use DiagrammeR to generate the flowchart
  DiagrammeR::grViz(graph_script)
}

# Run the app
shinyApp(ui = ui, server = server)

Answer 1

To render a graph created with grViz() you have to use renderGrViz/grVizOutput instead of renderDiagrammeR/DiagrammeROutput: