Understanding the structure and dependencies of my application

shiny
1

Hi all,

Hope you all are good and safe. I have a very useful and informative concept to share with you and also need some inputs as well. I have almost read many R studio articles but did not find anything so posting directly here only.

The reason why I am trying to solve this problem is, Say we have a application with 10 tabs and many reactivity (Like clicking a button is Tab1 renders a table/output in Tab10 and so on. The user wants to understand the dependcies)

From the below application (ui.R) can we list all labels, Id and its type like

Expected Output 1 : This is with respect to UI

# as a dataframe
Input Type                       label            ID

numericInput                      N:              n
actionButton                      Go!          goButton
verbatimTextOutput                              nText       # we have no Label
verbatimTextOutput                               Fun         # we have no Label

By doing above, the user will come to know about the UI

Expected Output 2 : This is with respect to server

OutputType/Object                Function                        argument

output$nText                     renderText                         nText()
output$Fun                       renderText                         asd(3,4)
ntext                            eventReactive                    input$goButton , input$n

By doing above things, the user will clearly get to know, That output$nText is a output that has renderText function that in turn is depending on nText().
Again nText depends on both goButton and n which in turn is linked to output$nText
So the user can tell "Well Output$nText depends on 2 inputs.

Note : Team do you really believe this makes sense ? and This is something we can think of in future in case if this is not done earlier. Please guide me in solving this issue

Below is the simple application

ui.R

source("Fun.R")
pageWithSidebar(
  headerPanel("actionButton test"),
  sidebarPanel(
    numericInput("n", "N:", min = 0, max = 100, value = 50),
    br(),
    actionButton("goButton", "Go!"),
    p("Click the button to update the value displayed in the main panel.")
  ),
  mainPanel(
    verbatimTextOutput("nText"),
    verbatimTextOutput("Fun")
  )
)

server.R

function(input, output) {
  
  # builds a reactive expression that only invalidates 
  # when the value of input$goButton becomes out of date 
  # (i.e., when the button is pressed)
  ntext <- eventReactive(input$goButton, {
    input$n
  })
  
  output$nText <- renderText({
    ntext()
  })

output$Fun <- renderText({
    asd(3,4)
  })
}

Fun.R

asd <- function (a,b){
c <- a+b
return(c)
}
2

Hi, you might interested one of my application.

shinyAssemble

with given code, it will generate image like this.

image
image1225×859 62.2 KB

Regards.

3

Great . You almost answered 90% of my problem. Thanks a lot for your time . Really appreciate

4

Can I ask another small question please :slight_smile: Here instead of ID, can we have label printed? Example instead of n , can we have N: ?

5

not available for label now, but I think use label on tooltip could be good improvement.

6

Gotcha. Sorry what is meant by tool tip?

7

Sorry, I did try by following steps on my application

remotes::install_github('jhk0530/shinyAssemble')

library(shinyAssemble)

shinyAssemble()

But I get the results that you have shown above in the image I understand may be you have done for your application. How do I repliate to my application. I did see readme, But not able to get? Can you guide me

8

The reason why I am telling is, I have lots of files like (ui.R, server.R, utils.R and many more in my directory) I have sourced them so how do I include them?

9

Hi, First tooltip that I mentioned is kind of "pop-up" that appears with mouse cursor hovers.

and, sorry for not informative readme.

to generate that image,

  1. I merged codes in to 1 source. because I prefer one source file (app.R) as shiny application code. I'm not sure about whether it's recommended style or not but if you interested, refer this link

Code is

ui <- pageWithSidebar(
  headerPanel("actionButton test"),
  sidebarPanel(
    numericInput("n", "N:", min = 0, max = 100, value = 50),
    br(),
    actionButton("goButton", "Go!"),
    p("Click the button to update the value displayed in the main panel.")
  ),
  mainPanel(
    verbatimTextOutput("nText"),
    verbatimTextOutput("Fun")
  )
)

