ggplot2 - Show multiple keys (shapes) in size legend - r

I have an issue related to displaying legends. I am not even sure it is something I can solve with ggplot, but since I am quite a basic user of R, I am confident it is just my ignorance to speak for me.
The Setting
I am trying to plot two distinct sets of points from two distinct dataset, over the same sets of aesthetics: x, y, size. The two sets of points change in the vertical nudge with respect to the y axis, and with respect to their shape.
The issue
The plot comes out as expected (see image below the code). The only thing I have not been able to fix is related to the legends. In particular, I would like to have the size legend to display both the shapes I am using in the chart (in this case, both circles and triangles). Is there any way to do so? I browsed a bit in the internet, but I did not find any question dealing with this issue.
Data and Code
Here I put the data I am using as a reproducible example (obtained with dput()).
# Packages
library(tidyverse)
library(ggtext)
library(janitor)
library(delabj)
library(wesanderson)
library(forcats)
# Basic data
basedata<-structure(list(country = structure(c("Argentina", "Argentina",
"Argentina", "Argentina", "Argentina", "Argentina", "Argentina",
"Argentina", "Argentina", "Argentina", "Argentina", "Argentina",
"Argentina", "Argentina"), format.stata = "%44s"), iso = structure(c("ARG",
"ARG", "ARG", "ARG", "ARG", "ARG", "ARG", "ARG", "ARG", "ARG",
"ARG", "ARG", "ARG", "ARG"), label = "iso_3", format.stata = "%9s"),
region = structure(c("Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean"), label = "Region", format.stata = "%26s"),
income_group = structure(c("Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income"
), label = "Income group", format.stata = "%19s"), gdp = structure(c(519871519807.795,
519871519807.795, 519871519807.795, 519871519807.795, 519871519807.795,
519871519807.795, 519871519807.795, 519871519807.795, 519871519807.795,
519871519807.795, 519871519807.795, 519871519807.795, 519871519807.795,
519871519807.795), label = "(first) gdp_o", format.stata = "%9.0g"),
assessment = structure(c(2, 2, 1, 1, 2, 1, 2, 1, 1, 1, 1,
1, 2, 1), label = "Initial assessment", format.stata = "%12.0g", labels = c(liberalising = 1,
restrictive = 2)), start_date = structure(c(18341, 18349,
18354, 18366, 18393, 18393, 18270, 18270, 18339, 18354, 18354,
18393, 18393, 18351), label = "Announcement date", class = "Date", format.stata = "%td"),
duration = structure(c(357, 349, 344, 63, 33, 305, 156, 156,
87, 62, 344, 305, 33, 359), format.stata = "%9.0g"), GTAinterventiontype = structure(c("Export licensing requirement",
"Export licensing requirement", "Import Internal taxation",
"Import Internal taxation", "Import Internal taxation", "Import Internal taxation",
"Import licensing requirement", "Import licensing requirement",
"Import licensing requirement", "Import licensing requirement",
"Import tariff", "Import tariff", "Import tariff", "Import-related, Unknown measure"
), label = "GTA intervention type", format.stata = "%38s"),
any_food = structure(c(0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
0, 0), label = "Product: Food", format.stata = "%8.0g", labels = c(`FALSE` = 0,
`TRUE` = 1)), any_medical = structure(c(1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1), label = "Product: Any medical product", format.stata = "%8.0g", labels = c(`FALSE` = 0,
`TRUE` = 1)), food_position = structure(c("Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter", "Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter", "Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter", "Net Exporter",
"Net Exporter"), format.stata = "%12s"), meds_position = structure(c("Net Importer",
"Net Importer", "Net Importer", "Net Importer", "Net Importer",
"Net Importer", "Net Importer", "Net Importer", "Net Importer",
"Net Importer", "Net Importer", "Net Importer", "Net Importer",
"Net Importer"), format.stata = "%12s"), month = c(3, 3,
4, 4, 5, 5, 1, 1, 3, 4, 4, 5, 5, 3), Announcement = c("March",
"March", "April", "April", "May", "May", "January", "January",
"March", "April", "April", "May", "May", "March"), Domain = c("Medical",
"Medical", "Medical", "Medical", "Medical", "Medical", "Food & Meds",
"Food & Meds", "Medical", "Medical", "Medical", "Medical",
"Medical", "Medical"), gdp_group_avg = c("Low Income", "Low Income",
"Low Income", "Low Income", "Low Income", "Low Income", "Low Income",
"Low Income", "Low Income", "Low Income", "Low Income", "Low Income",
"Low Income", "Low Income"), gdp_group_med = c("High Income",
"High Income", "High Income", "High Income", "High Income",
"High Income", "High Income", "High Income", "High Income",
"High Income", "High Income", "High Income", "High Income",
"High Income"), shp_point = c(23, 23, 21, 21, 23, 21, 23,
21, 21, 21, 21, 21, 23, 21), length_cat = c("More than 3 months",
"More than 3 months", "More than 3 months", "[1-3] months",
"[1-3] months", "More than 3 months", "More than 3 months",
"More than 3 months", "[1-3] months", "[1-3] months", "More than 3 months",
"More than 3 months", "[1-3] months", "More than 3 months"
), type = structure(c(2L, 2L, 1L, 1L, 2L, 1L, 2L, 1L, 1L,
1L, 1L, 1L, 2L, 1L), .Label = c("Liberalizig", "Restrictive"
), class = "factor")), row.names = c(NA, -14L), class = "data.frame")
# Subset 1 - assessment == 1
prova1<-structure(list(country = c("Argentina", "Argentina", "Argentina",
"Argentina", "Argentina", "Argentina", "Argentina", "Argentina",
"Argentina"), iso = c("ARG", "ARG", "ARG", "ARG", "ARG", "ARG",
"ARG", "ARG", "ARG"), region = c("Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean"), income_group = c("Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income"), gdp = c(519871519807.795,
519871519807.795, 519871519807.795, 519871519807.795, 519871519807.795,
519871519807.795, 519871519807.795, 519871519807.795, 519871519807.795
), assessment = c(1, 1, 1, 1, 1, 1, 1, 1, 1), start_date = structure(c(18354,
18366, 18393, 18270, 18339, 18354, 18354, 18393, 18351), class = "Date"),
duration = c(344, 63, 305, 156, 87, 62, 344, 305, 359), GTAinterventiontype = c("Import Internal taxation",
"Import Internal taxation", "Import Internal taxation", "Import licensing requirement",
"Import licensing requirement", "Import licensing requirement",
"Import tariff", "Import tariff", "Import-related, Unknown measure"
), any_food = c(0, 0, 0, 1, 0, 0, 0, 0, 0), any_medical = c(1,
1, 1, 1, 1, 1, 1, 1, 1), food_position = c("Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter", "Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter", "Net Exporter"
), meds_position = c("Net Importer", "Net Importer", "Net Importer",
"Net Importer", "Net Importer", "Net Importer", "Net Importer",
"Net Importer", "Net Importer"), month = c(4, 4, 5, 1, 3,
4, 4, 5, 3), Announcement = c("April", "April", "May", "January",
"March", "April", "April", "May", "March"), Domain = c("Medical",
"Medical", "Medical", "Food & Meds", "Medical", "Medical",
"Medical", "Medical", "Medical"), gdp_group_avg = c("Low Income",
"Low Income", "Low Income", "Low Income", "Low Income", "Low Income",
"Low Income", "Low Income", "Low Income"), gdp_group_med = c("High Income",
"High Income", "High Income", "High Income", "High Income",
"High Income", "High Income", "High Income", "High Income"
), shp_point = c(21, 21, 21, 21, 21, 21, 21, 21, 21), length_cat = c("More than 3 months",
"[1-3] months", "More than 3 months", "More than 3 months",
"[1-3] months", "[1-3] months", "More than 3 months", "More than 3 months",
"More than 3 months"), type = structure(c(1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L), .Label = c("Liberalizig", "Restrictive"
), class = "factor")), row.names = c(3L, 4L, 6L, 8L, 9L,
10L, 11L, 12L, 14L), class = "data.frame")
# Subset 2 - assessment == 2
prova2<-structure(list(country = c("Argentina", "Argentina", "Argentina",
"Argentina", "Argentina"), iso = c("ARG", "ARG", "ARG", "ARG",
"ARG"), region = c("Latin America & Caribbean", "Latin America & Caribbean",
"Latin America & Caribbean", "Latin America & Caribbean", "Latin America & Caribbean"
), income_group = c("Upper middle income", "Upper middle income",
"Upper middle income", "Upper middle income", "Upper middle income"
), gdp = c(519871519807.795, 519871519807.795, 519871519807.795,
519871519807.795, 519871519807.795), assessment = c(2, 2, 2,
2, 2), start_date = structure(c(18341, 18349, 18393, 18270, 18393
), class = "Date"), duration = c(357, 349, 33, 156, 33), GTAinterventiontype = c("Export licensing requirement",
"Export licensing requirement", "Import Internal taxation", "Import licensing requirement",
"Import tariff"), any_food = c(0, 0, 0, 1, 0), any_medical = c(1,
1, 1, 1, 1), food_position = c("Net Exporter", "Net Exporter",
"Net Exporter", "Net Exporter", "Net Exporter"), meds_position = c("Net Importer",
"Net Importer", "Net Importer", "Net Importer", "Net Importer"
), month = c(3, 3, 5, 1, 5), Announcement = c("March", "March",
"May", "January", "May"), Domain = c("Medical", "Medical", "Medical",
"Food & Meds", "Medical"), gdp_group_avg = c("Low Income", "Low Income",
"Low Income", "Low Income", "Low Income"), gdp_group_med = c("High Income",
"High Income", "High Income", "High Income", "High Income"),
shp_point = c(23, 23, 23, 23, 23), length_cat = c("More than 3 months",
"More than 3 months", "[1-3] months", "More than 3 months",
"[1-3] months"), type = structure(c(2L, 2L, 2L, 2L, 2L), .Label = c("Liberalizig",
"Restrictive"), class = "factor")), row.names = c(1L, 2L,
5L, 7L, 13L), class = "data.frame")
Notice that prova1 and prova2 are just two subset of basedata. The code of the plot is the followig
countrydata %>%
ggplot(aes(x = start_date, y = fct_rev(GTAinterventiontype), shape = type)) +
geom_point(data = prova1, aes(color = fct_rev(GTAinterventiontype),size=duration, shape = fct_rev(type)), alpha = 0.65, position = position_nudge(y = +0.05)) +
geom_point(data = prova2, aes(color = fct_rev(GTAinterventiontype),size=duration, shape = fct_rev(type)), alpha = 0.65, position = position_nudge(y = -0.05)) +
scale_shape(drop=FALSE) +
guides(color = FALSE,
shape = guide_legend(order = 1, nrow = 2, ncol = 1),
size = guide_legend(order = 2)) +
delabj::theme_delabj() +
delabj::scale_color_delabj() +
#delabj::legend_none() +
labs(shape = 'Type',
size = "Duration",
x="",
y="",
title = paste("ARG", "Med-related Measures by Announcement date", sep = ": "),
subtitle = "Bubbles are proportional to expected duration of the measure",
caption = "")
The resulting plot is this one.
Any idea, suggestion, or even warning of unfeasibility (if it really so) is more than welcome!

