Shiny + downloadHandler + Openxlsx does not generate a xlsx file - r

I'm trying to generate a .xlsx file through the Openxlsx package with a reactive name and header inside file (the input variables are "ASL.1" and "Year.1"). The object to be saved in the file is the reactive table "tab_1 ()", that is generated by the app without any problems, but when I try to download it the name that is generated by the browser (Chrome) is not (i.e.) "Tab_1_TOSCANA_2015".xlsx" but "download_tab_1", the outputId of the button "download" associated, and nothing is generated. I do not understand where the problem is, since I checked other similar examples with Openxlsx and I do not see errors in my script; if I try to write a .csv file using the "write.csv" command everything works.
The script is here: https://drive.google.com/drive/folders/1dSI9qWgQyShjXjkJ2B6COuWzuWZie5IP?usp=sharing
The App (this is just a small part) is
https://cerimp-open-data.shinyapps.io/Malprof/
require(shiny)
require(dplyr)
require(reshape2)
require(stringr)
require(shinythemes)
require(ggplot2)
require(openxlsx)
require(leaflet)
require(RColorBrewer)
require(rgdal)
require(rgeos)
require(maptools)
load("dati.RData")
#### UI ####
ui <- fluidPage(
theme = shinytheme("spacelab"),
titlePanel("Indice"),
navlistPanel(
#### Tab I ####
tabPanel(title = "Tab. I Tassi per ASL di competenza e Sesso",
h1(textOutput(outputId = "tab_1_text"), style = "font-size:100%"),
fluidRow(column(3, selectInput(inputId = "ASL.1",
label = "Territorio",
choices = list("TOSCANA", "ASL CENTRO","ASL NORD-OVEST","ASL SUD-EST"),
selected = "Toscana",
multiple = FALSE)),
column(3, selectInput(inputId = "Anno.1",
label = "Anno di manifestazione",
choices = as.list(unique(malprof$Anno)),
selected = max(malprof$Anno),
multiple = FALSE))),
fluidRow(column(2, downloadButton(outputId = "download_tab_1",
label = "Scarica i dati"))),
div(tableOutput(outputId = "tab_1"), style = "font-size:80%")
),
#### Fig 1 ####
tabPanel(title = "Fig. 1 Andamento delle denunce INAIL e delle segnalazioni Malprof",
h1(textOutput(outputId = "fig_1_text"), style = "font-size:100%"),
fluidRow(column(3, selectInput(inputId = "ASL.fig.1",
label = "Territorio",
choices = list("TOSCANA", "ASL CENTRO","ASL NORD-OVEST","ASL SUD-EST"),
selected = "Toscana",
multiple = FALSE))),
div(plotOutput(outputId = "fig.1"), style = "font-size:80%")
)
)
#### SERVER ####
server <- function(input, output) {
fargs <- list(big.mark=".", decimal.mark=",") #parametri per la formattazione dei numeri nelle tabelle
annoUltimo <- max(malprof$Anno)
rg <- filter(malprof, ASL == "TOSCANA")
no <- filter(malprof, ASL == "ASL NORD-OVEST")
se <- filter(malprof, ASL == "ASL SUD-EST")
ce <- filter(malprof, ASL == "ASL CENTRO")
#### Tabella I - Distribuzione di frequenza delle segnalazioni di MP e dei relativi tassi per 100.000 abitanti suddivisi per ASL di competenza e Sesso ####
selezioneASL.1 <- reactive({switch(input$ASL.1,
"TOSCANA" = rg,
"ASL CENTRO" = ce,
"ASL NORD-OVEST" = no,
"ASL SUD-EST" = se)})
tab.1 <- reactive({
pop <- popTosc %>% filter(Anno == input$Anno.1) %>%
dcast(EXASL ~ SEX, drop = T, fill = 0, fun.aggregate = sum, value.var = "N") %>%
filter(!is.na(EXASL))
mp <- selezioneASL.1() %>% filter(Anno == input$Anno.1) %>%
dcast(EXASL ~ sesso_lav, drop = T, fill = 0, fun.aggregate = length, value.var = "Anno")
tab <- pop %>% inner_join(mp, by = c("EXASL" = "EXASL")) %>%
mutate(T_F = round((F.y/F.x)*100000, 1),
T_M = round((M.y/M.x)*100000, 1)) %>%
select(EXASL, F.x, M.x, F.y, M.y, T_F, T_M)
tab.tot <- c("TOTALE", sum(tab$F.x), sum(tab$M.x), sum(tab$F.y), sum(tab$M.y), round((sum(tab$F.y)/sum(tab$F.x))*100000, 1), round((sum(tab$M.y)/sum(tab$M.x))*100000, 1))
tab <- rbind(tab, tab.tot)
tab$F.x <- as.numeric(tab$F.x)
tab$M.x <- as.numeric(tab$M.x)
tab$F.y <- as.numeric(tab$F.y)
tab$M.y <- as.numeric(tab$M.y)
tab$T_F <- as.character(tab$T_F)
tab$T_M <- as.character(tab$T_M)
tab <- rename(tab, "EXASL" = EXASL, "Pop. F" = F.x, "Pop. M" = M.x, "Segn. F" = F.y, "Segn. M" = M.y, "Tasso - F" = T_F, "Tasso - M" = T_M)
tab
})
output$tab_1_text <- renderText(paste0("Distribuzione di frequenza delle segnalazioni di MP e dei relativi tassi per 100.000 abitanti suddivisi per ASL di competenza e Sesso - ", input$ASL.1, ", ", input$Anno.1, "."))
output$tab_1 <- renderTable({tab.1()},
display=c("s","s","d","d","d","d","s","s"),
spacing="s",
align = 'lcccccc',
na="--", format.args=fargs)
output$download_tab_1 <- downloadHandler(
filename = function() {
paste("Tab_1_", input$ASL.1, "_", input$Anno.1, ".xlsx", sep = "")
},
content = function(file) {
wb <- createWorkbook()
addWorksheet(wb, sheetName = "Dati", gridLines = TRUE)
intestazione <- paste0("Distribuzione di frequenza delle segnalazioni di MP e dei relativi tassi per 100.000 abitanti suddivisi per ASL di competenza e Sesso - ", input$ASL.1, ", ", input$Anno.1, ".")
writeData(wb, 1, x = intestazione)
writeDataTable(wb, sheet = 1, startRow = 3, x = tab.1(), colNames = TRUE)
saveWorkbook(wb, file)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)

I have been working through what sounds like the same problem. It was caused by a problem the openxlsx package being accessed by the downloadHandler (Shiny). No amount of fixing permissions or ensuring the package was in the correct folder worked. As far as we could figure out its a problem with the Shiny download handler interacting with openxlsx.
In the end I fixed this by saving a local version temp of the XLSX and then referencing this in the downloadHandler.
Move this section (inside the downloadHandler) to outside of the download handler:
addWorksheet(wb, sheetName = "Dati", gridLines = TRUE)
intestazione <- paste0("Distribuzione di frequenza delle segnalazioni di MP e dei relativi tassi per 100.000 abitanti suddivisi per ASL di competenza e Sesso - ", input$ASL.1, ", ", input$Anno.1, ".")
writeData(wb, 1, x = intestazione)
writeDataTable(wb, sheet = 1, startRow = 3, x = tab.1(), colNames = TRUE)
saveWorkbook(wb, file)
Then inside the handler use a version of this:
output$downloadData <- downloadHandler(
filename = function(){paste0(intestazione,".xlsx")},
content = function(file) {
file.copy(filename,file)
#file.rename(fname,file)
}
)

I think I get it working by simply referencing file in the saveWorkbook function inside the download handler...
This is working with openxlsx package and Shiny downloadHandler :
output$quick_export <- downloadHandler(
filename = "my export.xlsx",
content = function(file) {
wb <- createWorkbook()
addWorksheet(wb, "Cars")
x <- mtcars[1:6, ]
writeData(wb, "Cars", x, startCol = 2, startRow = 3, rowNames = TRUE)
saveWorkbook(wb, file, overwrite = TRUE)
}
)

Related

Function Not returning results on Shiny App

I wrote this function below:
leg.rpps = function(es, municipio) {
est = as.character(es)
mun = as.character(municipio)
url = paste0("https://apicadprev.economia.gov.br/RPPS_REGIME_PREVIDENCIARIO?sg_uf=",
est, "&no_ente=", curlEscape(mun), "&")
tmp = tempfile()
hdl = curl::new_handle(ssl_verifypeer = 0)
curl::curl_download(url, destfile = tmp, handle = hdl)
tpdt = fromJSON(tmp)
dt1 = (tpdt$results)
dt2 = dt1$data
dt.real = dt2[[1]]
rm(tpdt, tmp, dt1, dt2)
dados = cbind(dt.real$sg_uf, dt.real$no_ente, dt.real$no_tipo_legislacao,
dt.real$nr_legislacao, dt.real$dt_legislacao, dt.real$te_ementa)
colnames(dados) = c("UF", "Ente", "Tipo Legal", "No. Dispositivo",
"Data Publicação", "Ementa")
return(datatable(dados))
}
it works fine by itself, generating the expected results. But when I try to build a shiny app and call it , I get no results at all. The shiny page just stays blank where the data table was supposed to appear. Below is the code for my app (I must say that I'm a beginner on shiny, so I might be f'in up some shiny-related code)
library(shiny)
library(DT)
library(curl)
library(jsonlite)
library(RCurl)
ui <- fluidPage(
titlePanel("Legislação RPPS por Ente"),
sidebarLayout(
sidebarPanel(
textInput(inputId = "estado",
label = "Estado - Sigla:",
value = ""),
textInput(inputId = "municipio",
label = "Município:",
value = ""),
actionButton(
inputId = "click_go",
label = "Ir")
),
mainPanel(
h1("Legislação RPPS"),
h4("Utilizar sigla do Estado (Em maiúscula) e Nome do Município com as
iniciais em Maiúscula"),
dataTableOutput("tabela")
)
)
)
server <- function(input, output) {
leg.rpps = function(es, municipio){
url = paste0("https://apicadprev.economia.gov.br/RPPS_REGIME_PREVIDENCIARIO?sg_uf=",
es, "&no_ente=", curlEscape(municipio), "&")
tmp = tempfile()
hdl = curl::new_handle(ssl_verifypeer = 0)
curl::curl_download(url, destfile = tmp, handle = hdl)
tpdt = fromJSON(tmp)
dt1 = (tpdt$results)
dt2 = dt1$data
dt.real = dt2[[1]]
rm(tpdt, tmp, dt1, dt2)
dados = cbind(dt.real$sg_uf, dt.real$no_ente, dt.real$no_tipo_legislacao,
dt.real$nr_legislacao, dt.real$dt_legislacao, dt.real$te_ementa)
#colnames(dados) = c("UF", "Ente", "Tipo Legal", "No. Dispositivo",
# "Data Publicação", "Ementa")
#return(datatable(dados))
datatable(dados)
}
current_data = eventReactive(
input$click_go,
leg.rpps(input$estado, input$municipio)
)
output$tabela <- renderDataTable({
req(input$click_go)
current_data()
})
}
shinyApp(ui, server)
I'm having a really hard-time to figure out what might be wrong with this. If anyone can even point me out a way out of this, I will be very grateful.
Apparently, I was calling a datatable on another datatable.
when I changed datatable(dados) to dados on leg.rpps() outcome, it worked.

How to solve the error in highcharOutput in shiny tool?

I'm working on cancer data from TCGA.
Im new to shiny and creating web applications (learning it!!)
I'm working on a shiny tool to plot the volcanoplot using highcharter package.
sometimes I'm successfully able to plot the volcanoplot in the UI. but sometimes it fails to plot it and throws an error saying,
"An error has occurred!
could not find function "highchartOutput"
and one warning message is given for the error;
Listening on http://127.0.0.1:5335
Warning: Error in highchartOutput: could not find function "highchartOutput"
83: dots_list
82: div
81: tabPanel
I think there is some problem with the tabset panel.
is this error has anything to do with indentation? (wherever I adjust the brackets it works magically. not sure how it works for sometimes.)
I am attaching the UI and server files with this post.
code is attached for one type of comparison
UI file below:
library(shiny)
# Define UI for application
shinyUI(fluidPage(
# Application title
titlePanel("miR-Gyn-Explorer"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
## select the count matrix
selectInput("file", label = h3("Count Matrix"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCASI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCECSI_NT.rda"))),
## select the phenodata of samples
selectInput("phenofile", label = h3("Sample Phenodata"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCA_phenoSI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCEC_phenoSI_NT.rda"))),
submitButton("Update View")
),
# Show a plot of the generated distribution
mainPanel(
tabsetPanel(
tabPanel("DEmiRNA", DT::dataTableOutput("DEmiRNA"),
"Volcano-Plot", highchartOutput("volcanoPlot", height = "500px"))
#tabPanel("miRNA-Targets", DT::dataTableOutput('miRTarget'),
#plotOutput("GO"))
)
)
)
)
)
server file:
library(shiny)
library(R.utils)
##function to find the DEmiRNA by edgeR method
library(limma)
library(edgeR)
library(DT)
library(dplyr)
library(multiMiR)
library(miRBaseConverter)
library(ggplot2)
#library(ggrepel)
library(tidyverse)
library(highcharter)
library(org.Hs.eg.db)
library(clusterProfiler)
library(purrr)
gdcDEmiRNA <- function(counts, groups, comparison, filter=TRUE) {
## method = edgeR
dge = DGEList(counts = counts, samples = groups)
group <- factor(groups$group)
design <- model.matrix(~0+group)
colnames(design) <- levels(group)
contrast.matrix <- makeContrasts(contrasts=comparison,
levels=design)
keep = filterByExpr(dge,design)
dge <- dge[keep,,keep.lib.sizes = TRUE]
dge <- calcNormFactors(dge)
dge <- estimateDisp(dge, design)
fit <- glmFit(dge, design)
lrt <- glmLRT(fit, contrast=contrast.matrix)
DEGAll <- lrt$table
DEGAll$FDR <- p.adjust(DEGAll$PValue, method = 'fdr')
o <- order(DEGAll$FDR)
DEGAll <- DEGAll[o,]
return (DEGAll)
}
# Define server logic required to perform the DEmiRNA analysis
server <- function(input, output) {
d <- reactive({
#DEmiRNA calculation
file <- load(input$file)
phenofile <- load(input$phenofile)
if(file == "SI_NT"){
if(phenofile == "phenoSI_NT"){
DEmiRNA <- gdcDEmiRNA(counts = SI_NT, groups = phenoSI_NT,
comparison = 'StageI-Normal')
}
}
})
output$DEmiRNA <- DT::renderDataTable({
mir <- d()
#mir <- mir[mir$FDR < input$FDR,]
})
output$volcanoPlot <- renderHighchart({
x <- d()
x$mirna <- rownames(x)
x$sig <- ifelse(x$PValue < 0.05 & abs(x$logFC) > 0.57, "DEmiRNA", "Not Regulated")
hc <- highchart() %>%
hc_add_series(x, "scatter", hcaes(logFC, -log10(PValue), group = sig, value = mirna),
color = c('rgba(67, 67, 72, 0.6)', 'rgba(124, 181, 236, 0.6)'),
enableMouseTracking = c(TRUE, TRUE),
showInLegend = TRUE, marker = list(radius = 4)) %>%
hc_tooltip(pointFormat = "{point.value}", headerFormat = "") %>%
hc_xAxis(title = list(text = "Log fold change"), gridLineWidth = 1,
tickLength = 0, startOnTick = "true", endOnTick = "true", min = -6, max = 6) %>%
hc_yAxis(title = list(text = "-Log10(p-value)")) %>%
hc_chart(zoomType = "xy", width=700) %>%
hc_exporting(enabled = TRUE, filename = "volcano")
hc
})
}
any comment and help from you guys is appreciated
Thank you in advance!
-Ankita

Missing search box on DT table in Shiny app when using brushing and zooming

Following on from this post I am trying to find a way to search multiple items my datatable with spaces rather than pipes and was able to implement this as per the previous post. Implementing this code into the following example works well:
library(shiny)
library(DT)
library(shinythemes)
## ------------------------------------ functions
## JS for searching with spaces between items instead of pipes
callback <- '
$("div.search").append($("#mySearch"));
$("#mySearch").on("keyup redraw", function(){
var splits = $("#mySearch").val().split(" ").filter(function(x){return x !=="";})
var searchString = "(" + splits.join("|") + ")";
table.search(searchString, true).draw(true);
});
'
## css styling
CSS <- function(values, colors){
template <- "
.option[data-value=%s], .item[data-value=%s]{
background: %s !important;
color: white !important;
}"
paste0(
apply(cbind(values, colors), 1, function(vc){
sprintf(template, vc[1], vc[1], vc[2])
}),
collapse = "\n"
)
}
## points to highlight
highlightOnPlot <- function(coords, fd, myfoi, labels = FALSE) {
.data <- coords
points(.data[myfoi, 1], .data[myfoi, 2], col = "white",
pch = 21, cex = 1, lwd = 1.3)
if (labels) {
text(.data[myfoi, 1], .data[myfoi, 2], myfoi, pos = 3, font = 2, cex = 1.2)
}
}
## ------------------------------------ data
## create dataset from iris
data(iris)
object <- iris
rownames(object) <- 1:nrow(object)
m <- object$Species
um <- levels(factor(m))
M <- matrix(0, nrow = nrow(object), ncol = length(um))
rownames(M) <- rownames(object)
colnames(M) <- um
for (j in um) M[which(j == m), j] <- 1
fd <- data.frame(markers = iris$Species, M)
## generate pca
coords <- prcomp(object[,1:4])$x[, 1:2]
rownames(coords) <- rownames(M)
## ------------------------------------ app settings
pmsel <- 1:ncol(M)
profs <- iris[, 1:4]
feats <- toSel <- c(1:ncol(fd))
idxDT <- numeric()
namesIdxDT <- character()
cols <- c("#E41A1C", "#377EB8", "#238B45", "#FF7F00")
fcol <- "markers"
css <- CSS(colnames(M), cols[seq(colnames(M))])
## ------------------------------------ UI
ui <-
shinyUI(
tagList(
navbarPage(
theme = shinytheme("flatly"), "flatly theme",
tabPanel("",
sidebarLayout(
## sidebarPanel
sidebarPanel(
tags$head(tags$style(HTML(css))),
selectizeInput("markers", "Labels",
choices = colnames(M),
multiple = TRUE,
selected = colnames(M)[pmsel])),
## mainPanel
mainPanel(
plotOutput("pca")
) # end of mainPanel
), # end of sidebarLayout
## ------Datatable-----
tags$head(tags$style(HTML(".search {float: right;}"))),
br(),
tags$input(type = "text", id = "mySearch", placeholder = "Search"),
DT::dataTableOutput("fDataTable")
) # end of tabPanel
)))
## ------------------------------------ SERVER
server <-
shinyServer(
function(input, output, session) {
## Get coords for data according to selectized class(es)
mrkSel <- reactive({lapply(input$markers, function(z) which(M[, z] == 1))})
## Update colours according to selected classes
myCols <- reactive({cols[sapply(input$markers, function(z)
which(colnames(M) == z))]})
## PCA plot
output$pca <- renderPlot({
plot(x = coords[,1], y = coords[,2])
if (!is.null(input$markers)) {
for (i in 1:length(input$markers))
points(coords[mrkSel()[[i]], ], col = myCols()[i], pch = 19)
}
})
## Feature data table
output$fDataTable <- DT::renderDataTable({
dtdata <- fd
## display datatable
DT::datatable(data = dtdata,
rownames = TRUE,
options = list(
search = list(regex = TRUE,
caseInsensitive = TRUE),
dom = "l<'search'>rtip"
),
selection = list(mode = 'multiple', selected = toSel),
callback = JS(callback))
})
})
shinyApp(ui, server)
I have quite a complicated app that uses brushing and zooming on multiple plots and have tried to simplify it here into a reproducible example. If I add in the brushing and zooming features, as per the below code, I lose the search box of my DT table.
Can anyone please advise how to rectify this? (Apologies this is still code heavy but leaving out the brushing and zooming I can't reproduce the error.)
Many thanks in advance.
library(shiny)
library(DT)
library(shinythemes)
## ------------------------------------ functions
## JS for searching with spaces between items instead of pipes
callback <- '
$("div.search").append($("#mySearch"));
$("#mySearch").on("keyup redraw", function(){
var splits = $("#mySearch").val().split(" ").filter(function(x){return x !=="";})
var searchString = "(" + splits.join("|") + ")";
table.search(searchString, true).draw(true);
});
'
## css styling
CSS <- function(values, colors){
template <- "
.option[data-value=%s], .item[data-value=%s]{
background: %s !important;
color: white !important;
}"
paste0(
apply(cbind(values, colors), 1, function(vc){
sprintf(template, vc[1], vc[1], vc[2])
}),
collapse = "\n"
)
}
## points to highlight
highlightOnPlot <- function(coords, fd, myfoi, labels = FALSE) {
.data <- coords
points(.data[myfoi, 1], .data[myfoi, 2], col = "white",
pch = 21, cex = 1, lwd = 1.3)
if (labels) {
text(.data[myfoi, 1], .data[myfoi, 2], myfoi, pos = 3, font = 2, cex = 1.2)
}
}
## ------------------------------------ data
## create dataset from iris
data(iris)
object <- iris
rownames(object) <- 1:nrow(object)
m <- object$Species
um <- levels(factor(m))
M <- matrix(0, nrow = nrow(object), ncol = length(um))
rownames(M) <- rownames(object)
colnames(M) <- um
for (j in um) M[which(j == m), j] <- 1
fd <- data.frame(markers = iris$Species, M)
## generate pca
coords <- prcomp(object[,1:4])$x[, 1:2]
rownames(coords) <- rownames(M)
## ------------------------------------ app settings
pmsel <- 1:ncol(M)
profs <- iris[, 1:4]
feats <- toSel <- c(1:ncol(fd))
idxDT <- numeric()
namesIdxDT <- character()
cols <- c("#E41A1C", "#377EB8", "#238B45", "#FF7F00")
fcol <- "markers"
css <- CSS(colnames(M), cols[seq(colnames(M))])
## ------------------------------------ UI
ui <-
shinyUI(
tagList(
navbarPage(
theme = shinytheme("flatly"), "flatly theme",
tabPanel("",
sidebarLayout(
## sidebarPanel
sidebarPanel(
tags$head(tags$style(HTML(css))),
selectizeInput("markers", "Labels",
choices = colnames(M),
multiple = TRUE,
selected = colnames(M)[pmsel]),
br(),
actionButton("resetButton", "Zoom/reset plot"),
br(),
actionButton("clear", "Clear selection"),
width = 3),
## mainPanel
mainPanel(
plotOutput("pca",
dblclick = "dblClick",
brush = brushOpts(id = "pcaBrush", resetOnNew = TRUE))
) # end of mainPanel
), # end of sidebarLayout
## ------Datatable-----
tags$head(tags$style(HTML(".search {float: right;}"))),
br(),
tags$input(type = "text", id = "mySearch", placeholder = "Search"),
DT::dataTableOutput("fDataTable")
) # end of tabPanel
)))
## ------------------------------------ SERVER
server <-
shinyServer(
function(input, output, session) {
## settings for brushing on the plot
ranges <- reactiveValues(x = NULL, y = NULL)
brushBounds <- reactiveValues(i = try(coords[, 1] >= min(coords[, 1]) &
coords[, 1] <= max(coords[, 1])),
j = try(coords[, 2] >= min(coords[, 2]) &
coords[, 2] <= max(coords[, 2])))
resetLabels <- reactiveValues(logical = FALSE)
## Get coords for data according to selectized class(es)
mrkSel <- reactive({lapply(input$markers, function(z) which(M[, z] == 1))})
## Update colours according to selected classes
myCols <- reactive({cols[sapply(input$markers, function(z)
which(colnames(M) == z))]})
## PCA plot
output$pca <- renderPlot({
plot(x = coords[,1], y = coords[,2],
xlim = ranges$x, ylim = ranges$y)
if (!is.null(input$markers)) {
for (i in 1:length(input$markers))
points(coords[mrkSel()[[i]], ], col = myCols()[i], pch = 19)
}
## highlight point on plot by selecting item in table
idxDT <<- feats[input$fDataTable_rows_selected]
if (resetLabels$logical) idxDT <<- numeric() ## If TRUE labels are cleared
namesIdxDT <<- names(idxDT)
if (length(idxDT)) {
highlightOnPlot(coords, fd, namesIdxDT)
highlightOnPlot(coords, fd, namesIdxDT, labels = TRUE)
}
resetLabels$logical <- FALSE
})
## Feature data table
output$fDataTable <- DT::renderDataTable({
## Double clicking to identify point
feats <<- which(brushBounds$i & brushBounds$j)
if (!is.null(input$dblClick)) {
dist <- apply(coords, 1, function(z) sqrt((input$dblClick$x - z[1])^2
+ (input$dblClick$y - z[2])^2))
idxPlot <- which(dist == min(dist))
if (idxPlot %in% idxDT) { ## 1--is it already clicked?
setsel <- setdiff(names(idxDT), names(idxPlot)) ## Yes, remove it from table
idxDT <<- idxDT[setsel]
} else { ## 2--new click?
idxDT <<- c(idxDT, idxPlot) ## Yes, highlight it to table
}
}
namesIdxDT <<- names(idxDT)
toSel <- match(namesIdxDT, rownames(fd)[brushBounds$i & brushBounds$j])
if (resetLabels$logical) toSel <- numeric()
dtdata <- fd
dtdata <- dtdata[brushBounds$i & brushBounds$j, ]
## display datatable
DT::datatable(data = dtdata,
rownames = TRUE,
options = list(
search = list(regex = TRUE,
caseInsensitive = TRUE),
dom = "l<'search'>rtip"
),
selection = list(mode = 'multiple', selected = toSel),
callback = JS(callback))
})
## When a the reset button is clicked check to see is there is a brush on
## the plot, if yes zoom, if not reset the plot.
observeEvent(input$resetButton, {
brush <- input$pcaBrush
if (!is.null(brush)) {
ranges$x <- c(brush$xmin, brush$xmax)
ranges$y <- c(brush$ymin, brush$ymax)
brushBounds$i <- coords[, 1] >= brush$xmin & coords[, 1] <= brush$xmax
brushBounds$j <- coords[, 2] >= brush$ymin & coords[, 2] <= brush$ymax
} else {
ranges$x <- NULL
ranges$y <- NULL
brushBounds$i <- try(coords[, 1] >= min(coords[, 1])
& coords[, 1] <= max(coords[, 1]))
brushBounds$j <- try(coords[, 2] >= min(coords[, 2])
& coords[, 2] <= max(coords[, 2]))
}
})
## Clear indices and reset clicked selection
observeEvent(input$clear, {resetLabels$logical <- TRUE})
})
shinyApp(ui, server)
SessionInfo
> sessionInfo()
R version 3.6.3 (2020-02-29)
Platform: x86_64-apple-darwin15.6.0 (64-bit)
Running under: macOS High Sierra 10.13.6
Matrix products: default
BLAS: /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/3.6/Resources/lib/libRlapack.dylib
locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shinythemes_1.1.2 DT_0.13 shiny_1.4.0.2
loaded via a namespace (and not attached):
[1] Rcpp_1.0.4.6 crayon_1.3.4 digest_0.6.25 later_1.0.0 mime_0.9 R6_2.4.1
[7] jsonlite_1.6.1 xtable_1.8-4 magrittr_1.5 rlang_0.4.5 rstudioapi_0.11 promises_1.1.0
[13] tools_3.6.3 htmlwidgets_1.5.1 crosstalk_1.1.0.1 rsconnect_0.8.16 yaml_2.2.1 httpuv_1.5.2
[19] fastmap_1.0.1 compiler_3.6.3 htmltools_0.4.0
Thanks again.
When you play with the brushing/zooming, the renderDT reacts. I believe this destroys the previous table and also the text input mySearch because it is included in the datatable.
I have not tried with a reactive datatable, but I think the following code should work. The text input mySearch is created in the callback, so it should be recreated when a new table is created. So remove the tags$input as well as the CSS, because I set the CSS property float in the callback.
library(shiny)
library(DT)
callback <- '
var x = document.createElement("INPUT");
x.setAttribute("type", "text");
x.setAttribute("id", "mySearch");
x.setAttribute("placeholder", "Search");
x.style.float = "right";
$("div.search").append($(x));
$("#mySearch").on("keyup redraw", function(){
var splits = $("#mySearch").val().split(" ").filter(function(x){return x !=="";})
var searchString = "(" + splits.join("|") + ")";
table.search(searchString, true).draw(true);
});
'
ui <- fluidPage(
#tags$head(tags$style(HTML(".search {float: right;}"))), --- REMOVE THAT
br(),
DTOutput("dtable")
)
server <- function(input, output){
output[["dtable"]] <- renderDT({
datatable(
iris[c(1,2,51,52,101,102),],
options = list(
dom = "l<'search'>rtip"
),
callback = JS(callback)
)
}, server = FALSE)
}
shinyApp(ui, server)

Archive button in R shiny, activate only once

I have the following code which runs perfectly!. However, I want to restrict the archiving of the data by pushing the "Export All" button to only once per day. I tried to use if statements and not successful. Another fact is the code is running over Shiny-Server pro and different browser sessions will be created. Any Suggestions?.
library(shiny)
library(shinyBS)
library(XLConnect)
library(lubridate)
cData <- '
Candidate,Party,Province,Age,Gender
"L, L",NDP,Quebec,22,Female
"M, M",Bloc Quebecois,Quebec,43,Female
"M, S",Bloc Quebecois,Quebec,34,Female
"S, D",NDP,Quebec,,Female
"S, L",NDP,Quebec,72,Female
"F, H",Liberal,British Columbia,71,Female
"T, N",NDP,Quebec,70,Female
"S, J",Liberal,Ontario,68,Female
"R, Francine",NDP,Quebec,67,Female
"D, Patricia",Conservative,Ontario,66,Female
"S, Joy",Conservative,Manitoba,65,Female
"W, Alice",Conservative,British Columbia,64,Female
"O, Tilly",Conservative,New Brunswick,63,Female
"A, Diane",Conservative,Alberta,63,Female
"D, Linda",NDP,Alberta,63,Female
"B, Carolyn",Liberal,Ontario,62,Female
"N, Peggy",NDP,Ontario,61,Female
"M, Irene",NDP,Ontario,61,Female
"S, Jinny",NDP,British Columbia,60,Female
"F, Judy",Liberal,Newfoundland,60,Female
"C, Jean",NDP,British Columbia,60,Female
"D, Libby",NDP,British Columbia,59,Female
"Y, Lynne",Conservative,Saskatchewan,59,Female
"D, Anne",NDP,Quebec,58,Female
"M, Elizabeth",Green,British Columbia,58,Female
"M, Joyce",Liberal,British Columbia,58,Female
"F, Kerry",Conservative,British Columbia,57,Female
"B, Lois",Conservative,Ontario,57,Female
"B, Marj",NDP,Quebec,57,Female
"C, Joan",Conservative,Alberta,56,Female
"C, Olivia",NDP,Ontario,55,Female
"M, Cathy",Conservative,British Columbia,55,Female
"F, Diane",Conservative,Ontario,55,Female
"L, Helene",NDP,Quebec,54,Female
"G, Nina",Conservative,British Columbia,54,Female
"H, Carol",NDP,Ontario,54,Female
"P, Gail",Conservative,Prince Edward Island,53,Female
"T, Susan",Conservative,Ontario,53,Female
"Y, Wai",Conservative,British Columbia,52,Female'
con <- textConnection(cData)
cEl <- read.csv(con, header=TRUE, stringsAsFactors = FALSE)
cEl$votes <- round(runif(nrow(cEl), min=500, max=15000))
TheDataDF <- cEl
ui <- fluidPage(
titlePanel("Archive Data Post on Stack Overflow"),
# Button and Alert, we use the alert to control only onetime Archive
sidebarLayout(
sidebarPanel(
bsAlert("alert"),
downloadButton("ArchiveBtn", "Archive All")
),
# Show the table
mainPanel(
DT::dataTableOutput('TheData')
)
)
)
server <- function(input, output,session) {
output$TheData <- DT::renderDataTable(DT::datatable(TheDataDF,options = list(pageLength = 25,scrollX = TRUE),
rownames = FALSE,class = 'cell-border stripe')
%>% formatStyle(c(2:ncol(TheDataDF)),
color = styleInterval(55, c('red', 'black'))))
output$ArchiveBtn <- downloadHandler(
filename = function() {
paste("ArchiveData-", ymd(Sys.Date()), ".xlsx", sep="")
},
content = function(file) {
fname <- paste(file,"xlsx",sep=".")
wb <- loadWorkbook(fname, create = TRUE)
#creating sheets within the Excel workbook
createSheet(wb, name = "The Arc Data")
#writing into sheet within the Excel workbook :
writeWorksheet(wb, TheDataDF, sheet = "The Arc Data", startRow = 1, startCol = 1)
saveWorkbook(wb)
file.rename(fname,file)
# Create the message for the complition of the archive
createAlert(session, "alert", "exampleAlert", style="success",title = "Archive Complete!",
content = "Data archived", append = FALSE)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)

Conditional checkbox plotting in Shiny

I have two checkbox group fiscal and manager. When a particular value from fiscal check box say 2016Q1 is selected and if a checkbox from manager is ticked, the application should plot the graph from 2016Q1fiscal year for that manager. I have written logic for both the checkboxes individually but am unable to integrate that.
library(shiny)
library(shinythemes)
ui <- fluidPage(theme = shinytheme("journal"),h1("India-DSI",align="center",style = "font-family: 'Lobster', cursive;font-weight: 500; line-height: 1.1; color: #4d3a7d;"),
sidebarLayout(
sidebarPanel(fileInput('file1', 'Choose file to upload',accept= c('text/csv','text/comma-separated-values','text/tab-separated-values','text/plain','.csv','.tsv')),width=2,
checkboxGroupInput("fiscal", "Fiscal Quarter:", c("2015Q1","2015Q2","2015Q3","2015Q4","2016Q1"),selected = NULL,inline=FALSE),
checkboxGroupInput("manager", "Manager:", c("Kalla,Abhay","Koul,Samir","Pudipeddi,Harinath","Huruli,Sharath"),selected = NULL,inline = FALSE)
),
mainPanel({
plotOutput("plot")
})))
server <- function (input , output )
{
myread <- function ()
{
inFile <- input$file1
if (is.null(inFile))
return(NULL)
mydata <- read.csv(inFile$datapath)
return (mydata)
}
## Quarter filter
{
output$plot <- renderPlot({
x <- data.frame(myread())
y <- x[x$Fiscal.Quarter == input$fiscal, ]
resources <- factor(y$Resource.Name)
stan <- tapply(y$Standard.Hours, resources, sum, na.rm = TRUE)
bil <- tapply(y$Billable.Hours, resources, sum, na.rm = TRUE)
bu <- bil*100 / stan
mp <- barplot (bu, col = colors(27), las = 2, yaxt = "n",xlim=NULL, ylim = c(0,200))
bu<- round(bu, 2)
text(mp, bu, labels = bu, pos = 3)
})
}
## Manager Filter
{
output$plot <- renderPlot({
x <- data.frame(myread())
y <- x[x$Manager == input$manager, ]
resources <- factor(y$Resource.Name)
stan <- tapply(y$Standard.Hours, resources, sum, na.rm = TRUE)
bil <- tapply(y$Billable.Hours, resources, sum, na.rm = TRUE)
bu <- bil*100 / stan
mp <- barplot (bu, col = colors(27), las = 2, yaxt = "n", ylim = c(0,200))
bu<- round(bu, 2)
text(mp, bu, labels = bu, pos = 3)
})
}
}
shinyApp(ui=ui ,server=server)

Resources