I'm trying to get the timing of a user's click on a dynamically-generated image using Shiny and some Javascript. The app below reports the client's time as LATER than the time captured within the server, which is not desired. I'd like to capture the time given by the user's browser when they click on the image (this will prevent noise and delays from the trip from the client to the Shiny server). Any ideas?
The ultimate goal for the app is to calculate a "find time" -- the duration it takes for a user to click on a specific coordinate after the image appears in their browser.
library(shiny)
library(shinyjs)
options(digits.secs = 3) # Modify and save default global time options
click.time.image.js <- "
document.getElementById('img').onclick = function(){
var the_time = new Date().getTime();
console.log(the_time);
// set input$client_time to the_time:
Shiny.setInputValue('client_time', the_time)
}
"
shinyApp(
ui = fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
p("When clicking on the histogram, I'd like to capture the client-side computer's time"),
actionButton(inputId="new_image", label= "New Image")
),
mainPanel(
imageOutput("img", click = "photo_click"),
textOutput("client_time"),
textOutput("server_time")
)
)
),
server = function(input, output) {
output$img <- renderImage({
input$new_image
outfile <- tempfile(fileext='.png')
png(outfile, width=400, height=400)
hist(rnorm(100))
dev.off()
shinyjs::runjs(click.time.image.js)
list(src = outfile,
alt = "This is alternate text")
},
deleteFile = TRUE)
output$server_time <- renderText({
req(input$photo_click)
server.time <- as.character(strptime(Sys.time(), "%Y-%m-%d %H:%M:%OS")) # Time with milliseconds
paste("SERVER TIME:", server.time)
})
output$client_time <- renderText({
req(input$photo_click)
req(input$client_time)
client.time <- input$client_time # Time with milliseconds
client.time <- as.POSIXct(client.time/1000, origin="1970-01-01")
paste("CLIENTs TIME:", client.time)
})
}
)
Related
I am building a shiny app that, among other things, tries to identify a person's Census subdivision (in Canada) from an input postal code. Occasionally, postal codes overlap multiple subdivisions, so when that happens, I want users to be able to choose which subdivision they want to see. I was hoping to do it with a radio button input inside of a modal dialog. In the app below, the appropriate radio buttons appear, but I am unable to select a value. Each time I try to press one of the radio buttons, it appears to re-load the modal dialog without recording the choice. I am wondering if there is a) a way to make this work that has escaped me or b) a better way to accomplish this same goal? There are only two postal codes in the data frame that loads - A0A1P0 which exhibits the problem and N5X1G4, which has only a single census subdivision and thus doesn't trigger the modal.
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
withSpinner(verbatimTextOutput("mygeog"))
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$mygeog <- renderPrint({
validate(need(input$findpc, ""))
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
tmp_pc <- tmp_pc[which(geog_chc == input$chooseGeog), ]
}
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
I was able to find a suitable solution by putting an event observer around the "Find Me!" button and rendering the print output inside the event observer. Here's the solution:
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
tags$script("
Shiny.addCustomMessageHandler('chooseGeog', function(value) {
Shiny.setInputValue('chooseGeog', value);
});
"),
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
verbatimTextOutput("mygeog")
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$trig <- renderUI({
actionButton("trigger", "trigger")
})
observeEvent(input$findpc, {
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
}else{
session$sendCustomMessage("chooseGeog", tmp_pc$CSDuid[1])
}
output$mygeog <- renderPrint({
req(input$chooseGeog)
tmp_pc <- tmp_pc %>% filter(geog_chc == input$chooseGeog)
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
Problem Statement:
I am trying to load interactive networks of STRING into a Shiny website using R
What I've Tried:
According to STRING, I can embed the interactive network but I need a couple of elements:
Javascript libary
<script type="text/javascript" src="http://string-db.org/javascript/combined_embedded_network_v2.0.2.js"></script>
Embed the div item
<div id="stringEmbedded"></div>
Call the specific protein with parameters e.g. TP53
getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})"
In theory, the produced network should be targetted to wherever the <div id="stringEmbedded"></div> is placed.
So I did this for Shiny:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Test")
tags$head(HTML("<script type='text/javascript' src='http://string-db.org/javascript/combined_embedded_network_v2.0.2.js'></script>"))
sidebar <- dashboardSidebar(sidebarMenu(
menuItem("Item1", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Item2", tabName = "widgets", icon = icon("th")),
sidebarSearchForm(textId = "searchText", buttonId = "searchButton",label = "Search...") #input$searchText and input$searchButton
))
body <-dashboardBody(
fluidRow(
tags$body(tags$script(HTML("getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})")),
fluidRow(
tabBox(
side = "left", height = "250px",
selected = "Tab3",
tabPanel("Tab1", tags$div(id="stringEmbedded")),
tabPanel("Tab2", "Tab content 2"),
tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
)
)
ui <- fluidPage(dashboardPage(header, sidebar, body))
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
Following my comments from above, here is a minimal working example on how to embed a STRING gene network into a shiny app. I've made use of shinyjs which -- while not strictly necessary -- makes working with custom JS code easier.
library(shiny)
library(shinyjs)
jsCode <- "
shinyjs.loadStringData = function(gene) {
getSTRING('https://string-db.org', {
'ncbiTaxonId':'9606',
'identifiers': gene,
'network_flavor':'confidence'})
}"
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
tags$head(tags$script(src = "http://string-db.org/javascript/combined_embedded_network_v2.0.2.js")),
textInput("gene", "Gene symbol", value = "TP53"),
actionButton("button", "Show"),
h3("Network:"),
tags$div(id = "stringEmbedded")
)
server <- function(input, output, session) {
onclick("button", {
req(input$gene)
js$loadStringData(input$gene)
})
}
shinyApp(ui, server)
I have a selectizeInput with multiple = TRUE in a shiny application and I would like to prevent the user from selecting NULL (i.e., from leaving it blank). My goal is to ensure that at least one item is selected (no matter which one).
I found this question on the opposite problem (i.e., limiting maximum number of selections) and I checked selectize documentation. Unfortunately, there seem to be no minItems option. Is there a way to achieve my desired functionality?
Minimum example:
library(shiny)
shinyApp(
ui = fluidPage(
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = LETTERS[1:4],
selected = LETTERS[1],
multiple = TRUE,
# Problem: how to specify 'minItems' here
options = list(maxItems = 2)
),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
}
)
Seems to be an open issue: #https://github.com/selectize/selectize.js/issues/1228.
Concerning your R/Shiny implementation you could use a workaround with renderUI().
You would build the input on the server side and control the selected choices.
Before you build the input on the server side you can check the current value and if it does not fulfill your requirement you can overwrite it:
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
Reproducible example:
library(shiny)
choices <- LETTERS[1:4]
shinyApp(
ui = fluidPage(
uiOutput("select"),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
output$select <- renderUI({
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = choices,
selected = selected,
multiple = TRUE,
options = list(maxItems = 2)
)
})
}
)
We have created sankey diagram to show flow between different cities via networkD3::sankeyNetwork() in R.
We have received client requirement to show "state" name corresponding to city on tooltip/hover of sankey node.
In following code we want to show State value on tool-tip(hover) of node
library(shiny)
library(networkD3)
library(shinydashboard)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY1','CITY2','CITY3','CITY4','CITY5','CITY6')
State <- c( 'IL','CA','FL','NW','GL','TX')
nodes <-data.frame(cbind(ID,indx,State))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
output$simple <- renderSankeyNetwork({
sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = " " )
})
}
shinyApp(ui = ui, server = server)
As the networkD3 package does not provide a customized tooltip feature, please suggest how it can be achieved via javascript or some other way in networkD3::sankeyNetwork().
You can use a technique similar to this Stack Overflow answer. Save the output of the sankeyNetwork function, then add back in the data that gets stripped out, then use htmlwidgets::onRender to add some JavaScript to modify the tooltip text of the nodes...
library(shiny)
library(networkD3)
library(shinydashboard)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY1','CITY2','CITY3','CITY4','CITY5','CITY6')
State <- c( 'IL','CA','FL','NW','GL','TX')
nodes <-data.frame(cbind(ID,indx,State))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
output$simple <- renderSankeyNetwork({
sn <- sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = " " )
# add the states back into the nodes data because sankeyNetwork strips it out
sn$x$nodes$State <- nodes$State
# add onRender JavaScript to set the title to the value of 'State' for each node
sn <- htmlwidgets::onRender(
sn,
'
function(el, x) {
d3.selectAll(".node").select("title foreignObject body pre")
.text(function(d) { return d.State; });
}
'
)
# return the result
sn
})
}
shinyApp(ui = ui, server = server)
I'm trying to save data from rpivotTable in my dashboardUI.
I already read
https://github.com/smartinsightsfromdata/rpivotTable/issues/62
and in works with ui.r and server.r
But when I try to use this with dashboard - it's nothing .
dashboard.r
# install.packages("devtools")
#devtools::install_github("smartinsightsfromdata/rpivotTable",ref="master")
options(java.parameters = "-Xmx8000m")
library(shiny)
library(shinyjs)
library(shinydashboard)
library(highcharter)
library(xts)
library(htmlwidgets)
library(rpivotTable)
library(xml2)
library(rvest)
sotrud <- c("1","2")
dashboardUI <- function(id) {
ns <- NS(id)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("log", tabName = "login", icon = icon("user")),
menuItem("test", tabName = "ost", icon = icon("desktop"))
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "login",
tabPanel("log",
useShinyjs(), # Set up shinyjs
br(),
selectInput(inputId=ns("sel_log"), label = h5("log"),
choices= c(unique(as.character(sotrud)))
, selected = NULL),
tags$form( passwordInput(inputId=ns("pass"), label =
h3("int psw"), value = "000")),
fluidRow(
br(),
column(8,actionButton(ns("psw"), "in")
)
)
)
),
tabItem(tabName = "ost",
tabPanel("test",
fluidRow(
column(3,
h4(" "),
conditionalPanel(
condition = paste0("input['", ns("psw"), "'] > '0' "),
actionButton(ns("save"), "download") )
)
,br()
,br()
)
)
,DT::dataTableOutput(ns('aSummaryTable'))
,rpivotTableOutput(ns('RESULTS'))
,column(6,
tableOutput(ns('myData')))
)
))
# Put them together into a dashboardPage
dashboardPage(
dashboardHeader(title = "1"),
sidebar,
body
)
}
dashboard <- function(input, output, session) {
observe({ ## will 'observe' the button press
if(input$save){
print("here") ## for debugging
print(class(input$myData))
}
})
# Make some sample data
qbdata <- reactive({
expand.grid(LETTERS,1:3)
})
# # Clean the html and store as reactive
# summarydf <- eventReactive(input$myData,{
# print("here")
#
# input$myData %>%
# read_html %>%
# html_table(fill = TRUE) %>%
# # Turns out there are two tables in an rpivotTable, we want the
second
# .[[2]]
#
# })
# # show df as DT::datatable
# output$aSummaryTable <- DT::renderDataTable({
# datatable(summarydf(), rownames = FALSE)
# })
# Whenever the config is refreshed, call back with the content of the table
output$RESULTS <- renderRpivotTable({
rpivotTable(
qbdata(),
onRefresh =
htmlwidgets::JS("function(config) {Shiny.onInputChange('myData', document.getElementById('RESULTS').innerHTML);}")
)
})
}
app.r
source("dashboard.R")
ui <-
dashboardUI("dash")
server <- function(input, output, session) {
df2 <- callModule(dashboard, "dash")
}
shinyApp(ui, server)
I fell problem with this:
htmlwidgets::JS("function(config) {Shiny.onInputChange('myData', document.getElementById('RESULTS').innerHTML);}")
I tried to change 'myData' to ns('myData') , but nothing
print(class(input$myData)) - always shows [1] "NULL" in console, that's mean I didn't pass data to 'myData'
Maybe someone know how to resolve this?
p.s. button "download" appears after pushing "in"
You have a lot of extra, unnecessary stuff in your code (not ideal for a minimal reproducible example). However, I've found that as long as you always use ns() when appropriate, everything works as expected, even with modules. The largest deviation from the non-modular code I've made is using a downloadHandler() because that answer doesn't follow best practices for that.
So extending the original solution (from here) to modules gives you something like this (notice that in the jsCallback function, you need to use ns() for both myData and the pivot, as they both belong to that module):
library(shiny)
library(shinyjs)
library(shinydashboard)
library(highcharter)
library(xts)
library(htmlwidgets)
library(rpivotTable)
library(xml2)
library(rvest)
options(shiny.launch.browser=F, shiny.minified=F, shiny.port = 6245)
sotrud <- c("1","2")
dashboardUI <- function(id) {
ns <- NS(id)
dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
tableOutput(ns('tbl')),
downloadButton(ns('save')),
rpivotTableOutput(ns('pivot'))
)
)
}
dashboard <- function(input, output, session) {
output$pivot <- renderRpivotTable({
jsCallback <- paste0("function(config) {",
"Shiny.onInputChange('",
session$ns("myData"), "',",
"document.getElementById('", session$ns("pivot"), "').innerHTML);}")
rpivotTable(
expand.grid(LETTERS, 1:3),
onRefresh = htmlwidgets::JS(jsCallback)
)
})
summarydf <- eventReactive(input$myData, {
input$myData %>%
read_html %>%
html_table(fill = TRUE) %>%
.[[2]]
}, ignoreInit = TRUE)
output$tbl <- renderTable({ summarydf() })
output$save <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
req(summarydf())
write.csv(summarydf(), file)
}
)
}
ui <- dashboardUI("dash")
server <- function(input, output, session) { callModule(dashboard, "dash") }
shinyApp(ui, server)