The given R shiny script creates popoup based on clicking of a button in which the text is displayed.
library(shiny)
library(shinyBS)
CR1_BS<-paste("i. This is line 1",
"ii. This is line 2",
"iii. This is line 3", sep = "<br>")
ui <- fluidPage(
actionButton("CR1_S1", "Button"),
bsPopover(id="CR1_S1",title="x",content=CR1_BS ,"right",options =
list(container = "body")))
server <- function(input, output){}
shinyApp(ui, server)
My requirement is to fit the below rpivotTable in the popup upon clicking of the button.
library(rpivotTable)
rpivotTable(mtcars,rows="gear",cols = c("cyl","carb"),width = "100%",
height = "400px")
Something like this do?
rm(list = ls())
library(shiny)
library(shinyBS)
library(rpivotTable)
shinyApp(
ui =
fluidPage(
sidebarLayout(
sidebarPanel(actionButton("CR1_S1", "Button")),
mainPanel(
bsModal("modalExample", "Your Table", "CR1_S1", size = "large",rpivotTableOutput("test"))
)
)
),
server =
function(input, output, session) {
output$test <- rpivotTable::renderRpivotTable({
rpivotTable(mtcars,rows="gear",cols = c("cyl","carb"),width = "100%", height = "400px")
})
}
)
Related
I am using boxSidebar for my non-english shiny app, and would really like to replace the 'More' text that appears on hovering over the icon. Can anyone help me with a solution for this?
Alternatively, I was thinking to remove it by using shinyjs::hide(), but the ID seems to change on every hover so I do not know if that's an option here.
minimum example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
)
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
We can use {htmltools} to do the work:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(htmltools)
library(magrittr)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
) %>% {
tagQuery(.)$
find("#mycardsidebar")$
removeAttrs("data-original-title")$
addAttrs(`data-original-title`="whatever")$
allTags()
}
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
change whatever to your text.
I have a Shiny code as like this
library(datasets)
ui <-fluidPage(
titlePanel("Telephones by region"),
sidebarLayout(
sidebarPanel(
selectInput("region", "Region:",
choices=colnames(WorldPhones)), checkboxInput(inputId = "Adv",
label = strong("Advanced"),
value = FALSE),fileInput("file1", "Choose CSV File",
multiple = FALSE,accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
hr(),
helpText("Data from AT&T (1961) The World's Telephones.")),
mainPanel(
plotOutput("phonePlot") )))
server <- function(input, output) {
output$phonePlot <- renderPlot({
barplot(WorldPhones[,input$region]*1000,
main=input$region,
ylab="Number of Telephones",
xlab="Year")})}
shinyApp(ui, server)
I need to implement following modifications
How to disable/enable selectInput and fileInput upon the selection of Advanced checkboxInput. If user choose advanced, the selectInput must be disable (vice versa)
How to use if function for fileInput from user input (Asia,Africa….ect one per line )
To enable/disable the inputs you can use package shinyjs.
Something like this should work:
library(datasets)
library(shiny)
ui <-fluidPage(
shinyjs::useShinyjs(),
titlePanel("Telephones by region"),
sidebarLayout(
sidebarPanel(
selectInput("region", "Region:",
choices=colnames(WorldPhones)),
checkboxInput(inputId = "Adv",
label = strong("Advanced"),
value = FALSE),
fileInput("file1", "Choose CSV File",
multiple = FALSE,accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
hr(),
helpText("Data from AT&T (1961) The World's Telephones.")),
mainPanel(
plotOutput("phonePlot") )))
server <- function(input, output) {
observe({
if((input$Adv == TRUE)) {
shinyjs::disable("region")
shinyjs::disable("file1")
} else {
shinyjs::enable("region")
shinyjs::enable("file1")
}
})
output$phonePlot <- renderPlot({
barplot(WorldPhones[,input$region]*1000,
main=input$region,
ylab="Number of Telephones",
xlab="Year")})}
shinyApp(ui, server)
I try to observe an event in shiny. If I define a radio manually, it will be observed correctly - output: print(paste0("SELECT * FROM daten;")). I want to avoid writing several tenths of radio buttons in ui.r. Thus I wrote a loop in the server part.
But the same observeEvent() does not react on my "loop-listed" radio buttons which where correctly built in shiny app. I have no idea why.
I wrote a minimal example:
library(shiny)
shinyApp(
ui = fluidPage(
####### manually set radio #######
print("This radio 'pd1' will be observed:"),
radioButtons(inputId = "pd1", label = "value:", choices = c("?", "0", "1")),
br(), br(),
####### versus looped set set radio #######
uiOutput("scrlst"),
),
server = function(input, output) {
tablscr <- data.frame("1","question")
###################### observeEvent
##### "counter" for several items (in this case just 1 item)
rv <- reactiveValues(counter = 0)
lapply(1:dim(tablscr)[1], function(i) {
isolate({qnum <- paste0('pd', rv$counter <- rv$counter + 1)})
observeEvent(input[[qnum]], {print(paste0("SELECT * FROM daten;"))})
})
### output for tenths of items in one loop (in this case just 1 item)
output$scrlst <- renderUI({
tagList(
scr <- list(),
for (sq in 1:dim(tablscr)[1]){
scr[[sq]] = list(sq,
print("This radio 'pd1' will not be observed:"),
radioButtons(inputId = "pd1", label = "value:", choices = c("?", "0", "1")),
br(),
br()
)
},
return(scr),
)
})
}
)
Your tagList containing a loop and a return statement sounds weird. Moreover you have a duplicated id pd1. Here is a working code:
library(shiny)
shinyApp(
ui = fluidPage(
uiOutput("scrlst")
),
server = function(input, output) {
tablscr <- data.frame(c("1","2"), c("question", "hello"))
lapply(1:nrow(tablscr), function(i) {
qnum <- paste0('pd', i)
observeEvent(input[[qnum]], {print(paste0("SELECT * FROM daten;"))})
})
output$scrlst <- renderUI({
do.call(tagList, lapply(1:nrow(tablscr), function(i){
tagList(
radioButtons(paste0("pd", i), label = "value:", choices = c("?", "0", "1")),
br(), br()
)
}))
})
}
)
I'd like to display a modal dialog if users click a link. Currently, the modal dialog works if users click on the action button.
Any ideas are appreciated. Thanks.
## app.R ##
server <- function(input, output) {
observeEvent(input$act_guide, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionButton("act_guide", "Click Here!")
)
shinyApp(ui = ui, server = server)
You can use actionLink instead of actionButton to trigger the pop-up as shown below.
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!")
),
server = function(input, output, session){
observeEvent(input$link1, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
)
}
An alternate way is to use bsModal inside ui.R to trigger the pop-up as shown below:
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!"),
bsModal(id = "modal1", title = "Test Modal", trigger = "link1",
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
),
server = function(input, output, session){
}
)
}
I working on a project where I have to create a form in shiny. I currently have a datatable in the UI which has email in the form of hyperlink. Once the hyperlink is clicked the modal window opens where I have another UI which shows the various fields to be filled. I have a save button here that should update my DB in the backend once the button is clicked.
The problem I am facing is that I am unable to reference each email to that particular modal window and my update query updates all the records in the DB. Is there a way to pass all the record details that has been clicked into the modal window??
What I basically need to know is how to update the record that I have clicked on and for which the pop up window is opened??
I am attaching the UI.R and server.R for use.
enter code here
ui.R
library(shiny)
library(DT)
library(shinyBS)
fluidPage(
fluidRow(
actionButton(inputId = "view",label = "Hi")),
#actionButton(inputId = "savepage1", label = "Save"),
DT::dataTableOutput('my_table'),
bsModal("FormModal", "My Modal", "",textOutput('mytext'),uiOutput("form1"),
actionButton("savepage2","Save"),DT::dataTableOutput("table1"),size = "large")
)
enter code here
server.R
library(shinyBS)
server <- function(session, input, output){
uedata<-c("","Prime","Optimus") ##add source data here
output$form1<-renderUI({
tagList(
column(width=6,selectInput("samplevalue","Select Custom Source*",choices=c("Please select",samplevaluedata))),
column(width=6,textInput("sampletext",label = "Enter Text",value = NULL,placeholder = NULL)))
})
on_click_js = "Shiny.onInputChange('mydata', '%s');
$('#FormModal').modal('show')"
convert_to_link = function(x) {
as.character(tags$a(href = "#", onclick = sprintf(on_click_js,x), x))
}
observeEvent(input$view,{
session$sendCustomMessage(type = "unbinding_table_elements", "my_table")
output$my_table <- DT::renderDataTable({
a=dbGetQuery(hcltcprod,paste0("select name,mobile,email,assignedto from public.tempnew order by 3;"))
a <- data.frame(a,row.names = NULL)
a$email <- sapply(a$email,convert_to_link)
a1 <- datatable(a,
escape = F,
options = list(paging = FALSE, ordering = FALSE, searching = FALSE, rownames = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
a1
})
})
observeEvent(input$my_table_cell_clicked, {
print(Sys.time())
})
observe({
if(input$savepage2==0)
return()
isolate({
for(i in 1:nrow(a))
dbGetQuery(hcltcprod,paste0("update public.tempnew set s_text='",input$samplevalue,"',s_value='",input$sampletext,"' where mobile in ('",a$email,"');"))
})
})
}
As your example is connected to database and you didnt provide sample data I will go with mtcars dataset. Building on the example in the link you can view the selected data using the following:
rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- mtcars
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
# Here I created a reactive to save which row was clicked which can be stored for further analysis
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
# This is needed so that the button is clicked once for modal to show, a bug reported here
# https://github.com/ebailey78/shinyBS/issues/57
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
my_data()[SelectedRow(),2:ncol(my_data())]
})
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
DT::renderDataTable(DataRow())
)
)
})
}
shinyApp(ui, server)