How to center *reactive* box in RShiny? - r

I am trying to have an explanatory image and text box appear after a user presses an action button. Ideally, Id like the box to be centered and directly below the image without too much space in between. Also, I'm curious how to make the box wider for aesthetic purposes.
Here is what my attempt looks like:
Here is my code:
ui <- dashboardPage(
dashboardHeader(title = "Test Test Test"),
dashboardSidebar(disable = T),
dashboardBody(useShinyjs(),
shinyUI(fluidPage(
navbarPage(
"Test",
id = "main_navbar",
tabPanel(
"Test",
fluidRow(align="center",
column(width = 6,
numericInput("age", "Age", 40, min = 18, max = 100, step = 2)
)),
fluidRow(align="center",
actionButton("predict", "Predict")
),
br(),
fluidRow(align="center",
imageOutput("waterfallPlot")
),
shinyjs::hidden(
div(style="text-align: justify",
id = "hiddenbox",
box(
title = "Hidden Box",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
uiOutput(outputId = "waterfallDescription")
)
)
)
)
)
))))
server <- function(input, output, session) {
results <- eventReactive(input$predict, {
output <- as.integer(input$age)
output
})
output$waterfallPlot <- renderImage({
# Return a list containing the filename
temp <- results()
list(src = waterfallPlots[1],
contentType = 'image/png'
,width = 400,
height = 300
)
}, deleteFile = FALSE)
observeEvent(input$predict, {
shinyjs::show(id = "hiddenbox")
})
output$waterfallDescription <- renderText({
temp <- results()
HTML(paste0("<p>","bold","</b>", " The waterfall chart to the left explains why your prediction
differs from the average person’s prediction.The average prediction is shown at the bottom.", "</p>", "<p>",
"Each factor that goes into the model is shown in increasing order of impact going up.
For example, a blue bar pointing left means that your input for that feature decreases the model’s
output from the average output by the listed number.", "</p>"))
})
}
shinyApp(ui, server)

library(shiny);
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(title = "Test Test Test"),
dashboardSidebar(disable = T),
dashboardBody(useShinyjs(),
shinyUI(fluidPage(
navbarPage(
"Test",
id = "main_navbar",
tabPanel(
"Test",
fluidRow(align="center",
column(width = 12,
numericInput("age", "Age", 40, min = 18, max = 100, step = 2)
)),
fluidRow(align="center",
actionButton("predict", "Predict")
),
br(),
fluidRow(align="center",
imageOutput("waterfallPlot", height = "200px")
),
shinyjs::hidden(
div(style="text-align: justify",
id = "hiddenbox",
box(
width = 12,
title = "Hidden Box",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
uiOutput(outputId = "waterfallDescription")
)
)
)
)
)
))))
server <- function(input, output, session) {
results <- eventReactive(input$predict, {
output <- as.integer(input$age)
output
})
output$waterfallPlot <- renderImage({
# Return a list containing the filename
temp <- results()
list(src = tempfile(),
contentType = 'image/png'
,width = 400,
height = 300
)
}, deleteFile = FALSE)
observeEvent(input$predict, {
shinyjs::show(id = "hiddenbox")
})
output$waterfallDescription <- renderText({
temp <- results()
HTML(paste0("<p>","bold","</b>", " The waterfall chart to the left explains why your prediction
differs from the average person’s prediction.The average prediction is shown at the bottom.", "</p>", "<p>",
"Each factor that goes into the model is shown in increasing order of impact going up.
For example, a blue bar pointing left means that your input for that feature decreases the model’s
output from the average output by the listed number.", "</p>"))
})
}
shinyApp(ui, server)
You can use width to change box width, from 1-12.
Use height of imageOutput to adjust the gap between image and box.

Related

How to change variable name using textInput in a ShinyApp?

I would like the name of the variables to change according to a text typed in textInput.
For example, when I typed "Stack Overflow" in "A1" field, this name ("Stack Overflow") would appear as the new name, instead conj1.
My code:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
sidebar <- dashboardSidebar(width = 300,
sidebarMenu(
menuItem(text = "Simulador", tabName = "simulador1",icon = icon("dashboard"))
)
)
body <- dashboardBody(
column(id = "c1", width = 12,
textInput(inputId = "ar1", label = "A 1", placeholder = "Digite")
),
column(id = "colsimul4", width = 12,
textInput(inputId = "lvl1", value = 1,label = "Nível 1", placeholder = "Digite")
),
column(width = 12, tableOutput(outputId = "new"))
)
server <- function(session, input, output) {
fpred_1 <- function(x) {
x
}
predattr1 <- reactive({
fpred_1(x = input$ar1)
})
pred_1 <- reactive({
fpred_1(x = input$lvl1)
})
output$new <- renderTable({
isolate(expr = conj1 <- predattr1())
experiment <- expand.grid(conj1 = c(pred_1()))
isolate(expr = experiment)
})
}
ui <- dashboardPage(header, sidebar, body)
shinyApp(ui, server)
I would like the name of the variables conj to be modified according to what is typed in the field A1
I tried this:
isolate(expr = conj1 <- predattr1())
But doesn't work.
For example, if I typed "Stack Overflow", this name appears instead of conj1.
The values ​​change normally, only the variable names do not.
Edit
I tried that too:
output$new <- renderTable({
isolate(expr = conj1 <- predattr1())
x <- names(predattr1())
experiment <- expand.grid(
colnames(x)[1] = c(pred_1())
)
expr = experiment
})
Nothing...
library(shiny)
library(shinydashboard)
################################################################################
# UI
################################################################################
# Header
header <- dashboardHeader(title = "Dashboard", titleWidth = 300)
# Sidebar
sidebar <- dashboardSidebar(width = 300,
sidebarMenu(menuItem(
text = "Simulador",
tabName = "simulador1",
icon = icon("dashboard")
)))
# Body
body <- dashboardBody(
column(
id = "c1",
width = 12,
# Text input 1
textInput(
inputId = "ar1",
label = "A1",
placeholder = "Digite"
)
),
column(
id = "colsimul4",
width = 12,
# Text input 2
textInput(
inputId = "lvl1",
value = 1,
label = "Nível 1",
placeholder = "Digite"
)
),
# Table appears below text inputs in same column/panel
column(width = 12, tableOutput(outputId = "new"))
)
ui <- dashboardPage(header, sidebar, body)
################################################################################
# Server
################################################################################
server <- function(session, input, output) {
# Create table
experiment <- reactive({
df <- expand.grid(req(input$lvl1))
colnames(df) <- req(input$ar1)
return(df)
})
# Render table
output$new <- renderTable({
experiment()
})
}
shinyApp(ui, server)

Issue with UI side of Shiny app with data table

I am in the process of creating a shiny app for a process at work and am struggling to figure something out on the UI side of the app. I would like to display a data table next to a sidebar menu containing options for the app. The issue is that when I do so, the data table is pushed down below the sidebar panel instead of beside it (see the original data tab).
I found a work around as seen in the suggested tab, but that comes with its own issues. I need to be able to lock the column headers while scrolling through the app and when the data table is inside the box element, I am unable to find a way to do so.
Here is the code to a simplified version of the app.
library(shiny)
library(lubridate)
library(tidyverse)
library(DT)
library(shinydashboard)
library(shinythemes)
library(sortable)
library(reactlog)
ui<- dashboardPage(
#this gives you the name displayed on the tab
dashboardHeader(title = "HHS Resin Purchasing 0.99"),
#this gives you your sidebar (page) options
dashboardSidebar(
sidebarMenu(
menuItem("Original Data", tabName = "original"),
menuItem("Suggested", tabName = "suggested")
)
),
#this is the body of the webpages
dashboardBody(
#this gives you the body options that are displayed on every page
sidebarPanel(width = 2,
h2("Menu Options"),
h4(strong("Upload Data:")),
fileInput("file", "Data", buttonLabel = "Upload..."),
textInput("delim", "Delimiter (leave blank to guess)", ""),
numericInput("skip", "Rows to skip", 0, min = 0),
h4(strong("User Options:")),
selectInput("plant", "Select a Plant", choices =
c("All")),
dateInput("latest_date", "Select the latest W_LEAD date in the data",
value = Sys.Date()),
numericInput("avg_multiple", "Multiple of Daily Useage for Cuttoff",21, min = 1, max = 50),
h4(strong("Download Options:")),
actionButton("complete_orders", "Analysis for plant orders complete"),
actionButton("complete_checks", "Mid month check complete"),
downloadButton("downloadData1", label = "Download Suggested Orders...", class = "btn-block"),
downloadButton("downloadData2", label = "Download Flags...", class = "btn-block"),
downloadButton("downloadData3", label = "Download Full Suggested Orders Data...", class = "btn-block")
),
#This is the actual data that fills those page options listed above
tabItems(
tabItem(tabName = "original",
DT::dataTableOutput(outputId = "preview1")
),
tabItem(tabName = "suggested",
box(title = "Suggested Orders",width = 9, status = "primary", height = "auto",
solidHeader = T, dataTableOutput("preview2"), style = "max-height:800px; overflow-y: scroll;overflow-x: scroll;")
)
)
)
)
server <- function(input, output) {
output$preview1 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20))
})
output$preview2 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20))
})
}
shinyApp(ui, server)
Help in fixing either of the issues outlined above would be very appreciated! Thanks in advance.
I think using the column() function will support your first question of the datatable moving under the sidebar sidebarPanel. Please see example below.
I think the second request of freezing the row header in the datatable can be resolved with the advice found at Freezing header and first column using data.table in Shiny
library(shiny)
library(lubridate)
library(tidyverse)
library(DT)
library(shinydashboard)
library(shinythemes)
library(sortable)
library(reactlog)
ui<- dashboardPage(
#this gives you the name displayed on the tab
dashboardHeader(title = "HHS Resin Purchasing 0.99"),
#this gives you your sidebar (page) options
dashboardSidebar(
sidebarMenu(
menuItem("Original Data", tabName = "original"),
menuItem("Suggested", tabName = "suggested")
)
),
#this is the body of the webpages
dashboardBody(
#this gives you the body options that are displayed on every page
fluidRow(
column(width = 2,
sidebarPanel(width = 2,
h2("Menu Options"),
h4(strong("Upload Data:")),
fileInput("file", "Data", buttonLabel = "Upload..."),
textInput("delim", "Delimiter (leave blank to guess)", ""),
numericInput("skip", "Rows to skip", 0, min = 0),
h4(strong("User Options:")),
selectInput("plant", "Select a Plant", choices =
c("All")),
dateInput("latest_date", "Select the latest W_LEAD date in the data",
value = Sys.Date()),
numericInput("avg_multiple", "Multiple of Daily Useage for Cuttoff",21, min = 1, max = 50),
h4(strong("Download Options:")),
actionButton("complete_orders", "Analysis for plant orders complete"),
actionButton("complete_checks", "Mid month check complete"),
downloadButton("downloadData1", label = "Download Suggested Orders...", class = "btn-block"),
downloadButton("downloadData2", label = "Download Flags...", class = "btn-block"),
downloadButton("downloadData3", label = "Download Full Suggested Orders Data...", class = "btn-block")
)
),
#This is the actual data that fills those page options listed above
column(width = 6,
tabItems(
tabItem(
tabName = "original",
DT::dataTableOutput("preview1",
options = list(dom = 't',
scrollX = TRUE,
paging=FALSE,
fixedHeader=TRUE,
fixedColumns = list(leftColumns = 1, rightColumns = 0)))
),
tabItem(tabName = "suggested",
box(title = "Suggested Orders",width = 9, status = "primary", height = "auto",
solidHeader = T, dataTableOutput("preview2"), style = "max-height:800px; overflow-y: scroll;overflow-x: scroll;")
)
)
)
)
)
)
server <- function(input, output) {
output$preview1 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20)))
})
output$preview2 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20)))
})
}
shinyApp(ui, server)