Try this. Basic idea is to duplicate the breaks and the symbols for the size legend. In a second step I adjust the symbols via guide_legend. Perhaps not perfect but after trying some approaches the best I can come up with.
library(tidyverse)
library(ggtext)
library(janitor)
library(delabj)
library(wesanderson)
library(forcats)
# Breaks, labels and symbols
breaks <- c(100, 200, 300)
n_breaks <- length(breaks)
labels <- c(breaks, rep("", n_breaks))
shapes <- c(rep(16, n_breaks), rep(17, n_breaks))
breaks2 <- rep(breaks, 2)
basedata %>%
ggplot(aes(x = start_date, y = fct_rev(GTAinterventiontype), shape = type)) +
geom_point(data = prova1, aes(color = fct_rev(GTAinterventiontype), size=duration, shape = fct_rev(type)), alpha = 0.65, position = position_nudge(y = +0.05)) +
scale_size_continuous(breaks = breaks2, labels = labels,
guide = guide_legend(order = 2, nrow = 2, byrow = TRUE,
override.aes = list(shape = shapes),
direction = "horizontal", label.vjust = -.5)) +
geom_point(data = prova2, aes(color = fct_rev(GTAinterventiontype), size=duration, shape = fct_rev(type)), alpha = 0.65, position = position_nudge(y = -0.05)) +
scale_shape(drop=FALSE) +
guides(color = FALSE,
shape = guide_legend(order = 1, nrow = 2, ncol = 1)) +
delabj::theme_delabj() +
delabj::scale_color_delabj() +
#delabj::legend_none() +
labs(shape = 'Type',
size = "Duration",
x="",
y="",
title = paste("ARG", "Med-related Measures by Announcement date", sep = ": "),
subtitle = "Bubbles are proportional to expected duration of the measure",
caption = "")

Related

Add_annotations plotly first and last datapoints

