I would like to apply JS/Jquery within the cell ids of a DT.
I used .css() as an example, but I have other plans, so I asked the question. My intention is not to color the words, but to use other functions.
My code:
library(shiny)
library(shinydashboard)
library(DT)
header <- dashboardHeader(title = "DT")
sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "mydatatable", tabName = "dt1")))
body <- dashboardBody(
HTML(
"<head>
<script>
$(function() {
$('#stackid, #dtid').mouseover(function() {
$(this).css('color','red');
});
$('#stackid, #dtid').mouseout(function() {
$(this).css('color','#333333');
});
});
</script>
</head>"
),
tabItems(
tabItem(
tabName = "dt1",
fluidPage(
column(
width = 12,
HTML("<strong id='dtid' style='font-size:50px;'>DATATABLE</strong>"),
DTOutput(outputId = "outdt1")
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
df_1 <- data.frame(
x = c("<span id='stackid'>Stack</span>", "Over", "Flow"),
y = 1:3,
z = LETTERS[1:3]
)
output$outdt1 <- DT::renderDataTable({
datatable(
data = df_1,
escape = FALSE
)
})
}
shinyApp(ui, server)
I tried using JS/ jQuery inside tags$div() on server, but that didn't work either.
See that the effect is applied to dtid, as expected. But, my intention is to apply the effect within the id of the DT.
Related
I wish to use shinydashboardPlus' carousel to display a number of charts. The number of these charts can vary on a daily basis from one to ten.
A cron job runs the R script daily.
Here is a working example with a fixed number of slides, three.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
chart_names <- c( "http://placehold.it/900x500/39CCCC/ffffff&text=Slide+1",
"http://placehold.it/900x500/39CCCC/ffffff&text=Slide+2",
"http://placehold.it/900x500/39CCCC/ffffff&text=Slide+3")
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(disable = TRUE ),
sidebar = dashboardSidebar(width = 0 ),
body = dashboardBody(
carousel(indicators = TRUE,
id = "mycarousel",
carouselItem(
tags$img(src = chart_names[1])
),
carouselItem(
tags$img(src = chart_names[2])
),
carouselItem(
tags$img(src = chart_names[3])
)
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Is this an example of where do.call could be used?
constructs and executes a function call from a name or a function and a list of arguments to be passed to it.
This attempt:
do.call(carousel, as.list(c(id = "mycarousel", "carouselItem(tag$img(src = chart_names[1])")))
results in this error:
Error: $ operator is invalid for atomic vectors
How do I programmatically add a previously unknown number of slides to a shinydashboardPlus carousel?
The answer was in the doc with the .list parameter ?carousel
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
nb_items = 5
items = Map(function(i) {carouselItem(
tags$img(src = paste0("http://placehold.it/900x500/39CCCC/ffffff&text=Slide+", i))
)}, 1:5)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(disable = TRUE ),
sidebar = dashboardSidebar(width = 0 ),
body = dashboardBody(
carousel(indicators = TRUE,
id = "mycarousel",
.list = items
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Is there a way to make the Search bar of the datatable empty instead of having the 'setosa' inside it by default while keeping the 'setosa' highlighted inside the table? Or at least find another way to highlight or underline the 'setosa'?
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(
),
dashboardBody(
DT::dataTableOutput("t")
)
)
server <- function(input, output) {
output$t <- renderDT(
datatable(iris, options = list(searchHighlight = TRUE, search = list(search = 'setosa')))
)
}
shinyApp(ui, server)
Ok, you can do something like this.
library(DT)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(
),
dashboardBody(
DT::dataTableOutput("t")
)
)
server <- function(input, output) {
data <- reactive({
mydata <- iris
rownames(mydata) <- gsub("setosa",tags$span(style="color:red", "setosa"),rownames(mydata))
for(i in 1:ncol(mydata)){
mydata[,i] <- gsub("setosa",tags$span(style="color:red", "setosa"),mydata[,i])
}
mydata
})
output$t <- renderDT(
datatable(data(), options = list(searchHighlight = TRUE, search = list(search = '')), escape = F)
)
}
shinyApp(ui, server)
I am building a dashboard where I need to create a number of boxes (based on the dataset) provided and then have each box be able to click and show subset boxes.
I can do this if I knew the data beforehand but I am having trouble with creating link id's and showing and hiding content when creating things dynamically.
Below is the code of how it should function (but using static content)
library(shiny)
library(shinydashboard)
library(shinyjs)
#####/UI/####
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
useShinyjs(),
fluidRow(
uiOutput("box1"),
uiOutput("box2"),
uiOutput("box3")
),
fluidRow(
div(id = "ILRow",
uiOutput("box1a"),
uiOutput("box1b"),
uiOutput("box1c")
),
div(id = "NCRow",
uiOutput("box2a"),
uiOutput("box2b")
),
div(id = "INRow",
uiOutput("box3a")
)
)
)
ui <- dashboardPage(header, sidebar, body)
#####/SERVER/####
server <- function(input, output) {
CSRbox <- function(description = NULL, linkName = NULL) {
# the box tags
withTags(
# col
div(
class = "col-md-2",
# Widget: user widget style 1
div(
class = "box",
## Box Header ##
div(
actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x")),
h2(description)
)
)
)
)
}
dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))
output$box1 <- renderUI({
CSRbox("Illinois", "Ill_Link")
})
output$box2 <- renderUI({
CSRbox("North Carolina", "NC_Link")
})
output$box3 <- renderUI({
CSRbox("Indiana", "IN_Link")
})
output$box1a <- renderUI({
CSRbox("Chicago", "CH_Link")
})
output$box1b <- renderUI({
CSRbox("Niles", "NI_Link")
})
output$box1c <- renderUI({
CSRbox("Evanston", "EV_Link")
})
output$box2a <- renderUI({
CSRbox("Charlotte", "CA_Link")
})
output$box2b <- renderUI({
CSRbox("Raleigh", "RL_Link")
})
output$box3a <- renderUI({
CSRbox("West Lafayette", "WL_Link")
})
shinyjs::hide("ILRow")
shinyjs::hide("NCRow")
shinyjs::hide("INRow")
observeEvent(input$Ill_Link, {
shinyjs::toggle("ILRow")
shinyjs::hide("NCRow")
shinyjs::hide("INRow")
})
observeEvent(input$NC_Link, {
shinyjs::toggle("NCRow")
shinyjs::hide("ILRow")
shinyjs::hide("INRow")
})
observeEvent(input$IN_Link, {
shinyjs::toggle("INRow")
shinyjs::hide("ILRow")
shinyjs::hide("NCRow")
})
}
shinyApp(ui, server)
Below is the code of creating the boxes dynamically but the functionality doesn't work (this is where I need help!):
library(shiny)
library(shinydashboard)
library(shinyjs)
#####/UI/####
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
useShinyjs(),
fluidRow(
uiOutput("boxLevel1")
),
fluidRow(
div(id = "LevelDetail",
uiOutput("boxLevel2")
)
)
)
ui <- dashboardPage(header, sidebar, body)
#####/SERVER/####
server <- function(input, output) {
CSRbox <- function(description = NULL, linkName = NULL) {
# the box tags
withTags(
# col
div(
class = "col-md-2",
# Widget: user widget style 1
div(
class = "box",
## Box Header ##
div(
actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x")),
h2(description)
)
)
)
)
}
dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))
output$boxLevel1 <- renderUI({
lapply(sort(unique(dat$State)), function(name) {
CSRbox(name, paste0(name,"Link"))
})
})
output$boxLevel2 <- renderUI({
temp <- dat[dat$State == "Illinois",] #Should be based of off the input$Click of the Input Link. Ex: input$Illinois
lapply(sort(unique(temp$City)), function(name) {
CSRbox(name, paste0(name,"Link2"))
})
})
shinyjs::hide("LevelDetail")
observeEvent(input$IllinoisLink, { #Would need to loop through and make an observeEvent for each possible input$click
shinyjs::toggle("LevelDetail")
})
}
shinyApp(ui, server)
UPDATE
I have figured out how to track the input ID's which allows me to create the correct subset of boxes dynamically(woo!). I am still having trouble with the show and hide though. I have figured out how to show the subset of boxes but I can't figure out how to hide since I am using the input ID which doesn't change when pressing on the link twice so the observeEvent doesn't run. I tried to get just the input of the link which would tell me the count of it so I know if it's changed BUT I am getting errors when I use the input[[input$last_btn]] (which should be the same as ex: input$Illinois). Any help is appreciated! I could add another button separately that would do the hide but that is not ideal.
library(shiny)
library(shinydashboard)
library(shinyjs)
#####/UI/####
header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody(
useShinyjs(),
tags$head(tags$script(HTML("$(document).on('click', '.needed', function () {
Shiny.onInputChange('last_btn',this.id);
});"))),
fluidRow(
uiOutput("boxLevel1"),
textOutput("lastButtonCliked")
),
fluidRow(
div(id = "LevelDetail",
uiOutput("boxLevel2")
)
)
)
ui <- dashboardPage(header, sidebar, body)
#####/SERVER/####
server <- function(input, output) {
CSRbox <- function(description = NULL, linkName = NULL) {
# the box tags
withTags(
# col
div(
class = "col-md-2",
# Widget: user widget style 1
div(
class = "box",
## Box Header ##
div(
actionLink(linkName, NULL, icon = icon("plus-square-o", "fa-2x"), class="needed"),
h2(description)
)
)
)
)
}
dat <- data.frame(State = c("Illinois","Illinois","Illinois","North Carolina","North Carolina","Indiana"), City = c("Chicago","Niles","Evanston","Charlotte","Raleigh","West Lafayette"))
output$boxLevel1 <- renderUI({
lapply(sort(unique(dat$State)), function(name) {
CSRbox(name, paste0(name))
})
})
output$boxLevel2 <- renderUI({
temp <- dat[dat$State == input$last_btn,] #Should be based of off the input$Click of the Input Link. Ex: input$Illinois
lapply(sort(unique(temp$City)), function(name) {
CSRbox(name, paste0(name,"Link2"))
})
})
avs <- reactiveValues(
clickN = NA, #new click
clickO = NA, #original click
dataSame = TRUE #data sets are the same
)
observe({
avs$clickN <- input$last_btn
})
shinyjs::hide("LevelDetail")
observeEvent(input$last_btn, {
avs$dataSame <- identical(avs$clickN, avs$clickO)
if(!avs$dataSame) {
shinyjs::show("LevelDetail")
avs$clickO <- avs$clickN
} else {
shinyjs::hide("LevelDetail")
avs$clickO <- NULL
}
})
}
shinyApp(ui, server)
I am using sliderTextInput from the shinyWidgets package. I am having trouble making the labels readable.
To begin with, they are too small, which I have fixed using css. However, now the labels overlap so it is hard to read them.
I would like to be able to do one or both of the following:
Angle the text at 45 or 90 degrees so labels don't overlap.
Reduce the number of labels so there is more space between them. I tried doing this in the choices = argument but that then stops those options from being selected. I think this might be to do with this relating to text rather than numbers, so that might make this impossible.
I have tried using sliderInput instead, but that presents different issues. I almost got it working using this answer, but the additional problem is that I have the input server side, fed in as a uiOutput, which is something I can't change because it's important for a different element. This approach doesn't work with the linked solution - I end up with nice enough labels but the breaks are daily rather than monthly.
Here is a pared down example:
Using sliderTextInput (labels overlapping)
library(shinydashboard)
library(shinyWidgets)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(type = "text/css", ".irs-grid-text {font-size: 12pt !important;")),
fluidRow(
box(uiOutput("month_selection"))
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderTextInput(
inputId = "month_select",
label = "",
grid = TRUE,
force_edges = TRUE,
choices = seq(from = as.Date("2017-01-01"), to = as.Date("2019-12-31"),by = 30)
)
})
}
shinyApp(ui, server)
Using sliderInput (doesn't run)
library(shinydashboard)
library(shinyWidgets)
library(shiny)
monthStart <- function(x) {
x <- as.POSIXlt(x)
x$mday <- 1
as.Date(x)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(type = "text/css", ".irs-grid-text {font-size: 12pt !important;")),
fluidRow(
box(uiOutput("month_selection"))
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderInput(
inputId = "month_select",
label = "",
min = as.Date("2017-01-01"),
max = as.Date("2019-12-31"),
value = as.Date("2019-12-31"),
timeFormat = "%b %Y",
animate = TRUE
)
})
sliderMonth <- reactiveValues()
observe({
sliderMonth$Month <- as.character(monthStart(input$month_select))
})
}
shinyApp(ui, server)
> Warning: Error in as.POSIXlt.default: do not know how to convert 'x' to class “POSIXlt”
Solution (credits go to Victor Perrier) taken from the shinyWidgets issue created by the asker.
Text can be roteted with nothing more than CSS. The class .irs-grid-text identifies the labels of the sliderTextInput widget. With transform the text can be rotated so that it does not overlap.
library(shinydashboard)
library(shinyWidgets)
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(
type = "text/css",
".irs-grid-text {font-size: 12pt !important; transform: rotate(-90deg) translate(-30px);"
)),
fluidRow(
box(uiOutput("month_selection"), height = "200px")
)
)
)
server <- function(input, output) {
output$month_selection <- renderUI({
sliderTextInput(
inputId = "month_select",
label = "",
grid = TRUE,
force_edges = TRUE,
choices = seq(from = as.Date("2017-01-01"), to = as.Date("2019-12-31"), by = 30)
)
})
}
shinyApp(ui, server)
I am trying to create menu items under the dashboard Sidebar automatically from a table without success. I am using the code below.
library(shiny)
library(shinydashboard)
header = dashboardHeader(title = "title")
sidebar = dashboardSidebar(sidebarMenuOutput("sidebarMenu"))
body = dashboardBody()
ui = dashboardPage(header, sidebar, body)
labels = data.frame(id = c(1,2,3),
name = c("lab1", "lab2", "lab3"))
server = function(input, output) {
output$sidebarMenu <- renderMenu({
sidebarMenu(id="tabs",
for (i in labels) {
menuItem(labels$name[i], tabName = labels$id[i])
})
})
}
shinyApp(ui, server)
data.frame labels contains the labels and id I need to use in the menu. I am running a for loop. How should I do it?
for (i in labels)
This loop does not work since you will always get the dataframe, not not a row of the dataframe. Anyhow, I did not get it to work with the loop, i normally use a combination of lapply to store all items in a list and use do.call to visualize it with the renderUI function.
library(shiny)
library(shinydashboard)
labels = data.frame(id = c(1,2,3),
name = c("lab1", "lab2", "lab3"))
header = dashboardHeader(title = "title")
sidebar = dashboardSidebar(sidebarMenu(id="mytabs",
uiOutput("sidebar_menu_UI")))
body = dashboardBody()
ui = dashboardPage(header, sidebar, body)
server = function(input, output) {
output$sidebar_menu_UI <- renderUI({
myTabs = lapply(1:nrow(labels) , function(i) {
menuItem(labels$name[i], tabName = labels$id[i])
})
print(myTabs)
do.call(sidebarMenu, myTabs)
})
}
shinyApp(ui, server)