Adding a sliderInput to a ggplot line chart in ShinyDashboard

I've been struggling to add a functional slider input to my ggplot line chart for "number of observations", but I keep getting errors .. The code below works but the plot does not change ( I tried lots of stuff like adding a reactive function or adding input$obs inside ggplot but it still didn't work) .. I really appreciate your help ! Thanks
library(shiny)
library(shinydashboard)
library(readxl)
library(ggplot2)
library(dashboardthemes)
library(shinyWidgets)
library(dplyr)
df=read_excel("MASI.xlsx")
# Define UI for application that draws a histogram
ui <- dashboardPage(
dashboardHeader(title = "Finance Dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(
title = "Line chart", status = "primary", solidHeader = TRUE,
collapsible = TRUE,
plotOutput("plot1", height = 250)
),
box(
title = "MASI", status = "primary", solidHeader = TRUE,
"The MASI index (Moroccan All Shares Index) is a stock index that tracks the performance of all
companies listed in the Casablanca Stock Exchange located at Casablanca."
),
box(
title = "Inputs", status = "primary", solidHeader = TRUE, collapsible = TRUE,
sliderInput("obs",
"Number of observations:",
min = 1,
max = length(df$MASI),
value = 50)
),
),
),
setBackgroundColor(
color = "white",
gradient = c("linear", "radial"),
direction = c("bottom", "top", "right", "left"),
shinydashboard = TRUE
)
)
server <- function(input, output) {
output$plot1 <- renderPlot({
ggplot(df,aes(x=Session, y=MASI)) + geom_line( color="darkblue", size=0.7) + theme_bw()
}, bg="transparent")
}
shinyApp(ui, server)
EDIT
Thank you for the kind answer #chemdork123.
I want to add a Date range in addition to the sliderInput. Here's what I did:
library(shiny)
library(shinydashboard)
library(readxl)
library(ggplot2)
library(dashboardthemes)
library(shinyWidgets)
library(dplyr)
df=read_excel("MASI.xlsx")
# Define UI for application that draws a histogram
box_height = "20em"
plot_height = "16em"
ui <- dashboardPage(
dashboardHeader(title = "Finance Dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(
title = "Line chart", status = "primary", solidHeader = TRUE,
collapsible = TRUE,
plotOutput("plot1", height = 250)
),
box(
title = "MASI", status = "primary", solidHeader = TRUE,
"The MASI index (Moroccan All Shares Index) is a stock index that tracks the performance of all
companies listed in the Casablanca Stock Exchange located at Casablanca."
),
box(
title = "Inputs", status = "primary", solidHeader = TRUE, collapsible = TRUE,
sliderInput("obs",
"Number of observations:",
min = 1,
max = length(df$MASI),
value = 50),
dateRangeInput("date", strong("Date range"),
start = "2015-01-02", end = "2020-07-17",
min = "2015-01-02", max = "2020-07-17")
),
box(
title = "Line chart", status = "success", solidHeader = TRUE,
collapsible = TRUE,
plotOutput("plot2", height = 250)
),
box(
title = "Return", status = "success", solidHeader = TRUE,
"The relative difference of the MASI index"
),
box(
title = "Inputs", status = "success", solidHeader = TRUE, collapsible = TRUE,
sliderInput("obs",
"Number of observations:",
min = 1,
max = length(df$MASI),
value = 50)
),
),
),
setBackgroundColor(
color = "white",
gradient = c("linear", "radial"),
direction = c("bottom", "top", "right", "left"),
shinydashboard = TRUE
)
)
server <- function(input, output) {
reactive_data <- reactive({
set.seed(8675309) # for some consistent sampling
df <- df[sample(x=1:nrow(df), size = input$obs),]
return(df)
req(input$date)
validate(need(!is.na(input$date[1]) & !is.na(input$date[2]), "Error: Please provide both a start and an end date."))
validate(need(input$date[1] < input$date[2], "Error: Start date should be earlier than end date."))
df %>%
filter(
date > as.POSIXct(input$date[1]) & date < as.POSIXct(input$date[2]
))
})
output$plot1 <- renderPlot({
ggplot(reactive_data(),aes(x=Session, y=MASI)) + geom_line(color="darkblue", size=0.7) + theme_bw()
}, bg="transparent")
output$plot2 <- renderPlot({
ggplot(df,aes(x=Session, y=Return)) + geom_line( color="darkblue", size=0.7) + theme_bw()
}, bg="transparent")
}
shinyApp(ui, server)
Here is a link for the Dataset
Capture
OP. Without your data, it's difficult to give you a clear answer to your particular question, but I can show you how the input$obs slider input control can be used (or any other one for that matter) to filter and provide data for your ggplot() function to display.
Here's a working app that gives you two controls to adjust what data is displayed from the mtcars built-in dataset. The sliderInput() control determines how many rows are sampled from the total mtcars dataset. The selectInput() control allows you to select one or all of the values for mtcars$carb to display in the chart based on the sampled dataset.
You will see the general approach on how to use both inputs reactively is to create a reactive function (called sample_cars()) that is called inside of the renderPlot() function. The reactive function sample_cars() returns a data frame that is used in the ggplot() call.
library(shiny)
library(shinydashboard)
library(ggplot2)
library(dplyr)
library(tidyr)
ui <- dashboardPage(
dashboardHeader(title = "Example App"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(
title = "Line chart", status = "primary", solidHeader = TRUE,
collapsible = TRUE,
plotOutput("plot1", height = 250)),
box(
title = "Inputs", status = "primary", solidHeader = TRUE, collapsible = TRUE,
sliderInput("obs", "Number of observations:",
min = 1, step = 1, max = nrow(mtcars), value = nrow(mtcars)),
selectInput("carbs", "Select carb to show",
choices = c('All', unique(mtcars$carb))
)
),
)
)
)
server <- function(input, output) {
sample_cars <- reactive({
set.seed(8675309) # for some consistent sampling
df <- mtcars[sample(x=1:nrow(mtcars), size = input$obs),]
if(input$carbs != "All")
df <- df %>% dplyr::filter(carb == input$carbs)
return(df)
})
output$plot1 <- renderPlot({
ggplot(sample_cars(), aes(mpg, disp)) + geom_point() +
labs(title=paste('You selected',input$obs, 'cars\n and to show',input$carbs, 'values of carb!'))
}, bg="transparent")
}
shinyApp(ui, server)