My Main Goal:
Trying to add annotations to both the first datapoint of my
scatterplot and the last datapoint of my scatterplot (the entries for
years 2006 and 2021 respectively).
My Secondary Goals:
If possible, it would also be helpful to find out how to select out
specific datapoints to add annotations, as I only know the
which.max/which.min functions so far.
It would also be nice to know how to list the jobs on each point.
My Dput:
structure(list(Year = 2006:2021, Month_USD = c(1160L, 1240L,
1360L, 1480L, 1320L, 1320L, 375L, 1600L, 2000L, 2000L, 1600L,
2240L, 1900L, 2300L, 2900L, 2300L), Degree = c("High School",
"High School", "High School", "High School", "High School", "High School",
"High School", "High School", "High School", "BA", "BA", "BA",
"BA", "BA", "M.Ed", "M.Ed"), Country = c("USA", "USA", "USA",
"USA", "USA", "USA", "DE", "USA", "USA", "USA", "USA", "USA",
"PRC", "PRC", "PRC", "HK"), Job = c("Disher", "Prep", "Prep",
"Prep", "Prep", "Prep", "Au Pair", "CSA", "Valet", "Valet", "Intake",
"CM", "Teacher", "Teacher", "Teacher", "Student"), Median_Household_Income_US = c(4833L,
4961L, 4784L, 4750L, 4626L, 4556L, 4547L, 4706L, 4634L, 4873L,
5025L, 5218L, 5360L, 5725L, NA, NA), US_Home_Price_Index = c(183.24,
173.36, 152.56, 146.69, 140.64, 135.16, 143.88, 159.3, 166.5,
175.17, 184.51, 195.99, 204.9, 212.59, 236.31, NA)), class = "data.frame", row.names = c(NA,
-16L))
Current Scatterplot:
pal <- c("Red", "Blue", "Green")
plot_ly(data = Earnings_Year,
x=~Year,
y=~Month_USD,
type='scatter',
mode='markers',
symbol = ~as.factor(Degree),
symbols=c("star-open-dot","hexagon-open-dot","diamond-open-dot"),
color = ~as.factor(Degree),
colors = pal,
hoverinfo="text",
text= paste("Year: ",
Earnings_Year$Year,
"<br>", #this is a line break
"Monthly USD: ",
Earnings_Year$Month_USD),
size=10) %>%
add_annotations(
x=Earnings_Year$Year[which.min(Earnings_Year$Month_USD)],
y=Earnings_Year$Month_USD[which.min(Earnings_Year$Month_USD)],
text = "Au Pair Job in Germany") %>%
add_annotations(
x=Earnings_Year$Year[which.max(Earnings_Year$Month_USD)],
y=Earnings_Year$Month_USD[which.max(Earnings_Year$Month_USD)],
text = "Last Teaching Job in China") %>%
layout(legend= list(x=1,y=0.5),
title="Earnings by Degree",
xaxis=list(title="Year"),
yaxis=list(title="Monthly USD"))
Image of Current Scatter:
Scatter That I Want:
Figured it out. Just needed to pipe additional add_annotations as well as just select specific values for x and y:
pal <- c("Red", "Blue", "Green")
plot_ly(data = Earnings_Year,
x=~Year,
y=~Month_USD,
type='scatter',
mode='markers',
symbol = ~as.factor(Degree),
symbols=c("star-open-dot","hexagon-open-dot","diamond-open-dot"),
color = ~as.factor(Degree),
colors = pal,
hoverinfo="text",
text= paste("Year: ",
Earnings_Year$Year,
"<br>", #this is a line break
"Monthly USD: ",
Earnings_Year$Month_USD),
size=10) %>%
add_annotations(
x=Earnings_Year$Year[which.min(Earnings_Year$Month_USD)],
y=Earnings_Year$Month_USD[which.min(Earnings_Year$Month_USD)],
text = "Au Pair Job in Germany") %>%
add_annotations(
x=Earnings_Year$Year[which.max(Earnings_Year$Month_USD)],
y=Earnings_Year$Month_USD[which.max(Earnings_Year$Month_USD)],
text = "Last Teaching Job in China") %>%
add_annotations(
x=Earnings_Year$Year[Earnings_Year$Year==2006],
y=Earnings_Year$Month_USD[Earnings_Year$Month_USD==1160],
text="First Job"
) %>%
add_annotations(
x=Earnings_Year$Year[Earnings_Year$Year==2021],
y=Earnings_Year$Month_USD[Earnings_Year$Month_USD==2300],
text="Began Ph.D.") %>%
add_annotations(
x=Earnings_Year$Year[Earnings_Year$Year==2008],
y=Earnings_Year$Month_USD[Earnings_Year$Month_USD==1360],
text="Finished H.S.") %>%
add_annotations(
x=Earnings_Year$Year[Earnings_Year$Year==2015],
y=Earnings_Year$Month_USD[Earnings_Year$Month_USD==2000],
text="Finished BA") %>%
layout(legend= list(x=1,y=0.5),
title="Earnings by Degree",
xaxis=list(title="Year"),
yaxis=list(title="Monthly USD"))
Finished Product:

ggplot by group with filter()

I have big dataset with the following format:
structure(list(LOCATION = c("CAN", "CAN", "CAN", "CAN", "CAN",
"CAN", "CAN", "CAN", "CAN", "CAN"), Country = c("Canada", "Canada",
"Canada", "Canada", "Canada", "Canada", "Canada", "Canada", "Canada",
"Canada"), SUBJECT = c("ULABUL99", "ULABUL99", "ULABUL99", "ULABUL99",
"ULABUL99", "ULABUL99", "ULABUL99", "ULABUL99", "ULABUL99", "ULABUL99"
), Subject = c("Unit Labour Cost", "Unit Labour Cost", "Unit Labour Cost",
"Unit Labour Cost", "Unit Labour Cost", "Unit Labour Cost", "Unit Labour Cost",
"Unit Labour Cost", "Unit Labour Cost", "Unit Labour Cost"),
SECTOR = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), Sector = c("Total Economy",
"Total Economy", "Total Economy", "Total Economy", "Total Economy",
"Total Economy", "Total Economy", "Total Economy", "Total Economy",
"Total Economy"), MEASURE = c("ST", "ST", "ST", "ST", "ST",
"ST", "ST", "ST", "ST", "ST"), Measure = c("Level, ratio or national currency",
"Level, ratio or national currency", "Level, ratio or national currency",
"Level, ratio or national currency", "Level, ratio or national currency",
"Level, ratio or national currency", "Level, ratio or national currency",
"Level, ratio or national currency", "Level, ratio or national currency",
"Level, ratio or national currency"), FREQUENCY = c("A",
"A", "A", "A", "A", "A", "A", "A", "A", "A"), Frequency = c("Annual",
"Annual", "Annual", "Annual", "Annual", "Annual", "Annual",
"Annual", "Annual", "Annual"), TIME = 1970:1979, Time = 1970:1979,
Value = c(0.1304592, 0.1357066, 0.1430287, 0.1521136, 0.1752398,
0.2018611, 0.2193767, 0.2347496, 0.2470616, 0.2663881), Flag.Codes = c("E",
"E", "E", "E", "E", "E", "E", "E", "E", "E"), Flags = c("Estimated value",
"Estimated value", "Estimated value", "Estimated value",
"Estimated value", "Estimated value", "Estimated value",
"Estimated value", "Estimated value", "Estimated value")), row.names = c(NA,
10L), class = "data.frame")
And I want to draw time plot like the following (for each sector group in a particular country's particular subject, in this case, Germany's Labour Income Share)
I tried to code as follows:
library(ggplot2)
library(tidyr)
df <- read.csv("/Users/ulc.csv", header = TRUE)
fsector = factor(df$SECTOR)
df %>%
filter(df$MEASURE =="ST",
df$SUBJECT == "ULAIRU99",
df$LOCATION == "DEU") %>%
ggplot(aes(x = df$year, y = df$value, color = fsector, linetype = fsector)) +
scale_color_manual(labels=c("Sec 1","Sec 2", "Sec 3", "Sec 4", "Sec 5", "Sec 6", "Sec 7", "Sec 8"), values = 1:8) +
scale_linetype_manual(labels=c("Sec 1","Sec 2", "Sec 3", "Sec 4", "Sec 5", "Sec 6", "Sec 7", "Sec 8"), values = 1:8) +
theme(legend.position = c(0.8, 0.3), legend.title = element_blank()) +
ylab("LIS of Germany by sector") + xlab("year")
But the result does not show any plots and seems like a lot of elements are missing in my code. Maybe should I add geom_line() for each sector? But there seems much simpler way. Any help would be appreciated.
You can try the following code -
library(dplyr)
library(ggplot2)
df %>%
filter(MEASURE =="ST",SUBJECT == "ULAIRU99",LOCATION == "DEU") %>%
mutate(SECTOR = factor(SECTOR)) %>%
ggplot(aes(x = TIME, y = Value, color = SECTOR, linetype = SECTOR)) +
geom_line() +
scale_color_manual(labels=c("Sec 1","Sec 2", "Sec 3", "Sec 4", "Sec 5", "Sec 6", "Sec 7", "Sec 8"), values = 1:8) +
scale_linetype_manual(labels=c("Sec 1","Sec 2", "Sec 3", "Sec 4", "Sec 5", "Sec 6", "Sec 7", "Sec 8"), values = 1:8) +
theme(legend.position = c(0.8, 0.3), legend.title = element_blank()) +
ylab("LIS of Germany by sector") + xlab("year")

