I want to apply style based on value in column. For example first column has text 'A' and then apply style to the whole row. I tried the same with rowcallback, it works but it does not apply borders. I tried with default datatable border style overriding border-collapse : collapse
library(shiny)
library(DT)
css <- "
table.dataTable {
border-collapse: collapse !important;
}
.lastRow {
border-top: 1px solid #000 !important;
font-size: 13px;
font-weight: 600;
color: red;
letter-spacing: .5px;
}
"
Clback <- JS(
"function(row, data, index){",
"if (data[0] == 'C') {",
" $(row).addClass('lastRow');",
"}}"
)
shinyApp(
ui = fluidPage(
tags$head(
tags$style(HTML(css))
),
fluidRow(
column(12,
DTOutput('table')
)
)
),
server = function(input, output) {
mydf <- data.frame(x = LETTERS[1:10], y = sample(1:10))
output$table <- renderDT({
datatable(
mydf,
rownames = F,
options = list(
rowCallback = Clback
)
)
}
)
}
)
That's because the border properties must be applied to the td elements:
" $(row).find('td').addClass('lastRow');"
Related
I have been using the guidance here to colour the cells of my table in based on the number in the cell. However the whole table is currently displaying in the colour selected and not just the one cell.
This is what is currently outputting
I believe the issue with this is that my shiny app is built in modules.
This is the code in my DriversTable module:
# UI ----
topDriversTableUI <- function(id) {
tagList(
div(
style = "text-align: left; font-size: 120%",
h4(strong("Social risk")),
p("This section of the tool looks exclusively at the reasons why a neighbourhood is socially vulnerable.")
),
textOutput(NS(id, "lsoas_clicked_name")),
br(),
# dataTableOutput(NS(id, "drivers_table_domains")),
fluidRow(box(
tableOutput(NS(id, "top_drivers_table_domains")),
title = "Overarching reasons why the neighbourhood is socially vulnerable to flooding",
solidHeader = TRUE,
width = 11,
status = "primary",
collapsible = TRUE
)),
fluidRow(box(
tableOutput(NS(id, "top_drivers_table_variables")),
title = "Underlying reasons why the neighbourhood is socially vulnerable to flooding",
solidHeader = TRUE,
width = 11,
status = "primary",
collapsible = TRUE)
),
tags$head(tags$style("#top_drivers_table_variables td{
position:relative;
};
"))
)
}
# Server ----
topDriversTableServer <- function(id,
vuln_drivers,
lsoas_clicked,
selected_ltlas) {
# Checks to ensure the inputs are reactive (data not reactive)
stopifnot(is.reactive(lsoas_clicked))
moduleServer(id, function(input, output, session) {
observeEvent(
lsoas_clicked(),
{
top_drivers_data <- reactive({
vuln_drivers |>
dplyr::filter(lsoa11_name %in% lsoas_clicked()) |>
# explain the concept of quantiles in plain language
# variable_quantiles = 1 means in top 10% worst scoring neighborhoods nationally
mutate(quantiles_eng = case_when(
quantiles_eng <= 5 ~ '<div style="width: 100%; height: 100%; z-index: 0; background-color: red; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>',
quantiles_eng > 5 ~ '<div style="width: 100%; height: 100%; z-index: 0; background-color: green; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>')
) |>
select(
`Rank` = normalised_rank,
`Driver of flooding vulnerability` = domain_variable_name,
`Domain or variable` = domain_variable,
`Comparison of value nationally` = quantiles_eng
# `Values` = values
) |>
arrange(`Domain or variable`, Rank) |>
mutate(Rank = if_else(is.na(Rank), "-", as.character(Rank))) |>
mutate(`Comparison of value nationally` = if_else(is.na(`Comparison of value nationally`), "No data available", `Comparison of value nationally`))
})
output$top_drivers_table_domains <- renderTable({
top_drivers_data() |>
filter(`Domain or variable` == "domain") |>
select(-`Domain or variable`)
}, sanitize.text.function = function(x) x)
output$top_drivers_table_variables <- renderTable({
top_drivers_data() |>
filter(`Domain or variable` == "variable") |>
select(-`Domain or variable`)
}, sanitize.text.function = function(x) x)
output$lsoas_clicked_name <- renderText({
# Message to user if no LSOAs selected ----
# Blank since error message captured in 'top_drivers_table' object
validate(need(
length(lsoas_clicked()) > 0,
""
))
paste("Neighbourhood: ", lsoas_clicked())
})
},
ignoreNULL = FALSE # means event triggered when the input (i.e. lsoa_clicked()) is NULL. Needed to trigger the validate message
)
observeEvent(
selected_ltlas(),
{
lsoas_clicked(NULL)
}
)
})
}
I believe the issue is coming from this part of the code:
tags$head(tags$style("#top_drivers_table_variables td{
position:relative;
};
"))
I believe it is this part of the code because if I run this test code and commented out that part then a similar issue occurs:
test <- data.frame(test1 = c(1:3), test2 = c(4:6))
test[test$test2 == 5, "test2"] <- '<div style="width: 100%; height: 100%; z-index: 0; background-color: green; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>'
test[test$test2 == 4, "test2"] <- '<div style="width: 100%; height: 100%; z-index: 0; background-color: red; position:absolute; top: 0; left: 0; padding:5px;">
<span>1</span></div>'
library(shiny)
ui <- shinyUI(fluidPage(
box(tableOutput("tt"), title = "title"),
# tags$head(tags$style("#tt td{
# position:relative;
# };
#
# "))
)
)
server <- shinyServer(function(input, output) {
output$tt <- renderTable({
test
}, sanitize.text.function = function(x) x)
})
shinyApp(ui = ui, server = server)
When using module, you must use ns() around your objects IDs in your module. This ns() is adding the module id to the object id.
Which mean your object #top_drivers_table_variables actually is #moduleid-top_drivers_table_variables in your HTML code when it is inside a module.
So to add some CSS to it, you need to add the module id to it.
I think doing something like this should solve the problem
tags$head(tags$style(paste0("#",NS(id, "top_drivers_table_variables"), "td{
position:relative;
};
")))
To make some tests on what is really the id of an object when using modules, and especially nested modules, you can launch your app, and on you browser do a right click on the object and click "Inspect'. Then the HTML and CSS code of the app will appear on a panel on your browser. You can then verify what is really the id of you object.
I want the user to complete his email address to restore the password. I need the user to populate part of his email address in a inputText that is in the same line with the rest. I want something like this:
but this is what i get:
This is my code:
library(shiny)
ui <- fluidPage(
uiOutput("completeMailMessage")
,actionButton("Restore","Restore user")
)
server <- function(input, output, session) {
emailAddress<-"someone#gmail.com"
dotPosition<-tail(unlist(gregexpr("#", emailAddress)), n=1)
firstPart<-substr(emailAddress,1,1)
secondPart<-substr(emailAddress,2,dotPosition-2)
thirdPart<-substr(emailAddress,dotPosition-1,nchar(emailAddress))
observeEvent(input$Restore,{
emailAddress2<-paste0(firstPart,input$b,thirdPart)
print(emailAddress2)
})
output$completeMailMessage<-renderUI({
fluidRow(
tags$head(
tags$style(type="text/css","label{ display: table-cell; text-align: center;vertical-align: middle; } .form-group { display: table-row;}")
),
h4("Complete the email to restore the password:"),
div(style= " text-align: left;"
,tags$h5(firstPart)
,textInput(inputId = "b",
label = div(style = "font-size:10pX;", ""), value=secondPart,width = "200px")
,tags$h5(thirdPart)
)
)
})
}
shinyApp(ui = ui, server = server)
Any suggestion?
Thanks!
One solution:
library(shiny)
ui <- fluidPage(
uiOutput("completeMailMessage")
,actionButton("Restore","Restore user")
)
server <- function(input, output, session) {
emailAddress<-"someone#gmail.com"
dotPosition<-tail(unlist(gregexpr("#", emailAddress)), n=1)
firstPart<-substr(emailAddress,1,1)
secondPart<-substr(emailAddress,2,dotPosition-2)
thirdPart<-substr(emailAddress,dotPosition-1,nchar(emailAddress))
observeEvent(input$Restore,{
emailAddress2<-paste0(firstPart,input$b,thirdPart)
print(emailAddress2)
})
output$completeMailMessage<-renderUI({
fluidPage(
fluidRow(h4("Complete the email to restore the password:")),
fluidRow(
tags$head(
tags$style(HTML(
".form-control { height:auto; padding:1px 1px;}"
))
),
column(width = 1,
div(style = "white-space: nowrap;",
h5(firstPart,style="display:inline-block"),
div(style="display: inline-block; width: 100%;margin-left:0px",textInput("b", label = NULL, value = secondPart, width = 80)),
h5(thirdPart,style="display:inline-block")
)
)
)
)
})
}
shinyApp(ui = ui, server = server)
I would like to reduce the font-size (ticks) in the sliderInput. The UI is too large. Anyone can give helps? Thanks
Simple example:
ui <- fluidPage(
sliderInput("obs", "Number of observations:",
min = 0, max = 1000, value = 500
),
plotOutput("distPlot")
)
# Server logic
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs))
})
}
# Complete app with UI and server components
shinyApp(ui, server)
Best wishes,
hees
You can do this with CSS. Here I am modifying the property of the slider class, so if you have several sliderInput in your code, it will alter all of them.
ui <- fluidPage(
tags$head(
tags$style(HTML("
.irs-grid-text {
font-size: 6px;
}
.irs--shiny .irs-min,.irs--shiny .irs-max {
font-size: 6px;
}
.irs--shiny .irs-from,.irs--shiny .irs-to,.irs--shiny .irs-single {
font-size: 7px;
}
"))
),
sliderInput("obs", "Number of observations:",
min = 0, max = 1000, value = 500
),
plotOutput("distPlot")
)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs))
})
}
shinyApp(ui, server)
So far I successfully made a Shiny dashboard that makes a user select from the first dropdown and a second dropdown dependent on the first. Functionality-wise everything works well except for the UI part marked in star (*) in my script. What I want is the following two:
Make the second dropdown appear right next to the first and not below which can be accomplished by:
div(style="display:inline-block; vertical-align:top; margin-left: 20px", uiOutput("var_dropdown2"))
Make the second dropdown have a loading spinner once the first dropdown is selected:
uiOutput("var_dropdown2") %>% withSpinner(type = 6)
Both 1 and 2 work but when I try to combine these two it won't:
div(style="display:inline-block; vertical-align:top; margin-left: 20px", uiOutput("var_dropdown2") %>% withSpinner(type = 6))
How can I achieve the both?
Here is the fully working script:
#### Packages
library(dplyr)
library(shiny)
library(shinyWidgets) # pickerInput()
library(shinycssloaders) # withSpinner()
#### UI
ui <- fluidPage(
mainPanel(
### Dropdown 1
div(
style="display:inline-block; vertical-align:top; margin-left: 20px",
pickerInput(
"var_dropdown1",
"Dropdown 1:",
choices = c("Sepal", "Petal"),
multiple = T
)
),
### Dropdown 2
uiOutput("var_dropdown2") %>% withSpinner(type = 6) # Works without div()
# div(style="display:inline-block; vertical-align:top; margin-left: 20px", uiOutput("var_dropdown2")) # Works without withSpinner()
# div(style="display:inline-block; vertical-align:top; margin-left: 20px", uiOutput("var_dropdown2") %>% withSpinner(type = 6)) # Doesn't work if using both div() and withSpinner() *
)
)
#### Server
server <- function(input, output, session) {
### Dropdown 2
dropdown2 <- reactive({
if (length(input$var_dropdown1) == 1) {
if (input$var_dropdown1 == "Sepal") {
c("Sepal.Length", "Sepal.Width")
}
else {
c("Petal.Length", "Petal.Width")
}
}
else {
c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
}
})
## renderUI
output$var_dropdown2 <- renderUI({
req(input$var_dropdown1)
pickerInput(
"var_dropdown2",
"Dropdown 2:",
choices = dropdown2(),
multiple = T
)
})
}
####
shinyApp(ui=ui, server=server)
One possible solution is to use cloumn layout:
ui <- fluidPage(
mainPanel(
### Dropdown 1
fluidRow(
column(
6,
pickerInput(
"var_dropdown1",
"Dropdown 1:",
choices = c("Sepal", "Petal"),
multiple = T
)
),
column(
6,
uiOutput("var_dropdown2") %>% withSpinner(type = 6)
)
)
)
)
However, we can see the loader is not positioned in the right location as the dropdown. This is hard to achieve with shinycssloaders package. To do so, we can use some advanced loaders.
#### Packages
library(dplyr)
library(shiny)
library(shinyWidgets) # pickerInput()
library(spsComps)
#### UI
ui <- fluidPage(
mainPanel(
### Dropdown 1
div(
style="display:inline-block; vertical-align:top; margin-left: 20px",
pickerInput(
"var_dropdown1",
"Dropdown 1:",
choices = c("Sepal", "Petal"),
multiple = T
)
),
### Dropdown 2
div(
id = "dropdown2_container",
style="display:inline-block; vertical-align:top; margin-left: 20px; min-height: 50px; min-width: 250px",
uiOutput("var_dropdown2")
)
)
)
#### Server
server <- function(input, output, session) {
### Dropdown 2
dropdown2 <- reactive({
if (length(input$var_dropdown1) == 1) {
if (input$var_dropdown1 == "Sepal") {
c("Sepal.Length", "Sepal.Width")
}
else {
c("Petal.Length", "Petal.Width")
}
}
else {
c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
}
})
## renderUI
dd_loader <- spsComps::addLoader$new(target_selector = "dropdown2_container")
output$var_dropdown2 <- renderUI({
dd_loader$show()
on.exit({dd_loader$hide()})
req(input$var_dropdown1)
Sys.sleep(1)
pickerInput(
"var_dropdown2",
"Dropdown 2:",
choices = dropdown2(),
multiple = T
)
})
}
####
shinyApp(ui=ui, server=server)
Attaching loaders from spsComps takes a few more steps, but it allow you to have complete control of the loader, when to display, when to hide, change loader type, position, size and more dynamically, etc.
In this case, the loader is attached to the outside div instead of the uiOutput directly, because the height and width is subject to change when new UI is rendered inside var_dropdown2. The outside container is not usually modified by renderUI.
I'm trying to replicate this site_details table in R shiny , using stacked bar chart within a column in a table. Here is the code that I'm using currently:
cost_data<- data.frame(site = c('Site 1', 'Site 2','Site 3', 'Site 4'),
cost = c("6,3,6,7", "7,4,7,5","3,2,2,2","6,5,3,2"))
ui <- fluidPage(sparklineOutput("details.1"),
DT::dataTableOutput("cost_table"))
server <- function(input, output) {
output$cost_table <- DT::renderDataTable({
dt <- DT::datatable(as.data.frame(cost_data), rownames = FALSE,
options = list(columnDefs = list(list(targets = 1, render =
JS("function(data, type, full){ return '<span class=sparkSamples>' + data + '</span>' }"))),
fnDrawCallback = JS(paste0("function (oSettings, json) {\n
$('.sparkSamples:not(:has(canvas))').sparkline('html', { ", "type: 'bar',
fillColor: 'black'", " });\n}"), collapse = "")))
})
}
shinyApp(ui = ui, server = server)
The above code gives a simple bar chart. Can a horizontal stacked bar be added instead (as shown in image attached).
Thanks!!
Sparkline may not be able to do what you are looking for i.e., the stacked horizontal bar charts. But you can essentially render a custom JS code within the columnDefs of your renderDataTable.
Below is the sample code for the same-
# Prepare the Sample data
test_data <-
data.table(
Sites = c('Site1', 'Site2', 'Site3', 'Site4'),
A = c(6, 3, 6, 7),
B = c(7, 4, 7, 5),
C = c(3, 2, 2, 2),
D = c(6, 5, 3, 2)
)
test_data$chart <- NA
# Define the Shiny UI and Custom CSS Elements
ui <- fluidPage(tags$head(tags$style(
HTML(
"
.bar-chart-bar {
background-color: #e8e8e8;
display: block;
position:relative;
width: 100%;
height: 20px;
}
.bar {
float: left;
height: 100%;
}
.bar1 {
background-color: green;
}
.bar2 {
background-color: yellow;
}
.bar3 {
background-color: black;
}
.bar4 {
background-color: blue;
}
"
)
)), DT::dataTableOutput("test_table"))
# Rendering the DataTable in Shiny Server
server <- function(input, output) {
output$test_table <- DT::renderDataTable({
dt <- DT::datatable(
as.data.frame(test_data),
rownames = FALSE,
class = "compact display",
options = list(columnDefs = list(list(
targets = -1,
render =
JS(
"function(data, type, row, meta){
return $('<div></div>', {
'class': 'bar-chart-bar'
}).append(function(){
console.log(row)
console.log(row[1])
var bars = [];
for(var i = 1; i < row.length; i++){
bars.push($('<div></div>',{
'class': 'bar ' + 'bar' + i
}).css({
'width': row[i] + '%'
}))
}
return bars;
}).prop('outerHTML')
}"
)
)))
)
})
}
# Run the App
shinyApp(ui, server)
Check below image for the output of above code to show Bar Chart within RenderDataTable -
See Output Image