Generate Mean by using reactive value for use in if-function

shiny
,
1

I have Shiny App to display and to group a selected variable. I now try to display the selected variable in a different way regarding the mean. Therefore, I generate the mean of the selected variable and use the new reactive value for a if-function. First I have an error regarding the calculation of the mean:

  mean_var <- reactive({
    input$question
  })
  controll_mean <- reactive({
    mean(mean_var())
  })

, second regarding the if-function. Here is a small example:

library(shiny)
library(shinydashboard)
library(dplyr)
library(likert)
library(DT)
library(ggplot2)
library(likert)


levels.netusoft <- c("Sehr wenig", "Etwas", "Stark", "Sehr stark", "Verweigert", 
                     "Weiß nicht", "Keine Antwort")
levels.ppltrst <- c("1", "2", "3", "4", "5", "6", "Verweigert", "Weiß nicht", 
                    "Keine Antwort")
levels.polintr <- c("Überhaupt nicht", "Sehr wenig", "Etwas", "Stark", "Sehr stark", 
                    "Verweigert", "Weiß nicht", "Keine Antwort")
levels.psppsgva <- c("Überhaupt nicht fähig", "Wenig fähig", "Ziemlich fähig", 
                     "Sehr fähig", "Vollkommen fähig", "Verweigert", "Weiß nicht", 
                     "Keine Antwort")
levels.actrolga <- c("Wenig fähig", "Ziemlich fähig", "Sehr fähig", "Vollkommen fähig", 
                     "Verweigert", "Weiß nicht", "Keine Antwort")
levels.gndr <- c("männlich", "weiblich")

dataset <- data.frame("netusoft" = factor(sample(levels.netusoft, 100, 
                                                 replace = TRUE),
                                          levels.netusoft),
                      "ppltrst" = factor(sample(levels.ppltrst, 100, 
                                                replace = TRUE),
                                         levels.ppltrst),
                      "polintr" = factor(sample(levels.polintr, 100, 
                                                replace = TRUE),
                                         levels.polintr),
                      "psppsgva" = factor(sample(levels.psppsgva, 100, 
                                                 replace = TRUE),
                                          levels.psppsgva),
                      "actrolga" = factor(sample(levels.actrolga, 100, 
                                                 replace = TRUE),
                                          levels.actrolga),
                      "gndr" = factor(sample(levels.gndr, 100,
                                             replace = TRUE),
                                      levels.gndr),
                      check.names = FALSE)



# ----- UI
ui <- fluidPage(
  dashboardPage(
    dashboardHeader(title = "Test Dashboard", 
                    titleWidth = 300),
    dashboardSidebar(width = 300,
                     selectInput(inputId = "round", 
                                 label = "Wählen Sie eine ESS Runde aus",  
                                 c("ESS 9" = "9"),
                                 selected = "9", selectize = FALSE), 
                     #end selectinput
                     conditionalPanel(
                       condition = "input.round == '9'",
                       selectInput(inputId = "battery", 
                                   label = "Wählen Sie Themenfeld aus",
                                   c("A: Medien-, Internetnutzung, Soziales Vertrauen" = "A",
                                     "B: Politische Variablen, Immigration" = "B"), 
                                   selectize = FALSE), #end selectinput
                       uiOutput("question_placeholder")
                     ),
                     checkboxInput(
                       inputId = "group",
                       label = "Daten gruppieren",
                       value = FALSE), #end checkbox
                     
                     conditionalPanel(
                       condition = "input.group == true",
                       selectInput(
                         inputId = "UV",
                         label = "Daten gruppieren nach:",
                         c("Geschlecht" = "gndr")
                       ) # end conditionalPanel
                     )
    ), # end dashboardSidebar
    dashboardBody(
      fluidRow(
        box(width = 7, status = "info", solidHeader = TRUE,
            title = "Table:",
            dataTableOutput("tabelle", width = "100%")
        ),
        box(width = 8, status = "info", solidHeader = TRUE,
            title = "Graph:",
            plotOutput("plot", width = "auto", height = 500)
        )
      ) # end fluidRow
      
    ) #end dashboardBody
  )
)

server <- function(input, output, session) {
  get_data <- reactive({
    req(input$question)
    if (input$group) {
      dataset %>% 
        select(Antwortkategorie = input$question, req(input$UV)) %>% 
        group_by(grp = !!as.symbol(input$UV), Antwortkategorie)
    } else {
      dataset %>% 
        select(Antwortkategorie = input$question) %>% 
        group_by(Antwortkategorie)
    } 
  })
 
  #Generate Mean 
  mean_var <- reactive({
    input$question
  })
  controll_mean <- reactive({
    mean(mean_var())
  })
  
  output$question_placeholder <- renderUI({
    if (input$battery == "A") {
      choices <- c("A2|Häufigkeit Internetnutzung" = "netusoft",
                   "A4|Vertrauen in Mitmenschen" = "ppltrst")
    } else if (input$battery == "B") {
      choices <- c("B1|Interesse an Politik" = "polintr",
                   "B2|Politische Mitsprachemöglichkeit" = "psppsgva",
                   "B3|Fähigkeit politischen Engagements " = "actrolga")
    }
    selectInput(inputId = "question", 
                label = "Wählen Sie eine Frage aus",
                choices,
                selectize = FALSE)
  })
  
  output$tabelle <- renderDataTable({
    tab <- datatable(get_data() %>% 
                summarize(n = n()) %>% 
                mutate(Prozent = n / sum(n),
                       "Kum. Prozent" = cumsum(Prozent)),
              rownames = FALSE) %>% 
      formatPercentage(c("Prozent","Kum. Prozent"), 1) 
  
    if(controll_mean() > 2) {
      tab <- datatable(get_data() %>% 
                         select("gndr"))
    }
    tab
    })
  
  output$plot <- renderPlot({
    dat <- req(get_data())
    lik <- likert(dat %>% ungroup() %>% select(Antwortkategorie) %>% 
                    as.data.frame(),
                  grouping = if (input$group) dat %>% pull(grp))
    plot(lik)
  })
}

shinyApp(ui, server)
2

this means that mean_var will be exactly the value that input$question has taken (meaning it doesn't add anything beyond what you already had by being able to refer to input$question - it could perhaps be dispensed with), concretely this will be some string value like "netusoft" or "polintr"

therefore controll_mean will take the value of applying the mean function over a string with content like "netusoft" or "polintr". This will generate a warning and return NA
think about using the name to access a numeric vector somewhere and then calculating the mean on that.

3

Thanks for your advice. Do you have any idea how i get a numeric vector to calculate the mean?

I tried it this way - without success:

   mean_var <- reactive({
    dataset %>% 
       select(input$question) %>% 
       as.numeric()
    })
  
   controll_mean <- reactive({
     mean(mean_var(), na.rm = TRUE)
   })
4

Your issue is that select returns a dataframe with particular columns, whereas you want a specific column, but not for it to be a dataframe but as a standalone vector.
Therefore pull() is more appropriate than select()
here is an example:

library(shiny)
library(tidyverse)

dataset <- iris 

ui <- fluidPage(
  selectInput("question","pick a var",
              choices=names(select(dataset,where(is.numeric)))),
  verbatimTextOutput("out")
)

server <- function(input, output, session) {
  mean_var <- reactive({
    dataset %>% 
      pull(input$question) 
  })
  
  controll_mean <- reactive({
    mean(mean_var(), na.rm = TRUE)
  })
  
  output$out <- renderPrint({
    req(controll_mean())
  })
}

shinyApp(ui, server)
1 Like
5

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

If you have a query related to it or one of the replies, start a new topic and refer back with a link.