Images for radiobutton r shiny - html

I am learning how to use images as radiobuttons.
I found this page and have been playing around with it:
Can you have an image as a radioButton choice in shiny?
The answer here has been very useful but the app doesn't load the Rlogo for the radiobutton (when using the second part of the answer using the functions). I have saved the image into a www file. I have tried different variations of writing the line '<img src="Rlogo.png">' = 'logo' like removing the quotations, replacing it with img(src='Rlogo.png') = 'logo' , replace it with the web link, but have been unsuccessful. Please can someone point out where I am going wrong or if the original code works for you!
logo is here: http://i1.wp.com/www.r-bloggers.com/wp-content/uploads/2016/02/Rlogo.png?resize=300%2C263
code is copied over from the page:
library(shiny)
radioButtons_withHTML <- function (inputId, label, choices, selected = NULL, inline = FALSE,
width = NULL)
{
choices <- shiny:::choicesWithNames(choices)
selected <- if (is.null(selected))
choices[[1]]
else {
shiny:::validateSelected(selected, choices, inputId)
}
if (length(selected) > 1)
stop("The 'selected' argument must be of length 1")
options <- generateOptions_withHTML(inputId, choices, selected, inline,
type = "radio")
divClass <- "form-group shiny-input-radiogroup shiny-input-container"
if (inline)
divClass <- paste(divClass, "shiny-input-container-inline")
tags$div(id = inputId, style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), class = divClass,
shiny:::controlLabel(inputId, label), options)
}
generateOptions_withHTML <- function (inputId, choices, selected, inline, type = "checkbox")
{
options <- mapply(choices, names(choices), FUN = function(value,
name) {
inputTag <- tags$input(type = type, name = inputId, value = value)
if (value %in% selected)
inputTag$attribs$checked <- "checked"
if (inline) {
tags$label(class = paste0(type, "-inline"), inputTag,
tags$span(HTML(name)))
}
else {
tags$div(class = type, tags$label(inputTag, tags$span(HTML(name))))
}
}, SIMPLIFY = FALSE, USE.NAMES = FALSE)
div(class = "shiny-options-group", options)
}
choices <- c('\\( e^{i \\pi} + 1 = 0 \\)' = 'equation',
'<img src="Rlogo.png">' = 'logo')
ui <- shinyUI(fluidPage(
withMathJax(),
img(src='Rlogo.png'),
fluidRow(column(width=12,
radioButtons('test', 'Radio buttons with MathJax choices',
choices = choices, inline = TRUE),
br(),
h3(textOutput('selected'))
))
))
server <- shinyServer(function(input, output) {
output$selected <- renderText({
paste0('You selected the ', input$test)
})
})
shinyApp(ui = ui, server = server)

Here is a way.
library(shiny)
radioImages <- function(inputId, images, values){
radios <- lapply(
seq_along(images),
function(i) {
id <- paste0(inputId, i)
tagList(
tags$input(
type = "radio",
name = inputId,
id = id,
class = "input-hidden",
value = as.character(values[i])
),
tags$label(
`for` = id,
tags$img(
src = images[i]
)
)
)
}
)
do.call(
function(...) div(..., class = "shiny-input-radiogroup", id = inputId),
radios
)
}
css <- HTML(
".input-hidden {",
" position: absolute;",
" left: -9999px;",
"}",
"input[type=radio] + label>img {",
" width: 50px;",
" height: 50px;",
" transition: 500ms all;",
"}",
"input[type=radio]:checked + label>img {",
" border: 1px solid #fff;",
" box-shadow: 0 0 3px 3px #090;",
" transform: rotateZ(-10deg) rotateX(10deg);",
"}"
)
ui <- fluidPage(
tags$head(tags$style(css)),
br(),
wellPanel(
tags$label("Choose a language:"),
radioImages(
"radio",
images = c("java.svg", "javascript.svg", "julia.svg"),
values = c("java", "javascript", "julia")
)
),
verbatimTextOutput("language")
)
server <- function(input, output, session){
output[["language"]] <- renderPrint({
input[["radio"]]
})
}
shinyApp(ui, server)
Credit.

This will also work:
library(shiny)
library(shinyWidgets)
ui <- shinyUI(fluidPage(
withMathJax(),
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
fluidRow(column(width=12,
radioGroupButtons('test', 'Radio buttons with MathJax choices',
choiceNames = c('\\( e^{i \\pi} + 1 = 0 \\)',
'<i class="icon_rlogo"></i>'),
choiceValues = c('equation', 'logo')),
br(),
h3(textOutput('selected'))
))
))
server <- shinyServer(function(input, output) {
output$selected <- renderText({
paste0('You selected the ', input$test)
})
})
shinyApp(ui = ui, server = server)
With in your www folder your Rlogo.png image and a style.css file with:
.icon_rlogo {background: url(Rlogo.png) no-repeat center;
background-size: contain;
display: inline-block;
width: 30px;
height: 20px;}
To be customised as you wish.

