I'm building a shiny app where I can manipulate a histogram of the diamonds dataset by changing the input to be displayed which works fine. I now want to be able to change the colours of the plot to reflect the cut, clarity and color of the diamonds data.
Code to build app
#Data preparation
library(shiny)
library(tidyverse)
library(ggplot2)
diamonds_data <- as_tibble(diamonds) %>%
rename_all(stringr::str_to_title)
#App design
ui <- fluidPage(
#App title
titlePanel("Histogram version"),
#Sidebar layout for main and sidebar panel
sidebarLayout(
# Sidebar panel for inputs
sidebarPanel(
#Selecting histogram colour
selectInput(inputId="color1",label="Choose Color",choices = c("Color"="Color","Carat"="Carat","Clarity"="Clarity"),
selected = "Cut",multiple = F),
#Selecting Histogram input
selectInput(inputId="channel1",label="Distribution of data",choices = c("Carat"="Carat",
"Depth"="Depth",
"Table"="Table",
"Price"="Price",
"X"="X",
"Y"="Y",
"Z"="Z"),
selected = "Carat",multiple = F),
#Selecting number of histogram bind
sliderInput(inputId = "NOofBins",
label = "Number of bins:",
min = 1,
max = 50,
value = 30),
),
#Main panel for outputs
mainPanel(
#Histogram
plotOutput(outputId = "distPlot")
)
)
)
server <- function(input, output){
output$distPlot <- renderPlot({
if(input$color1=="Clarity"){
Color = "Clarity"
}else if(input$color1=="Cut"){
Color = "Cut"
}else if(input$color1=="Color"){
Color = "Color"
}
my_plot <- diamonds_data %>% ggplot()
if(input$channel1 == "Carat"){
my_plot <- my_plot + geom_histogram(aes(x=Carat),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "Depth"){
my_plot <- my_plot + geom_histogram(aes(x=Depth),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "Table"){
my_plot <- my_plot + geom_histogram(aes(x=Table),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "Price"){
my_plot <- my_plot + geom_histogram(aes(x=Price),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "X"){
my_plot <- my_plot + geom_histogram(aes(x=X),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "Y"){
my_plot <- my_plot + geom_histogram(aes(x=Y),bins = input$NOofBins,fill=Color)
}else if(input$channel1 == "Z"){
my_plot <- my_plot + geom_histogram(aes(x=Z),bins = input$NOofBins,fill=Color)
}
my_plot <- my_plot + theme_bw()+
theme(axis.title = element_text(size=26,color="Grey",face="bold"),
axis.text = element_text(size=12,color="Grey",face="bold"))+
labs(x="Diamonds Element",y="Count",title=paste("Distribution of diamonds data",input$channel1,sep = " "))
my_plot
})
}
shinyApp(ui = ui, server = server)
As mentioned I want to be able to alter the input of the histogram where I can change the colours based on the cut, clarity or color as can be seen with the code below:
ggplot(data = diamonds_data, aes(x = Price)) +
geom_histogram(aes(fill = Cut))
When I use my app script I get the warning >Unknown colour name: Color
You can use the .data argument of ggplot which accepts strings as inputs and so significantly simplify your code:
my_plot <- diamonds_data %>%
ggplot() +
geom_histogram(aes(x = .data[[input$channel1]], fill = .data[[input$color1]]), bins = input$NOofBins) +
theme_bw()+
theme(axis.title = element_text(size=26,color="Grey",face="bold"),
axis.text = element_text(size=12,color="Grey",face="bold"))+
labs(x="Diamonds Element",y="Count",title=paste("Distribution of diamonds data",input$channel1,sep = " "))
Related
When I run this code with renderPlotly. It gives me error but without renderplotly it is working fine. Can you help me in fixing this code with renderPlotly? Thanks in advance.
output$tot_finalized_claims1 <- renderPlotly({
req(input$yearSelectInput)
#filter df to be used in graph
claims1 <- newly_formatted_logResults %>% filter(YEAR == input$yearSelectInput) %>% filter(PEND == "CMI") %>% select(YEAR,MONTH_NUM,PEND, TOTAL_FINALIZE,TOTAL)
data_pcode <- summarize(group_by(claims1,MONTH_NUM), actual_auto = round(sum(as.numeric(TOTAL_FINALIZE),na.rm = TRUE)/sum(as.numeric(TOTAL),na.rm = TRUE),digits = 2))
data_pcode <- data.frame(data_pcode)
ggplot(data = data_pcode,aes(x = MONTH_NUM, y = actual_auto )) +
geom_point() + geom_line() + # add the points and lines
stat_QC(method = "XmR" # specify QC charting method
auto.label = T, # Use Autolabels
label.digits = 2, # Use two digit in the label
show.1n2.sigma = T # Show 1 and two sigma lines
)+
labs(x = "Months",y = "Automation Rate",title = paste("Actual automations by CMI Pend code"))+
geom_text(aes(label=paste(actual_auto ,"%")), position=position_dodge(width=0.95), vjust=-0.5)+
scale_x_continuous(breaks = 1:12,labels = c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"))+
scale_y_continuous(breaks = seq(0.0, 1.0, 0.1))
}) #end tot finalized plot summary
Apart from the fact that you didn't even use the plotly function to create the plot, if you want to generate plotly output you must remember two things:
In server section renderPlotly instead of renderPlot
In UI section plotlyOutput instead of plotOutput
You can try this code to see how it works:
library(shiny)
library(ggplot2)
library(ggthemes)
library(plotly)
ui <- fluidPage(
titlePanel("Plotly"),
sidebarLayout(
sidebarPanel(),
mainPanel(
plotlyOutput("plot2"))
))
server <- function(input, output) {
output$plot2 <- renderPlotly({
ggplotly(
ggplot(data = mtcars, aes(x = disp, y = cyl)) +
geom_smooth(method = lm, formula = y~x) +
geom_point() +
theme_gdocs())
})
}
shinyApp(ui, server)
Hello is there a way to display the data labels only for specific data of my dataset? I used key instead of label in order to create the tooltip but I cannot make it work. As a final result I want to be able to display labels of my choice as now and also have some data labels always displayed.
library(shiny)
library(plotly)
library(ggplot2)
ui <- fluidPage(
plotlyOutput("iris")
)
server <- function(input, output, session) {
output$iris <- renderPlotly({
# set up plot
p1 <- ggplot(iris, aes_string(x = "Sepal.Length",
y = "Sepal.Width",
key = "Species")) +
geom_point()+
geom_text(data=subset(iris, Sepal.Lenth > 6),
aes(Sepal.Length,Sepal.Width,label=Species))
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# if a point has been clicked, add a label to the plot
if(!is.null(click_data)) {
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
p1 <- p1 +
geom_text(data = label_data,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 0.25)
}
# return the plot
ggplotly(p1, source = "select", tooltip = c("key"))
})
}
shinyApp(ui, server)
A possible solution is:
library(shiny)
library(plotly)
library(ggplot2)
p1 <- ggplot(iris, aes_string(x = "Sepal.Length",
y = "Sepal.Width",
text = "Species")) +
geom_point() +
geom_text(data=subset(iris, Sepal.Length > 6),
aes(Sepal.Length,Sepal.Width,label=Species))
ui <- fluidPage(
plotlyOutput("iris")
)
server <- function(input, output, session) {
output$iris <- renderPlotly({
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# if a point has been clicked, add a label to the plot
if(!is.null(click_data)) {
pos <- click_data$pointNumber+1
label_data <- data.frame(x = iris$Sepal.Length[pos],
y = iris$Sepal.Width[pos],
label = iris$Species[pos],
stringsAsFactors = FALSE)
p1 <<- p1 +
geom_text(data = label_data,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_y=.1)
}
# return the plot
ggplotly(p1, source = "select", tooltip = c("text"))
})
}
shinyApp(ui, server)
I have the following shiny app:
library(shiny)
library(ggplot2)
library(dplyr)
library(networkD3)
library(ggmosaic)
#Loading data
Category <- c("Bankpass", "Bankpass", "Bankpass", "Moving", "Moving")
Subcategory <- c("Stolen", "Lost", "Login", "Address", "New contract")
Weight <- c(10,20,13,40,20)
Duration <- as.character(c(0.2,0.4,0.5,0.44,0.66))
Silence <- as.character(c(0.1,0.3,0.25,0.74,0.26))
df <- data.frame(Category, Subcategory, Weight, Duration, Silence)
ui <- fluidPage(
tags$div(class="header",
selectInput("measure", "", c("Duration", "Silence"))
),
mainPanel(
tags$div(class = "dashboard_main",
tags$div(class="dashboard_main_left", plotOutput("secondPlot"))
)
)
)
server <- function(input, output){
output$secondPlot <- renderPlot({
ggplot(data = df) +
geom_mosaic(aes(weight = Weight, x = product(Category), fill=Duration),
offset = 0, na.rm=TRUE) +
theme(axis.text.x=element_text(angle=-25, hjust= .1)) +
theme(axis.title.x=element_blank()) +
scale_fill_manual(values=c("#e8f5e9", "#c8e6c9", "#a5d6a7", "#81c784", "#66bb6a"))
})
}
shinyApp(ui = ui, server= server)
I would like to make the second plot interactive now. So if you select the Duration the fill in the plot "secondPlot" should be Duration and if you you select "Silence" the fill should be "Silence".
However when I change the relevante code of the graph to:
ggplot(data = df) +
geom_mosaic(aes(weight = Weight, x = product(Category), fill=input$measure),
offset = 0, na.rm=TRUE) +
theme(axis.text.x=element_text(angle=-25, hjust= .1)) +
theme(axis.title.x=element_blank())
I dont see the colour gradients anymore. Any thoughts on what goes wrong here?
You should use aes_string inside geom_mosaic. Try this:
server <- function(input, output){
df$prodcat <- product(df$Category)
output$secondPlot <- renderPlot({
ggplot(data = df) +
geom_mosaic(aes_string(weight = "Weight", x = "prodcat", fill=input$measure),
offset = 0, na.rm=TRUE) +
theme(axis.text.x=element_text(angle=-25, hjust= .1)) +
theme(axis.title.x=element_blank()) +
scale_fill_manual(values=c("#e8f5e9", "#c8e6c9", "#a5d6a7", "#81c784", "#66bb6a"))
})
}
I'm working on a little shiny app that requests stock data from Yahoo. If one clicks on the plot, the respective price / datetime row from the dataset shall be shown. But unfortunately it seems that input$plot_click does not return the correct x,y - values.
Here's the mwe:
library(shiny)
library(htmlwidgets)
library(ggplot2)
library(scales)
library(dplyr)
library(RCurl)
library(XML)
library(rvest)
server <- function(input, output, session) {
Sys.setlocale("LC_TIME", "C")
dataset <- data.frame()
xml.url <- "http://query.yahooapis.com/v1/public/yql?q=select%20*%20from%20yahoo.finance.quote%20where%20symbol%20in%20(%22YHOO%22%2C%22AAPL%22%2C%22GOOG%22%2C%22MSFT%22)&diagnostics=true&env=store%3A%2F%2Fdatatables.org%2Falltableswithkeys"
YahooObs <- function(xml.url){
script <- getURL(xml.url)
doc <- xmlParse(script)
results <- doc %>% xml_nodes("results")
dataset <- lapply(results, FUN=function(x){xmlToDataFrame(x, stringsAsFactors = F)})[[1]]
dataset$LastTradePriceOnly <- as.numeric(dataset$LastTradePriceOnly)
created <- doc %>% xml_node("query") %>% xml_attr("created")
dataset$created <- as.POSIXct(strptime(created, format="%Y-%m-%dT%H:%M:%SZ", tz="UTC")+3600)
return(dataset)
}
output$newsplot <- renderPlot({
invalidateLater(10000, session)
dataset <<- rbind(dataset, YahooObs(xml.url))
p <- ggplot(data = dataset)
p <- p + layer(mapping=aes(x=created, y=LastTradePriceOnly, color= Symbol),
geom="point", stat="identity", position="identity")
limit_down <- as.POSIXct(Sys.time()-input$timeslider*60)
attributes(limit_down)$tzone <- input$timezone
limit_up <- as.POSIXct(Sys.time())
attributes(limit_up)$tzone <- input$timezone
p <- p + scale_x_datetime(breaks = date_breaks("200 sec"), labels = date_format("%H:%M:%S"),
limits=c(min(dataset$created-1800), max(dataset$created))) +
theme(axis.text.x = element_text(angle = 90), panel.grid.major=element_blank(), panel.grid.minor=element_blank(),
panel.background = element_blank()) + coord_cartesian()
print(p)
})
output$plot_click <- renderPrint({
paste(str(input$plot_click))
})
output$newstable <- renderDataTable({
##Transforming the created column to numeric was a hint on stackoverflow but it didn't work out
#dataset$created <- as.numeric(dataset$created)
nearPoints(dataset, input$plot_click, xvar="created",yvar="LastTradeDatePrice", threshold = 100, maxpoints = 10,
addDist = TRUE)
})} #the server
ui_2 <- shinyUI(fluidPage(
#header
titlePanel(tags$h1("Share Prices")),
#horizontal line
sidebarLayout(
sidebarPanel(
sliderInput("timeslider", label = "Choose Timespan in minutes", min = 1, max = 60, value = 30, step = 1),
width=3
),
mainPanel(
tabsetPanel(type="tabs",
tabPanel("News Plot", plotOutput("newsplot", click="plot_click"),dataTableOutput("newstable"), textOutput("plot_click")),
tabPanel("Settings", selectInput("timezone", label="Choose your Timezone", choices=c("UTC")))
)
)
)))# the user interface
shinyApp(ui = ui_2, server = server) # this launches your app
Any idea?
It seems that print(p) manipulates something. Using only p solves the problem and shows the POSIXct values correctly as numeric.
p <- ggplot(data = dataset)
p <- p + layer(mapping=aes(x=created, y=LastTradePriceOnly, color= Symbol),
geom="point", stat="identity", position="identity")limit_down <- as.POSIXct(Sys.time()-input$timeslider*60)
attributes(limit_down)$tzone <- input$timezone
limit_up <- as.POSIXct(Sys.time())
attributes(limit_up)$tzone <- input$timezone
p <- p + scale_x_datetime(breaks = date_breaks("200 sec"), labels = date_format("%H:%M:%S"),
limits=c(min(dataset$created-1800), max(dataset$created))) +
theme(axis.text.x = element_text(angle = 90), panel.grid.major=element_blank(), panel.grid.minor=element_blank(),
panel.background = element_blank()) + coord_cartesian()
p
works.
I am trying to display a map and a plot here in a tab interface using Shiny package in R. Inspite of setting the environment by calling the environment(), I am getting this error. The code snippet is given below:
server.R :
shinyServer(function(input, output, session) {
output$box <- renderPlot({
filtered<- aleast.scores[aleast.scores$team == input$typeInput , ]
ggplot(data=filtered) +
geom_bar(mapping=aes(x=score, fill=team), binwidth=1) +
#facet_grid(team~.) +
theme_bw() + scale_color_brewer() +
labs(title="MOBILE PHONE REVIEW")
})
output$map <- renderPlot({
long <-locations_f$longitude
lat <- locations_f$latitude
worldMap <- map_data("world")
zp1 <- ggplot(worldMap,environment=environment())
zp1 <- zp1 + geom_path(aes(x = long, y = lat, group=group), #Draw map
colour = gray(2/3), lwd = 1/3)
filtered<- locations_f[locations_f$team == input$typeInput , ]
zp1 <- zp1 + geom_point(data = filtered, #Add points indicating users
aes(x = long, y = lat, color=type),
alpha = 1, size = 1.5)#+facet_grid(team~.)# +
zp1<-zp1+theme_bw() # + scale_color_brewer()
zp1 <- zp1 + theme_minimal()
print(zp1)
})
})
UI.R
library(shiny)
# Define UI for random distribution application
shinyUI(fluidPage(
# Application title
titlePanel("Tabsets"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
radioButtons("typeInput", "Product type",
choices = c("motorola","nexus","iphone")),
br()
),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("plot", plotOutput("box")),
tabPanel("Map", plotOutput("map"))
)
)
)
))
And This is the error I am getting
Warning: Error in exists: argument "env" is missing, with no default
Stack trace (innermost first):
68: output$box
1: shiny::runApp
Also the program worked fine when the first graph (MOBILE PHONE REVIEW) was alone plotted without any tab interface
You did not provide a reproducible example, so I made up some data, and the app ran fine. Try updating your packages.
I made some changes:
replaced geom_bar with geom_histogram to deal with the Warning: 'geom_bar() no longer has a 'binwidth' parameter. Please use 'geom_histogram()' instead.
replaced long and lat in geom_point(data = filtered, aes(x = longitude, y = latitude, color=type), alpha = 1, size = 1.5) since you want the colours to be from the filtered data
server.R
aleast.scores <- data.frame(score = runif(100, min = 0, max = 10), team = sample(c("motorola","nexus","iphone"), 100, replace = TRUE))
locations_f <- data.frame(latitude = runif(100, min = -35, max = 35), longitude = runif(100, min = -120, max = 150), team = sample(c("motorola","nexus","iphone"), 100, replace = TRUE), type = sample(c("good phone", "crap phone"), 100, replace = TRUE))
library(ggplot2)
shinyServer(function(input, output, session) {
output$box <- renderPlot({
filtered<- aleast.scores[aleast.scores$team == input$typeInput , ]
ggplot(data=filtered) +
geom_histogram(mapping=aes(x=score, fill=team), binwidth=1) +
#facet_grid(team~.) +
theme_bw() + scale_color_brewer() +
labs(title="MOBILE PHONE REVIEW")
})
output$map <- renderPlot({
long <-locations_f$longitude
lat <- locations_f$latitude
worldMap <- map_data("world")
zp1 <- ggplot(worldMap,environment=environment())
zp1 <- zp1 + geom_path(aes(x = long, y = lat, group=group), #Draw map
colour = gray(2/3), lwd = 1/3)
filtered<- locations_f[locations_f$team == input$typeInput , ]
zp1 <- zp1 + geom_point(data = filtered, #Add points indicating users
aes(x = longitude, y = latitude, color=type),
alpha = 1, size = 1.5)#+facet_grid(team~.)# +
zp1<-zp1+theme_bw() # + scale_color_brewer()
zp1 <- zp1 + theme_minimal()
print(zp1)
})
})
ui.R
shinyUI(fluidPage(
# Application title
titlePanel("Tabsets"),
# Sidebar with controls to select the random distribution type
# and number of observations to generate. Note the use of the
# br() element to introduce extra vertical spacing
sidebarLayout(
sidebarPanel(
radioButtons("typeInput", "Product type",
choices = c("motorola","nexus","iphone")),
br()
),
# Show a tabset that includes a plot, summary, and table view
# of the generated distribution
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("plot", plotOutput("box")),
tabPanel("Map", plotOutput("map"))
)
)
)
))