How to group a legend or get seperate legends by facets in ggplot2

I have a dataset that I am presenting facetted by region and then using sub region as a fill. I have defined the colours using a separate named variable relating to the names of the subregion. I am wondering if it is possible to make the legend itself grouped in a similar way to the facet to make it easier to interpret.
The named sub_region variable
sub_region_colours <- c("South America" = "#0570b0", "Western Africa" = "#8c96c6", "Central America" = "#74a9cf", "Eastern Africa" = "#8856a7", "Northern Africa" = "#edf8fb", "Middle Africa" = "#b3cde3", "Southern Africa" = "#810f7c", "Northern America" = "#f1eef6", "Caribbean" = "#bdc9e1", "Eastern Asia" = "#bd0026", "Southern Asia" = "#fd8d3c", "South-Eastern Asia" = "#f03b20", "Southern Europe" = "#238b45", "Australia and New Zealand" = "#ce1256", "Melanesia" = "#df65b0", "Micronesia" = "#d7b5d8", "Polynesia" = "#f1eef6", "Central Asia" = "#fecc5c", "Western Asia" = "#ffffb2", "Eastern Europe" = "#66c2a4", "Northern Europe" = "#edf8fb", "Western Europe" = "#b2e2e2", "Small Islands" = "#252525")
This is the head(exporting_countries) grouping by sender_iso3, year and sender_region removed.
structure(list(sender_iso3 = c("ABW", "ABW", "ABW", "ABW", "ABW",
"ABW"), year = c(2005, 2011, 2014, 2015, 2016, 2017), sender_region = c("Americas",
"Americas", "Americas", "Americas", "Americas", "Americas"),
sender_subregion = c("Caribbean", "Caribbean", "Caribbean",
"Caribbean", "Caribbean", "Caribbean"), export = c(1, 1,
4, 5, 2, 1)), class = "data.frame", row.names = c(NA, -6L
))
Finally this is the code for the current plot
geom_bar()+
labs(title = "Number of countries reporting export of chickens",
fill = "Subregion")+
facet_wrap(~ sender_region)+
theme_minimal()+
scale_x_continuous(name = "Year", limits = c(1986, 2017), breaks = c(1986, 1990, 2000, 2010, 2017), guide = guide_axis(angle = 90))+
scale_fill_manual(values = sub_region_colours)+
guides(fill = guide_legend(ncol = 2))
Which at the moment produces this:
Graph with less than ideal legend
It would be great if I can group the legend fill colours similarly to the facets which would make it easier to read off.
One approach to achieve this would be to make seperate plots for each region and make use of patchwork to glue the plots together. A second approach would be to make use of the ggnewscale package which allows to have multiple fill (or ...) scales and legends in one plot.
However, similiar to using patchwork the approach using ggnewscale package could become a bit tedious as it requires to split the data according to the number of facets and plot each dataset via seperate layers. Therefore my solution adds a helper function which 1) splits the data and sets up the layers for each region or facet and 2) can be used to loop over the regions via e.g. lapply.
BTW: As your sample data included only one region I added a second region.
library(dplyr)
library(ggplot2)
library(ggnewscale)
sub_region_colours <- c("South America" = "#0570b0", "Western Africa" = "#8c96c6", "Central America" = "#74a9cf", "Eastern Africa" = "#8856a7", "Northern Africa" = "#edf8fb", "Middle Africa" = "#b3cde3", "Southern Africa" = "#810f7c", "Northern America" = "#f1eef6", "Caribbean" = "#bdc9e1", "Eastern Asia" = "#bd0026", "Southern Asia" = "#fd8d3c", "South-Eastern Asia" = "#f03b20", "Southern Europe" = "#238b45", "Australia and New Zealand" = "#ce1256", "Melanesia" = "#df65b0", "Micronesia" = "#d7b5d8", "Polynesia" = "#f1eef6", "Central Asia" = "#fecc5c", "Western Asia" = "#ffffb2", "Eastern Europe" = "#66c2a4", "Northern Europe" = "#edf8fb", "Western Europe" = "#b2e2e2", "Small Islands" = "#252525")
d <- structure(list(sender_iso3 = c(
"ABW", "ABW", "ABW", "ABW", "ABW",
"ABW", "ABW", "ABW", "ABW", "ABW", "ABW", "ABW"
), year = c(
2005,
2011, 2014, 2015, 2016, 2017, 2005, 2011, 2014, 2015, 2016, 2017
), sender_region = c(
"Americas", "Americas", "Americas", "Americas",
"Americas", "Americas", "Africa", "Africa", "Africa", "Africa",
"Africa", "Africa"
), sender_subregion = c(
"Caribbean", "Caribbean",
"Caribbean", "Caribbean", "Caribbean", "Caribbean", "Southern Africa",
"Southern Africa", "Southern Africa", "Southern Africa", "Southern Africa",
"Southern Africa"
), export = c(
1, 1, 4, 5, 2, 1, 1, 1, 4, 5,
2, 1
)), class = "data.frame", row.names = c(NA, -12L))
regions <- unique(d$sender_region)
# Layers for each region
make_layers <- function(x) {
d <- filter(d, sender_region == regions[[x]])
list(
if (x != 1) new_scale_fill(),
geom_bar(data = d, aes(x = year, fill = sender_subregion)),
scale_fill_manual(
values = sub_region_colours,
guide = guide_legend(
order = x,
title = regions[x],
title.position = "top"
)
)
)
}
p <- ggplot() +
lapply(seq_along(regions), make_layers)
# Add theme and wrap
p +
theme_minimal() +
scale_x_continuous(
name = "Year", limits = c(1986, 2017),
breaks = c(1986, 1990, 2000, 2010, 2017),
guide = guide_axis(angle = 90)
) +
facet_wrap(~sender_region)