Related

Is there a way to display HTML inside a selectInput in an R shiny app [duplicate]

This question already has an answer here:
use html in selectizeInput with R shiny
(1 answer)
Closed 5 months ago.
Is there a way to display HTML tags such as Cu<sup>2+</sup> displaying as "Cu2+" inside a selectInput option in an R shiny app ? I would like to display chemical formulae for instance:
library(shiny)
ui <- fluidPage(
withMathJax(),
selectInput(
inputId = "id",
label = "Choice",
choices = c('H<sub>2</sub> O', 'CO<sub>2 </sub>','NH<sub>4 </sub><sup>+<\sup>')
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
I have already tried MathJax which works but considerably slows down the application and KaTeX which is faster but only works in a browser. I think HTML would be the most efficient way.
Its possible to set it up all in the ui like so :
library(shiny)
ui <- fluidPage(
selectizeInput("myinput",
label="choose",
choices = c(r'(H<sub>2</sub> O)',
r'(CO<sub>2 </sub>)',
r'(NH<sub>4 </sub><sup>+</sup>)'),
options = list(render = I(
'{
item: function(item, escape) {
return "<div>" + item.value + "</div>";
},
option: function(item, escape) {
return "<div>" + item.value + "</div>";
}
}')))
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
As shown in this article we can use updateSelectizeInput to use custom HTML for the choices parameter:
library(shiny)
ui <- fluidPage(withMathJax(),
selectizeInput(
inputId = "id",
label = "Choice",
choices = NULL
))
server <- function(input, output, session) {
updateSelectizeInput(
session,
inputId = "id",
choices = c(
h2o = "H<sub>2</sub>O",
co2 = "CO<sub>2 </sub>",
NH4Plus = "NH<sub>4</sub><sup>+</sup>"
),
options = list(
render = I(
'{
item: function(item, escape) {
return "<div>" + item.value + "</div>";
},
option: function(item, escape) {
return "<div>" + item.value + "</div>";
}
}')
),
server = FALSE
)
}
shinyApp(ui, server)

Problem in centering table header in shiny

Problem in centering table header in shiny, when centering my table the first column remains aligned to the left. How do I fix this? Just below I made available my CSS code. I'm in doubt as to how to align the first column of my table. I am also in doubt, if I called the CSS correctly in my code.
library(shiny)
library(dplyr)
bd= read.csv("bd.csv", sep = ";")
ui = fluidPage(
fixedRow(
column(12,
titlePanel("Tabelas"),
sidebarLayout(
sidebarPanel(selectInput("TABELA", "Selecione a Tabela:", choices = bd$TABELA),
downloadButton("downloadData", "Download")),
mainPanel(tags$link(
rel='stylesheet',
type='text/css',
href='custom.css'),
(tableOutput("bd")))
)
)
)
)
server = function(input, output) {
output$bd <- renderTable({
bd %>%
dplyr::filter(TABELA == input$TABELA)%>%
dplyr::select(LOCAL, ENTREVISTAS.PRE, ENTREVISTAS.POS, CITACOES.PRE, CITACOES.POS, PERCENT.PRE, PERCENT.POS)
}
)
output$downloadData <- downloadHandler(
filename = function() {
paste("bd-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
write.csv(bd, file)
}
)
}
shinyApp(ui = ui, server = server)
.table.shiny-table>thead>tr>th,
.table.shiny-table>thead>tr>td,
.table.shiny-table>tbody>tr>th,
.table.shiny-table>tbody>tr>td,
.table.shiny-table>tfoot>tr>th,
.table.shiny-table>tfoot>tr>td {
padding-right: 12px;
padding-left: 12px;
font-size:80%;
text-align: center;
}
.table>caption+thead>tr:first-child>td,
.table>caption+thead>tr:first-child>th,
.table>colgroup+thead>tr:first-child>td,
.table>colgroup+thead>tr:first-child>th,
.table>thead:first-child>tr:first-child>td,
.table>thead:first-child>tr:first-child>th {
border-top: 0;
font-size:80%;
text-align: center;
}
What I like to do to format the table is to use the datatable function from the DT package.
I create a create_dt function with new variables to pass some values, which I use throughout the shiny application. I leave the format that I use in my tables, if you want to use it. There are many options to configure your table here.
create_dt <- function(x,y = NULL,z = NULL,w,v = NULL){
v <- if_else(is.null(v),TRUE,FALSE)
y <- if_else(is.null(y),16,y)
datatable(x,
rownames = FALSE,
class = "compact cell-border",
extensions = 'Buttons',
caption = z,
options = list(dom = 'rtB',
buttons = list(list(extend='excel',
filename = 'Nombre tabla',
text = '<i class="fas fa-download"></i>')),
pageLenght = y,
lengthMenu = list(c(y,25,50,-1),
c(y,25,50,"All")),
scrollX = TRUE,
initComplete = htmlwidgets::JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});","}"),
columnDefs = list(list(className = 'dt-center', targets = '_all'))
),
container = w,
escape = v) %>%
formatStyle(columns = names(x),
color = "black",
fontSize = '8pt')
This is what my table looks like.
example of table
And this is how I apply the function with the data:
And the Ui part:
fluidRow(column(6,withSpinner(dataTableOutput("resume_tbl_entero",height = '100%'))))
The server part:
output$resume_tbl_entero <- renderDataTable(
{create_dt({React_ano_filter_general_entero() %>%
mutate(Resultado = str_to_sentence(Resultado)) %>%
pivot_wider(names_from = Resultado,values_from=Total)},
z = "Enterococcus")}
And the data used looks like this
I hope it serves you greetings!

How can I add background color and icon in title of modalDialog() function in R shiny?

I have the following code.
library(shiny)
library(dplyr)
library(DT)
app <- shinyApp(
ui = fluidPage(
tags$head(tags$style("#modal1 .modal-header {background-color: #339FFF}")),
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- reactive({ head(mtcars)})
output$mydatatable = DT::renderDataTable(mycars(), selection = 'single',
rownames = FALSE, options = list(dom = 't'))
selected_row <- reactiveVal(value = NULL)
observeEvent(input$mydatatable_rows_selected,{
selected_row(input$mydatatable_rows_selected)
})
observeEvent(selected_row(), {
showModal(tags$div(id="modal1", modalDialog(
title = tags$a(style = "color: black", icon('robot'), br(), 'Query Text'),
tags$div(HTML(paste(
"cyl = ",
tags$span(mycars()$cyl[selected_row()],
style = paste("color:", if (mycars()$mpg[selected_row()] > 21) {
"red"
} else {
"blue"
})
)
)))
)))
})
})
)
app
My aim is to change background color of title similar to the color I have for cyl value in modalDialog() and also to add a robot icon in the title if cyl <= 6 and a user icon if cyl > 6, like below picture.
How is it possible in R shiny? Thanks in advance =)
library(shiny)
library(dplyr)
library(DT)
app <- shinyApp(
ui = fluidPage(
uiOutput("code"),
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- reactive({ head(mtcars)})
output$mydatatable = DT::renderDataTable(mycars(), selection = 'single',
rownames = FALSE, options = list(dom = 't'))
selected_row <- reactiveVal(value = NULL)
observeEvent(input$mydatatable_rows_selected,{
selected_row(input$mydatatable_rows_selected)
})
output$code <- renderUI({
validate(need(!is.null(selected_row()) & nrow(mycars()) > 0, " "))
if (mycars()$mpg[selected_row()] > 21) {
tags$head(tags$style("#modal1 .modal-header {background-color: #FFD8D8; text-align: center}"))
} else {
tags$head(tags$style("#modal1 .modal-header {background-color: #339FFF; text-align: center}"))
}
})
f <- function(){
if (mycars()$mpg[selected_row()] > 21){
tags$a(style = "color: black", icon('robot'), br(), 'Query Text')
} else{
tags$a(style = "color: black", icon('users'), br(), 'Query Text')
}
}
observeEvent(selected_row(), {
showModal(tags$div(id="modal1", modalDialog(
title = f(),
tags$div(HTML(paste(
"cyl = ",
tags$span(mycars()$cyl[selected_row()],
style = paste("color:", if (mycars()$mpg[selected_row()] > 21) {
"red"
} else {
"blue"
})
)
)))
)))
})
})
)
app

Unable to place element to inline-block

I have an example, where dateRangeInput and actionButton are added dynamically.
I need elements to be positioned side by side and not in the block.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(), #Set up shinyjs
tabsetPanel(
tabPanel("Settings",
br(),
fluidRow(
column(width = 8,
box(
title = "Set parameters", id = "RO_05_param_box", width = NULL, solidHeader = TRUE, status ="primary", collapsible = TRUE,
fluidRow(
box(radioButtons("RO_05_param_radio", h6("Company"), choices = list("A" = 1,
"B" = 2), selected = 1), br(),
dateRangeInput("date_range_view", h6("Timeline"), start = "2019-06-30", end = "2020-06-30"), br(),
selectInput("RO_05_param_select", h6("Distribute over time"), choices = list("Stepped line" = 2, "Linear funcion" = 1))
),
box(id= "step_box", dateRangeInput("RO05_date1", h6("Start and end date"), start = "2019-06-30", end = "2020-06-30"),
tags$div(id = 'placeholder_dateRangeInput'),
actionButton("add_lag", "Add dates")
)
)
)
)
)
)
)
)
)
server <- function(input, output) {
observeEvent(input$RO_05_param_select, {
if(input$RO_05_param_select == 2){
show(id = "step_box")
} else {
hide(id = "step_box")
}
})
observeEvent(input$add_lag, {
add <- input$add_lag + 1
addID <- paste0("NO", add)
daterangeID <- paste0('RO05_date', add)
removeID <- paste0('remove_lag', add)
insertUI(
selector = '#placeholder_dateRangeInput',
ui = tags$span(id = addID,
tags$span(dateRangeInput(daterangeID, h6("Near lag and far lag"), start = "2019-06-30", end = "2020-06-30")),
tags$span(actionButton(removeID, label= '', icon("minus")))
)
)
observeEvent(input[[removeID]], {
removeUI(selector = paste0('#', addID))
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I tried adding this css:
#placeholder_dateRangeInput {
display: inline-block;
}
But all it does it only shrinks dateRangeInput widget.
However, #placeholder_dateRangeInput wraps all added elements, so I think that css should be wrapped around addID.
Here is a way that you can use to make your elements side by side. In css, you tell the element that your want on the left to be
float:left;
and the element that you want on the right to be
float:right;
This should make them side by side.
Here is an example of this being used:
https://www.geeksforgeeks.org/how-to-float-three-div-side-by-side-using-css/

Triggering alerts with validate-need in Shiny?

I am having difficulty triggering an alert in a Shiny app that I have created. The app itself is very simple, and displays one slider with numbers and a line plot. However, I would like for an alert to be triggered whenever the slider is set to a value above 5. Here is the code:
UI
library(shiny)
library(shinythemes)
library(shinyBS)
shinyUI(fluidPage(theme = shinytheme("superhero"),
tags$head(
tags$style(HTML("
.shiny-output-error-validation {
color: green;
}
"))
),
sidebarLayout(
sidebarPanel(
sliderInput("samplestat",
"Value:",
min = 1,
max = 10,
value = 1)
),
mainPanel(
h3("Graph", style = "font-family: 'Jura'; color: blue; font-size: 32px;"),
HTML("<p>Graph</p>"),
plotOutput("LinePlot")
)
)
))
SERVER
library(shiny)
library(ggplot2)
library(scales)
samplestat <- function(input) {
if (input > 5) {
"Choose another value. samplestat must be below 5!"
} else if (input < 4) {
FALSE
} else {
NULL
}
}
shinyServer(function(input, output) {
data <- reactive({
validate(
need(input$data != "", "Please select a value below 5")
)
get(input$data)
})
output$LinePlot <- renderPlot({
n=1:10
samplestat <- seq(min(n), max(n), length.out = input$samplestat)
plot(samplestat, type = "o", col = 'blue', border = 'white', xlab="X Axis", ylab ="Y Axis")
}
)
})
When I run this code, the line and slider displays, but I do not get any alert when I slide the slider to a value above 5. I am not sure if I am possibly using validate-need incorrectly, or whether I have overlooked something else.
You should place validate(...) insider renderPlot({...}). That is, your server.R should be something like:
function(input, output) {
output$LinePlot <- renderPlot({
validate(
need(input$samplestat <= 5, "Please select a value below 5")
)
n <- 1:10
samplestat <- seq(min(n), max(n), length.out = input$samplestat)
plot(samplestat, type = "o", col = 'blue',
fg = 'white', xlab= "X Axis", ylab = "Y Axis")
})
}
which produces this output:
Note that there should be no problem with wrapping your validation code in a reactive function. Suppose your function to test for a condition is
validate_samplestat <- function(input) {
if (input > 5) {
"Choose another value. samplestat must be below 5!"
} else {
NULL
}
}
You can wrap this in reactive in your main server function, and place the reactive function in your output rendering function. The main thing is to place the bit of code that calls validate in your output rendering function:
function(input, output) {
v <- reactive({
validate(validate_samplestat(input$samplestat))
})
output$LinePlot <- renderPlot({
v() # <--- validate here
n <- 1:10
samplestat <- seq(min(n), max(n), length.out = input$samplestat)
plot(samplestat, type = "o", col = 'blue',
fg = 'white', xlab= "X Axis", ylab = "Y Axis")
})
}