R shiny: slickROutput disappears when switching tabpanel()

I am making a Shiny app with tabPanels embedded in a navbarPage.
In each tabPanel, I generate a serie of image. When switching from one panel to the other one, the image loaded in one of them disappear.
I have to "refresh" manually the page to see it again. The problem seems similar than the one posted here but I cannot really subset my tabPanels, even though I gave $id and value to them.
Here is a reproducible example:
library(shiny)
library(shinythemes)
library(slickR)
## ui ----
# Image list
imgs <- list(
stackoverflow =
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
stackexchange =
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png"
)
ui <- navbarPage(title = div(
HTML('<span style="font-size:180%;color:white;font-weight:bold;"> Navbarpage</span></a>'),
tags$style(style = 'position:absolute; right:42px;'),
tags$style(HTML("#panel1{font-size: 25px}")),
tags$style(HTML("#panel2{font-size: 25px}")),
tags$style(HTML("#panel_about{font-size: 25px}"))
),
theme = shinytheme("flatly"),
windowTitle = "Navbarpage",
id = "navbar",
## First tabpanel ----
tabPanel(h1(id = "panel1", "Panel 1"), value = 1, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel1"))),
),
tabPanel(h1(id = "panel2", "Panel 2"), value = 2, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel2"))),
)
) # closes navbarpage
## server ----
server <- function(input, output, session){
observe({
output$plot_panel1 <- renderSlickR({
slick1 <- slick_list(slick_div(
input$img_list,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick1)
})
})
observe({
output$plot_panel2 <- renderSlickR({
slick2 <- slick_list(slick_div(
input$img_list,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick2)
})
})
}
shinyApp(ui, server)
And what it produces:
When there are multiple slickR objects to be rendered, you need to use a unique slideId for each. Furthermore you should not wrap render* functions in observe and use the same id for two selectInputs.
Please check the following:
library(shiny)
library(shinythemes)
library(slickR)
## ui ----
# Image list
imgs <- list(
stackoverflow =
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
stackexchange =
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png"
)
ui <- navbarPage(title = div(
HTML('<span style="font-size:180%;color:white;font-weight:bold;"> Navbarpage</span></a>'),
tags$style(style = 'position:absolute; right:42px;'),
tags$style(HTML("#panel1{font-size: 25px}")),
tags$style(HTML("#panel2{font-size: 25px}")),
tags$style(HTML("#panel_about{font-size: 25px}"))
),
theme = shinytheme("flatly"),
windowTitle = "Navbarpage",
id = "navbar",
## First tabpanel ----
tabPanel(h1(id = "panel1", "Panel 1"), value = 1, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list1", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel1"))),
),
tabPanel(h1(id = "panel2", "Panel 2"), value = 2, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list2", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel2"))),
)
) # closes navbarpage
## server ----
server <- function(input, output, session){
output$plot_panel1 <- renderSlickR({
slick1 <- slick_list(slick_div(
input$img_list1,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick1, slideId = "slide1")
})
output$plot_panel2 <- renderSlickR({
slick2 <- slick_list(slick_div(
input$img_list2,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick2, slideId = "slide2")
})
}
shinyApp(ui, server)

R highcharter, valuebox, eventreactive didn't work together in shiny

I want to build an app by shinydashboard that work like this:
textInput
Submit actionbutton to update value box based in input text
valuebox (to show input text)
Tabbox with 5 tabpanel
Each tabpanel has histogram with different data and rendered by Highcharter
VerbatimTextOutput to indivate which tabpanel chosen
This is my code:
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
textInput(
"unicode",
"Your Unique ID:",
placeholder = "Input your unique ID here"
),
actionButton(
"ab1_unicode",
"Submit"
),
width = 6
),
tags$head(tags$style(HTML(".small-box {height: 130px}"))),
valueBoxOutput(
"vbox1_unicode",
width = 6
)
),
fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",
id = "tabset1",
height = "500px",
width = 12,
tabPanel(
"Extraversion",
"This is Extraversion",
highchartOutput(
"hist"
)
),
tabPanel(
"Conscientiousness",
"This is Conscientiousness",
highchartOutput(
"hist"
)
),
tabPanel(
"Agreeableness",
"This is Agreeableness",
highchartOutput(
"hist"
)
),
tabPanel(
"Emotional Stability",
"This is Emotional Stability",
highchartOutput(
"hist"
)
),
tabPanel(
"Intelligent",
"This is Intelligent",
highchartOutput(
"hist"
)
)
)
),
fluidRow(
box(
"Personality in a nutshell", br(),
"Second row of personality explanation",
verbatimTextOutput(
"tabset1selected"
),
width = 12,
height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
}, ignoreNULL = F)
output$vbox1_unicode <- renderValueBox({
valueBox(
update_unicode(),
"Your Unique ID",
icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "Conscientiousness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
output$hist <- renderHighchart({
hchart(
dimension(input$tabset1)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),
plotBands = list(
color = '#3ac9ad',
from = update_unicode,
to = update_unicode,
label = list(
text = "Your Score",
color = "#9e9e9e",
align = ifelse(update_unicode>30,"right","left"),
x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)
Problems:
valuebox dissapear
highchart didn't appear
I made only 1 histogram with conditions to save the efeciency. but it looks didn't work well.
This is what the result looked like
Please help me guys
The issue is that the the binding between an id in the UI and on the server side has to be unique. However, in your dashboard the id="hist" appears more than once in the UI, i.e. you have a duplicated binding.
This could be seen by 1. opening the dashboard in the Browser, 2. opening the dev tools 3. having a look the console output which shows a JS error message "Duplicate binding for id hist".
Not sure about your final result but to solve this issue you could e.g. add one highchartOutput per panel. To this end:
I have put the plotting code in a separate function make_hc
Added an highchartOutput for each of your panels or datasets, e.g.
output$hist1 <- renderHighchart({
make_hc("Extraversion", update_unicode())
})
This way we get 5 outputs with unique ids which could be put inside the respective panels in the UI.
Full reproducible code:
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
textInput(
"unicode",
"Your Unique ID:",
placeholder = "Input your unique ID here"
),
actionButton(
"ab1_unicode",
"Submit"
),
width = 6
),
tags$head(tags$style(HTML(".small-box {height: 130px}"))),
valueBoxOutput(
"vbox1_unicode",
width = 6
)
),
fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",
id = "tabset1",
height = "500px",
width = 12,
tabPanel(
"Extraversion",
"This is Extraversion",
highchartOutput(
"hist1"
)
),
tabPanel(
"Conscientiousness",
"This is Conscientiousness",
highchartOutput(
"hist2"
)
),
tabPanel(
"Agreeableness",
"This is Agreeableness",
highchartOutput(
"hist3"
)
),
tabPanel(
"Emotional Stability",
"This is Emotional Stability",
highchartOutput(
"hist4"
)
),
tabPanel(
"Intelligent",
"This is Intelligent",
highchartOutput(
"hist5"
)
)
)
),
fluidRow(
box(
"Personality in a nutshell", br(),
"Second row of personality explanation",
verbatimTextOutput(
"tabset1selected"
),
width = 12,
height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
}, ignoreNULL = F)
output$vbox1_unicode <- renderValueBox({
valueBox(
update_unicode(),
"Your Unique ID",
icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "Conscientiousness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
make_hc <- function(x, update_unicode) {
hchart(
dimension(x)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),
plotBands = list(
color = '#3ac9ad',
from = update_unicode,
to = update_unicode,
label = list(
text = "Your Score",
color = "#9e9e9e",
align = ifelse(update_unicode>30,"right","left"),
x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
}
output$hist1 <- renderHighchart({
make_hc("Extraversion", update_unicode())
})
output$hist2 <- renderHighchart({
make_hc("Conscientiousness", update_unicode())
})
output$hist3 <- renderHighchart({
make_hc("Agreeableness", update_unicode())
})
output$hist4 <- renderHighchart({
make_hc("Emotional Stability", update_unicode())
})
output$hist5 <- renderHighchart({
make_hc("Intelligent", update_unicode())
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)

Resources