I am working on a shiny app. The server.R contains codes like......
dFt1 <- reactiveValues()
dFt1$dat <- data.frame(loadTransactionData())
...
output$t_tab_1 <- DT::renderDataTable({
DT::datatable(
dFt1$dat
,selection = list(mode = "single")
,options = list(
rownames = TRUE
,pageLength = 10
,order = list(list(2,"desc"),list(1,"asc"))
)
)
})
...
observe({
if (is.null(input$delete) || input$delete == 0){return()}
session$sendCustomMessage(
type = 'jsCode'
,list(value = 'confirm("Are You Sure?");')
)
})
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
}
})
deleteTransaction <- function(x) {
qy <- "DELETE FROM Transactions where timestamp = '<t>'"
qy <- gsub("<t>",x,qy)
db <- dbConnect(SQLite(), dbname=systemDatabase)
dbGetQuery(db,qy)
dbDisconnect(db)
}
And of course there is the delete button in the ui.R and a called to javascript confirm box.
The app runs good. I can select a record and delete it. Then I can select another record. But I cannot delete it. The javascript confirm box runs, but clicking Yes does not delete the record. I wonder why it is okay for 1 time but not the next time.
Any help?
Ok! Finally come to something that is working ...
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
shinyjs::disable("delete")
shinyjs::disable("edit")
session$sendCustomMessage(
type = 'jsCode'
,list(value = '1 != 1;')
)
}
})
I added another session$sendCustomMessage call that evaluate to be FALSE.
Wonder if there is any better solution?
Here is another approach...
I changed the javascript code passed to session$sendCustomMessage. Clicking the No button returns 0. Clicking the Yes button returns a random number. This I hope will guarantee a different value in two consecutive clicks of the Yes button.
observe({
if (is.null(input$delete) || input$delete == 0){return()}
session$sendCustomMessage(
type = 'jsCode'
,list(value =
'
(function() {
if (confirm("Are you sure?")) {
return Math.random()*3 + 1;
} else {
return 0;
}
})()
'
)
)
})
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
}
})
Any other cleaner solution?
Related
I have a datatable in Shiny where I use the filter option. When I want to filter a boolean column, I can choose true and false. I would like to rename these values. So instead of true and false, it should show yes and no.
The displayed column entries are not TRUE or FALSE but checkboxes. This is important, that's why I add it to the code example.
I had the idea to convert the booleans to factors. Then the filter shows yes and no. However, in this case all checkboxes are checked, so this doesn't work. I commented out the line that does the converting in the code below. If there is a solution without this converting step it would be nice.
As I didn't find any option to change the values, I guess, this can only be accomplished with JavaScript code. Unfortunately, I am not really familiar with JavaScript. I hopse someone call help me here.
library(shiny)
library(DT)
library(dplyr)
library(forcats)
set.seed(43)
data <- data.frame(A = rnorm(10),
B = letters[1:10],
C = sample(c(TRUE, FALSE), 10, TRUE))
ui <- fluidPage(
DTOutput("table_id")
)
server <- function(input, output, session) {
output$table_id <- renderDT(
data %>%
# mutate(C = as_factor(if_else(C == TRUE, "yes", "no"))) %>%
datatable(filter = "top",
options = list(
columnDefs = list(
list(
targets = c(3),
render = JS(
"function(data, type, row, meta) {",
" if(type === 'display'){",
" return data ? '<input type=\"checkbox\" disabled checked/>' : '<input type=\"checkbox\" disabled/>';",
" }",
" return data;",
"}"
)
))
)
)
)
}
shinyApp(ui, server)
Your factor C in your data.frame will pass values of either "yes" or "no"; however, your JS function is checking data to see if it is TRUE or FALSE. If you compare data with "yes", then the "yes" will be considered TRUE and "no" will be considered FALSE. Let me know if this produces the desired behavior.
library(shiny)
library(DT)
set.seed(43)
data <- data.frame(A = rnorm(10),
B = letters[1:10],
C = sample(c(TRUE, FALSE), 10, TRUE))
ui <- fluidPage(
DTOutput("table_id")
)
server <- function(input, output, session) {
output$table_id <- renderDT(
data %>%
mutate(C = as_factor(if_else(C == TRUE, "yes", "no"))) %>%
datatable(filter = "top",
options = list(
columnDefs = list(
list(
targets = c(3),
render = JS(
"function(data, type, row, meta) {",
" if(type === 'display'){",
" return data == \"yes\" ? '<input type=\"checkbox\" disabled checked/>' : '<input type=\"checkbox\" disabled/>';",
" }",
" return data;",
"}"
)
))
)
)
)
}
shinyApp(ui, server)
I am building a barcode scanner application to verify that a primary barcode label matches all secondary barcode labels generated from the primary. The current iteration uses R, shiny and modal dialogs for scanning of the barcode labels.
I would like the app to autofocus on the text input field(s) after the modal pops up so that the user does not have to click the entry field or tab to it before scanning the label. I have read that the JS focus function may be appropriate but I am not sure where this function needs to be implemented. Your help is appreciated.
.libPaths(c(.libPaths(), temp <- tempdir()))
if(!require(shiny)) {install.packages("shiny", lib=temp, repos='http://cran.us.r-project.org')}
if(!require(shinyWidgets)) {install.packages("shinyWidgets", lib=temp, repos='http://cran.us.r-project.org')}
if(!require(shinyalert)) {install.packages("shinyalert", lib=temp, repos='http://cran.us.r-project.org')}
if(!require(devtools)) {install.packages("devtools", lib=temp, repos='http://cran.us.r-project.org')}
if(!require(shinyBarcode)) {devtools::install_github("CannaData/shinyBarcode")}
if(!require(shinyjs)) {install.packages("shinyjs", lib=temp, repos='http://cran.us.r-project.org')}
if(!require(V8)) {install.packages("V8", lib=temp, repos='http://cran.us.r-project.org')}
library(shiny)
library(shinyWidgets)
library(shinyalert)
library(shinyBarcode)
library(shinyjs)
library(V8)
options(shiny.sanitize.errors = TRUE)
options(rsconnect.max.bundle.size="xxxlarge")
ui <- fluidPage(
# must include javascript dependencies
useShinyalert(), # Set up shinyalert
shinyBarcode::includeJsBarcode(cdn = TRUE),
shinyBarcode::barcodeOutput("barcode"),
useShinyjs(),
extendShinyjs(script = "beep.js"),
extendShinyjs(script = "beep2.js"),
)
server <- function(input, output, session) {
vals <- reactiveValues(txt = NULL)
# Create modals
primary <- function(failed = FALSE) {
modalDialog(
textInput("txt", "Scan primary tube"),
footer = NULL,
actionButton("reset", "Reset")
)
}
secondary <- function(failed = FALSE) {
modalDialog(
textInput("txt2", "Scan secondary tube"),
footer = NULL,
actionButton("reset", "Reset")
)
}
# Show modal on startup
showModal(primary())
observeEvent(input$txt, {
if (!is.null(input$txt) && nzchar(input$txt)) {
vals$txt <- input$txt
removeModal()
showModal(secondary())
} else {
showModal(primary(failed = TRUE))
}
})
observeEvent(input$txt2, {
if (!is.null(input$txt2) & nzchar(input$txt2) & input$txt2!="Reset") {
vals$txt2 <- input$txt2
removeModal()
if (vals$txt2==vals$txt) {
js$beep()
showModal(secondary())
}
else if (vals$txt2!=vals$txt) {
js$beep2()
shinyalert("Error", "Primary and secondary labels do not match", type = "error")
showModal(secondary())
}
} else if (!is.null(input$txt2) & nzchar(input$txt2) & input$txt2=="Reset"){
showModal(primary())
} else {
showModal(secondary(failed = TRUE))
}
})
observeEvent(input$reset, {
showModal(primary())
})
output$barcode <- shinyBarcode::renderBarcode(vals$txt)
}
shinyApp(ui = ui, server = server)
The app below contains a selectInput input$set1 with two options (download and upload) and a radio button group input$set2 that is rendered using renderUI(). I am using a custom message handler that disables a radio button in the radio button group depending on the value of the selectInput (if input$set1 == 'download' then disable the upload radio button and enable it otherwise).
Here is the app:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
toggleRadioOpt <- function(session, inputId, choice, enable = TRUE, selected) {
session$sendCustomMessage(
type = 'toggleRadioOpt',
message = list(id = inputId, choice = choice, enable = enable, selected = selected)
)
}
modUI <- function(id) {
ns <- NS(id)
tagList(
tags$head(
tags$script("
Shiny.addCustomMessageHandler('toggleRadioOpt',
function(data) {
$('#' + data.id + ' input[value = \"' + data.choice + '\"]').attr('disabled', !data.enable).prop('checked', false);
if(data.selected !== null) {
$('#' + data.id + ' input[value = \"' + data.selected + '\"]').prop('checked', true);
}
}
);
")
),
prettyRadioButtons(ns('set1'), label = 'Select', choices = c('download', 'upload', 'abb')),
# selectInput(ns('set1'), label = 'Select', choices = c('download', 'upload', 'sql')),
uiOutput(ns('taskUI'))
)
}
modServer <- shinyServer(function(input, output, session) {
ns = session$ns
output$taskUI <- renderUI({
switch(input$set1,
'download' = selectInput(ns('data'), '', state.area),
'upload' = selectInput(ns('data'), '', state.center),
'abb' = tagList(
selectInput(ns('data'), '', state.abb),
actionButton(ns('upload'), 'Upload')
)
)
prettyRadioButtons(ns('set2'), label = '', choices = c('split', 'upload'))
})
observe({
if(!is.null(input$set2)) {
if(input$set1 %in% c('download', 'abb')) {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload', enable = F, selected = 'split')
} else {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload', enable = T, selected = 'split')
}
}
})
})
# UI ----------------------------------------------------------------------
ui = fluidPage(modUI('first'))
# SERVER ------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
callModule(modServer, 'first')
})
shinyApp(ui, server)
The handler works as expected if the radio button group is created in the UI but fails if the buttons are created using renderUI(). Specifically, it fails on startup but then works if input$set1 is changed subsequently. I am new to using custom message handlers so I'm not sure what's going on here or how to fix it. I thought it may have something to do with the jQuery being triggered before the UI has loaded but I can't be sure.
I thought it may have something to do with the jQuery being triggered
before the UI has loaded but I can't be sure.
I think so. Before the UI has loaded, input$set2 is NULL. You can do:
observe({
if(!is.null(input$set2)){
if(input$set1 == 'download') {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload',
enable = F, selected = 'split')
} else {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload',
enable = T, selected = 'split')
}
}
})
I have a first DT table oTable with cell selection enabled. When the user click (select) a cell, that will generate another DT table nTable.
Then, in nTable I want to insert a selectInput. The code below is a working example. Mostly adapted from this post.
Problem:
When nTable is regenerated, the connection (binding?) with shinyValue is somehow broken.
Step to reproduce the problem:
launch the app.
select top left cell (e.g. Sepal.Length=5.1). In fact, select any cell will also work.
In the second DT generated below, change the selectInput in col from A to something else, say, B. Check that this change is detected in the TableOutput below.
De-select the selected cell
Re-select the same cell.
Now, you can change the selectInput again but no changes will be detected.
Also, I am not sure how to use session$sendCustomMessage("unbind-DT", "oTable"), I tried changing oTable to nTable but that didn't work.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})"
)
),
h2('The data'),
DT::dataTableOutput("oTable"),
DT::dataTableOutput("nTable"),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i),label=NULL, ...))
}
inputs
}
mydata=reactive({
session$sendCustomMessage("unbind-DT", "oTable")
input$oTable_cells_selected
})
output$nTable=renderDataTable({
req(mydata())
dd=as.data.frame(mydata())
dd$col=shinyInput(selectInput,nrow(dd),"selecter_",choices=LETTERS[1:3])
dd
},selection='none',server=FALSE,escape=FALSE,rownames=FALSE,
options=list(
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
output$oTable=renderDataTable(DT::datatable(iris,selection=list(mode="multiple",target='cell')))
# helper function for reading select input
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else
value
}))
}
# output read selectInput
output$checked <- renderTable({
req(mydata())
data.frame(selected = shinyValue("selecter_", nrow(mydata())))
})
}
))
You have to run Shiny.unbindAll on nTable (the table which contains the inputs). But only after the table has been created a first time.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})"
))
),
h2('The data'),
DT::dataTableOutput("oTable"),
DT::dataTableOutput("nTable"),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i),label=NULL, ...))
}
inputs
}
observeEvent(input$oTable_cells_selected, {
session$sendCustomMessage("unbindDT", "nTable")
})
mydata = eventReactive(input$oTable_cells_selected, {
if(length(input$oTable_cells_selected)){
input$oTable_cells_selected
}
})
output$nTable=DT::renderDataTable({
req(mydata())
dd=as.data.frame(mydata())
dd$col=shinyInput(selectInput,nrow(dd),"selecter_",choices=LETTERS[1:3])
datatable(dd, selection='none', escape=FALSE,rownames=FALSE,
options=list(
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
},server=FALSE)
output$oTable=DT::renderDataTable(
DT::datatable(iris,selection=list(mode="multiple",target='cell'),
options=list(pageLength = 5)))
# helper function for reading select input
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else
value
}))
}
# output read selectInput
output$checked <- renderTable({
req(mydata())
data.frame(selected = shinyValue("selecter_", nrow(mydata())))
})
}
))
I want to pull in data from 538, but I want the full data which is arrived at by clicking on "Show more polls"... Is there any way for the function to access the additional lines of the table?
http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/
The code for pulling in the top level data is:
require(XML)
polls.html <- htmlTreeParse("http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/",
useInternalNodes = TRUE)
parsedDoc <- readHTMLTable(polls.html, stringsAsFactors=FALSE)
pollData <- data.frame(parsedDoc[4])
I'm a little confused as to why this got downvoted... still doesn't seem obvious to me! But for anyone who wants to know the solution, I did figure it out (thanks to some help from #duncantl). (Also, the complete analysis is at: https://github.com/hardin47/prediction2016)
require(XML)
require(dplyr)
require(tidyr)
require(readr)
require(mosaic)
require(RCurl)
require(ggplot2)
require(lubridate)
require(RJSONIO)
url = "http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/"
doc <- htmlParse(url, useInternalNodes = TRUE)
sc = xpathSApply(doc, "//script[contains(., 'race.model')]",
function(x) c(xmlValue(x), xmlAttrs(x)[["href"]]))
jsobj = gsub(".*race.stateData = (.*);race.pathPrefix.*", "\\1", sc)
data = fromJSON(jsobj)
allpolls <- data$polls
#unlisting the whole thing
indx <- sapply(allpolls, length)
pollsdf <- as.data.frame(do.call(rbind, lapply(allpolls, `length<-`, max(indx))))
#unlisting the weights
pollswt <- as.data.frame(t(as.data.frame(do.call(cbind, lapply(pollsdf$weight, data.frame,
stringsAsFactors=FALSE)))))
names(pollswt) <- c("wtpolls", "wtplus", "wtnow")
row.names(pollswt) <- NULL
pollsdf <- cbind(pollsdf, pollswt)
#unlisting the voting
indxv <- sapply(pollsdf$votingAnswers, length)
pollsvot <- as.data.frame(do.call(rbind, lapply(pollsdf$votingAnswers,
`length<-`, max(indxv))))
pollsvot1 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V1, data.frame,
stringsAsFactors=FALSE))))
pollsvot2 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V2, data.frame,
stringsAsFactors=FALSE))))
pollsvot1 <- cbind(polltype = rownames(pollsvot1), pollsvot1,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot1)),
polltype1 = extract_numeric(rownames(pollsvot1)))
pollsvot1$polltype1 <- ifelse(is.na(pollsvot1$polltype1), 1, pollsvot1$polltype1 + 1)
pollsvot2 <- cbind(polltype = rownames(pollsvot2), pollsvot2,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot2)),
polltype1 = extract_numeric(rownames(pollsvot2)))
pollsvot2$polltype1 <- ifelse(is.na(pollsvot2$polltype1), 1, pollsvot2$polltype1 + 1)
pollsdf <- pollsdf %>%
mutate(population = unlist(population),
sampleSize = as.numeric(unlist(sampleSize)),
pollster = unlist(pollster),
startDate = ymd(unlist(startDate)),
endDate = ymd(unlist(endDate)),
pollsterRating = unlist(pollsterRating)) %>%
select(population, sampleSize, pollster, startDate, endDate, pollsterRating,
wtpolls, wtplus, wtnow)
allpolldata <- cbind(rbind(pollsdf[rep(seq_len(nrow(pollsdf)), each=3),],
pollsdf[rep(seq_len(nrow(pollsdf)), each=3),]),
rbind(pollsvot1, pollsvot2))
allpolldata <- allpolldata %>%
arrange(polltype1, choice)