Current status of the boxes :
I am unable to improve the following things :
Have the text in a row by itself(The Select the modules... one)
The box and text are not aligned on the same line.
The checkboxes on the top line are slightly truncated.(the remaining is encircled below)
The labels(a to j) need to be in white bold text.
This is what I have tried so far :
ui.R :
library(shiny)
controls <- list(tags$div(align = 'left',
class = 'multicol',
checkboxGroupInput(inputId = 'modules',
label = "Step 1 : Select the modules to be executed",
choices = c(process_names),
selected = "",
inline = FALSE)))
shinyUI(fluidPage(
tags$style(type='text/css', "label {font-size: 22px; } # controls the text of check-boxes
.form-group {margin-top: 5px; margin-bottom: 5px;}
.nav-tabs {font-family:'arial';font-size:20px}
#sidebar {background-color: #5C97BF;}
#mainbar {background-color: #5C97BF;}
body { background-color: #002B55;}
input[type=checkbox] {transform: scale(2);}
.multicol {height: 200px; -webkit-column-count: 4;
-moz-column-count: 4; /* Firefox */
column-count: 4; -moz-column-fill: auto;-column-fill: auto;} # increases the size of checkboxes
div.checkbox {margin-top: 10px;color:'#FFFFFF';font-weight: bold; }
.btn {display:block;height: 60px;width: 40px;border-radius: 50%;} # for actionButton
"),
sidebarLayout(
position = "left",
sidebarPanel(controls),
mainPanel()
)
))
server.R
shinyServer(
function(input, output){
}
)
Here's fixed code for your app:
library(shiny)
process_names <- letters[1:13]
controls <- tags$div(
tags$label("Step 1 : Select the modules to be executed"),
tags$div(align = 'left',
class = 'multicol',
checkboxGroupInput(inputId = 'modules',
label = NULL,
choices = c(process_names),
selected = "",
inline = FALSE)))
ui<-(fluidPage(
tags$style(type='text/css', "label {font-size: 22px; }
.form-group {margin-top: 5px; margin-bottom: 5px;}
.nav-tabs {font-family:'arial';font-size:20px}
#sidebar {background-color: #5C97BF;}
#mainbar {background-color: #5C97BF;}
body { background-color: #002B55;}
input[type=checkbox] {transform: scale(2);margin-top:10px;}
.multicol {height: 200px; -webkit-column-count: 4;
-moz-column-count: 4; /* Firefox */
column-count: 4; -moz-column-fill: auto;-column-fill: auto;}
.checkbox {margin-top:-5px;}
.btn {display:block;height: 60px;width: 40px;border-radius: 50%;}
#modules .checkbox label span {font-weight:bold;}
label {color:#fff;}
"),
sidebarLayout(
position = "left",
sidebarPanel(controls),
mainPanel()
)
))
server<-function(input,output){}
shinyApp(ui,server)
This takes care of all your issues. Note that one big problem you had (that took me a long time to debug!) is that you cannot use # as comments inside CSS. That breaks your CSS. You can only use /* comment here */ as comments in CSS.
To have the label on a single line, set label = NULL and add a p("text") before the checkBox() to have it on a single line.
To have the text in 'white', add a style="color:#FFFFFF" to the list(tags$div().
I'm still trying to figure out why the boxes are slightly truncated.
Related
I have a ColourPicker that I use to determine the background color of an action button. What I would like to do is click on the action button and have the hex code that was clicked from the ColourPicker be copied to my clipboard. The goal is to then paste that value to be the background color in a cell of a data table. Right now, I am mostly worried about the copying part.
I have a button that I can copy-button so I can copy a text value, which is easy enough, but this is not what I am trying to do.
What I would like to do is copy the hex code from the small button that is generated in my code, which can change color based on the color selected by the ColourPicker, and access just the hex code value of that button.
Do I need to reference the ID of the ColourPicker in order to access the hex code? Or could I just copy that hex code straight from the button? I haven't been able to find any packages that work with getting hex codes from objects.
For reference, this is basically what I have (much thanks again to #lz100)
library(shiny)
library(shinythemes)
library(sortable)
library(colourpicker)
library(glue)
library(png)
library(dplyr)
library(DT)
library(rclipboard)
# funcs
plate96 <- function(id) {
div(
style = "position: relative; height: 500px",
tags$style(HTML(
'
.wells {
height: 490px;
width: 750px;
overflow: hidden;
min-height: 20px;
padding: 19px;
margin-bottom: 20px;
border: 1px solid #e3e3e3;
border-radius: 4px;
-webkit-box-shadow: inset 0 1px 1px rgb(0 0 0 / 5%);
box-shadow: inset 0 1px 1px rgb(0 0 0 / 5%);
position: relative;
transform: translateX(50%);
}
.wells:after {
content: "";
height: 450px;
width: 690px;
border: 1px solid;
position: absolute;
transform: translate(15px, -100%);
z-index: -1;
}
.wells .corner-top {
position: absolute;
margin: -20px;
width: 43px;
height: 34px;
transform: rotate(45deg);
background-color: white;
z-index: 1;
left: 30px;
border-right: 1px solid;
}
.wells .corner-bot {
position: absolute;
margin: -20px;
width: 40px;
height: 40px;
transform: rotate(45deg);
background-color: white;
z-index: 1;
left: 35px;
bottom: 20px;
border-top: 1px solid;
}
.wells .html-widget {
transform: translateX(20px);
}
.wells thead tr th {
font-weight: 100;
}
.wells table:after {
content: "";
border: 1px solid #ccc;
position: absolute;
height: 410px;
width: 635px;
z-index: -1;
transform: translate(33px, -99%);
}
.wells table.dataTable.no-footer {
border-spacing: 3px;
border-bottom: unset;
}
.wells table.dataTable thead th {
border-bottom: unset;
}
.wells tbody tr td:not(:first-of-type) {
border-radius: 50%;
border: 1px solid black;
height: 15px;
width: 15px;
padding: 15px;
font-size: 0;
}
.wells table.dataTable.cell-border tbody tr td:first-of-type {
border: unset;
border-right: 1px solid #ccc;
font-weight: 900;
}
'
)),
div(
style = "position: absolute; left: 50%; transform: translateX(-100%);",
div(
class = "wells",
div(class = "corner-top"),
div(class = "corner-bot"),
DT::dataTableOutput(id, width = "90%", height= "100%")
)
)
)
}
renderPlate96 <- function(id, colors = rep("white", 96), byrow = TRUE) {
stopifnot(is.character(colors) && length(colors) == 96)
plate <- matrix(1:96, nrow = 8, ncol = 12, byrow = byrow, dimnames = list(LETTERS[1:8], 1:12))
colnames(plate) <- stringr::str_pad(colnames(plate), 2, "left", "0")
renderDataTable({
datatable(
plate,
options = list(dom = 't', ordering = F),
selection = list(target = 'cell'),
class = 'cell-border compact'
) %>%
formatStyle(
1:12,
cursor = 'pointer',
backgroundColor = styleEqual(1:96, colors, default = NULL)
)
})
}
# app code
ui <- fluidPage(
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("well_selected"),
rclipboardSetup(),
numericInput("num_conds",
label = h3("Enter the number of treatments/ conditions"),
min = 1,
max = 20,
value = 1),
uiOutput("cond_colors"),
htmlOutput("cond_buttons", align = 'center'),
# Add a text input
textInput("copytext", "Copy this:", "Test 1"),
# UI ouputs for the copy-to-clipboard buttons
uiOutput("clip"),
# A text input for testing the clipboard content.
textInput("paste", "Paste here:")
)
server <- function(input, output, session){
#####Number output for number of conditions#####
output$value = renderPrint({ input$num_conds })
#### Color selection for UI input####
output$cond_colors <- renderUI({
num_conds <- as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
colourInput(paste0("colors", i),
label = (paste0("Select a color for condition ", i)),
show = c("both"),
value = "black",
palette = c("limited"),
)
})
})
#### Create action buttons for conditions to be selected####
output$cond_buttons <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
bg = input[[paste0("colors", i)]]
style = paste0(
collapse = " ",
glue("background-color:{bg};
color:#ffffff;
border-color:#000000")
)
label = input[[paste0("condID", i)]]
cond_buttons = actionButton(paste0("cond_buttons", i),
label = label,
style = style
)
})
})
# Add clipboard buttons
output$clip <- renderUI({
output$clip <- renderUI({
rclipButton(
inputId = "clipbtn",
label = "Test copy button",
clipText = input$copytext,
icon = icon("clipboard")
)
})
})
# Workaround for execution within RStudio version < 1.2
if (interactive()){
observeEvent(input$clipbtn, clipr::write_clip(input$copytext))
}
output$plate <- renderPlate96(
"plate",
colors = c(
rep("#eeeeee", 12),
rep("#27408b", 12),
rep("#0f8b44", 12),
rep("#9400d3", 12),
rep("#0701ff", 12),
rep("white", 36)
)
)
output$well_selected <- renderPrint({
input$plate_cells_selected
})
}
shinyApp(ui = ui, server = server)
And here is a picture to kind of explain what I am thinking. Before:
After:
You could set an input value via client-side Javascript, using Shiny.setInputValue and process this value like those provided by UI input elements.
Simple example:
library(shiny)
ui <- shiny::fluidPage(
actionButton('colored_button', 'a green button',
style = 'background-color:#00ff00'
),
actionButton('button_get_color', 'get color'),
textOutput('color_message'),
## inject client-side javascript:
tags$script('
// bind JS code to the getter button:
document.getElementById("button_get_color")
.onclick = function(){
// set input value via JS:
Shiny.setInputValue("color",
// select colored button and get its background color:
document.getElementById("colored_button")
.style.backgroundColor)
}'
)
)
server <- function(input, output) {
observeEvent(input$button_get_color,{
## do stuff, e. g.
output$color_message <- renderPrint(input$color)
})
}
shinyApp(ui, server)
Edit:
You can also use the colored button (or any page element) to set the input value: get the element by ID and have it trigger Shiny.setInputValue on click (or other mouse event)
more information on communicating via JS here
some suggestions on converting RGB to Hex
There are a few solutions here and here but none of them works on Shiny 1.3.2.
This is what I attempted so far
library(shiny)
server <- shinyServer(function(input, output) { NULL })
ui <- shinyUI(
pageWithSidebar(
headerPanel("side-by-side"),
sidebarPanel(
fluidRow(
tags$head(
tags$style(type="text/css", "label.control-label, .selectize-control.single{ display: table-cell; text-align: center; vertical-align: middle; } .form-group { display: table-row;}")
),
column(2),
column(4,
sliderInput("slider", label = h5("slider") ,value = 500,min = 0, max =1000,ticks = F)
)
)),
mainPanel(
fluidRow(
h3("bla bla")
))
)
)
shinyApp(ui=ui,server=server)
Is there a way to make the slider wider?
There’s a lot of different ways to do positioning with CSS. My choice here would be to use flexbox, as annotated below. Note the use of a
.label-left container to scope the positioning changes.
library(shiny)
ui <- fluidPage(
tags$style(HTML(
"
.label-left .form-group {
display: flex; /* Use flexbox for positioning children */
flex-direction: row; /* Place children on a row (default) */
width: 100%; /* Set width for container */
max-width: 400px;
}
.label-left label {
margin-right: 2rem; /* Add spacing between label and slider */
align-self: center; /* Vertical align in center of row */
text-align: right;
flex-basis: 100px; /* Target width for label */
}
.label-left .irs {
flex-basis: 300px; /* Target width for slider */
}
"
)),
div(class = "label-left",
sliderInput("slider_1", "First slider", 0, 10, 5),
sliderInput("slider_2", "Second slider", 0, 10, 5)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Following this question, I want to have different styles for different tooltips in my Shiny app. How can I do that?
For example, if I have three buttons, I want to have three different background colors or font color or font style for each of them.
Just repeating the code doesn't work
actionButton("button1", "Click button 1"),
bsTooltip("button1",
"Button 1 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL),
tags$style(HTML("
.tooltip > .tooltip-inner {
width: 1000px;
color: black;
background-color: yellow;
opacity: 1;
}"
))
actionButton("button2", "Click button 2"),
bsTooltip("button2",
"Button 2 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL),
tags$style(HTML("
.tooltip > .tooltip-inner {
width: 600px;
color: white;
background-color: darkblue;
opacity: 1;
}"
))
actionButton("button3", "Click button 3"),
bsTooltip("button3",
"Button 3 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL),
tags$style(HTML("
.tooltip > .tooltip-inner {
width: 1000px;
color: white;
background-color: red;
opacity: 1;
}"
))
What is the solution to this?
Could you wrap each button in a separate div? Then you could define the css for each div, including different background colors.
library(shiny)
library(shinyBS)
ui <- fluidPage(
tags$style(HTML(
"#button1_div .tooltip > .tooltip-inner {
background-color: yellow;
width: 1000px;
color: black;
opacity: 1;}
#button2_div .tooltip > .tooltip-inner {
background-color: darkblue;
width: 600px;
color: white;
opacity: 1;}
#button3_div .tooltip > .tooltip-inner {
background-color: red;
width: 1000px;
color: white;
opacity: 1;}"
)),
column(4,
div(id = "button1_div",
actionButton("button1", "Click button 1"),
bsTooltip("button1",
"Button 1 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL)
),
),
column(4,
div(id = "button2_div",
actionButton("button2", "Click button 2"),
bsTooltip("button2",
"Button 2 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL)
),
),
column(4,
div(id = "button3_div",
actionButton("button3", "Click button 3"),
bsTooltip("button3",
"Button 3 Tooltip",
placement = "bottom", trigger = "hover",
options = NULL)
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
I am using R's bsplus package to build a carousel of images. I want to move the chevrons next to the bullets.
I am aware of this SO sol'n regarding how to reposition the prev/next chevrons.
I can get close (see the 'right' chevron) but when I position it where I want it (see the 'left' chevron) it's no longer clickable.
Why is this?
How can I position the chevrons next to the bullets and maintain their functionality?
R Script
library("shiny")
library("bsplus")
ui <- fluidPage(
includeCSS("/home/law/whatbank_home/tests/bullet.css"),
# Application title
titlePanel("Carousel Demo"),
uiOutput("carousel")
)
server <- shinyServer(function(input, output) {
output$carousel <- renderUI({
bs_carousel(id = "images", use_indicators = TRUE) %>%
bs_append(
content = bs_carousel_image(src = "https://placehold.it/900x500/3c8dbc/ffffff&text=Merry")
) %>%
bs_append(
content = bs_carousel_image(src = "https://placehold.it/900x500/3c8dbc/ffffff&text=Christmas")
) %>%
bs_append(
content = bs_carousel_image(src = "https://placehold.it/900x500/3c8dbc/ffffff&text=To")
) %>%
bs_append(
content = bs_carousel_image(src = "https://placehold.it/900x500/3c8dbc/ffffff&text=All")
)
})
})
# Run the application
shinyApp(ui = ui, server = server)
css
.carousel-control.left,
.carousel-control.right {
background: transparent;
}
.carousel-indicators .active {
background-color: #FCB700;
margin-bottom: 70px;
}
.carousel-indicators li {
background-color: #D8D8D8;
border: 1px solid #000;
margin-bottom: 70px;
}
.carousel-control.left .glyphicon {
left: 180px;
margin-left: 180px;
top: 183px;
margin-top: 183px;
}
.carousel-control.right .glyphicon {
right: 180px;
margin-right: 180px;
top: 160px;
margin-top: 160px;
}
You should try
.carousel-control {
width: 2%
}
In the example below, I use 2%.
library(shiny)
library(shinydashboardPlus) ### carousel() is from this package
library(DT)
jscode <-"
$(document).ready(function(){
$('#mycarousel').carousel( { interval: false } );
});"
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = dashboardBody(
tags$head(
tags$style(HTML("
#mycarousel {
width:900px;
height:600px;
}
.carousel-control{
color:#FF0000;
width: 2%;
}
"))
),
tags$head(tags$script(HTML(jscode))),
carousel(
id = "mycarousel",
carouselItem(
DTOutput("show_iris_dt")
),
carouselItem(
caption = "An image file",
tags$img(src = "YBS.png")
),
carouselItem(
caption = "Item 3",
tags$img(src = "http://placehold.it/900x500/39CCCC/ffffff&text=Happy+New+Year")
)
)
),
title = "Carousel Demo"
),
server = function(input, output) {
output$show_iris_dt <- renderDT({
datatable(iris)
})
}
)
Using navbarPage I would like to have some tabPanels to be right-aligned while the rest of tabPanels and navbarMenus to be left-aligned:
So, instead of this
library(shiny)
ui = tagList(
navbarPage(
title = "My app",
navbarMenu("Left1",
tabPanel("Subleft11"),
tabPanel("Subleft12")),
tabPanel("Left2"),
tabPanel("Left3"),
tabPanel("Right1"),
tabPanel("Right2")
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
I would like to get something like this:
Solution from GyD works fine for tabsetPanel but I was not able to adapt it to navbarPage. I tried to add
tags$head(
tags$style(HTML(
".navbar ul li:nth-child(4) { float: right; }
.navbar ul li:nth-child(5) { float: right; }"
))),
but without desired effect.
You could do that with some css.
This would be an easy example which aligns the 4th and 5th list elements inside the class navbar-nav a float: right;.
By including right: 150px; to the 4th child, you keep the tabs in correct order.
App.R
library(shiny)
library(shinythemes)
ui = tagList(
tags$head(tags$style(HTML("
.navbar-nav {
float: none !important;
}
.navbar-nav > li:nth-child(4) {
float: right;
right: 150px;
}
.navbar-nav > li:nth-child(5) {
float: right;
}
"))),
navbarPage(
title = "My app",
theme = shinytheme("cerulean"),
navbarMenu("Left1",
tabPanel("Subleft11"),
tabPanel("Subleft12")),
tabPanel("Left2"),
tabPanel("Left3"),
tabPanel("Right1"),
tabPanel("Right2")
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Maybe something along these lines:
tags$head(
tags$style(HTML(
"
.navbar-header { width: 10% }
.navbar-nav { width: 90% }
.navbar-nav>li:nth-child(4) { float: right; }
.navbar-nav>li:nth-child(5) { float: right; }"
)))