Search code examples
rshiny3dplotly

Using a dynamic UI to draw a 3d plot in shiny

I have a dataframe:

df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))

I am drawing a 3d plot with plotly by adding add_trace in a loop, like:

library(shiny)
library(plotly)
library(tidyverse)
df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))

test<-unique(df1$ID2)
tempt.col<-c("red","blue","green","yellow")
p<-plot_ly()
for(i in 1:length(test)){
  df2<-df1[df1$ID2==test[i],] %>%
    select(a,b,c)
  p<-add_trace(p=p,
               data = df2,
               x=~a,y=~b,z=~c,
               type="scatter3d",
               marker = list(size=5,color=tempt.col[i]),
               mode="markers"
  )
}
p

It works very well like:

enter image description here

Now I want to achieve this in shiny, I would like to generate colourInput based on the length of the selected ID, the ui:

ui<-fluidPage(
  fluidRow(
    sidebarPanel(
      selectInput("select1","Select the ID",choices = colnames(df1[,4:5]),multiple = FALSE),
      actionButton("act1","Go"),
      uiOutput("ui1"),
    ),
    mainPanel(
      tableOutput("table1"),
      plotlyOutput("plot.3d",height = "1000px")
    )
  )
)

server:

server<-function(input,output){
  tempt.group<-reactive({
    unique(df1[,input$select1])
  })
  observeEvent(input$act1,{
    tempt.vector<-list()
    tempt.col.name<-isolate(
      vector(mode = "list",length = 2)
    )
    for(i in 1:length(tempt.group())){
      tempt.vector[[i]]<-colourpicker::colourInput(
        inputId = paste0("ColorID",i),
        label = tempt.group()[i])
      tempt.col.name[[1]][i]<-paste0("ColorID",i)
      tempt.col.name[[2]][i]<-tempt.group()[i]
    }
    output$ui1<-renderUI({
      tempt.vector
    })
    names(tempt.col.name)<-c("inputId","label")
    col.name<-reactive({
      data.frame(sapply(tempt.col.name,cbind))
    })
    
    col.df<-reactive({
      tempt.col.df<-reactiveValuesToList(input)
      data.frame(
        names = names(tempt.col.df[grepl("ColorID", names(tempt.col.df))]),
        values = unlist(tempt.col.df[grepl("ColorID", names(tempt.col.df))], use.names = FALSE)
      )
    })
    
    group.col.df<-reactive({
      merge(col.df(),col.name(),by.x="names",by.y="inputId")
    })
    
    output$table1<-renderTable(
      group.col.df()
    )
    
    pp<-reactive({
      p<-plot_ly()
      for(i in 1:length(tempt.group())){
        # col<-group.col.df()[group.col.df()[,"label"]==tempt.group()[i],"values"] ####it should be something wrong with here
        df2<-df1[df1$ID==tempt.group()[i],] %>%
          select(a,b,c)
        p<-add_trace(p=p,
                     data = df2,
                     x=~a,y=~b,z=~c,
                     type="scatter3d",
                     # marker = list(size=5,color=col[i]),  ####it should be something wrong with here
                     mode="markers"
        )
      }
      p
    })
    output$plot.3d<-renderPlotly({
      pp()
    })
    
  })
  
}


shinyApp(ui=ui,server=server)

The app is like: enter image description here

I want to fetch the colourInput and pass to the color of the 3d scatter plot, but nothing works. The page either keeps refreshing or frozen, That must be something wrong with col<-group.col.df()[group.col.df()[,"label"]==tempt.group()[i],"values"] and marker = list(size=5,color=col[i]),

please help.

Solution

  • The below works as intended.

    library(shiny)
library(plotly)
df1<-data.frame(a=rnorm(100),b=rnorm(100),c=rnorm(100),ID1=c("A","B"),ID2=(c("A","B","C","D")))

# Define UI 
ui<-fluidPage(
  fluidRow(
    sidebarPanel(
      selectInput("select1","Select the ID",choices = colnames(df1[,4:5]),multiple = FALSE),
      # actionButton("act1","Go"),
      uiOutput("myui"),
      # keep track of the last selection on all selectInput created dynamically
      
    ),
    mainPanel(
      #tableOutput("table1"),
      plotlyOutput("plot.3d",height = "1000px")
    )
  )
)

# Define server logic required to draw a histogram
server<-function(input,output){
  rv <- reactiveValues(mygroup=0, uitaglist = list(), uilabels = list(), input_subset = list(), plotly=NULL)
  
  observeEvent(input$select1, {
    newgroup <- unique(df1[,input$select1])
    rv$mygroup <- newgroup
    
    # ui tags
    rv$uitaglist <- list()
    for(i in 1:length(rv$mygroup)){
      rv$uitaglist[[i]]<-colourpicker::colourInput(
        inputId = paste0("ColorID",i),
        label = rv$mygroup[i])
      rv$uilabels[[i]] <- paste0("ColorID",i)
    }
   
  })
  
  output$myui <- renderUI({
    rv$input_subset <- rv$uitaglist
  })
  
  observe({
    rv$input_subset <- lapply(rv$uilabels, function(x) input[[x]])
    p<-plot_ly()
    for(i in 1:length(rv$mygroup)) {

      df2<-df1[df1$ID2 == rv$mygroup[i],] %>% select(a,b,c)
      p<-add_trace(p=p,
                   data = df2,
                   x=~a,y=~b,z=~c,
                   type="scatter3d",
                   marker = list(size=5,color=rv$input_subset[[i]]),
                   mode="markers"
      )
    }
    rv$plotly <- p
  })

  output$plot.3d<-renderPlotly({
    rv$plotly
  })
} # end server

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

    The main difficulty was to observe all your dynamically-generated UI inputs at once. Turns out it could be done using observe and lapply.

    enter image description here

    Observing several inputs is problematic because the error Must use single string to index into reactivevalues is returned by trying to index input by a vector or list.

    Now, Why this can't be done out-of-the-box is a good question.