server <- function(input, output) {
  
 asd <- function (a,b){
       c <- a+b
       return(c)
     }

  # builds a reactive expression that only invalidates 
  # when the value of input$goButton becomes out of date 
  # (i.e., when the button is pressed)
  ntext <- eventReactive(input$goButton, {
    input$n
  })
  
  output$nText <- renderText({
    ntext()
  })

output$Fun <- renderText({
    asd(3,4)
  })
}

This code will work.

Also I'm not sure about what your source code files include, but my first intention was just visualizing for shiny terms with keywords like input output render reactive only.

So if separated file has that word which should be included in visualization, you may consider to merge them into app.R.

(or you can fork and improve as you want.)

Thanks.

10

Thanks I got your point. Also I tried with the new application of mine. But the app is getting crashed. Below sample

if (!require("colourpicker")) install.packages("colourpicker")
if (!require("shiny")) install.packages("shiny")
if (!require("shinyCyJS")) remotes::install_github("jhk0530/shinyCyJS")
if (!require("shinymaterial")) install.packages("shinymaterial")

library(shinyCyJS)
library(shiny)
library(colourpicker)
library(shinymaterial)

exampleCode <- function() {
  '
shinyUI(
  dashboardPage(title = "Dashboard",
                dashboardHeader(),
                dashboardSidebar(
                  tabsetPanel(
                    tabPanel("tab1",
                             uiOutput("selectInput1")
                    ),
                    tabPanel("tab2",
                             uiOutput("selectInput2")
                    )
                  )),
                dashboardBody(
                  verbatimTextOutput("selected")
                )
  )
)

# Define server logic required to draw a histogram
function(input, output, session) {
  thechoice <- reactiveVal("a")
  output$selectInput1 <- renderUI({
    selectInput(inputId = "id1",
                label = "select",
                choices = c("a","b","c"),
                selected = thechoice())
  })
  output$selectInput2 <- renderUI({
    selectInput(inputId = "id2",
                label = "select",
                choices = c("a","b","c"),
                selected = thechoice())
  })
    observeEvent(input$id2,{
    thechoice(input$id2)
  })
    observeEvent(input$id1,{
    thechoice(input$id1)
  })

  output$selected <- renderPrint({
    c(input$id1, input$id2)
  })


}'
}

solvedcard <- function(title, ..., depth = NULL, color = NULL, divider = FALSE, height = '90%') {
  shiny::tags$div(
    class = paste("card", ifelse(is.null(depth), "", paste0("z-depth-", depth)), ifelse(is.null(color), "", color)),
    style = paste0("height:",height),
    shiny::tags$div(
      class = "card-content",
      style = "height:90%;",
      shiny::tags$span(
        class = "card-title",
        title
      ),
      shiny::tags$div(
        class = paste0("", ifelse(divider, "divider", ""))
      ),
      ...
    )
  )
}

ui <- function() {
  material_page(
    title = "shinyAssemble <i style = 'margin-left:1em; font-size:2.5rem;' class = 'material-icons'>build</i>",
    shinyjs::useShinyjs(),
    background_color = "mybodystyle",
    nav_bar_color = "mynavstyle",
    tags$head(tags$style(type = "text/css", "html, body {height:100% !important; width:100% !important;}")),
    tags$head(tags$style(type = "text/css", ".form-group.shiny-input-container label { font-weight : bold;}")),
    tags$head(tags$style(type = "text/css", ".mybodystyle { background-color : #f7f1e3 !important;}")),
    tags$head(tags$style(type = "text/css", "#btn { float:right;}")),
    #tags$head(tags$style(type = "text/css", "#txt { font-size:1.3em;}")),
    tags$head(tags$style(type = "text/css", ".mynavstyle { background-color : #2c2c54 !important;}")),
    tags$head(tags$style(type = "text/css", ".shiny-input-container:not(.shiny-input-container-inline) {height:100% !important; width:100% !important;  margin-bottom : 1em !important;}")),
    div(style = 'height:1em;'),
    material_row(
      style = "height : 90%;",
      material_column(
        style = "height:100%;",
        solvedcard(
          title = "Code",
          height = '90%',
          textAreaInput(
            inputId = "txt",
            label = NULL,
            height = "100%",
            width = "100%",
            value = exampleCode()
          ),
          material_button("btn", "Investigate", icon = 'dashboard', color = 'mynavstyle'),
          depth = 3
        ),
        width = 6
      ),
      material_column(
        style = "height:90%;",
        solvedcard(
          title = '',
          height = '13.8%',
          material_column(colourInput(inputId = 'col', label = 'Input', value ='#9b59b6'), width = 2),
          material_column(colourInput(inputId = 'col2', label = 'Output', value ='#2ecc71'), width = 2),
          material_column(colourInput(inputId = 'col3', label = 'Render', value ='#FECA57'), width = 2),
          material_column(colourInput(inputId = 'col4', label = 'Reactive', value ='#FECA57'), width = 2),
          material_column(colourInput(inputId = 'col5', label = 'Data', value ='#48dbfb'), width = 2),
          material_column(colourInput(inputId = 'col6', label = 'Module', value ='#2c2c54'), width = 2),
          depth = 3
        ),
        solvedcard(
          title = "Assembly Information",
          height = '85%',
          div(
            ShinyCyJSOutput("cy", height = "100%"),
            style= 'background-color: #f7f1e3; height : 100%;'
          ),
          material_button(input_id = "btn2", label = "Module", icon = 'check_box_outline_blank', color = 'mynavstyle'),
          depth = 3
        ),
        width = 6
      )
    )
  )
}