make a interactive bar chart using plotly and shiny have color and a back button

I created an interactive bar chart in shiny and it is working well however there are 2 things I cannot get working.
adding color to the bar chart for each region.
having a back button so after you drill down from Region to Item Type you can click back to just see Region.
Any help is much appreciated. below is the file and code
library(shiny)
library(plotly)
library(dplyr)
dput(head(sales,100))
structure(list(Region = c("Sub-Saharan Africa", "Europe", "Middle East and North Africa",
"Sub-Saharan Africa", "Europe", "Sub-Saharan Africa", "Asia",
"Asia", "Sub-Saharan Africa", "Central America and the Caribbean",
"Sub-Saharan Africa", "Europe", "Europe", "Asia", "Middle East and North Africa",
"Australia and Oceania", "Central America and the Caribbean",
"Europe", "Middle East and North Africa", "Europe", "Sub-Saharan Africa",
"Europe", "Europe", "Asia", "Europe", "Europe", "Europe", "Europe",
"Australia and Oceania", "Central America and the Caribbean",
"Europe", "Europe", "Central America and the Caribbean", "Europe",
"Central America and the Caribbean", "Middle East and North Africa",
"Asia", "Europe", "Sub-Saharan Africa", "Central America and the Caribbean",
"Europe", "Asia", "Middle East and North Africa", "Europe", "Middle East and North Africa",
"Europe", "Europe", "Central America and the Caribbean", "Australia and Oceania",
"Middle East and North Africa", "Europe", "Australia and Oceania",
"Sub-Saharan Africa", "Sub-Saharan Africa", "Asia", "Sub-Saharan Africa",
"Europe", "Europe", "Central America and the Caribbean", "Europe",
"Middle East and North Africa", "Central America and the Caribbean",
"Europe", "Europe", "Europe", "Sub-Saharan Africa", "Sub-Saharan Africa",
"Sub-Saharan Africa", "Europe", "Europe", "Europe", "Europe",
"Sub-Saharan Africa", "Sub-Saharan Africa", "Europe", "Central America and the Caribbean",
"Sub-Saharan Africa", "Middle East and North Africa", "Europe",
"Central America and the Caribbean", "Asia", "Middle East and North Africa",
"North America", "Sub-Saharan Africa", "Sub-Saharan Africa",
"Europe", "Europe", "Sub-Saharan Africa", "Europe", "Sub-Saharan Africa",
"Central America and the Caribbean", "Sub-Saharan Africa", "Middle East and North Africa",
"Australia and Oceania", "Middle East and North Africa", "Europe",
"Sub-Saharan Africa", "Europe", "Sub-Saharan Africa", "Sub-Saharan Africa"
), Country = c("Chad", "Latvia", "Pakistan", "Democratic Republic of the Congo",
"Czech Republic", "South Africa", "Laos", "China", "Eritrea",
"Haiti", "Zambia", "Bosnia and Herzegovina", "Germany", "India",
"Algeria", "Palau", "Cuba", "Vatican City", "Lebanon", "Lithuania",
"Mauritius", "Ukraine", "Russia", "Japan", "Russia", "Liechtenstein",
"Greece", "Albania", "Federated States of Micronesia", "Dominica",
"Andorra", "Switzerland", "Trinidad and Tobago", "San Marino",
"Nicaragua", "Azerbaijan", "Bangladesh", "Serbia", "Mauritius",
"Jamaica", "Italy", "Bhutan", "Turkey", "Bulgaria", "Pakistan",
"Poland", "France", "Jamaica", "Australia", "Somalia", "Slovenia",
"Samoa", "South Africa", "Ghana", "Sri Lanka", "Guinea", "Spain",
"Moldova", "Dominican Republic", "Luxembourg", "Kuwait", "Saint Lucia",
"Georgia", "Bosnia and Herzegovina", "Iceland", "Mauritius",
"Malawi", "Seychelles", "Montenegro", "Germany", "Estonia", "Serbia",
"Madagascar", "Benin", "Hungary", "Cuba", "Senegal", "Algeria",
"Bosnia and Herzegovina", "Antigua and Barbuda", "Cambodia",
"Oman", "United States of America", "Mauritania", "Central African Republic",
"Albania", "Switzerland", "Ghana", "Austria", "Democratic Republic of the Congo",
"Dominican Republic", "Mauritius", "Libya", "Samoa", "Kuwait",
"Hungary", "Senegal", "Moldova", "Eritrea", "Niger"), Item_Type = c("Office Supplies",
"Beverages", "Vegetables", "Household", "Beverages", "Beverages",
"Vegetables", "Baby Food", "Meat", "Office Supplies", "Cereal",
"Baby Food", "Office Supplies", "Household", "Clothes", "Snacks",
"Beverages", "Beverages", "Personal Care", "Snacks", "Cosmetics",
"Office Supplies", "Snacks", "Cosmetics", "Meat", "Vegetables",
"Clothes", "Baby Food", "Baby Food", "Beverages", "Office Supplies",
"Personal Care", "Baby Food", "Vegetables", "Fruits", "Cosmetics",
"Personal Care", "Beverages", "Fruits", "Baby Food", "Cereal",
"Clothes", "Clothes", "Cosmetics", "Household", "Cereal", "Baby Food",
"Baby Food", "Personal Care", "Fruits", "Cosmetics", "Clothes",
"Cereal", "Vegetables", "Office Supplies", "Meat", "Fruits",
"Personal Care", "Cereal", "Personal Care", "Office Supplies",
"Fruits", "Vegetables", "Cosmetics", "Snacks", "Personal Care",
"Office Supplies", "Meat", "Personal Care", "Household", "Meat",
"Clothes", "Baby Food", "Beverages", "Clothes", "Cosmetics",
"Fruits", "Vegetables", "Personal Care", "Baby Food", "Personal Care",
"Vegetables", "Baby Food", "Office Supplies", "Cosmetics", "Baby Food",
"Vegetables", "Household", "Vegetables", "Household", "Clothes",
"Baby Food", "Cosmetics", "Office Supplies", "Personal Care",
"Meat", "Beverages", "Personal Care", "Beverages", "Personal Care"
), Sales_Channel = c("Online", "Online", "Offline", "Online",
"Online", "Offline", "Online", "Online", "Online", "Online",
"Offline", "Offline", "Online", "Online", "Offline", "Offline",
"Online", "Online", "Offline", "Offline", "Offline", "Online",
"Offline", "Offline", "Offline", "Offline", "Online", "Offline",
"Online", "Offline", "Online", "Online", "Offline", "Online",
"Online", "Online", "Online", "Online", "Offline", "Offline",
"Offline", "Offline", "Online", "Offline", "Offline", "Offline",
"Offline", "Offline", "Online", "Offline", "Online", "Offline",
"Online", "Online", "Offline", "Online", "Offline", "Online",
"Online", "Online", "Offline", "Online", "Offline", "Offline",
"Online", "Online", "Online", "Online", "Online", "Online", "Offline",
"Online", "Offline", "Offline", "Online", "Online", "Offline",
"Online", "Online", "Online", "Online", "Online", "Offline",
"Offline", "Offline", "Online", "Online", "Online", "Online",
"Offline", "Online", "Offline", "Offline", "Online", "Online",
"Online", "Offline", "Offline", "Offline", "Online"), Order_Priority = c("L",
"C", "C", "C", "C", "H", "L", "C", "L", "C", "M", "M", "C", "C",
"C", "L", "H", "L", "H", "H", "H", "C", "L", "H", "L", "L", "C",
"C", "M", "H", "M", "M", "L", "H", "L", "M", "L", "H", "H", "H",
"H", "L", "L", "L", "M", "C", "M", "C", "H", "C", "M", "C", "M",
"L", "M", "C", "L", "M", "L", "L", "L", "C", "H", "H", "H", "M",
"C", "C", "L", "L", "H", "M", "C", "H", "M", "L", "H", "M", "M",
"H", "H", "C", "L", "L", "H", "H", "M", "M", "H", "L", "L", "H",
"C", "M", "H", "C", "C", "H", "M", "C"), Order_Date = c("1/27/2011",
"12/28/2015", "1/13/2011", "9/11/2012", "10/27/2015", "7/10/2012",
"2/20/2011", "4/10/2017", "11/21/2014", "7/4/2015", "7/26/2016",
"10/20/2012", "2/22/2015", "8/27/2016", "6/21/2011", "9/19/2013",
"11/15/2015", "4/6/2015", "4/12/2010", "9/26/2011", "5/14/2016",
"8/14/2010", "4/13/2012", "9/19/2013", "12/2/2015", "2/26/2017",
"10/9/2016", "5/20/2011", "10/24/2013", "6/14/2011", "6/20/2015",
"8/5/2011", "11/30/2016", "7/5/2015", "3/25/2015", "8/22/2013",
"12/11/2016", "6/23/2013", "5/8/2015", "10/24/2016", "3/10/2013",
"3/18/2012", "2/11/2015", "10/30/2012", "7/6/2012", "1/4/2011",
"10/25/2013", "2/16/2016", "3/16/2014", "9/24/2016", "9/30/2010",
"11/5/2010", "7/21/2017", "7/10/2013", "10/6/2012", "6/4/2011",
"4/12/2014", "10/26/2015", "8/4/2011", "2/24/2017", "3/30/2011",
"5/2/2015", "2/1/2014", "3/3/2012", "4/22/2015", "5/12/2011",
"12/21/2011", "12/2/2010", "8/14/2010", "10/5/2010", "2/8/2012",
"9/8/2012", "8/11/2011", "10/28/2012", "10/11/2013", "10/6/2016",
"7/28/2017", "11/4/2016", "4/12/2016", "11/13/2014", "8/26/2012",
"7/15/2014", "5/2/2011", "11/11/2013", "4/14/2011", "10/4/2012",
"5/14/2013", "1/12/2013", "10/3/2012", "10/23/2010", "2/6/2014",
"9/4/2011", "5/12/2016", "7/19/2015", "10/28/2012", "8/25/2016",
"10/25/2013", "2/11/2011", "5/27/2016", "2/6/2012"), Order_ID = c(292494523,
361825549, 141515767, 500364005, 127481591, 482292354, 844532620,
564251220, 411809480, 327881228, 773452794, 479823005, 498603188,
151717174, 181401288, 500204360, 640987718, 206925189, 221503102,
878520286, 192088067, 746630275, 246883237, 967895781, 305029237,
223957431, 510666692, 121455848, 332936227, 692031657, 365978467,
392325484, 528934037, 603977954, 965943562, 233629691, 246147668,
212921321, 763686978, 798493468, 637702119, 671986758, 912333714,
540041816, 156722390, 434299266, 765008771, 611399734, 856333482,
652983844, 574837148, 365692222, 289660394, 681165492, 594943845,
956044280, 509828126, 771969211, 178453862, 835580909, 869961678,
278519999, 478492200, 257427108, 723186051, 353942859, 848183858,
374707877, 322626245, 351362788, 640653836, 540548217, 821407258,
523904788, 109027135, 108073127, 672654092, 224693858, 406428754,
230407607, 129491746, 606854999, 885983693, 260676658, 345045220,
123513209, 900816953, 452005279, 672439515, 827793490, 704053533,
157518470, 464799630, 272820842, 548818433, 530341231, 875250566,
511720263, 688236653, 923598563), Ship_Date = c("2/12/2011",
"1/23/2016", "2/1/2011", "10/6/2012", "12/5/2015", "8/21/2012",
"3/20/2011", "5/12/2017", "1/10/2015", "7/20/2015", "8/24/2016",
"11/15/2012", "2/27/2015", "9/2/2016", "7/21/2011", "10/4/2013",
"11/30/2015", "4/27/2015", "5/19/2010", "10/2/2011", "6/18/2016",
"8/31/2010", "4/22/2012", "9/28/2013", "12/26/2015", "2/28/2017",
"10/13/2016", "6/19/2011", "12/3/2013", "7/20/2011", "7/21/2015",
"9/1/2011", "1/9/2017", "7/29/2015", "5/9/2015", "8/30/2013",
"1/13/2017", "7/18/2013", "5/13/2015", "11/24/2016", "4/4/2013",
"5/4/2012", "3/2/2015", "11/3/2012", "8/1/2012", "2/21/2011",
"12/10/2013", "3/22/2016", "4/27/2014", "10/29/2016", "11/11/2010",
"12/5/2010", "8/22/2017", "7/26/2013", "10/21/2012", "7/24/2011",
"4/15/2014", "12/15/2015", "8/27/2011", "4/14/2017", "4/12/2011",
"6/14/2015", "2/26/2014", "4/10/2012", "5/13/2015", "5/15/2011",
"1/18/2012", "12/25/2010", "9/16/2010", "11/14/2010", "3/18/2012",
"9/20/2012", "8/19/2011", "11/7/2012", "10/27/2013", "10/20/2016",
"7/31/2017", "11/25/2016", "5/1/2016", "12/20/2014", "9/22/2012",
"8/15/2014", "5/4/2011", "12/17/2013", "5/20/2011", "11/21/2012",
"6/10/2013", "2/2/2013", "11/12/2012", "11/20/2010", "3/28/2014",
"9/4/2011", "6/26/2016", "8/20/2015", "11/24/2012", "9/25/2016",
"11/3/2013", "2/26/2011", "6/13/2016", "2/26/2012"), Units_Sold = c(4484,
1075, 6515, 7683, 3491, 9880, 4825, 3330, 2431, 6197, 724, 9145,
6618, 5338, 9527, 441, 1365, 2617, 6545, 2530, 1983, 3345, 7091,
725, 3784, 2835, 6477, 339, 2083, 6401, 16, 6684, 2191, 9353,
3020, 5072, 9420, 7005, 803, 816, 9083, 4670, 8675, 9229, 6493,
7659, 1950, 5623, 6962, 1285, 5941, 5310, 5802, 861, 5959, 3603,
8327, 1699, 7318, 5814, 9848, 9112, 5330, 7257, 5678, 8412, 5307,
3243, 1130, 4912, 2562, 9084, 1516, 3924, 2407, 95, 2148, 761,
155, 1586, 8340, 735, 1118, 8871, 5403, 9158, 609, 7261, 8650,
1344, 3941, 2070, 3394, 2605, 6425, 8611, 4947, 8252, 3375, 2194
), Unit_Price = c(651.21, 47.45, 154.06, 668.27, 47.45, 47.45,
154.06, 255.28, 421.89, 651.21, 205.7, 255.28, 651.21, 668.27,
109.28, 152.58, 47.45, 47.45, 81.73, 152.58, 437.2, 651.21, 152.58,
437.2, 421.89, 154.06, 109.28, 255.28, 255.28, 47.45, 651.21,
81.73, 255.28, 154.06, 9.33, 437.2, 81.73, 47.45, 9.33, 255.28,
205.7, 109.28, 109.28, 437.2, 668.27, 205.7, 255.28, 255.28,
81.73, 9.33, 437.2, 109.28, 205.7, 154.06, 651.21, 421.89, 9.33,
81.73, 205.7, 81.73, 651.21, 9.33, 154.06, 437.2, 152.58, 81.73,
651.21, 421.89, 81.73, 668.27, 421.89, 109.28, 255.28, 47.45,
109.28, 437.2, 9.33, 154.06, 81.73, 255.28, 81.73, 154.06, 255.28,
651.21, 437.2, 255.28, 154.06, 668.27, 154.06, 668.27, 109.28,
255.28, 437.2, 651.21, 81.73, 421.89, 47.45, 81.73, 47.45, 81.73
), Total_Profit = c(566105, 16834.5, 411291.95, 1273303.59, 54669.06,
154720.8, 304602.25, 319213.8, 139053.2, 782371.25, 64139.16,
876639.7, 835522.5, 884666.74, 699662.88, 24316.74, 21375.9,
40982.22, 164017.7, 139504.2, 344784.21, 422306.25, 390997.74,
126055.75, 216444.8, 178973.55, 475670.88, 32496.54, 199676.38,
100239.66, 2020, 167501.04, 210029.26, 590454.89, 7278.2, 881868.64,
236065.2, 109698.3, 1935.23, 78221.76, 804662.97, 342964.8, 637092,
1604646.23, 1076084.89, 678510.81, 186927, 539020.78, 174467.72,
3096.85, 1032961.67, 389966.4, 513999.18, 54354.93, 752323.75,
206091.6, 20068.07, 42576.94, 648301.62, 145698.84, 1243310,
21959.92, 336482.9, 1261774.59, 313084.92, 210804.72, 670008.75,
185499.6, 28317.8, 814065.76, 146546.4, 667128.96, 145323.76,
61449.84, 176770.08, 16517.65, 5176.68, 48041.93, 3884.3, 152033.96,
209000.4, 46400.55, 107171.48, 1119963.75, 939419.61, 877885.88,
38446.17, 1203365.53, 546074.5, 222741.12, 289427.04, 198430.2,
590114.78, 328881.25, 161010.5, 492549.2, 77470.02, 206795.12,
52852.5, 54981.64), Month_RecentYear = c(NA, NA, NA, NA, NA,
NA, NA, "April", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
NA, NA, NA, NA, NA, NA, "February", NA, NA, NA, NA, NA, NA, NA,
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
NA, NA, NA, "July", NA, NA, NA, NA, NA, NA, "February", NA, NA,
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, "July",
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
NA, NA, NA, NA, NA, NA, NA)), class = c("tbl_df", "tbl", "data.frame"
), row.names = c(NA, -100L))
ui <- fluidPage(
plotlyOutput("Region", height = 200),
plotlyOutput("Item_Type", height = 200),
dataTableOutput("datatable")
)
axis_titles <- . %>%
layout(
xaxis = list(title = ""),
yaxis = list(title = "Total Profit")
)
server <- function(input, output, session) {
Region <- reactiveVal()
Item_Type <- reactiveVal()
observeEvent(event_data("plotly_click", source = "Region"), {
Region(event_data("plotly_click", source = "Region")$x)
Item_Type(NULL)
})
observeEvent(event_data("plotly_click", source = "Item_Type"), {
Item_Type(event_data("plotly_click", source = "Item_Type")$x)
})
output$Region <- renderPlotly({
sales %>%
count(Region, wt = Total_Profit) %>%
plot_ly(x = ~Region, y = ~n, source = "Region") %>%
axis_titles() %>%
layout(title = "Total Profit by Region")
})
output$Item_Type <- renderPlotly({
if (is.null(Region())) return(NULL)
sales %>%
filter(Region %in% Region()) %>%
count(Item_Type, wt = Total_Profit) %>%
plot_ly(x = ~Item_Type, y = ~n, source = "Item_Type") %>%
axis_titles() %>%
layout(title = Region())
})
}
shinyApp(ui, server)
Thank you for adding the data with dput - that was very helpful.
To add colors, you can set color in your plot_ly statement to Region (so different colors for different region). If you want to set custom colors, then use colors as well, and set to a color vector, for example.
For the back button, you need another uiOutput to show the button (and hide when appropriate). If Region has been selected, then Region() will not be NULL and it should show the button. Otherwise should hide. Once the button is clicked, then input$clear should clear the Region() choice.
I also noticed the warnings including:
The 'plotly_click' event tied a source ID of 'Item_Type' is not
registered.
That's a tough one, and there is a github issue on this. While we can register the plots, clearly the second plot as it is dependent on the first won't be registered when observeEvent is looking out for the plotly_click event.
As a workaround, you can make it observe instead, and add req to require that Region has been selected before doing anything with the plotly_click event. It seems like the warnings went away, I hope the behavior is still maintained.
library(shiny)
library(plotly)
library(dplyr)
my_colors = c("blue", "red", "green", "purple", "orange", "black", "pink")
###
ui <- fluidPage(
plotlyOutput("Region", height = 400),
plotlyOutput("Item_Type", height = 200),
uiOutput("back"),
dataTableOutput("datatable")
)
axis_titles <- . %>%
layout(
xaxis = list(title = ""),
yaxis = list(title = "Total Profit")
)
server <- function(input, output, session) {
Region <- reactiveVal()
Item_Type <- reactiveVal()
observeEvent(event_data("plotly_click", source = "Region"), {
Region(event_data("plotly_click", source = "Region")$x)
Item_Type(NULL)
})
observe({
req(Region())
Item_Type(event_data("plotly_click", source = "Item_Type")$x)
})
output$Region <- renderPlotly({
sales %>%
count(Region, wt = Total_Profit) %>%
plot_ly(x = ~Region, y = ~n, source = "Region", type = "bar", color = ~Region, colors = my_colors) %>%
axis_titles() %>%
layout(title = "Total Profit by Region") %>%
event_register('plotly_click')
})
output$Item_Type <- renderPlotly({
if (is.null(Region())) return(NULL)
sales %>%
filter(Region %in% Region()) %>%
count(Item_Type, wt = Total_Profit) %>%
plot_ly(x = ~Item_Type, y = ~n, source = "Item_Type", type = "bar") %>%
axis_titles() %>%
layout(title = Region()) %>%
event_register('plotly_click')
})
# populate back button if category is chosen
output$back <- renderUI({
if (!is.null(Region()))
actionButton("clear", "Back", icon("chevron-left"))
})
# clear on back button press
observeEvent(input$clear, Region(NULL))
}
shinyApp(ui, server)

