Related
I want the user of my Shiny app to be able to choose between two types of plots by clicking on radiobuttons in the Events panel. The code I have written works, but the page leaves a huge white space when going from "Map" to "Plot". Is there any way to get rid of the white space and position the plot at the very top?
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
}else{
shinyjs::enable("range")
}
})
output$plot <- renderPlot({
if (input$plotType == "l") {
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
}
})
output$map <- renderLeaflet({
if ( input$plotType == "m") {
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
}
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
There is a big space because the map html object still exists, but is empty. To avoid this, I created and observeEvent that hides or show the map output depending on input value. I did the same thing with the plot, in cas you need to add others elements below it.
Please note that there are others solutions (conditionalPanel for example), I am just giving you the one I think is the simpliest here.
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
# hide or show map and plot
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
shinyjs::hide("map")
shinyjs::show("plot")
}
if(input$plotType == "m"){
shinyjs::enable("range")
shinyjs::show("map")
shinyjs::hide("plot")
}
})
output$plot <- renderPlot({
req(input$plotType == "l") # good practice to use req instead of if
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
})
output$map <- renderLeaflet({
req(input$plotType == "m")
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
I would like to load data and set up a custom projection in R Shiny. I am able to load the data but cannot get the projection right (ESPG:26916). I have searched but am not sure what I have missed. Help much appreciated.
Here is the code I have
library(leaflet)
library(tidyverse)
ui <- fluidPage(
column(
width = 4,
leafletOutput("mymap", width = 1400, heigh = 700)),
p(),
fileInput("in_file", "Input file:",
accept=c("txt/csv", "text/comma-separated-values,text/plain", ".csv", "Decimal seperator")),
actionButton("upload_data", "Visualize New points")#,
)
server <- function(input, output, session) {
visualize <- reactive({
if(input$upload_data==0) {
return(NULL)
}
df <- read.csv(input$in_file$datapath,
sep = ',',
header = TRUE,
quote = "#",
row.names = NULL)
epsg26916 <- leafletCRS(
crsClass = "L.Proj.CRS",
code = 'EPSG:26916',
proj4def = "+proj=utm +zone=16 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs",
resolutions = 2^(15:-1)
)
return(leaflet(df,
options = leafletOptions(crs = epsg26916)
) %>%
addProviderTiles(providers$Esri.WorldImagery,
options = providerTileOptions(noWrap = TRUE)) %>%
setView(-85.39310209, 42.41438242, zoom = 16) %>%
addCircleMarkers(~easting, ~northing,
group = "my data",
weight = 1, fillOpacity = 0.7, radius = 3) %>%
addLayersControl(overlayGroups = c("my data"))
)
})
output$mymap <- renderLeaflet({
visualize()
})
}
shinyApp(ui, server)
I have been trying to merge data with another data set based on input from a drop down. I have just started learning R and have run into some problems and want to know if there is a better way of going about this.
I am getting an error that it cannot coerce class c(ReactiveExpr, reactive) to a data frame.
library(shiny)
library(plyr)
library(dplyr)
library(xlsx)
server <- function(input, output){
annotation1 <- read.xlsx("input1.xlsx", sheetIndex = 1, header = TRUE)
annotation2 <- read.xlsx("input2.xlsx", sheetIndex = 1, header = TRUE)
data_input <- eventReactive(input$userfile, {
df <- read.xlsx(input$userfile$datapath, sheetIndex = 1, header = TRUE)
})
output$data_input <- renderTable(data_input())
output$annotation <- renderTable(annotation)
data_species <- c("Set1", "Set2")
# Drop-down selection box for which data set
output$choose_species <- renderUI ({
selectInput("species", "Species", as.list(data_species))
})
output$mergeddata <- renderTable({
if(input$species == "Set1"){
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
}
else if(input$species == "Set2"){
eventReactive("Set2",({left_join(data_input(), annotation2, by = c("Column1" = "Column1"))}))
}
})
}
ui <- fluidPage(
titlePanel(
div("Test")
),
sidebarLayout(
sidebarPanel(
fileInput("userfile", "Input File", multiple =FALSE,
buttonLabel = "Browse Files", placeholder = "Select File"),
uiOutput("choose_species"),
uiOutput("choose_annotations"),
),
mainPanel(
tableOutput("mergeddata"),
br()
),
),
)
# Run the application
shinyApp(ui = ui, server = server)
In general, you approach seems ok. The error you get is from the line
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
An eventReactive returns an (unevaluated) reactive expression which you try to render as data.frame with renderTable. To circumvent this, you could use:
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))()
However, here you don't need eventReactive, because your reactivity comes from input$species (you want to change the table output based on this input). Therefore, you can just use:
output$mergeddata <- renderTable({
if(input$species == "Set1"){
merge_data <- annotation1
} else {
merge_data <- annotation2
}
left_join(data_input(), merge_data, by = c("Column1"))
})
In the basic example below I would like to have all filters updated every time user add a filter.
ui :
library(shiny)
library(DT)
fluidPage(
fluidRow(
column(4,
DT::dataTableOutput("dt")
)
)
)
Server :
library(shiny)
shinyServer(function(input, output) {
df <- data.frame(var1 = c(rep("A",3),rep("B",3)), var2 = c("x","y","x","z","x","s"), var3 = c(1:6))
output$dt <- renderDataTable({
DT::datatable(df, filter = 'top')
})
})
When no filter applied :
When I apply filter on var1 to "A", s and z still remain in the suggested label in var2 filter even if there are no value to s or z
This is how I would do if I use selectInput for the filters. May not be the best solution, but it has always worked for me.
Code for ui.r
library(shiny)
library(DT)
fluidPage(
fluidRow(
column(4,selectizeInput("var1", label = "Var 1", choices = NULL, multiple = TRUE)),
column(4,selectizeInput("var2", label = "Var 2", choices = NULL, multiple = TRUE)),
column(4,selectizeInput("var3", label = "Var 3", choices = NULL, multiple = TRUE)),
column(4,DT::dataTableOutput("dt")
)
)
)
Code for server.R
library(shiny)
shinyServer(function(input, output, session) {
df <- data.frame(var1 = c(rep("A",3),rep("B",3)), var2 = c("x","y","x","z","x","s"), var3 = c(1:6))
updateSelectizeInput(session, 'var1', choices = sort(unique(df$var1)), server = TRUE)
updateSelectizeInput(session, 'var2', choices = sort(unique(df$var2)), server = TRUE)
updateSelectizeInput(session, 'var3', choices = sort(unique(df$var3)), server = TRUE)
filterData <- function(dataset){
df <- dataset
if (!is.null(input$var1)){
df <- df[which(df$var1 == input$var1),]
}
if (!is.null(input$var2)){
df <- df[which(df$var2 == input$var2),]
}
if (!is.null(input$var3)){
df <- df[which(df$var3 == input$var3),]
}
df
}
output$dt <- renderDataTable({
DT::datatable(filterData(df))
})
getwhich<-function(){
whichs<-which(df$var3 == df$var3)
if(!is.null(input$var1)){
whichs<-intersect(whichs,which(df$var1 %in% input$var1))
}
if(!is.null(input$var2)){
whichs<-intersect(whichs,which(df$var2 %in% input$var2))
}
if(!is.null(input$var3)){
whichs<-intersect(whichs,which(df$var3 %in% input$var3))
}
return(whichs)
}
observe({
w<-getwhich()
if(is.null(input$var1)){
updateSelectizeInput(session,"var1",choices=sort(unique(df$var1[w])))
}
})
observe({
w<-getwhich()
if(is.null(input$var2)){
updateSelectizeInput(session,"var2",choices=sort(unique(df$var2[w])))
}
})
observe({
w<-getwhich()
if(is.null(input$var3)){
updateSelectizeInput(session,"var3",choices=sort(unique(df$var3[w])))
}
})
})
Hope this helps.
I have an application which works fine locally and I would like to deploy it to shinyapps.io. I created a directory (dataviz) and the application code is in a file called app.R. When running deployApp("dataviz") from RStudio, it starts deploying but reaches a point where it fails with the error:
** preparing package for lazy loading
Error in loadNamespace(i, c(lib.loc, .libPaths()), versionCheck = vI[[i]]) :
there is no package called ‘htmltools’
ERROR: lazy loading failed for package ‘rcdimple’
* removing ‘/usr/local/lib/R/site-library/rcdimple’
################################### End Log ###################################
Error: Unhandled Exception: Child Task 27328802 failed: Error building image: Error building rcdimple (0.1). Build exited with non-zero status: 1
Not sure what could be happening here, any help greatly appreciated.
The app.R is as so
## app.R ##
library(shinydashboard)
library(shiny)
require(htmltools)
require(htmlwidgets)
library(rcdimple) #devtools::install_github("timelyportfolio/rcdimple")
library(curl) #devtools::install_github("jeroenooms/curl")
library(plyr) # for round_any
library(rCharts)
library(ggvis)
library(reshape2)
indicators <- read.csv(curl("https://raw.githubusercontent.com/kilimba/msc-impl-R/master/dataviz/data/testindicators.csv"))
choices <- as.vector(indicators$label)
indicators$label <- as.character(indicators$label)
indicators$file <- paste("",indicators$file,"",sep="")
getHeatMapData <- function(data,indicator){
df <- data
if(indicator$rate == "Y"){
hmap_df <- aggregate(cbind(denominator,numerator) ~ year + agegrp,df,sum)
hmap_df$rate <- round((hmap_df$numerator/hmap_df$denominator)*indicator$multiplier,2)
names(hmap_df)
}else{
hmap_df <- aggregate(denominator ~ agegrp + year,df, sum)
}
hmap_df$year <- factor(hmap_df$year)
# Helps to order the y-axis labels otherwise labels appear in mixed order
hmap_df$agegrp <- factor(hmap_df$agegrp, levels = rev(as.vector(unique(hmap_df$agegrp))))
return(hmap_df)
}
getData <- function(startyr,endyear,outcome_data) {
data <- subset(outcome_data,(year >= startyr & year <= endyear))
return(data)
}
getDataByAgeGroup <-function(data,agegrp){
d <- data
a <- agegrp
selection <- subset(d,agegrp==a)
return(selection)
}
lineChart <- function(data,agegrp,indicator){
if(indicator$rate == "Y"){
selection <- data
selection$rate <- round((selection$numerator/selection$denominator)*indicator$multiplier,2)
selection$sex <- ifelse(selection$sex == 1, "MALE", "FEMALE")
max_y <- round_any(max(selection$rate), 10, f = ceiling)
min_y <- round_any(min(selection$rate), 10, f = floor)
selection <- getDataByAgeGroup(selection,agegrp)
plot <- nPlot(rate ~ year,
data = selection,
type = "lineChart",
group = "sex",
height = 250,
width = 450 )
# Explicitly set year tick values for every year
plot$xAxis(tickValues = do.call(seq, c(as.list(range(selection$year)), 1)),rotateLabels= -40,showMaxMin = "true")
plot$chart(useInteractiveGuideline = "true", transitionDuration = 500)
plot$chart(forceY = c(min_y, max_y))
plot$chart(color = c("steelblue","firebrick"))
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = paste("Rate per",indicator$multiplier), width = 62)
plot$xAxis(axisLabel = "Year")
return(plot)
}else{
selection <- data
selection$sex <- ifelse(selection$sex == 1, "MALE", "FEMALE")
max_y <- round_any(max(selection$denominator), 10, f = ceiling)
min_y <- round_any(min(selection$denominator), 10, f = floor)
selection <- getDataByAgeGroup(selection,agegrp)
plot <- nPlot(denominator ~ year,
data = selection,
type = "lineChart",
group = "sex",
height = 250,
width = 450 )
# Explicitly set year tick values for every year
plot$xAxis(tickValues = do.call(seq, c(as.list(range(selection$year)), 1)),rotateLabels= -40,showMaxMin = "true")
plot$chart(useInteractiveGuideline = "true", transitionDuration = 500)
plot$chart(forceY = c(min_y, max_y))
plot$chart(color = c("steelblue","firebrick"))
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = "Population", width = 62)
plot$xAxis(axisLabel = "Year")
return(plot)
}
}
# Heat Map
heatmap <- function(data,indicator){
dat <- getHeatMapData(data,indicator)
if(indicator$rate == "Y"){
dat <- rename(dat, c("agegrp" = "Age","year" = "Year", "rate" = "Rate"))
dat %>%
ggvis(~Year, ~Age, fill = ~Rate) %>%
layer_rects(width = band(), height = band()) %>%
add_relative_scales() %>%
set_options(height = 200, width = 410, keep_aspect = TRUE) %>%
add_axis("y", title="")%>%
scale_nominal("x", padding = 0, points = FALSE) %>%
scale_nominal("y", padding = 0, points = FALSE) %>%
scale_numeric("fill",range = c("lightsteelblue","red")) %>%
hide_legend("fill") %>%
add_tooltip(function(d) {
if(is.null(d)) return(NULL)
paste0(names(d), ": ", format(d), collapse = "<br />")
}
) %>%
bind_shiny("heatmap")
}else{
dat <- rename(dat, c("agegrp" = "Age","year" = "Year", "denominator" = "Count"))
dat %>%
ggvis(~Year, ~Age, fill = ~Count) %>%
layer_rects(width = band(), height = band()) %>%
add_relative_scales() %>%
set_options(height = 200, width = 410, keep_aspect = TRUE) %>%
add_axis("y", title="")%>%
scale_nominal("x", padding = 0, points = FALSE) %>%
scale_nominal("y", padding = 0, points = FALSE) %>%
scale_numeric("fill",range = c("lightsteelblue","red")) %>%
hide_legend("fill") %>%
add_tooltip(function(d) {
if(is.null(d)) return(NULL)
paste0(names(d), ": ", format(d), collapse = "<br />")
}
) %>%
bind_shiny("heatmap")
}
}
# DimpleJS pyramid
dPyramid <- function(startyear, endyear, data, colors=c("steelblue","firebrick"),indicator) {
dat <- getData(startyear,endyear,data)
if(indicator$rate == "Y"){
dat$denominator <- ifelse(dat$sex == 1, -1 * dat$denominator, 1 * dat$denominator)
dat$Gender <- ifelse(dat$sex == 1,"Male", "Female")
dat$Rate <- (dat$numerator/dat$denominator)*indicator$multiplier
max_x <- round_any(max(dat$Rate), 10, f = ceiling)
min_x <- round_any(min(dat$Rate), 10, f = floor)
dat <- rename(dat, c("agegrp" = "Age"))
d1 <- dimple(
x = "Rate",
y = "Age",
groups = "Gender",
data = dat,
type = 'bar')
d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "Age")
d1 <- xAxis(d1,type = "addMeasureAxis")
# Ensure fixed x-axis independent of year selected
d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
if (!is.null(colors)){
d1 <- colorAxis(
d1,
type = "addColorAxis",
colorSeries = "sex",
palette = colors
)
}
# For storyboarding
if (endyear - startyear >= 1) {
d1 <- tack(d1, options = list( storyboard = "year" ) )
}
return(d1)
}
else{
dat$denominator <- ifelse(dat$sex == 1, -1 * dat$denominator, 1 * dat$denominator)
dat$Gender <- ifelse(dat$sex == 1,"Male", "Female")
max_x <- round_any(max(dat$denominator), 10, f = ceiling)
min_x <- round_any(min(-1*dat$denominator), 10, f = floor)
dat <- rename(dat,c("denominator" = "Count","agegrp" = "Age"))
d1 <- dimple(
x = "Count",
y = "Age",
groups = "Gender",
data = dat,
type = 'bar')
d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "Age")
d1 <- xAxis(d1,type = "addMeasureAxis")
# Ensure fixed x-axis independent of year selected
d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
if (!is.null(colors)){
d1 <- colorAxis(
d1,
type = "addColorAxis",
colorSeries = "sex",
palette = colors
)
}
# For storyboarding
if (endyear - startyear >= 1) {
d1 <- tack(d1, options = list( storyboard = "year" ) )
}
return(d1)
}
}
suppressMessages(
singleton(
addResourcePath(
get_lib("nvd3")$name
,get_lib("nvd3")$url
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "HealthData Viz"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Presentations", tabName = "widgets", icon = icon("file-powerpoint-o"))
),
tags$br(),
tags$fieldset(checkboxInput("doAnimate", "Animate Pyramid",value = TRUE),
tags$p("(Uncheck to select specific year)")),
conditionalPanel(
condition = "input.doAnimate == false",
uiOutput("choose_year")
),
uiOutput("choose_agegrp")
,
uiOutput("choose_dataset")
),
dashboardBody(
tags$head(get_assets_shiny(get_lib("nvd3"))[-3]),
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
box(dimpleOutput("distPlot", height = 250)),
box(showOutput("distPlot2","nvd3",add_lib=F))
),
fluidRow(
#box(infoBoxOutput("informationBox")),
infoBox("About", textOutput("caption"), icon = icon("info-circle"),width = 6),
(
#uiOutput("ggvis_ui"),
box(ggvisOutput("heatmap"))
)
)
),
# Second tab content
tabItem(tabName = "widgets",
h2("Links to interactive scientific presentations will go here...")
)
)
)
)
server <- function(input, output) {
output$choose_dataset <- renderUI({
selectInput("outcome", "Select Outcome", choices, selected="Population Structure",width="95%")
})
output$choose_agegrp <- renderUI({
selectInput("agegrp", "Select Age Group",
choices = c("00-04","05-09","10-14","15-19","20-24","25-29",
"30-34","35-39","40-44","45-49","50-54",
"55-59","60-64","65-69","70-74","75-79",
"80-84","85+"), selected="00-04",width="95%")
})
#############################################################
# PYRAMID
#############################################################
observe({
if(!is.null(input$outcome)){
selected_outcome <- input$outcome
selected_indicator <- subset(indicators,indicators$label == selected_outcome)
outcome_data <- reactive({
read.csv(curl(as.character(selected_indicator$file)))
})
d <- reactive({outcome_data()})
minYear <- reactive({min(d()$year)})
maxYear <- reactive({max(d()$year)})
observe({
if(input$doAnimate){
output$distPlot <- renderDimple({
dPyramid(minYear(), maxYear(),data = outcome_data(), indicator = selected_indicator)
})
}else{
years <- as.vector(unique(outcome_data()$year))
output$choose_year <- renderUI({
selectInput("startyr", "Select Pyramid Year", years, width="95%")
})
output$distPlot <- renderDimple({
if(!is.null(input$startyr)){
startyear <- as.numeric(input$startyr)
# Start year and end year are equal we only want cross-sectional pyramid
# for a single selected year
dPyramid(startyear, startyear, data = outcome_data(),indicator = selected_indicator)
}
})
}
})
}
})
###############################################
observe({
if(!is.null(input$outcome)
& !is.null(input$agegrp)){
selected_outcome <- input$outcome
selected_indicator <- subset(indicators,indicators$label == selected_outcome)
outcome_data <- reactive({
read.csv(curl(as.character(selected_indicator$file)))
})
d <- reactive({outcome_data()})
output$caption <- renderText({
return(paste("You are currently viewing",
ifelse(selected_indicator$rate=="N",paste(input$outcome,".\n",selected_indicator$description),
paste(input$outcome,"(per",selected_indicator$multiplier,"population).\n",selected_indicator$description))))
})
################################################
# Line chart
################################################
output$distPlot2 <- renderChart2({
lineChart(outcome_data(),input$agegrp,selected_indicator)
})
#################################################
# HEATMAP
#################################################
heatmap(outcome_data(),selected_indicator)
}
})
}
shinyApp(ui, server)
Tumaini
#timelyportfolio - It seems dependencies to htmltools was not listed in the DESCRIPTION file of the rcdimple package. Forked the package from https://github.com/timelyportfolio/rcdimple and added the dependencies to the DESCRIPTION file (https://github.com/kilimba/rcdimple). Can now deploy a shiny app which uses the rcdimple package to shinayapps.io. Have made a Pull Request to master branch