server <- function(input, output, session) {
  myf <- function(codes, verbose = FALSE) {
    widgets <- list()
    splitted <- function(text) {
      strsplit(text, "")[[1]]
    }
    found <- function(pattern, text) {
      text <- tolower(text)
      grepl(pattern, text) && grepl("\\(", text)
    }

    detectWidget <- function(codes, i) {
      first <- splitted(codes[i])

      blocks <- i

      count <- unname(table(first)["("]) # count number of ( , it expected as 1 but not for inline cases

      v <- unname(table(first)[")"])
      if (!is.na(v)) count <- count - v
      if (count <= 0) {
        return(blocks)
      }

      # detect Widget Block
      for (j in (i + 1):length(codes)) {
        text <- splitted(codes[j])

        countOpen <- table(text)["("]
        countClose <- table(text)[")"]

        if (!is.na(countOpen)) count <- count + countOpen
        if (!is.na(countClose)) count <- count - countClose

        blocks <- c(blocks, j)
        if (count <= 0) {
          return(blocks)
        }
      }
    }
    # for addin
    # codes = rstudioapi::getSourceEditorContext()$contents

    # remove white spaces
    codes <- sapply(codes, function(i) {
      trimws(i)
    }, USE.NAMES = FALSE)

    # remove empty lines
    codes <- codes[which(codes != "")]

    # remove comments
    codes <- codes[which(substr(codes, 1, 1) != "#")]
    bookmark <- 1

    for (i in 1:length(codes)) {
      if (i <= bookmark) {
        next
      }
      fI <- found("input", codes[i])
      fO <- found("output", codes[i])
      fR <- found("reactive", codes[i])

      # used xor to avoid server.
      if (xor(fI, fO)) {
        blocks <- detectWidget(codes, i)
        widget <- paste0(codes[blocks], collapse = "\n")
        # widget = gsub('\\)', '\\) \n', widget)
        widgets[[length(widgets) + 1]] <- widget
        if (verbose) cat(widget, "\n\n")
        bookmark <- blocks[length(blocks)]
      }

      if (fR) {
        blocks <- detectWidget(codes, i)
        widget <- paste0(codes[blocks], collapse = "\n")
        # widget = gsub('\\)', '\\) \n', widget)
        widgets[[length(widgets) + 1]] <- widget
        if (verbose) cat(widget, "\n\n")
        bookmark <- blocks[length(blocks)]
      }

    }
    return(unique(widgets))
  }

  myf2 <- function(widgets, verbose = FALSE) {
    found <- function(pattern, text) {
      text <- tolower(text)
      grepl(pattern, text)
    }

    detect <- function(thisWidget, word) {
      text <- strsplit(thisWidget, "\\(")[[1]]

      if (word == "outputid") {
        idx <- which(grepl("output", tolower(text)))[1]
        if (length(idx)) {
          text <- text[idx:length(text)]
        }
      }
      if (word == "inputid") {
        idx <- which(grepl("input", tolower(text)))[1]
        if (length(idx)) {
          text <- text[idx:length(text)]
        }
      }

      type <- text[1]

      text[2] <- strsplit(text[2], ",")[[1]][1]
      if (found(word, tolower(text[2]))) { # inputid declared explictly
        text <- strsplit(text[2], ",")[[1]]
        for (j in 1:length(text)) {
          if (found(word, tolower(text[j]))) {
            id <- strsplit(text[j], "=")[[1]][2]
          }
        }
      }
      else {
        id <- strsplit(text[2], ",")[[1]]
      }
      type <- trimws(type)
      id <- trimws(id)
      id <- gsub("\\)", "", id)
      id <- gsub('"', "", id)
      if (verbose) cat("type :", type, "/ id :", id, "\n")
      return(list(type = type, id = id))
    }

    res <- list()

    # identify widget types
    for (i in 1:length(widgets)) {
      thisWidget <- widgets[[i]]

      # must render first, else render will detected as input or output
      source <- target <- method <- c()
      if (found("input\\$", thisWidget) || found("output\\$", thisWidget)) {
        if (found("reactive", thisWidget)) { # reactive
          if (verbose) cat("reactive value\n")
          text <- strsplit(thisWidget, "\n")[[1]]
          for (j in 1:length(text)) {
            thisText <- text[j]

            if (found("<-", thisText)) { # reactive
              thisText <- strsplit(thisText, "<-")[[1]][1] # remove reactive({
              target <- trimws(thisText[1])
              method <- "reactive"
              thisText <- text[j]
            }

            if (found("input\\$", thisText)) { # input$
              thisText <- strsplit(thisText, " ")[[1]]
              thisText <- thisText[which(grepl("input\\$", thisText))]
              thisText <- strsplit(thisText, "\\$")[[1]][2]
              thisText <- gsub("\\(", "", thisText)
              thisText <- gsub("\\)", "", thisText)
              thisText <- gsub(",", "", thisText) # remove ,
              source <- c(source, thisText)
            }
          }
          if (verbose) cat("target :", target, "method :", method, "source :", source, "\n")
          res[[length(res) + 1]] <- list(widget = "reactive", target = target, method = method, source = source)
          next
        }

        else { # render

          if (verbose) cat("rendering widget\n")
          text <- strsplit(thisWidget, "\n")[[1]]
          for (j in 1:length(text)) {
            thisText <- text[j]

            if (found("output\\$", thisText)) { # output$ and render
              thisText <- strsplit(thisText, "\\$")[[1]][-1] # remove output$
              thisText <- strsplit(thisText, "<-")[[1]]
              target <- trimws(thisText[1])
              method <- strsplit(trimws(thisText[-1]), "\\(")[[1]][1]
              thisText <- text[j]
            }

            if (found("input\\$", thisText)) { # input$
              thisText <- strsplit(thisText, " ")[[1]]

              thisText <- thisText[which(grepl("input\\$", thisText))]
              thisText <- strsplit(thisText, "\\$")[[1]][-1]
              thisText <- gsub("\\(", "", thisText)
              thisText <- gsub("\\)", "", thisText)
              thisText <- gsub(",", "", thisText)
              source <- c(source, thisText) # remove output$
            }
          }

          if (length(source) == 0) { # reactive data render
            for (j in 1:length(text)) {
              thisText <- text[j]
              if (found("<-", thisText) && found("\\(\\)", thisText)) {
                thisText <- trimws(strsplit(thisText, "<-")[[1]][-1])
                thisText <- gsub("\\(", "", thisText)
                thisText <- gsub("\\)", "", thisText)
                thisText <- gsub(",", "", thisText)
                source <- c(source, thisText)
              }
            }
          }
          if (length(source) == 0) { # exception 2
            for (j in 1:length(text)) {
              thisText <- text[j]
              if (found("\\(\\)", thisText)) {
                thisText <- trimws(strsplit(thisText, "\\(\\)")[[1]][1])
                thisText <- gsub("\\(", "", thisText)
                thisText <- gsub("\\)", "", thisText)
                thisText <- gsub(",", "", thisText)
                source <- c(source, thisText)
              }
            }
          }

          if(length(source) ==0 ) { # exception 3
            # output$Fun <- renderText({ asd(3, 4) })
            for(j in 1:length(text)){
              thisText <- text[j]
              if(found('\\(', thisText) && found('\\)', thisText)){
                source <- c(source, thisText)
              }
            }

          }

          if (verbose) cat("target :", target, "method :", method, "source :", source, "\n")

          res[[length(res) + 1]] <- list(widget = "render", target = target, method = method, source = source)
          next
        }
      } # render & reactive

      if (found("input", thisWidget)) {
        if (verbose) cat("input widget\n")
        w <- detect(thisWidget, "inputid")
        res[[length(res) + 1]] <- list(widget = "input", type = w$type, id = w$id)
        next
      } # input

      if (found("output", thisWidget)) {
        if (verbose) cat("output widget\n")
        w <- detect(thisWidget, "outputid")
        res[[length(res) + 1]] <- list(widget = "output", type = w$type, id = w$id)
        next
      } # output

      cat("unknown type error please create issue on github\n")
    }
    if(length(source)==0) cat("unknown type error please create issue on github\n")
    res = unique(res)
    return(res)
  }

  myf3 <- function(myf2res) {
    res <- list()

    for (i in 1:length(myf2res)) {

      thiswidget <- myf2res[[i]]

      if (thiswidget$widget == "input") {

        res[[length(res) + 1]] <- buildNode(
          id = thiswidget$id,
          shape = "rectangle",
          borderColor = input$col,
          borderWidth = 5,
          bgColor = "#FFFFFF",
          labelColor = "#000000",
          height = 75,
          width = 75,
          textbgOpacity = 1,
          textBorderWidth = 2,
          tooltip = thiswidget$type
        )
      }
      if (thiswidget$widget == "output") {

        res[[length(res) + 1]] <- buildNode(
          id = thiswidget$id,
          shape = "ellipse",
          borderColor = input$col2,
          borderWidth = 5,
          bgColor = "#FFFFFF",
          labelColor = "#000000",
          height = 75,
          width = 75,
          textbgOpacity = 1,
          textBorderWidth = 2,
          tooltip = thiswidget$type
        )
      }

      if (thiswidget$widget == "render") {
        res[[length(res) + 1]] <- buildEdge(
          source = thiswidget$source,
          target = thiswidget$target,
          label = thiswidget$method,
          lineColor = input$col3,
          curveStyle = "taxi",
          targetArrowShape = "triangle",
          targetArrowColor = input$col3
        )
      }

      if (thiswidget$widget == "reactive") {

        targets <- thiswidget$target
        sources <- thiswidget$source

        # handled multiple target and source

        for(i in 1:length(targets)){
          targetItem <- targets[i]
          res[[length(res) + 1]] <- buildNode(
            id = targetItem,
            shape = "diamond",
            borderColor = input$col5,
            borderWidth = 5,
            bgColor = "#FFFFFF",
            labelColor = "#000000",
            height = 75,
            width = 75,
            textbgOpacity = 1,
            textBorderWidth = 2,
            tooltip = thiswidget$type
          )
        }

        for(i in 1:length(sources)){
          sourceItem = sources[i]
          for(j in 1:length(targets)){
            targetItem <- targets[j]
            res[[length(res) + 1]] <- buildEdge(
              source = sourceItem,
              target = targetItem,
              label = thiswidget$method,
              curveStyle = "taxi",
              lineColor = input$col4,
              targetArrowShape = "triangle",
              targetArrowColor = input$col4
            )
          }
        }

      }
    }

    CheckDefined <- function(element){
      for(i in 1:length(res)){
        if(res[[i]]$group=='nodes'){
          if(res[[i]]$data$id == element) return(TRUE)
        }
      }
      return(FALSE)
    }

    for(k in 1:length(res)){ # check all source are defined.
      thisWidget <- res[[k]]
      if(thisWidget$group =='edges'){
        sources <- thisWidget$data$source
        targets <- thisWidget$data$target
        for(i in 1:length(sources)){
          if(!CheckDefined(sources[i])){ # undetected element
            res[[length(res) + 1]] <- buildNode(
              id = sources[i],
              shape = "star",
              borderColor = '#e84118',
              borderWidth = 5,
              bgColor = "#FFFFFF",
              labelColor = "#000000",
              height = 75,
              width = 75,
              textbgOpacity = 1,
              textBorderWidth = 2,
              tooltip = sources[i]
            )
          }
        }
        for(i in 1:length(targets)){
          if(!CheckDefined(targets[i])){ # undetected element
            res[[length(res) + 1]] <- buildNode(
              id = targets[i],
              shape = "star",
              borderColor = '#e84118',
              borderWidth = 5,
              bgColor = "#FFFFFF",
              labelColor = "#000000",
              height = 75,
              width = 75,
              textbgOpacity = 1,
              textBorderWidth = 2,
              tooltip = targets[i]
            )
          }
        }


      }

    }


    return(res)
  }

  observeEvent(input$btn2, {
    if(input$btn2==0){return(NULL)}

    shinyjs::runjs("
    var nodes = cy.nodes();
    var moduleCnt = 0;
    while(nodes.length>0){

      var familly = nodes[0].component();

      moduleCnt = moduleCnt + 1;
      var newModule = {
        group:'nodes',
        data : {
          backgroundOpacity:1,
          shape:'rectangle',
          borderWidth:5,
          borderColor: $('#col6')[0].value,
          borderOpacity: 1,
          textOpacity: 1,
          id : 'module' + moduleCnt,
          label : 'module' + moduleCnt,
          labelColor:'#8395a7',
          width : 15,height:15,
          bgColor:'#48d8f8',
          bgOpacity:0, bgFill : 'solid',
          bgBlacken : 0, borderStyle : 'solid',
          textOpacity:0,
          fontSize:16,
          textOutlineColor:'#222f3e',
          textOutlineOpacity:1,
          textOutlineWidth:0,
          textbgColor:'#fff',
          textbgOpacity:0,
          textBorderColor:'#222f3e',
          textBorderOpacity:0,
          textBorderWidth:0,
          parent:null,
          opacity:1,
          pieSize1 : '0%', pieSize2 : '0%', pieSize3 : '0%', pieSize4 : '0%',
          pieSize5 : '0%', pieSize6 : '0%', pieSize7 : '0%', pieSize8 : '0%',
          pieSize9 : '0%', pieSize10 : '0%', pieSize11 : '0%', pieSize12 : '0%',
          pieSize13 : '0%', pieSize14 : '0%', pieSize15 : '0%', pieSize16 : '0%',
          pieColor1 : '#000', pieColor2 : '#000', pieColor3 : '#000', pieColor4 : '#000',
          pieColor5 : '#000', pieColor6 : '#000', pieColor7 : '#000', pieColor8 : '#000',
          pieColor9 : '#000', pieColor10 : '#000', pieColor11 : '#000', pieColor12 : '#000',
          pieColor13 : '#000', pieColor14 : '#000', pieColor15 : '#000', pieColor16 : '#000',
          tooltip:''
        }
      }
      cy.add( newModule )
      familly.move({ parent : 'module' + moduleCnt })

      nodes = nodes.difference(familly)
    }

")
  })

  observeEvent(input$btn, {
    if (input$btn == 0) {
      return(NULL)
    }
    code <- strsplit(input$txt, split = "\n")[[1]]
    shinyjs::runjs('var moduleCnt = 0;')
    widgets <- myf(code)
    myfres <- myf2(widgets)
    shinyobj <- myf3(myfres)
    output$cy <- renderShinyCyJS(shinyCyJS(shinyobj))
  })
}

shinyApp(ui = ui(), server = server, options = list(launch.browser = TRUE))
11

shinyAssemble doesn't support materialUI yet.

12

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.