Two shiny widgets cannot be used at the same time to subset a dataframe-CodePudding

I have the shiny app below in which I create a wordcloud. This wordcloud is based on the shiny widgets in the sidebar. The selectInput() subsets it by label, the Maximum Number of Words: is supposed to show the maximum count of words that will be displayed in the wordcloud and the Minimun Frequency the minimum frequency that a word needs to be displayed. Those widgets are reactive and are based on the df() function which creates the dataframe needed for the wordcloud. The proble is that when I subset using input$freq the dataframe has fewer rows than needed to subset with input$max as well so nothing is displayed.

## app.R ##
library(shiny)
library(shinydashboard)
library(dplyr)
library(tm)
library(wordcloud)
library(memoise)
library(janeaustenr)
library(tidyverse)
library(tidytext)
library(wordcloud2)
library(tidyr)
spam_or_not_spam2<-structure(list(email = c("' date wed NUMBER aug NUMBER NUMBER NUMBER NUMBER NUMBER from chris garrigues cwg dated NUMBER NUMBERfaNUMBERd deepeddy com message id NUMBER NUMBER tmda deepeddy vircio com i can t reproduce this error for me it is very repeatable like every time without fail this is the debug log of the pick happening NUMBER NUMBER NUMBER pick_it exec pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER NUMBER NUMBER exec pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER NUMBER NUMBER ftoc_pickmsgs NUMBER hit NUMBER NUMBER NUMBER marking NUMBER hits NUMBER NUMBER NUMBER tkerror syntax error in expression int note if i run the pick command by hand delta pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER hit that s where the NUMBER hit comes from obviously the version of nmh i m using is delta pick version pick nmh NUMBER NUMBER NUMBER compiled on URL at sun mar NUMBER NUMBER NUMBER NUMBER ict NUMBER and the relevant part of my mh_profile delta mhparam pick seq sel list since the pick command works the sequence actually both of them the one that s explicit on the command line from the search popup and the one that comes from mh_profile do get created kre ps this is still using the version of the code form a day ago i haven t been able to reach the cvs repository today local routing issue i think _______________________________________________ exmh workers mailing list exmh workers URL URL '", 
                                            "'martin a posted tassos papadopoulos the greek sculptor behind the plan judged that the limestone of mount kerdylio NUMBER miles east of salonika and not far from the mount athos monastic community was ideal for the patriotic sculpture as well as alexander s granite features NUMBER ft high and NUMBER ft wide a museum a restored amphitheatre and car park for admiring crowds are planned so is this mountain limestone or granite if it s limestone it ll weather pretty fast yahoo groups sponsor NUMBER dvds free s p join now URL to unsubscribe from this group send an email to forteana unsubscribe URL your use of yahoo groups is subject to URL '"
), label = c("spam", "ham")), row.names = c(NA, -2L), class = c("tbl_df", 
                                                                "tbl", "data.frame"))

ui <- dashboardPage(
  dashboardHeader(title = "Text Classification"),
  dashboardSidebar(
    uiOutput("spamham"),
    
    uiOutput("frequency"),
    
    uiOutput("maximum")
    
  ),
  
  dashboardBody(
    tabsetPanel(
      id="tabs",
      tabPanel("Wordcloud",wordcloud2Output("word",width="100%",height="850px"))
    )
    
  )
)

server <- function(input, output) {

 
  output$spamham<-renderUI({
    
      selectInput("selection", "Choose spam or ham:",
                  choices = unique(spam_or_not_spam2$label),
                  selected = unique(spam_or_not_spam2$label),
                  multiple = T
      )
    
  })
  
  smoh<-reactive({
    spam_or_not_spam2 <-subset( spam_or_not_spam2,  spam_or_not_spam2$label %in% input$selection)
    spam_or_not_spam2
  })
  df<-reactive({
    #Create a vector containing only the text
    #spam_or_not_spam2 <-subset( spam_or_not_spam2,  spam_or_not_spam2$label %in% input$selection)
    dt<-smoh()
    text <- dt$email
    # Create a corpus  
    docs <- Corpus(VectorSource(text))
    
    
    docs <- docs %>%
      tm_map(removeNumbers) %>%
      tm_map(removePunctuation) %>%
      tm_map(stripWhitespace)
    docs <- tm_map(docs, content_transformer(tolower))
    docs <- tm_map(docs, removeWords, stopwords("english"))
    
    
    dtm <- TermDocumentMatrix(docs) 
    matrix <- as.matrix(dtm) 
    words <- sort(rowSums(matrix),decreasing=TRUE) 
    df <- data.frame(word = names(words),freq=words)
  })
  output$maximum<-renderUI({
      sliderInput("max",
                  "Maximum Number of Words:",
                  min = 1,  max = nrow(df()),  value =nrow(df()),step=1 )
  })
  output$frequency<-renderUI({
      sliderInput("freq",
                  "Minimum Frequency:",
                  min = 1,  max =max(df()$freq), value = 1,step=1)
    
  })
  
  


    output$word<-renderWordcloud2({
    
    subs<-subset( df()
                  ,df()$freq >=input$freq )
    #subs<-subs[1:input$max,]
    wordcloud2(subs[1:input$max,],size = 4)
    #wordcloud(words = df()$word, freq = df()$freq, min.freq = input$freq,max.words=input$max, random.order=FALSE, rot.per=0.35,            colors=brewer.pal(8, "Dark2"))
  }) 
 
  
}


