sliderinput with observing multiple events and varying default value

Jacob1 · May 12, 2021, 8:30am

Disclaimer: I just started learning R to program an experiment for my thesis, so sorry in advance for asking what are probably super basic questions - I am struggling a bit and can´t really find anyone who could help me with this

I am building an interactive questionnaire (in German) consisting of multiple pages.

I want to load the page HSV8G1 if any of the action buttons input$HSV1G1eq, input$HSV2G1eq, input$HSV3G1eq, input$HSV4G1eq, input$HSV5G1eq, input$HSV6G1eq, input$HSV7G1eq, input$HSV7G1eq, input$HSV7G1A, input$HSV7G1B, input$HSV6G1A, input$HSV6G1B, input$HSV4G1A, input$HSV4G1B, input$HSV3G1A, input$HSV3G1B is toggled.

I tried implementing a solution suggested in another post but it returns the error "missing value where TRUE/FALSE needed".

The default value of HSV8S1 should depend on the action button used to access the page - how to implement it? I tried with an if function but couldn´t make it work.

Pls find the code I came up with so far below - I am aware it is probably a stupid and impractical way to build this, but again I just started

Many thanks for your understanding & support.

###instructions
W <-c("Weiter")
A <-c("Option A")
B <-c("Option B")
C <-c("Beiden Optionen haben den gleichen Wert")
D <-c("Fuer wie viele Jahre in perfekter Gesundheit waeren Sie indifferent zwischen Option A und Option B?")
E <-c("Welche Option bevorzugen Sie?")

###TTO input
tx <- 10
ty <- 20



library(shiny)

###################################################
#ui
###################################################

ui <- (htmlOutput("page"))

###intro
intro <- function(...) {
  div(class = 'container', id = "intro",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1("Startseite"),
          p("Platzhalter"),
          br(),
          actionButton("W1", W)
      ))
  
}

###declaration of consent
decl <- function(...) {
  div(class = 'container', id = "decl",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1("Einwilligung zur Teilnahme"),
          p("Platzhalter"),
          br(),
  radioButtons("Einwilligung",label = NULL, choices = c("Ich stimme zu","Ich stimme nicht zu")),
  actionButton("W2", W)
      ))
  
}

###explanation HSV
expl1 <- function(...) {
  div(class = 'container', id = "expl1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1("Einleitung Teil 1"),
          p("Platzhalter"),
          br(),
          actionButton("W3", W)
      ))
  
}

###HSV

#G1

HSV1G1 <- function(...) {
  div(class = 'container', id = "HSV1G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV1G1A", A),
          actionButton("HSV1G1B", B),
          actionButton("HSV1G1eq", C),
          sliderInput("S1", D, 0, ty, 10, step = 0.1)
      ))
  
}

HSV2G1 <- function(...) {
  div(class = 'container', id = "HSV2G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV2G1A", A),
          actionButton("HSV2G1B", B),
          actionButton("HSV2G1eq", C),
          sliderInput("HSV2S1", D, 0, ty, 15, step = 0.1)
      ))
  
}

HSV3G1 <- function(...) {
  div(class = 'container', id = "HSV3G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV3G1A", A),
          actionButton("HSV3G1B", B),
          actionButton("HSV3G1eq", C),
          sliderInput("HSV3S1", D, 0, ty, 17.5, step = 0.1)
      ))
  
}

HSV4G1 <- function(...) {
  div(class = 'container', id = "HSV4G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV4G1A", A),
          actionButton("HSV4G1B", B),
          actionButton("HSV4G1eq", C),
          sliderInput("HSV4S1", D, 0, ty, 12.5, step = 0.1)
      ))
  
}

HSV5G1 <- function(...) {
  div(class = 'container', id = "HSV5G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV5G1A", A),
          actionButton("HSV5G1B", B),
          actionButton("HSV5G1eq", C),
          sliderInput("HSV5S1", D, 0, ty, 5, step = 0.1)
      ))
  
}

HSV6G1 <- function(...) {
  div(class = 'container', id = "HSV6G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV6G1A", A),
          actionButton("HSV6G1B", B),
          actionButton("HSV6G1eq", C),
          sliderInput("HSV6S1", D, 0, ty, 7.5, step = 0.1),
      ))
  
}