Selectively apply custom function based on criteria

I am working with this dataframe:
structure(list(year = c("2012", "2016", "2012", "2016"), month = c("12",
"12", "12", "12"), company = c("ALSN", "ALSN", "DAN", "DAN"),
Revenue = c(2141.8, 1840.2, 7224, 5826), `Cost of Goods Sold` = c(1187.5,
976, 6250, 4982), `Gross Profit` = c(954.3, 864.2, 974, 844
), `Gross Margin %` = c(44.56, 46.96, 13.48, 14.49), `Selling, General, & Admin. Expense` = c(419,
323.9, 424, 406), `Impairment Of Capital Assets` = c(0, 0,
2, 0), Advertising = c(1, 1, 1, 1), `Research & Development` = c(115.1,
88.8, 0, 0), `Restructuring And Mergern Acquisition` = c(0,
0, 47, 0), `Other Operating Expense` = c(-5.68434188608e-14,
1.13686837722e-13, 121, 8), `Operating Income` = c(420.2,
451.5, 429, 430), `Operating Margin %` = c(19.62, 24.54,
5.94, 7.38), `Interest Income` = c(0.9, 0.7, 24, 13), `Interest Expense` = c(-152.1,
-101.6, -84, -113), `Net Interest Income` = c(-151.2, -100.9,
-60, -100), `Other Income (Expense)` = c(-52.8, -9.3, -5,
-115), `Non Operating Income` = c(-52.8, -9.3, -5, -115),
`Other Income (Minority Interest)` = c(0, 0, -15, -13), `Gain on Sale of Security` = c(-1.3,
-0.8, 0, 7), `Write Off` = c(1, 1, 1, 1), `Pre-Tax Income` = c(216.2,
341.3, 364, 215), `Tax Provision` = c(298, -126.4, -51, 424
), `Tax Rate %` = c(-137.84, 37.03, 14.01, -197.21), `Net Income (Continuing Operations)` = c(514.2,
214.9, 315, 653), `Net Income (Discontinued Operations)` = c(0,
0, 0, 0), `Net Income` = c(514.2, 214.9, 300, 640), `Net Margin %` = c(24.01,
11.68, 4.15, 10.99), `Preferred Dividends` = c(0, 0, 31,
0), `EPS (Basic)` = c(2.83, 1.28, 1.82, 4.38), `EPS (Diluted)` = c(2.76,
1.27, 1.4, 4.36), `Shares Outstanding (Diluted Average)` = c(186.2,
168.8, 214.7, 146.8), `Depreciation, Depletion and Amortization` = c(252.5,
175.9, 277, 182), EBITDA = c(620.8, 618.8, 725, 510)), .Names = c("year",
"month", "company", "Revenue", "Cost of Goods Sold", "Gross Profit",
"Gross Margin %", "Selling, General, & Admin. Expense", "Impairment Of Capital Assets",
"Advertising", "Research & Development", "Restructuring And Mergern Acquisition",
"Other Operating Expense", "Operating Income", "Operating Margin %",
"Interest Income", "Interest Expense", "Net Interest Income",
"Other Income (Expense)", "Non Operating Income", "Other Income (Minority Interest)",
"Gain on Sale of Security", "Write Off", "Pre-Tax Income", "Tax Provision",
"Tax Rate %", "Net Income (Continuing Operations)", "Net Income (Discontinued Operations)",
"Net Income", "Net Margin %", "Preferred Dividends", "EPS (Basic)",
"EPS (Diluted)", "Shares Outstanding (Diluted Average)", "Depreciation, Depletion and Amortization",
"EBITDA"), row.names = c(NA, 4L), class = "data.frame")
Constants:
startDate <- "2012-01-01"
endDate <- "2016-12-31"
What I want: to create a function that applies a custom function to all numeric columns. I am trying to calculate CAGRs. The CAGR formula is as such:
((End Value / Beginning Value)^(1/number of years)-1)
So as you can see, I need for each column to be able to find the correct end value and beginning value.
My function right now is this:
cagr <- function(startval,endval,x,y,years){
return(((endval[x == year(endDate)]/startval[y == year(startDate)])^(1/(years-1)))-1)
}
cagrNew <- function(df,colum,x,y,years){
colum <- quo(colum)
x <- quo(x)
y <- quo(y)
out <- df %>%
group_by(!!company) %>%
summarise(xxxx = cagr(!!colum[!!x == year(endDate)],!!colum[!!y == year(startDate)],!!x,!!y,numYears))
return(out)
}
When I run the above function (cagrNEW), I get this error:
Error in `[.formula`(colum, !(!x == year(endDate))) :
attempt to set an attribute on NULL
My desired output:
Company RevenueCagr Cost of Goods Sold CAGR ....
ALSN .5% .3%
DAN .3% .2%
I haven't repeated the data above, to conserve space. Convert to tibble and assign.
# df <- as_tibble(...)
library(tidyverse)
library(scales) #< For percentage formatting
start_year <- 2012
end_year <- 2016
df %>%
filter(year %in% c(start_year, end_year)) %>%
group_by(company) %>%
arrange(desc(year), .by_group = TRUE) %>%
summarise_if(is.double, funs(CAGR = percent( (.[[1]]/.[[2]])^ (1/(end_year - start_year)) - 1) ) )
# CAGR = ((End Value / Beginning Value)^(1/number of years)-1)
#Checksum: ALSN Company, Revenue
# (End Value / Beginning Value)^((1/number of years))-1
percent(( (1840 / 2142) ^ (1/(2016-2012)) - 1))
#> [1] "-3.73%"

Resources