shinyApp(ui, server)

CodePudding user response：

I'm not totally sure, but since you say

when the app is launched nothing is displayed

It could be related to this bug.

I created this solution.

This looks complicated, but it really isn't. Simply define the following function (wordcloud2a()), then use it where you'd normally use wordcloud2().

wordcloud2a <- function (data, size = 1, minSize = 0, gridSize = 0, fontFamily = "Segoe UI", 
          fontWeight = "bold", color = "random-dark", backgroundColor = "white", 
          minRotation = -pi/4, maxRotation = pi/4, shuffle = TRUE, 
          rotateRatio = 0.4, shape = "circle", ellipticity = 0.65, 
          widgetsize = NULL, figPath = NULL, hoverFunction = NULL) 
{
  if ("table" %in% class(data)) {
    dataOut = data.frame(name = names(data), freq = as.vector(data))
  }
  else {
    data = as.data.frame(data)
    dataOut = data[, 1:2]
    names(dataOut) = c("name", "freq")
  }
  if (!is.null(figPath)) {
    if (!file.exists(figPath)) {
      stop("cannot find fig in the figPath")
    }
    spPath = strsplit(figPath, "\\.")[[1]]
    len = length(spPath)
    figClass = spPath[len]
    if (!figClass %in% c("jpeg", "jpg", "png", "bmp", "gif")) {
      stop("file should be a jpeg, jpg, png, bmp or gif file!")
    }
    base64 = base64enc::base64encode(figPath)
    base64 = paste0("data:image/", figClass, ";base64,", 
                    base64)
  }
  else {
    base64 = NULL
  }
  weightFactor = size * 180/max(dataOut$freq)
  settings <- list(word = dataOut$name, freq = dataOut$freq, 
                   fontFamily = fontFamily, fontWeight = fontWeight, color = color, 
                   minSize = minSize, weightFactor = weightFactor, backgroundColor = backgroundColor, 
                   gridSize = gridSize, minRotation = minRotation, maxRotation = maxRotation, 
                   shuffle = shuffle, rotateRatio = rotateRatio, shape = shape, 
                   ellipticity = ellipticity, figBase64 = base64, hover = htmlwidgets::JS(hoverFunction))
  chart = htmlwidgets::createWidget("wordcloud2", settings, 
                                    width = widgetsize[1], height = widgetsize[2], sizingPolicy = htmlwidgets::sizingPolicy(viewer.padding = 0, 
                                                                                                                            browser.padding = 0, browser.fill = TRUE))
  chart
}

That is, define the function above and then replace this line in your code

wordcloud2(subs[1:input$max,],size = 4)

with this

wordcloud2a(subs[1:input$max,],size = 4)

CodePudding user response：

I adapted the input$max

