I have a shiny app linked to a duckdb. Since I have a very big dataset I just want to load in 10'000 rows. However as soon as the user downloads the dataset it should download the entire dataset and not just the first 10'000 rows. So I guess there should be some kind of if condition where i specify the "LIMIT 10000" which reacts on the download handler. However, I dont know how to change the LIMIT based on the download handler.
BestandeslisteDaten_UI <- function(id3, mydb, data_Vertrag){
ns <- NS(id3)
tagList(
fluidRow(
box(
title = "Daten Bestandesliste", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=9,
DTOutput(ns("dt31"))
),
box(
title = "Einschränkung des Datenset", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=3, height = "110em",
downloadButton(ns("download32"),"Download entire Table as csv")
)
)
)
}
BestandeslisteDaten_Server <- function(id3, mydb, data_Vertrag){
moduleServer(
id3,
function(input, output, session){
filter_BestandVertrag_Daten <- reactive({
query <- glue_sql("SELECT * FROM data_Vertrag",
.con = mydb)
add_where <- TRUE
query <- glue_sql(query, " LIMIT 10000", .con = mydb)
print(query)
dt <- as.data.table(dbGetQuery(mydb, query))
print(dt)
dt
})
# Data Table
output$dt31 <- renderDT({
filter_BestandVertrag_Daten() %>%
datatable(
extensions = 'Buttons',
options = list(
server = TRUE,
lengthMenu=c(10, 100),
scrollX = TRUE,
scrollY = "500px",
dom = 'Blfrtip'
))
})
# Download Datatable
output$download32 <- downloadHandler(
filename = function() {
paste("Bestandesliste_", Sys.Date(), ".csv", sep="")
},
content = function(file) {
write.csv(filter_BestandVertrag_Daten(), file)
}
)
}
)
}
I am trying to use shinyApp with the leaflet package. I have tried using the "SelectInput" function in the dashboard to create a reactive map based on the input selected(country).However, I am not able to make the leaflet and the SelectInput connect with each other.
Here is my code:
library(shiny)
library(leaflet)
ui <- (fluidPage(
titlePanel(title = "Pig breeding countries in 2000 - Top 5"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "country",
label = "Select a country to view it's values (you can choose more than one):",
c("Brazil", "China", "Russia", "USA", "Vietnam"), multiple = TRUE
)
),
#mainPanel must be outside the sidebarLayout argument
mainPanel(leafletOutput("mymap", height = "500"),
leafletOutput("country")
))
)
)
server <- (function(input, output){
output$mymap <- renderLeaflet(input$country)
output$mymap <- renderLeaflet({
mymap = leaflet()
setView(mymap, lng = -16.882374406249937, lat = -1.7206857960062047, zoom = 0)
mymap = addProviderTiles(mymap, provider = "CartoDB.Positron")
mymap = addMarkers(mymap,lng = 101.901875, lat = 35.486703, popup = "China 35,500")
mymap = addMarkers(mymap,lng = -95.712891, lat = 37.090240, popup = "USA 6,267")
mymap = addMarkers(mymap,lng = 108.339537, lat = 14.315424, popup = "Vietnam 2,947")
mymap = addMarkers(mymap,lng = 37.618423, lat = 55.751244, popup = "Russia 3,070")
mymap = addMarkers(mymap,lng = -46.625290, lat = -23.533773, popup = "Brazil 3,020")}
})
shinyApp(ui, server)
Can someone advise how to link them?
There is no reactive environment between your drop-down selection and leaflet map in your code. Check in the below code to create reactive leaflet map.
library(shiny)
library(leaflet)
df <- read.csv("leaflet.csv")
ui <- (fluidPage(
titlePanel(title = "Pig breeding countries in 2000 - Top 5"),
sidebarLayout(
sidebarPanel( uiOutput("countrynames")
),
mainPanel(leafletOutput("mymap", height = "500")
))
)
)
server <- function(input, output){
output$countrynames <- renderUI({
selectInput(inputId = "country", label = "Select a country to view it's values (you can choose more than one):",
c(as.character(df$country)))
})
map_data <- reactive({
data <- data.frame(df[df$country == input$country,])
data$popup <- paste0(data$country, " ", data$number)
return(data)
})
output$mymap <- renderLeaflet({
leaflet(data = map_data()) %>%
# setView( lng = -16.882374406249937, lat = -1.7206857960062047, zoom = 0) %>%
addProviderTiles( provider = "CartoDB.Positron") %>%
addMarkers(lng = ~lng, lat = ~lat, popup = ~popup)
# addCircles(lng = ~lng, lat = ~lat, popup = ~popup)
})
}
shinyApp(ui, server)
Below is the csv file i have imported in code.
structure(list(lng = c(101.901875, -95.712891, 108.339537, 37.618423
), lat = c(35.486703, 37.09024, 14.315424, 55.751244), country = structure(c(1L,
3L, 4L, 2L), .Label = c("China", "Russia", "USA", "Vietnam"), class = "factor"),
number = c(35500L, 6267L, 2947L, 3070L)), .Names = c("lng",
"lat", "country", "number"), class = "data.frame", row.names = c(NA,
-4L))
I have seen that this problem has happened to other people, but their solutions have not worked for me. I have my app.R file and a .RData file with the required inputs in the same ECWA_Strategic_Planning_Tool directory. When I run:
library(rsconnect)
rsconnect::deployApp('C:/Users/mikialynn/Documents/Duke/Spring2017/MP/GISTool/Final/ECWA_Strategic_Planning_Tool')
I get the following error on the web page that opens up:
ERROR: An error has occurred. Check your logs or contact the app author for clarification.
However, I cannot find anything wrong. I install all of my packages, I use relative pathways etc. I am pasting all of the code from my app below. If anyone can spot what I'm doing wrong, I would greatly appreciate it!
library(shiny)
library(leaflet)
library(sp)
library(rgdal)
library(rstudioapi) # For working directory
library(raster)
library(RColorBrewer)
library(rgeos) #Maybe use gSimplify to simplify polygon
library(DT) #To make interactive DataTable
library(plotly) #For pie chart
library(ggplot2) # for layout
# Set Working Directory
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
# Load R Workspace
load('Shiny.Strategies.RData')
# UI variables
neigh.names <- levels(merge.proj$View)
neigh.default <- c("Urban7")
dt.names <- c('PARCEL_ID', 'PIN', 'OWNER_NAME', 'SITE_ADDRE', 'OWNER_ADDR',
'SUM_ACRE', 'LANDUSE_DE', 'LAND_VALUE', 'TOTAL_VALU', 'SALE_PRICE',
'Pluvial_WtScore', 'Rest_WtScore', 'GI_WtScore', 'SC_WtScore',
'UNCWI_WtScore', 'Total_Score', 'View')
dt.default <- c('PARCEL_ID', 'Pluvial_WtScore', 'Rest_WtScore',
'GI_WtScore', 'SC_WtScore', 'UNCWI_WtScore', 'Total_Score', 'View')
# Build UI
ui <- fluidPage(
titlePanel("ECWA Strategic Planning Tool"),
HTML('<br>'),
column(2,
HTML("<strong>Instructions:</strong><br/><br/>"),
HTML("<p>1) Select weights for parameters and click 'Run' to
initiate tool.<br/><br/>
2) Use rightside panel to adjust Table and Map Settings.<br/>
<br/>
3) Use search/sort functions of Table to identify parcels.
Select row to display Total Score Chart.<br/><br/>
4) Input View and Parcel ID from Table to Map settings to
identify parcel in Map.<br/><br/>
5) When satisfied with weights, click 'Export Shapefile' to
save shapefile of all parcels.<p/><br/>"),
HTML("<strong>Calculate Parcel Scores: </strong><br/>"),
helpText('The sum of the weights must equal to 1.'),
sliderInput(inputId = "weightPluvial", label = "Weight for Pluvial
Flooding",
value = 0.20, min = 0, max = 1),
sliderInput(inputId = "weightRest", label = "Weight for
Restoration",
value = 0.20, min = 0, max = 1),
sliderInput(inputId = "weightGI", label = "Weight for Green
Infrastructure",
value = 0.20, min = 0, max = 1),
sliderInput(inputId = "weightSC", label = "Weight for City
Stormwater Controls",
value = 0.20, min = 0, max = 1),
sliderInput(inputId = "weightUNCWI", label = "Weight for UNCWI",
value = 0.20, min = 0, max = 1),
actionButton("run", "Run"),
actionButton("export", "Export Shapefile")),
column(8,
HTML("<h3><strong>Table Summary</strong></h3>"),
HTML("<br>"),
dataTableOutput("table")),
column(2,
HTML("<p><br><br></p>"),
HTML("<h4>Table Settings:</h4>"),
checkboxGroupInput(inputId = 'show_vars', label = 'Select column(s)
to display in Table:', choices = dt.names, selected = dt.default),
HTML("<strong>Total Score Chart:</strong>"),
helpText("Please select Table row to display pie chart."),
plotlyOutput("pie")
),
fluidRow(
column(8, offset = 2,
HTML("<br>"),
HTML("<h3><strong>Map Display</strong></h3>"),
leafletOutput("map", height = 800),
HTML("<br><br>")),
column(2,
HTML("<p><br><br><br></p>"),
HTML("<h4>Map Settings:</h4>"),
checkboxGroupInput(inputId = 'show_neigh', label = 'Select
View(s) to display in Map:', choices = neigh.names,
selected = neigh.default),
HTML("<br>"),
sliderInput("range", "Select score range to display in Map:", min
= 0.0, max= 10.0, value = as.numeric(c("0.0", "10.0")), step = 0.1),
HTML("<br>"),
HTML("<strong>Parcel Zoom:</strong>"),
helpText("The View and Score Range must contain the parcel of
interest to execute zoom."),
numericInput('parcel','Enter Parcel ID',0)
)
))
# SERVER
server <- function(input, output) {
defaultData <-
eventReactive(input$run, {
# Multiply by Weights
merge.proj#data$Pluvial_WtScore <-
round(merge.proj#data$Pluvial_Score*input$weightPluvial, digits = 1)
merge.proj#data$Rest_WtScore <-
round(merge.proj#data$Rest_Score*input$weightRest, digits = 1)
merge.proj#data$GI_WtScore <-
round(merge.proj#data$GI_Score*input$weightGI, digits = 1)
merge.proj#data$SC_WtScore <-
round(merge.proj#data$SC_Score*input$weightSC, digits = 1)
merge.proj#data$UNCWI_WtScore <-
round(merge.proj#data$UNCWI_Score*input$weightUNCWI, digits = 1)
# Find Total Score
merge.proj#data$Total_Score <- merge.proj#data$Pluvial_WtScore +
merge.proj#data$Rest_WtScore + merge.proj#data$GI_WtScore +
merge.proj#data$SC_WtScore + merge.proj#data$UNCWI_WtScore
return(merge.proj)
})
# Subset by neighborhood
neighData <- reactive ({
merge.proj <- defaultData()
merge.proj[merge.proj$View%in%input$show_neigh,]
})
# Plot with leaflet
# Palette for map
colorpal <- reactive({
merge.proj <- neighData()
colorNumeric(palette = "YlOrRd",
domain = merge.proj$Total_Score)
})
# Pop Up Option for map
# popup <- paste0("<strong>Parcel ID: </strong>",
# merge.proj#data$PARCEL_ID,
# "<br><strong>Total Score: </strong>",
# merge.proj#data$Total_Score)
# Label Option for map
labels <- reactive({
merge.proj <- neighData()
sprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score:
</strong>%g",
merge.proj$PARCEL_ID,
merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})
# Render Default Map
output$map <- renderLeaflet ({
merge.proj <- neighData()
pal <- colorpal()
lab <- labels()
leaflet() %>%
#addProviderTiles(provider='Esri.WorldImagery') %>%
# setView(zoom =) %>%
addTiles() %>%
addPolygons(
#data = merge.proj[input$show_neigh,, drop = FALSE],
data=merge.proj,
fillColor = ~pal(Total_Score),
weight = 1,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 3,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
# popup= popup) %>%
label = lab,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLegend(position = "bottomleft",pal = pal, opacity = 0.7, values =
merge.proj$Total_Score, title = "<strong>Total Score</strong>")
})
# Build Data Table
output$table <- renderDataTable({
merge.proj <- defaultData()
table.dat <- merge.proj[, c('PARCEL_ID', 'PIN', 'OWNER_NAME',
'SITE_ADDRE', 'OWNER_ADDR', 'SUM_ACRE', 'LANDUSE_DE', 'LAND_VALUE',
'TOTAL_VALU', 'SALE_PRICE', 'Pluvial_WtScore', 'Rest_WtScore', 'GI_WtScore',
'SC_WtScore', 'UNCWI_WtScore', 'Total_Score', 'View')]
datatable(data = table.dat#data[, input$show_vars, drop = FALSE],
options = list(lengthMenu = c(5, 10, 20, 30), pageLength = 20), rownames =
FALSE)
})
# Plot-ly
output$pie <- renderPlotly({
merge.proj <- defaultData()
names <- c('Pluvial', 'Rest', 'GI', 'SC', 'UNCWI')
colors <- c('rgb(128,133,133)', 'rgb(211,94,96)', 'rgb(144,103,167)',
'rgb(114,147,203)', 'rgb(171,104,87)')
selectedrowindex <-
input$table_rows_selected[length(input$table_rows_selected)]
selectedrowindex <- as.numeric(selectedrowindex)
df <- data.frame(merge.proj[selectedrowindex, c('Pluvial_WtScore',
'Rest_WtScore', 'GI_WtScore', 'SC_WtScore', 'UNCWI_WtScore')])
vector <- unname(unlist(df[1,]))
if (!is.null(input$table_rows_selected)) {
par(mar = c(4, 4, 1, .1))
plot_ly(labels = names, values = vector, type = 'pie',
textposition = 'inside',
textinfo = 'label+percent',
insidetextfont = list(color = '#FFFFFF'),
hoverinfo = 'text',
text = ~paste('Score:', vector),
marker = list(colors = colors,
line = list(color = '#FFFFFF', width = 1)),
#The 'pull' attribute can also be used to create space between the sectors
showlegend = FALSE) %>%
layout(#title = '% Total Score',
xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))
}
else {return(NULL)}
})
# Update map to parcel score slider
# Subset data
filteredData <- reactive({
merge.proj <- neighData()
merge.proj[merge.proj#data$Total_Score >= input$range[1] &
merge.proj#data$Total_Score <= input$range[2],]
})
# New Palette
colorpal2 <- reactive({
merge.proj <- filteredData()
colorNumeric(palette = "YlOrRd",
domain = merge.proj$Total_Score)
})
# Pop Up Option
# popup <- paste0("<strong>Parcel ID: </strong>",
# merge.proj#data$PARCEL_ID,
# "<br><strong>Total Score: </strong>",
# merge.proj#data$Total_Score)
# Label Option
labels2 <- reactive({
merge.proj <- filteredData()
sprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score:
</strong>%g",
merge.proj$PARCEL_ID,
merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})
#Leaflet Proxy
observe({
merge.proj <- filteredData()
pal2 <- colorpal2()
lab2 <- labels2()
leaf <- leafletProxy("map", data = filteredData()) %>%
clearShapes() %>%
addPolygons(
fillColor = ~pal2(Total_Score),
weight = 1,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 3,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
# popup= popup) %>%
label = lab2,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto"))
if(input$parcel>0){
sub.dat <- merge.proj[merge.proj$PARCEL_ID==input$parcel,]
zx <- mean(extent(sub.dat)[1:2])
zy <- mean(extent(sub.dat)[3:4])
leaf <- leaf %>%
setView(lng=zx,lat=zy,zoom=16)
}
leaf
})
#Update Legend
observe({
proxy <- leafletProxy("map", data = filteredData())
pal2 <- colorpal2()
proxy %>% clearControls()
proxy %>% addLegend(position = "bottomleft",pal = pal2, opacity = 0.7,
values = ~Total_Score, title = "<strong>Total Score</strong>")
})
# Export new shapefile
#make so that user can choose name and allow overwrite
observeEvent(input$export, {
merge.proj <- defaultData()
writeOGR(merge.proj, dsn = "Data", layer = "Strategies_Output", driver =
"ESRI Shapefile")
})
}
shinyApp(ui = ui, server = server)
Issue resolved! My initial suspicion was correct; it had to do with the .rdata file. It also relates to shinyapp.io's servers which run on a Linux based server. From my reading, Linux only handles lowercase file paths and extensions. The reason why it worked for the .csv file is because it's pretty common to have the file extension saved in all lowercase. This was not the case for the .RData file. Using the RStudio IDE and the physical "Save Workspace" button, the default file extension is .RData (case sensitive). I couldn't rename the file extension (for some reason, I'm not the most tech-savvy person). Similar to the load() function, there's the save() function. Previously, I used the save() file as follows (note the capitalized .RData at the end):
save(df_training_separated_with_models, file = "sample_data_with_models.RData")
However, using the same function in all lowercase fixes the issue:
save(df_training_separated_with_models, file = "sample_data_with_models.rdata")
Hope this helps any other poor soul with the same issue that is scouring the internet and other forums.
Cheers!
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)