HSV7G1 <- function(...) {
  div(class = 'container', id = "HSV7G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          actionButton("HSV7G1A", A),
          actionButton("HSV7G1B", B),
          actionButton("HSV7G1eq", C),
          sliderInput("HSV7S1", D, 0, ty, 2.5, step = 0.1)
      ))
  
}

HSV8G1 <- function(...) {
  div(class = 'container', id = "HSV8G1",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1(E),
          p(G1),
          br(),
          sliderInput("HSV8S1", D, 0, ty, 2.5, step = 0.1),
          actionButton("HSV8G1C", W)
      ))
  
}

###conclusive elicitation
concl <- function(...) {
  div(class = 'container', id = "concl",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1("Abschliessende Erhebung"),
          p("Bitte beantworten Sie zuletzt die folgenden Fragen."),
          br(),
          selectInput("Geschlecht","Mein Geschlecht ist", c("maennlich","weiblich","divers")),
          numericInput("Alter","Mein Alter ist",value = NULL),
          actionButton("W4", W)
      ))
  
}

###outro
outro <- function(...) {
  div(class = 'container', id = "outro",
      div(class = 'col-sm-2'),
      div(class = 'col-sm-8',
          h1("Abschluss"),
          p("Platzhalter"),
          br(),
          textInput("Email","Email"),
          actionButton("Senden", "Senden"),
          actionButton("end", "Beenden")
      ))

}





render_page <- function(...,f, title = "Test") {
  page <- f(...)
  renderUI({
    fluidPage(page, title = title)
  })
}

###################################################
###server
###################################################
server <- function(input, output){
  
  #intro
  output$page <- render_page(f = intro)
  
  #declaration of consent
  observeEvent(input$W1, {
    output$page <- render_page(f = decl)
  })
  
  #explanation HSV
  observeEvent(input$W2, {
    if (input$Einwilligung == "Ich stimme zu") output$page <- render_page(f = expl1)
  })
  
  #HSV
  observeEvent(input$W3, {
    output$page <- render_page(f = HSV1G1)
  })
  
  #HSV1G1
  observeEvent(input$HSV1G1A, {
    output$page <- render_page(f = HSV5G1)
  })
  
  observeEvent(input$HSV1G1B, {
    output$page <- render_page(f = HSV2G1)
  })
  
  #HSV2G1
  observeEvent(input$HSV2G1A, {
    output$page <- render_page(f = HSV4G1)
  })
  
  observeEvent(input$HSV2G1B, {
    output$page <- render_page(f = HSV3G1)
  })
  
  #HSV5G1
  observeEvent(input$HSV5G1A, {
    output$page <- render_page(f = HSV7G1)
  })
  
  observeEvent(input$HSV5G1B, {
    output$page <- render_page(f = HSV6G1)
  })
  
  #HSV8G1
  loadSlider <- reactive({
    list(input$HSV1G1eq, input$HSV2G1eq, input$HSV3G1eq, input$HSV4G1eq, input$HSV5G1eq, input$HSV6G1eq, input$HSV7G1eq, input$HSV7G1eq, input$HSV7G1A, input$HSV7G1B, input$HSV6G1A, input$HSV6G1B, input$HSV4G1A, input$HSV4G1B, input$HSV3G1A, input$HSV3G1B)
  })
  observeEvent(loadSlider(), {
    if(input$HSV1G1eq == 0 && input$HSV2G1eq == 0 && input$HSV3G1eq == 0 && input$HSV4G1eq == 0 && input$HSV5G1eq == 0 && input$HSV6G1eq == 0 && input$HSV7G1eq == 0 && input$HSV7G1A == 0 && input$HSV7G1B == 0 && input$HSV6G1A == 0 && input$HSV6G1B == 0 && input$HSV4G1A == 0 && input$HSV4G1B == 0 && input$HSV3G1A == 0 && input$HSV3G1B == 0){
      return()
    }
    output$page <- render_page(f = HSV8G1)
  })
  
  
  #outro
  observeEvent(input$W4, {
    output$page <- render_page(f = outro)
  })
  
  #end
  observeEvent(input$end, {
    stopApp()
  })

}



###################################################
###run
###################################################
shinyApp(ui = ui, server = server)

nirgrahamuk · May 12, 2021, 8:48am

seems like you are attempting to create shiny modules without using shiny modules.
Welcome | Mastering Shiny (mastering-shiny.org)
Chapter 19 Shiny modules | Mastering Shiny (mastering-shiny.org)

system · July 7, 2021, 6:38pm

This topic was automatically closed 54 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.