Please see attached image. Do you have suggestions how to avoid that the plot is outside the white area, or to make the grey area below the plot white?
ui <- dashboardPage(
# Application title
dashboardHeader(title=h4(HTML("Virus Coverage plot"))),
dashboardSidebar(
useShinyjs(),
selectInput("Taxa", "Taxa", choices = unique(files.Vir.DNA.df.test$V1))
),
dashboardBody(
tabsetPanel(
tabPanel("Taxa", plotOutput("myplot1"))
)
)
)
server <- function(input, output, session) {
data_selected <- reactive({
filter(files.Vir.DNA.df.test, V1 %in% input$Taxa)
})
output$myplot1 <- renderPlot({
#data_selected() %>%
# filter(Cancer=="Anus" | Cancer=="Cervix") %>%
p <- ggplot(data_selected(),aes(position,rowSums, fill = V1)) +
#theme_bw(base_size = 6) +
geom_bar(stat="identity") +
facet_grid(Cancer~. , scales = "free_x", space = "free_x", switch = "x") +
theme(strip.text.y = element_text(angle = 0),
strip.text.x = element_text(angle = 90),
strip.background = element_rect(colour = "transparent", fill = "transparent"),
plot.background = element_rect(colour = "white", fill = "white"),
panel.background = element_rect(colour = "white", fill = "white"),
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(y="Sum coverage within cancer type", x="", title="") +
scale_fill_manual(values=mycolors) +
theme(legend.position = "none")
#scale_y_log10()
print(p)
},res = 100,width = 600, height = 1200)
}
shinyApp(ui, server)
Your example isn't reproducible - so I made a new one.
You just need to wrap the plotOutput in a fluidRow:
library(shiny)
library(ggplot2)
library(datasets)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
# dashboardBody(plotOutput("myplot")) # exceeds body
dashboardBody(fluidRow(plotOutput("myplot"))) # works
)
server <- function(input, output, session) {
output$myplot <- renderPlot({
scatter <- ggplot(data=iris, aes(x = Sepal.Length, y = Sepal.Width))
scatter + geom_point(aes(color=Species, shape=Species)) +
xlab("Sepal Length") + ylab("Sepal Width") +
ggtitle("Sepal Length-Width")
}, height = 1200)
}
shinyApp(ui, server)
Related
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 want to fetch user choice from selectInput and store it as a string to be use as filename to save a plot. If user change selectInput choice, the string variable should also update to reflect change.
Here are my code so far and the xxx variable obviously is not a string. Can anyone assist?
pacman::p_load(dplyr, tidyverse, reshape, ggplot2, shiny, shinydashboard)
mtcars_colName <- colnames(mtcars)
x_coord <- mtcars_colName[c(1:2)]
y_coord <- mtcars_colName[c(3:7)]
#Put plots on shiny ui
ui <- dashboardPage(
dashboardHeader(title = 'mtcars data'),
dashboardSidebar(
sidebarMenu(
menuItem("mtcars data comparison", tabName = 'mtcars_data_comparison', icon = icon('dragon'))
)
),
dashboardBody(
tabItems(
tabItem('mtcars_data_comparison',
fluidPage(
downloadButton("downloadPlot", "Download mtcars plot"),
box(plotOutput('metrics_plot'), width = 8, height = '100%'),
box(selectInput('y_metrics', 'mtcars y-axis', choices = y_coord), width = 4),
box(selectInput('x_metrics', 'mtcars x-axis', choices = x_coord), width = 4)
),
)
)
)
)
server <- function(input, output, session){
mtcars_plot <- reactive({ggplot(mtcars, aes_string(x=input$x_metrics, y=input$y_metrics)) +
geom_jitter(width =0.05) +
scale_y_continuous(labels = scales::comma) +
theme(
axis.text.x = element_blank(),
axis.line = element_line(),
axis.ticks.x = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
panel.background = element_blank())
})
output$metrics_plot <- renderPlot({
mtcars_plot()
})
rv <- reactiveValues(value_store = character())
observeEvent(input$y_metrics, {
rv$value_store <- input$y_metrics
})
output$download10XPlot <- downloadHandler(
file = paste(rv$value_store, '.pdf', sep=''),
content = function(file) {
sep <- switch(input$filetype, "csv" = ",", "tsv" = "\t")
# pdf(file = file, width = 11, height = 8.5)
pdf(file, sep = sep)
print(TenX_plot())
dev.off()}
)
}
shinyApp(ui, server)
We can try
output$download10XPlot <- downloadHandler(
file = function() {paste(isolate(input$y_seq_metrics), '.pdf', sep='')},
content = function(file) {
pdf(file = file, width = 11, height = 8.5)
print(TenX_plot())
dev.off()}
)
So a plotly plot has an embedded rangeslider however I do not like the looks of it. The rangeslider in R Shiny looks much better and professional, however how do i connect the two?
Lets say you have a dataframe with some values and a daterange like:
library(lubridate)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
Code for the plotly plot
library(plotly)
plot_df <- plot_ly(df)
plot_df <- plot_df %>% add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
Code Shiny
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = tail(df$Date, 1)
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
plot_df
})
}
shinyApp(ui, server)
We can use dplyr::filter and pipe it to plot_ly().
output$plotdf<-renderPlotly({
filter(df, Date <= input$Date) %>%
plot_ly() %>%
add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
})
Edit: Below is the plot code separated from the app with a sliderInput to select a range of dates.
library(shiny)
library(dplyr)
library(lubridate)
library(plotly)
source(file = 'my_functions_script.R', local = TRUE)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
shiny::sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = c(df$Date[1],tail(df$Date, 1))
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
filter(df,Date >= input$Date[[1]], Date <= input$Date[[2]]) %>%
plt()
})
}
shinyApp(ui, server)
Can we add a small icon next to values in DT table. Example
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
fluidRow(column(width = 12),
fluidRow(box(width = 4, dateInput("date","Date", value = Sys.time(), min = Sys.time(), max = Sys.time()-30)),
box(width = 7, selectInput("df","DF",choices = unique(iris$Species)),offset = 0),
box(width = 2, actionButton("ab","Action")))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
IN the above DT table, can we add upward arrow next to Setosa . (It should be clickable)
Expect Output
You could use icon to display an up arrow.
library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
ui <- fluidPage(
tags$h3("Material switch examples"),
dataTableOutput("df")
)
server <- function(input, output) {
data <- head(iris) %>% mutate(Species = paste(Species,as.character(icon("arrow-up", lib = "glyphicon"))))
output$df <- DT::renderDataTable({
datatable(data,caption = "Iris",options = list(dom = 'ft'),escape=FALSE, selection = list(mode = 'single',target = 'cell'))
})
}
shinyApp(ui, server)
Is it possible to select/get only the input names of the widgets that have changed? Say that I have a Shiny App and that I deselect a box of a checkboxGroupInput. Is it possible to somehow get the inputId of that widget?
Here is a solution using basic shiny:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins1",
"Number of bins 1:",
min = 1,
max = 50,
value = 30),
sliderInput("bins2",
"Number of bins 2:",
min = 1,
max = 50,
value = 30),
textOutput("printChangedInputs")
),
mainPanel(
plotOutput("distPlot1"),
plotOutput("distPlot2")
)
)
)
server <- function(input, output) {
output$distPlot1 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins1 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
previousInputStatus <- NULL
changedInputs <- reactive({
currentInputStatus <- unlist(reactiveValuesToList(input))
if(is.null(previousInputStatus)){
previousInputStatus <<- currentInputStatus
changedInputs <- NULL
} else {
changedInputs <- names(previousInputStatus)[previousInputStatus != currentInputStatus]
print(paste("Changed inputs:", changedInputs))
previousInputStatus <<- currentInputStatus
}
return(changedInputs)
})
output$printChangedInputs <- renderText({paste("Changed inputs:", changedInputs())})
}
shinyApp(ui = ui, server = server)
Edit: Another way would be to listen for the JavaScript event shiny:inputchanged:
library(shiny)
ui <- fluidPage(
tags$head(
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name != 'changed') {
Shiny.setInputValue('changed', event.name);
}
});"
)
),
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins1",
"Number of bins 1:",
min = 1,
max = 50,
value = 30),
sliderInput("bins2",
"Number of bins 2:",
min = 1,
max = 50,
value = 30),
textOutput("changedInputs")
),
mainPanel(
plotOutput("distPlot1"),
plotOutput("distPlot2")
)
)
)
server <- function(input, output) {
output$distPlot1 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins1 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$changedInputs <- renderText({paste("Changed inputs:", input$changed)})
}
shinyApp(ui = ui, server = server)
Please see this for more information.