Dashboard deployed on shinyApps.io shows weird symbols - r

The local version of the dashboard looks different from the one deployed on the free Shiny server. To correct for this, I add some ccs and html to brute force the appearance. However, I am still running into some issues.
This is what it looks like locally:
This is what it looks like deployed on the shiny server:
Notice the weird symbols on the top left: (]*)?>)\1,
The symbols on the bottom left: 'TRUE TRUE TRUE'.
I have no idea what is causing this to happen. I've spent a lot of time tweaking the code, without any result.
I would really appreciate some insight! This issue only occurs when it is deployed on the server, and shows on BOTH tabs of the dashboard. :(
Here is my code:
library(shiny) # load the shiny package
library(ggplot2) # load the gglpot2 package if ploting using ggplot
library("shinythemes")
library(magrittr)
library(tidyverse)
library(shinyWidgets)
library(shiny)
library(shinymanager)
library(bsTools)
library(shinyBS)
# this was set placement to bottom, but selectize calls below were set to right set "right" here and no need to set it below
selectizeTooltip <- function(id, choice, title, placement = "right", trigger = "hover", options = NULL){
options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
bsTag <- shiny::tags$script(shiny::HTML(paste0("
$(document).ready(function() {
var opts = $.extend(", options, ", {html: true});
var selectizeParent = document.getElementById('", id, "').parentElement;
var observer = new MutationObserver(function(mutations) {
mutations.forEach(function(mutation){
$(mutation.addedNodes).filter('div').filter(function(){return(this.getAttribute('data-value') == '", choice, "');}).each(function() {
$(this).tooltip('destroy');
$(this).tooltip(opts);
});
});
});
observer.observe(selectizeParent, { subtree: true, childList: true });
});")))
htmltools::attachDependencies(bsTag, shinyBS:::shinyBSDep)
}
ui <- fluidPage(navbarPage(
theme = shinytheme("superhero"),
# can't comment within this section like I'd prefer ---
# first - control the tooltip window- I added min-width and max-width
# tool tip to the top by using z-index (I think that's why the tip was hidden)
# -- however, it still wants to show the tip after selecting it and the tip is hidden then...
# then control font-size by the entire form - (labels and input boxes don't inherit the form's styles)
# I tried to set the styles for the labels here, but they wouldn't stick
# I captured the class names by visiting developer tools in my browser after rendering online
# the class labels were not all the same when looking at it locally and after uploading
tags$head(tags$style(HTML('.tooltip .tooltip-inner { min-width: 200px; max-width: 400px;
font-size: 1.5em; text-align:left; padding:10px; z-index: 2 !important;}
.shiny-input-container .control-label {margin-bottom: 1em;}
.selectize-dropdown .option .selectize-input {line-height:1.1em; font-size:2em!important;}
.well {min-height:200px; min-width:200px; font-size:1.5em!important;}'))),
tabPanel(
title = "Program Participation",
sidebarLayout(
sidebarPanel(
uiOutput("choose_prog"),
uiOutput("choose_name"),
selectizeTooltip(id="choose_name", choice = "group 1",
title = "group 1 definition this is a long definition that does not really display well within the narrow text box",
trigger = "hover"),
selectizeTooltip(id="choose_name", choice = "group 2",
title = "group 2 definition this is another long definition. When group 1 and group 3 is is selected, you no longer see this definition",
trigger = "hover"),
selectizeTooltip(id="choose_name", choice = "group 3",
title = "group 3 definition this does not show if all of the other groups are selected ",
trigger = "hover"),
),
mainPanel(
plotOutput("plot")
# br(),
)
)),
# SECOND TAB
tabPanel(title = "Additional Information/ Documentation",
pageWithSidebar(
headerPanel("Data sources and other information"),
sidebarPanel(
),
mainPanel("Place holder for information about data"
)
)
)
))
server <- function(input, output) {
# result_auth <- secure_server(check_credentials = check_credentials(credentials))
output$plot <- renderPlot({
plot(mtcars$wt, mtcars$mpg)
}, height = 800, width = 'auto')
# Drop down selection to chose the program
output$choose_prog <- renderUI({
selectInput("program",
label = HTML('<font style="color:orange; font-size:2em;">Select a program:</font>'),
choices = c("A","B","C"))
})
# Drop down for name
output$choose_name <- renderUI({
# SelectInput works, but this only allows the selection of a SINGLE option
selectInput("names",
label = HTML('<font style="color:orange; font-size:2em;">Select user group of interest:</font>'),
choices = c("group 1", "group 2", "group 3"),
multiple = T)})
observeEvent(input$choose_name, {
updateSelectizeInput(session, "choose_name", choices = c("group 1", "group 2", "group 3"))
})
}
shinyApp(ui = ui, server = server)

Your rending true true true (and other appearing randomness) is eliminated by updating the libraries to what you're actually using.
For all of this programming, you only need to call:
library(shiny)
library(shinythemes)
library(tidyverse)
You used pageWithSidebar() in your second tabPanel. That function is deprecated. If you're going to use this app for a while, change that to fluidPage() or fluidRow().
When I rendered this, it kept wanting to put the plot below the sidebar. You should add fluidRow() in the first tabPanel(). That way it will try to render them next to each other unless the fit is an issue.
You have the plot at a set height and an auto width. I'm not sure exactly how shiny reads and renders this. It may be useful to lock the aspect ratio.
In the tags$head... call, I added .column-sm-8 {min-width:400px;} to make the main panel of the first tabPanel have a minimum width. It looks like this class (so this minimum width) will apply to any mainPanel you use.
Lastly, in the server function, you have the plot than the input form. Since it looks like your building the complexity as you go, it would be ideal to order the content here as it appears, when it gets really complex it will make following your work a lot easier. R doesn't care what order you put it in, though.

Related

Weird behavior of selectizeInput

In the Shiny App below, I am facing a very strange behavior, where selectInput box slides downwards when I type something in this box. Also, the text inside selectInput box moves towards the right while I type in this box. I have spent a lot of time to find out the reason for this problem but could not figure it out. Can someone point out the mistake I am doing causing this strange behavior?
library(shiny)
library(shinydashboard)
library(highcharter)
siderbar <- dashboardSidebar(
sidebarMenu(
selectizeInput(inputId = "select_by", label = "Select by:", choices = NULL, multiple = FALSE, options = NULL)
)
)
body <- dashboardBody(
fluidRow(
tabBox(
side = "right",
selected = "Tab1",
tabPanel("Tab1", "Tab content 1", highchartOutput("tabset1Selected"))
)
),
)
shinyApp(
ui = dashboardPage(
dashboardHeader(title = "tabBoxes"),
siderbar,
body
),
server = function(input, output, session) {
selectedVal <- reactiveValues()
updateSelectizeInput(session, "select_by", choices = c(as.character(1:10000)), selected = 2, server = TRUE)
output$tabset1Selected <- renderHighchart({
selectedVal <- input$select_by
print(highcharts_demo())
})
}
)
We were on the right track. It has something to do with selectize.js updating the items from the server. You can verify that by setting the loadThrottle option to 5000. This option determines how long the widget waits "before requesting options from the server" (see the manual). Now you have to wait exactly 5 seconds and then the select widget flickers.
The issue seems to be caused by a CSS conflict. selectize.js adds a CSS class to the widget. If you remove that feature, the flicker goes away.
selectizeInput(inputId = "select_by", label = "Select by:",
choices = NULL, multiple = FALSE,
options = list(loadThrottle=200, loadingClass=""))
loadingClass sets a specific CSS class (default: 'loading') while loading data from the server. Purpose: to change how the widget looks and communicate to users that an update is in progress.
loadThrottle does not need to be set. It's default is 300. You can set it to any value that suits your needs.
Details
highcharter defines it's own CSS class names loading with these specs:
.loading {
margin-top: 10em;
text-align: center;
color: gray;
}
That is the reason for the CSS conflict. The widget gets a top margin and it's content moved to the center, because the browser does not distinguish the source of the class. It only sees some CSS that fits and uses it. This image shows where you need to look:

How to display a hover in the box element inside fluidRow in shiny app

I have a code which has multiple fluidRows and every fluidrow comprises of multiple collapsible box elements which are default collapsed,
my concern is to display a hover when the box is collapsed on the shiny app, depicting "you can open the box to see the data and also a small brief about the data present"
With BSTooltip functionality I am able to show a hover on the data inside the box but not on the collapsible box.
This is a major functionality.
Please help.
fluidRow(
box(
id = "djc",
title = "BY SEGMENT",
width = 12,
status = "primary",
solidHeader = TRUE,
align='center',
collapsible = TRUE,
collapsed = TRUE,
DT::dataTableOutput("tab_PF2")
),
bsTooltip("djc", "This is a Table which talks about all the segments and there data shift and book shift respectfully", placement = "bottom", trigger = "hover",
options = NULL)
))
Above is one fluid row in which I can depict tooltip on the data.
I was able to achieve your question by applying js on columns not on column names.
library(shiny)
shinyApp(
ui = fluidPage(
DT::dataTableOutput("mtcarsTable")
),
server = function(input, output) {
output$mtcarsTable <- DT::renderDataTable({
DT::datatable(datasets::mtcars[,1:3],
options = list(rowCallback = JS(
"function(nRow) {",
"var full_text = 'Test1';",
"var full_text1 = 'Test2';",
"$('td:eq(0)', nRow).attr('title', full_text);",
"$('td:eq(1)', nRow).attr('title', full_text1);",
"}")
)
)
})
}
)
I hope this helps you.
Not sure of your exact use case, but you can use JavaScript to add a title attribute to all the box collapse buttons.
Add this code to your ui:
tags$head(tags$script("
$( document ).ready(function() {
$('.btn.btn-box-tool').attr('title', 'hovering info');
});
"))

Show/Hide button on tab select R shiny

I have a button in my ui.R that I want to be shown only when "Summary" tab is selected, so I thought of this code
fluidRow(
column(4,
column(12,id="sub",
actionButton("submit", "SUBMIT", width = "100%"))),
column(8,
bsCollapse(id = "collapse7", open = "Results",
bsCollapsePanel("Results",
tabsetPanel(
tabPanel("Summary",
tags$script(HTML("document.getElementById('sub').style.visibility = 'visible';")))
tabPanel("Plot",
tags$script(HTML("document.getElementById('sub').style.visibility = 'hidden';"))))
))))
The problem is, the button is hidden even though in my first tab it should be visible and also when i go to Plots and back to Summary, the button stays hidden.
After looking at: How to use tabPanel as input in R Shiny?
I decided to play with observeEvent and the input$tabset option. The result is 100% working and it's really simple. Here's the code:
observeEvent(input$choices, {
choice = input$choices
if(choice == "Summary")
{
runjs(
"document.getElementById('submit').style.visibility = 'visible';"
)
}
else
{
runjs(
"document.getElementById('submit').style.visibility = 'hidden';"
)
}
})
Also, I found out why my previous code wasn't working, it was due to the fact that when the UI was initialized, the button element kept the last style modification (the hidden one) and it didn't change depending on the tab I have selected, since its not reactive.

Rshiny - Disabling tabs / adding text to tabs

I have a problem with shiny tabs. I want to create a navigation page with two tabs. Right to them, I would like to insert some user's login details. There is no option "text" or other to insert a text in the navbarPage. But I created an additionnal tab instead:
library(shiny)
runApp(list(
ui = navbarPage(
title="My App",
tabPanel("tab1 title"),
tabPanel("tab2 title"),
tabPanel("User: Madzia")),
server = function(input, output) { }
))
It is OK like this, but I do not want the third tab to be "selectible": I want it to be disabled, so that we cannot click on it - the same as on "My App" text. Do you have any idea about how to handle this problem?
Thank you! Best, Madzia
You can achieve disabling a tab with a tiny bit of javascript. I have an example of how to hide a tab (not disable) in recent blog post, you can see the code for that here. I modified that code a bit for disabling instead.
This code is hacky because it was done in 2 minutes but will work for a basic use case
library(shiny)
library(shinyjs)
jscode <- '
shinyjs.init = function() {
$(".nav").on("click", ".disabled", function (e) {
e.preventDefault();
return false;
});
}
'
css <- '
.disabled {
background: #eee !important;
cursor: default !important;
color: black !important;
}
'
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jscode, functions = "init"),
tags$style(css),
checkboxInput("foo", "Disable tab2", FALSE),
tabsetPanel(
id = "navbar",
tabPanel(title = "tab1",
value = "tab1",
h1("Tab 1")
),
tabPanel(title = "tab2",
value = "tab2",
h1("Tab 2")
),
tabPanel(title = "tab3",
value = "tab3",
h1("Tab 3")
)
)
),
server = function(input, output) {
observe({
toggleClass(condition = input$foo,
class = "disabled",
selector = "#navbar li a[data-value=tab2]")
})
}
)
Edit I didn't fully read the question when I posted my answer, I just saw that you wanted a way to disable a tab and that was my answer. Your specific usecase (creating a tab only to show the name of a user) is a bit strange, but I suppose this will still work...
I would like to keep my previous answer in existence because it may be useful for someone in the future who wants to know how to disable a tab.
But for this specific problem, disabling the tab is not the correct approach. It makes more sense to simply add text to the tab (as Valter pointed out in a comment). If you look at the documentation for bootstrap, it says you can add text into the navbar by adding an html element with class navbar-text. I experimented with the HTML a little bit to figure out exactly where this needs to be done, and created a little function that will wrap around navbarPage() to allow you to add text to it.
Here's an example:
library(shiny)
navbarPageWithText <- function(..., text) {
navbar <- navbarPage(...)
textEl <- tags$p(class = "navbar-text", text)
navbar[[3]][[1]]$children[[1]] <- htmltools::tagAppendChild(
navbar[[3]][[1]]$children[[1]], textEl)
navbar
}
ui <- navbarPageWithText(
"Test app",
tabPanel("tab1", "tab 1"),
tabPanel("tab2", "tab 2"),
text = "User: Dean"
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)

Direct link to tabItem with R shiny dashboard

I am using the shiny dashboard template to generate my web UI.
I'd like to dynamically generate an infobox when a computation is completed with a link directed to one of the tabItems in dashboardBody.
For example,
I can put this in my tabItem1 output,
renderInfoBox({
infoBox("Completed",
a("Computation Completed", href="#tabItem2"),
icon = icon("thumbs-o-up"), color = "green"
)
})
But the problem is that when I click the link, it does nothing. I would like it jumps to tabItem2. The link href seems valid when I hover on it.
Thanks!
Update:
Other than using Javascripts, looks like using actionLink and updateTabItems functions in shinydashboard package will work as well.
I apologize for the lengthy code sample, but I had to copy an example with tabItems from the shinydashboard homepage.
Your approach has only few problems. First, if you would inspect the menuItems, you'd see that the actual tab's id is not tabItem2, but shiny-tab-tabItem2. This, plus the extra attribute data-toggle="tab" within the a tag would suffice to open the desired tab. Snippet:
a("Computation Completed", href="#shiny-tab-tabItem2", "data-toggle" = "tab")
But, this has its limits. First and most obvious, the state of the menuItem in the sidebar is not set to active. This looks very odd and one might not be convinced, that one has been moved to another tab.
Second, and less obvious, if you listen to tab changes (on the server side), you will not get information about this tab switch. Those are triggered by the menuItem being clicked, and the tab itself will not report if it is visible or hidden.
So, my approach will be to simulate that the corresponding menuItem is clicked, and thus, all the above problems are solved.
Code example:
library(shiny)
library(shinydashboard)
ui <- shinyUI(
dashboardPage(
dashboardHeader(title = "Some Header"),
dashboardSidebar(
sidebarMenu(
menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
menuItem("Results", tabName = "tabItem2", icon = icon("th"))
)
),
dashboardBody(
tags$script(HTML("
var openTab = function(tabName){
$('a', $('.sidebar')).each(function() {
if(this.getAttribute('data-value') == tabName) {
this.click()
};
});
}
")),
tabItems(
tabItem(tabName = "tabItem1",
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
),
infoBoxOutput("out1")
),
tabItem(tabName = "tabItem2",
h2("Widgets tab content")
)
)
)
)
)
server <- function(input, output){
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
output$out1 <- renderInfoBox({
infoBox("Completed",
a("Computation Completed", onclick = "openTab('tabItem2')", href="#"),
icon = icon("thumbs-o-up"), color = "green"
)
})
}
shinyApp(ui, server)
Note, that the only important thing is the onclick property, not an href. This means, that every div or other element can be used to create this link. You could even have just the thumbs-up image with this onclick command.
If you have more questions, please comment.
Best Regards
Edit: Whole infoBox clickable.
This is an answer to a comment by OmaymaS. The point was to make the infoBox a clickable container. To achieve this, one can define a new function that makes a somewhat different infoBox. The custom box will be as follows:
customInfoBox <- function (title, tab = NULL, value = NULL, subtitle = NULL, icon = shiny::icon("bar-chart"), color = "aqua", width = 4, href = NULL, fill = FALSE) {
validateColor(color)
tagAssert(icon, type = "i")
colorClass <- paste0("bg-", color)
boxContent <- div(class = "info-box", class = if (fill) colorClass,
onclick = if(!is.null(tab)) paste0("$('.sidebar a')).filter(function() { return ($(this).attr('data-value') == ", tab, ")}).click()"),
span(class = "info-box-icon", class = if (!fill) colorClass, icon),
div(class = "info-box-content",
span(class = "info-box-text", title),
if (!is.null(value)) span(class = "info-box-number", value),
if (!is.null(subtitle)) p(subtitle)
)
)
if (!is.null(href)) boxContent <- a(href = href, boxContent)
div(class = if (!is.null(width)) paste0("col-sm-", width), boxContent)
}
This code is copied from the original infoBox function definition and only the line with onclick is new. I also added the openTab function (with some twitches) right inside the container such that you dont need to worry where to put this function inside the view. Might be a bit overloaded i feel.
This custom info box can be used exactly like the default one and if you pass the additional tab argument, the link to the sidebar is added.
Edit: Subtitle exploit
As Alex Dometrius mentioned, the use of subtitle crashes this functionality. This is because the script tag that was inserted, on accident, was used as the subtitle argument in order to be rendered with the box. To free up this spot, I edited the main example up top such that the script tag is sitting top level in the dashboardBody (literally anywhere in the ui would be fine).
(To avoid confusion: in Version 1, the tags$script was supplied inside of infobox where it was interpreted as the subtitle parameter.)

Resources