## app.R ##
library(shiny)
library(shinydashboard)
library(dplyr)
library(tm)
library(wordcloud)
library(memoise)
library(janeaustenr)
library(tidyverse)
library(tidytext)
library(wordcloud2)
library(tidyr)
spam_or_not_spam2<-structure(list(email = c("' date wed NUMBER aug NUMBER NUMBER NUMBER NUMBER NUMBER from chris garrigues cwg dated NUMBER NUMBERfaNUMBERd deepeddy com message id NUMBER NUMBER tmda deepeddy vircio com i can t reproduce this error for me it is very repeatable like every time without fail this is the debug log of the pick happening NUMBER NUMBER NUMBER pick_it exec pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER NUMBER NUMBER exec pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER NUMBER NUMBER ftoc_pickmsgs NUMBER hit NUMBER NUMBER NUMBER marking NUMBER hits NUMBER NUMBER NUMBER tkerror syntax error in expression int note if i run the pick command by hand delta pick inbox list lbrace lbrace subject ftp rbrace rbrace NUMBER NUMBER sequence mercury NUMBER hit that s where the NUMBER hit comes from obviously the version of nmh i m using is delta pick version pick nmh NUMBER NUMBER NUMBER compiled on URL at sun mar NUMBER NUMBER NUMBER NUMBER ict NUMBER and the relevant part of my mh_profile delta mhparam pick seq sel list since the pick command works the sequence actually both of them the one that s explicit on the command line from the search popup and the one that comes from mh_profile do get created kre ps this is still using the version of the code form a day ago i haven t been able to reach the cvs repository today local routing issue i think _______________________________________________ exmh workers mailing list exmh workers URL URL '", 
                                            "'martin a posted tassos papadopoulos the greek sculptor behind the plan judged that the limestone of mount kerdylio NUMBER miles east of salonika and not far from the mount athos monastic community was ideal for the patriotic sculpture as well as alexander s granite features NUMBER ft high and NUMBER ft wide a museum a restored amphitheatre and car park for admiring crowds are planned so is this mountain limestone or granite if it s limestone it ll weather pretty fast yahoo groups sponsor NUMBER dvds free s p join now URL to unsubscribe from this group send an email to forteana unsubscribe URL your use of yahoo groups is subject to URL '"
), label = c("spam", "ham")), row.names = c(NA, -2L), class = c("tbl_df", 
                                                                "tbl", "data.frame"))

ui <- dashboardPage(
  dashboardHeader(title = "Text Classification"),
  dashboardSidebar(
    uiOutput("spamham"),
    
    uiOutput("frequency"),
    
    uiOutput("maximum")
    
  ),
  
  dashboardBody(
    tabsetPanel(
      id="tabs",
      tabPanel("Wordcloud",wordcloud2Output("word",width="100%",height="850px"))
    )
    
  )
)

server <- function(input, output) {

 
  output$spamham<-renderUI({
    
      selectInput("selection", "Choose spam or ham:",
                  choices = unique(spam_or_not_spam2$label),
                  selected = unique(spam_or_not_spam2$label),
                  multiple = T
      )
    
  })
  
  smoh<-reactive({
    spam_or_not_spam2 <-subset( spam_or_not_spam2,  spam_or_not_spam2$label %in% input$selection)
    spam_or_not_spam2
  })
  df<-reactive({
    #Create a vector containing only the text
    #spam_or_not_spam2 <-subset( spam_or_not_spam2,  spam_or_not_spam2$label %in% input$selection)
    dt<-smoh()
    text <- dt$email
    # Create a corpus  
    docs <- Corpus(VectorSource(text))
    
    
    docs <- docs %>%
      tm_map(removeNumbers) %>%
      tm_map(removePunctuation) %>%
      tm_map(stripWhitespace)
    docs <- tm_map(docs, content_transformer(tolower))
    docs <- tm_map(docs, removeWords, stopwords("english"))
    
    
    dtm <- TermDocumentMatrix(docs) 
    matrix <- as.matrix(dtm) 
    words <- sort(rowSums(matrix),decreasing=TRUE) 
    df <- data.frame(word = names(words),freq=words)
  })
  output$maximum<-renderUI({
    subs<-subset( df()
                  ,df()$freq >=input$freq )
      sliderInput("max",
                  "Maximum Number of Words:",
                  min = 1,  max = nrow(subs),  value =nrow(subs),step=1 )
  })
  output$frequency<-renderUI({
      sliderInput("freq",
                  "Minimum Frequency:",
                  min = 1,  max =max(df()$freq), value = 1,step=1)
    
  })
  
  
  
  output$word<-renderWordcloud2({
    
    subs<-subset( df()
                  ,df()$freq >=input$freq )
    #subs<-subs[1:input$max,]
    wordcloud2(subs[1:input$max,],size = 4)
    #wordcloud(words = df()$word, freq = df()$freq, min.freq = input$freq,max.words=input$max, random.order=FALSE, rot.per=0.35,            colors=brewer.pal(8, "Dark2"))
  })
  
}


shinyApp(ui, server)