Related
I am working on created a shiny app and I wrote a function to display a plotly. The function works fine and prints the plot when I run it in the console, but the ggplotly histogram will not render when I run the app. I do not receive any errors when running the function in the console nor when I try to run the app. The graphs just do not show up in the app. Here is the function, which I wrote in a helper file:
# making function to display simulated state-level pv2ps
pv2p_plot <- function(x) {
# filter based on input$state from ui.R
# getting text to specify the predicted pv2p and the chance of victory
pv2p <- sims %>%
drop_na() %>%
filter(state == x) %>%
mutate(d_pv2p = sim_dvotes_2020 / (sim_rvotes_2020 + sim_dvotes_2020),
r_pv2p = 1 - d_pv2p) %>%
summarise(d_pv2p = mean(d_pv2p) * 100,
r_pv2p = mean(r_pv2p) * 100)
win_prob <- sims %>%
mutate(biden_win = ifelse(sim_dvotes_2020 > sim_rvotes_2020, 1, 0)) %>%
group_by(state) %>%
summarise(pct_biden_win = mean(biden_win, na.rm = TRUE)) %>%
filter(pct_biden_win < 1 & pct_biden_win > 0) %>%
mutate(pct_trump_win = 1 - pct_biden_win) %>%
select(state, pct_biden_win, pct_trump_win) %>%
filter(state == x)
pv2p_lab <- paste0("Forecasted Two-Party Popular Vote: ", round(pv2p$d_pv2p, 2), "% for Biden and ", round(pv2p$r_pv2p, 2), "% for Trump")
win_lab <- paste0("Forecasted Probability of Electoral College Victory: ", round(win_prob$pct_biden_win * 100, 2), "% for Biden and ", round(win_prob$pct_trump_win * 100, 2), "% for Trump")
pv_plot <- sims %>%
filter(state == x) %>%
mutate(Democrat = sim_dvotes_2020 / (sim_dvotes_2020 + sim_rvotes_2020),
Republican = 1 - Democrat) %>%
pivot_longer(cols = c(Democrat, Republican), names_to = "party") %>%
ggplot(aes(value, fill = party)) +
geom_histogram(aes(y = after_stat(count / sum(count)),
text = paste0("Probability: ", round(after_stat(count / sum(count)), 5))), bins = 1000, alpha = 0.5, position = "identity") +
scale_fill_manual(breaks = c("Democrat", "Republican"),
labels = c("Biden", "Trump"),
values = c(muted("blue"), "red3")) +
labs(title = paste("Simulated Two-Party Popular Vote \nin", x),
x = "Predicted Share of the Two-Party Popular Vote",
y = "Probability",
fill = "Candidate",
subtitle = pv2p_lab) +
theme_hodp()
print(ggplotly(pv_plot, tooltip = "text"))
}
And this is my UI & server code from the app:
# loaded libraries, read in data, and created functions in other file to keep
# this script nice and clean
source("helper.R")
ui <- navbarPage(
# Application title
"Presidential Forecast in Retrospect",
tabPanel(
"About",
includeHTML(file.path("pages/about.html"))
),
navbarMenu("Forecast Simulations",
tabPanel("State-by-State Two-Party Popular Vote",
fluidPage(theme = "bootstrap.css",
tabsetPanel(
tabPanel("Estimated Vote Share",
selectInput("state",
"State:",
sims %>% pull(state) %>% unique() %>% sort()),
plotlyOutput("statesimPlotly")),
tabPanel("Probability of Victory",
selectInput("state_type",
"State Category:",
types %>% pull(type) %>% unique()),
plotlyOutput("statevictoryPlotly")
)
)
)
),
tabPanel("Predicted Vote Margin Map",
# creating this page to show the win margin
includeHTML(file.path("pages/margin_maps.html"))
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
output$statesimPlotly <- renderPlotly({
# calling function that I defined at the top of the app
pv2p_plot(input$state)
})
output$statevictoryPlotly <- renderPlotly(
# calling function from helper to make this plot
state_win_probs(input$state_type)
)
}
# Run the application
shinyApp(ui = ui, server = server)
As I said above, the function works fine in my console. Most people who have had issues with this online are not using the proper output/render functions (e.g. using renderPlot instead of renderPlotly), but I am not seeing what is wrong with my code. Thanks in advance!
I have the following 3 way table I created in R.
with(dataset, ftable(xtabs(count ~ dos + sex + edu)))
The output looks like
edu high low medium unknown
dos sex
five-to-ten-years female 247776 44916 127133 23793
male 225403 37858 147821 20383
five-years-or-less female 304851 58018 182152 33649
male 253977 55720 193621 28972
more-than-ten-years female 709303 452605 539403 165675
male 629162 309193 689299 121336
native-born female 1988476 1456792 2094297 502153
male 1411509 1197395 2790522 395953
unknown female 57974 75480 73204 593141
male 40176 57786 93108 605542
I want to rename the variables and format the table so that I can include it in a report. I know that I can use dnn to rename the variables, but are there any other recommendations to rename the variables? And to format the table (similar to using kable)?
You could convert the output to a text matrix using the following function, after which you can style with kable however you choose:
ftab_to_matrix <- function(ft)
{
row_vars <- attr(ft, "row.vars")
for(i in seq_along(row_vars)){
row_vars[[i]] <- c(names(row_vars[i]), row_vars[[i]])}
rowvar_widths <- sapply(row_vars, function(x) max(nchar(x))) + 1
col_vars <- attr(ft, "col.vars")
rowvar_widths <- c(1, cumsum(c(rowvar_widths, max(nchar(names(col_vars))))))
ft_text <- capture.output(print(ft))
row_cols <- sapply(seq_along(rowvar_widths)[-1], function(x)
substr(ft_text, rowvar_widths[x - 1], rowvar_widths[x]))
ft_text <- substr(ft_text, rowvar_widths[length(rowvar_widths)] + 2, 100)
ft_breaks <- c(1, cumsum(lapply(strsplit(ft_text[length(ft_text)], "\\d "),
function(x) nchar(x) + 2)[[1]]))
col_cols <- sapply(seq_along(ft_breaks)[-1], function(x)
substr(ft_text, ft_breaks[x - 1], ft_breaks[x]))
trimws(cbind(row_cols, col_cols))
}
So, for example, using my example data from your last question, you could do something like:
my_tab <- with(`3waydata`, ftable(xtabs(count ~ duration + sex + education)))
as_image(kable_styling(kable(ftab_to_df(my_tab))), file = "kable.png")
Might have been easier had you given the full picture when you asked your first question... You could use gt to make fancy tables for reports. This is an edited version more fully demonstrating some capabilities.
library(dplyr)
library(gt)
way3data <- data %>%
group_by(duration, education, sex) %>%
summarise(count = sum(number)) %>%
ungroup
# Reorder with select and Titlecase with stringr
longer <- tidyr::pivot_wider(way3data,
values_from = count,
names_from = "education") %>%
select(duration, sex, high, medium, low, unknown) %>%
rename_with(stringr::str_to_title)
# Demonstrating some of the features of gt
# obviously could have done some of this
# to the original dataframe
myresults <- longer %>%
group_by(Duration) %>%
gt(rowname_col = "Sex") %>%
row_group_order(
groups = c("native-born",
"more-than-ten-years",
"five-to-ten-years",
"five-years-or-less",
"unknown")
) %>%
tab_spanner(label = "Education",
columns = matches("High|Low|Medium|Unknown")) %>%
tab_stubhead(label = "Duration or something") %>%
tab_style(
style = cell_text(style = "oblique", weight = "bold"),
locations = cells_row_groups()) %>%
tab_style(
style = cell_text(align = "right", style = "italic", weight = "bold"),
locations = cells_column_labels(
columns = vars(High, Low, Medium, Unknown)
)) %>%
tab_style(
style = cell_text(align = "right", weight = "bold"),
locations = cells_stub()) %>%
tab_header(
title = "Fancy table of counts with Duration, Education and Gender") %>%
tab_source_note(md("More information is available at https://stackoverflow.com/questions/62284264."))
# myresults
# Can save in other formats including .rtf
myresults %>%
gtsave(
"tab_1.png", expand = 10
)
You can read about all the formatting choices here
Data compliments of Allan
set.seed(69)
data <- data.frame(education = sample(c("high","low","medium","unknown"), 600, T),
sex = rep(c("Male", "Female"), 300),
duration = sample(c("unknown", "native-born",
"five-years-or-less", "five-to-ten-years",
"more-than-ten-years"), 600, T),
number = rpois(600, 10))
I wanted to see an exact output of a Highcharter plot side by side in RStudio Viewer if it possible, exactly showed in this reference: http://jkunst.com/highcharter/highcharts.html, So let me define it like this for a simple usage
highcharter_all_plot <- function(){
library(highcharter)
library(dplyr)
library(stringr)
library(purrr)
n <- 5
set.seed(123)
colors <- c("#d35400", "#2980b9", "#2ecc71", "#f1c40f", "#2c3e50", "#7f8c8d")
colors2 <- c("#000004", "#3B0F70", "#8C2981", "#DE4968", "#FE9F6D", "#FCFDBF")
df <- data.frame(x = seq_len(n) - 1) %>%
mutate(
y = 10 + x + 10 * sin(x),
y = round(y, 1),
z = (x*y) - median(x*y),
e = 10 * abs(rnorm(length(x))) + 2,
e = round(e, 1),
low = y - e,
high = y + e,
value = y,
name = sample(fruit[str_length(fruit) <= 5], size = n),
color = rep(colors, length.out = n),
segmentColor = rep(colors2, length.out = n)
)
print(head(df))
create_hc <- function(t) {
dont_rm_high_and_low <- c("arearange", "areasplinerange",
"columnrange", "errorbar")
is_polar <- str_detect(t, "polar")
t <- str_replace(t, "polar", "")
if(!t %in% dont_rm_high_and_low){
df <- df %>% dplyr::select(-e, -low, -high)
}
highchart() %>%
hc_title(text = paste(ifelse(is_polar, "polar ", ""), t),
style = list(fontSize = "15px")) %>%
hc_chart(type = t,
polar = is_polar) %>%
hc_xAxis(categories = df$name) %>%
hc_add_series(df, name = "Fruit Consumption", showInLegend = FALSE)
}
hcs <- c("line", "spline", "area", "areaspline",
"column", "bar", "waterfall" , "funnel", "pyramid",
"pie" , "treemap", "scatter", "bubble",
"arearange", "areasplinerange", "columnrange", "errorbar",
"polygon", "polarline", "polarcolumn", "polarcolumnrange",
"coloredarea", "coloredline") %>% map(create_hc)
return(hcs)
}
x <- highcharter_all_plot()
#Then plot can be accessed in by calling x[[1]], x[[2]], x[[3]]..
As far as my understanding of side by side plot, I only know of 2 these handy methods, which is:
1) Using par(mfrow)
par(mfrow=c(3,4)) -> (which only can by applied to base plot)
2) Using grid.arrange from gridExtra
library(gridExtra)
grid.arrange(x[[1]], x[[2]], x[[3]], x[[4]], nrow=2, ncol=2)
-> (Cannot work since x not a ggplot type)
So I wanted to know if there is a way that this can be applied? I am new using Highcharter
If you inspect the Highcharter website you provided, you will see that those charts are not sided by side using R, but they are just renderer in separate HTML containers and positioned by bootstrap (CSS). So, if you want to render your charts in an HTML environment, I suggest rendering every chart into a separate div.
But maybe Shiny is a tool you are looking for. Maybe this is a duplicate of Shiny rcharts multiple chart output
Maybe this will help you too: https://github.com/jbkunst/highcharter/issues/37
I have boxplots on highcharter and I would like to customize both the
Fill color
Border color
Here is my code
df = data.frame(cbind(categ = rep(c('a','b','c','d')),value = rnorm(1000)))
hcboxplot(var = df$categ, x = as.numeric(df$value)) %>%
hc_chart(type = "column") %>%
hc_colors(c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"))
The hc_colors works only if I put var2 instead of var but then the box plot are shrunken...
API for styling fillColor: https://api.highcharts.com/highcharts/series.boxplot.fillColor
And for "Border color": https://api.highcharts.com/highcharts/series.boxplot.color
Pure JavaScript example of how to style and define points: https://jsfiddle.net/BlackLabel/6tud3fgx
And R code:
library(highcharter)
df = data.frame(cbind(categ = rep(c('a','b','c','d', 'e')),value = rnorm(1000)))
hcboxplot(var = df$categ, x = as.numeric(df$value)) %>%
hc_chart(type = "column", events = list(
load = JS("function() {
var chart = this;
chart.series[0].points[2].update({
color: 'red'
})
chart.series[0].points[4].update({
x: 4,
low: 600,
q1: 700,
median: 800,
q3: 900,
high: 1000,
color: 'orange'
})
}")
)) %>%
hc_plotOptions(boxplot = list(
fillColor = '#F0F0E0',
lineWidth = 2,
medianColor = '#0C5DA5',
medianWidth = 3,
stemColor = '#A63400',
stemDashStyle = 'dot',
stemWidth = 1,
whiskerColor = '#3D9200',
whiskerLength = '20%',
whiskerWidth = 3,
color = 'black'
)) %>%
hc_colors(c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"))
I made a couple functions to do some stuff with highcharts and boxplots. It will let you color each boxplot and fill it accordingly, and then inject new graphical parameters according to the Highcharts API, should you desire.
Check it out:
## Boxplots Data and names, note the data index (0,1,2) is the first number in the datum
series<- list(
list(
name="a",
data=list(c(0,1,2,3,4,5))
),
list(
name="b",
data=list(c(1,2,3,4,5,6))
),
list(
name="c",
data=list(c(2,3,4,5,6,7))
)
)
# Graphical attribute to be set: fillColor.
# Make the colors for the box fill and then also the box lines (make them match so it looks pretty)
cols<- viridisLite::viridis(n= length(series2), alpha = 0.5) # Keeping alpha in here! (for box fill)
cols2<- substr(cols, 0,7) # no alpha, pure hex truth, for box lines
gen_key_vector<-function(variable, num_times){
return(rep(variable, num_times))
}
kv<- gen_key_vector(variable = "fillColor", length(series))
# Make a function to put stuff in the 'series' list, requires seq_along to be used since x is the list/vector index tracker
add_variable_to_series_list<- function(x, series_list, key_vector, value_vector){
base::stopifnot(length(key_vector) == length(value_vector))
base::stopifnot(length(series_list) == length(key_vector))
series_list[[x]][length(series_list[[x]])+1]<- value_vector[x]
names(series_list[[x]])[length(series_list[[x]])]<- key_vector[x]
return(series_list[[x]])
}
## Put the extra stuff in the 'series' list
series2<- lapply(seq_along(series), function(x){ add_variable_to_series_list(x = x, series_list = series, key_vector = kv, value_vector = cols) })
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text="This is a title") %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=c("a", "b", "c"), title=list(text="Some x-axis title")) %>%
highcharter::hc_add_series_list(series2) %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
hc
This probably could be adjusted to work with a simple dataframe, but I think it will get you what you want for right now without having to do too much extra work. Also, maybe look into list_parse or list_parse2' fromhighcharter...it could probably help with building out theseries` object..I still need to look into that.
Edit:
I have expanded the example to make it work with a regular DF. As per some follow up questions, the colors are set using the viridis palette inside the make_highchart_boxplot_with_colored_factors function. If you want to allow your own palette and colors, you could expose those arguments and just include them as parameters inside the function call. The expanded example borrows how to add outliers from the highcharter library (albeit in a hacky way) and then builds everything else up from scratch. Hopefully this helps clarify my previous answer. Please note, I could probably also clean up the if condition to make it a little more brief, but I kept it verbose for illustrative purposes.
Double Edit: You can now specify a vector of colors for each level of the factor variable
library(highcharter)
library(magrittr)
library(viridisLite)
df = data.frame(cbind(categ = rep(c('a','b','c','d')),value = rnorm(1000)))
df$value<- base::as.numeric(df$value)
add_variable_to_series_list<- function(x, series_list, key_vector, value_vector){
base::stopifnot(length(key_vector) == length(value_vector))
base::stopifnot(length(series_list) == length(key_vector))
series_list[[x]][length(series_list[[x]])+1]<- value_vector[x]
names(series_list[[x]])[length(series_list[[x]])]<- key_vector[x]
return(series_list[[x]])
}
# From highcharter github pages:
hc_add_series_bwpout = function(hc, value, by, ...) {
z = lapply(levels(by), function(x) {
bpstats = boxplot.stats(value[by == x])$stats
outliers = c()
for (y in na.exclude(value[by == x])) {
if ((y < bpstats[1]) | (y > bpstats[5]))
outliers = c(outliers, list(which(levels(by)==x)-1, y))
}
outliers
})
hc %>%
hc_add_series(data = z, type="scatter", ...)
}
gen_key_vector<-function(variable, num_times){
return(rep(variable, num_times))
}
gen_boxplot_series_from_df<- function(value, by,...){
value<- base::as.numeric(value)
by<- base::as.factor(by)
box_names<- levels(by)
z=lapply(box_names, function(x) {
boxplot.stats(value[by==x])$stats
})
tmp<- lapply(seq_along(z), function(x){
var_name_list<- list(box_names[x])
#tmp0<- list(names(df)[x])
names(var_name_list)<- "name"
index<- x-1
tmp<- list(c(index, z[[x]]))
tmp<- list(tmp)
names(tmp)<- "data"
tmp_out<- c(var_name_list, tmp)
#tmp<- list(tmp)
return(tmp_out)
})
return(tmp)
}
# Usage:
#series<- gen_boxplot_series_from_df(value = df$total_value, by=df$asset_class)
## Boxplot function:
make_highchart_boxplot_with_colored_factors<- function(value, by, chart_title="Boxplots",
chart_x_axis_label="Values", show_outliers=FALSE,
boxcolors=NULL, box_line_colors=NULL){
by<- as.factor(by)
box_names_to_use<- levels(by)
series<- gen_boxplot_series_from_df(value = value, by=by)
if(is.null(boxcolors)){
cols<- viridisLite::viridis(n= length(series), alpha = 0.5) # Keeping alpha in here! (COLORS FOR BOXES ARE SET HERE)
} else {
cols<- boxcolors
}
if(is.null(box_line_colors)){
if(base::nchar(cols[[1]])==9){
cols2<- substr(cols, 0,7) # no alpha, pure hex truth, for box lines
} else {
cols2<- cols
}
} else {
cols2<- box_line_colors
}
# Injecting value 'fillColor' into series list
kv<- gen_key_vector(variable = "fillColor", length(series))
series2<- lapply(seq_along(series), function(x){ add_variable_to_series_list(x = x, series_list = series, key_vector = kv, value_vector = cols) })
if(show_outliers == TRUE){
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text=chart_title) %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=box_names_to_use, title=list(text=chart_x_axis_label)) %>%
highcharter::hc_add_series_list(series2) %>%
hc_add_series_bwpout(value = value, by=by, name="Outliers") %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
} else{
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text=chart_title) %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=box_names_to_use, title=list(text=chart_x_axis_label)) %>%
highcharter::hc_add_series_list(series2) %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
}
hc
}
# Usage:
tst_box<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title", chart_x_axis_label = "Some X Axis", show_outliers = TRUE)
tst_box
# Custom Colors:
custom_colors_with_alpha_in_hex<- paste0(gplots::col2hex(sample(x=colors(), size = length(unique(df$categ)), replace = FALSE)), "80")
tst_box2<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title",
chart_x_axis_label = "Some X Axis",
show_outliers = TRUE, boxcolors = custom_colors_with_alpha_in_hex)
tst_box2
tst_box3<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title",
chart_x_axis_label = "Some X Axis",
show_outliers = TRUE, boxcolors = custom_colors_with_alpha_in_hex, box_line_colors = "black")
tst_box3
I hope this helps, please let me know if you have any more questions. I'm happy to try to help as best I can.
-nate
Since there's no highcharter answer yet, I give you at least a base solution.
First, your definition of the data frame is somewhat flawed, rather do:
dat <- data.frame(categ=c('a','b','c','d'), value=rnorm(1000))
Now, using boxplot is quite straightforward. border option colors your borders. With option col you also could color the fills.
boxplot(value ~ categ, dat, border=c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"), pars=list(outpch=16))
Gives
Note: See this nice solution for further customizations.
Trying to run a shiny app, but keep getting the error: Error in filter_impl: Result must have length 4090, not 0
I've tried:
debugging by removing individual filters to try isolate the issue.
using dplyr::filter to force dplr's filter
ensured all filters are in a reactive function
checked whether it was an issue of sharing inputs between ui.R and server.r
checked whether it is caused by a previous df transformation.
Spent about 3 hours trying to find the cause, with no success.
Can you please help?
Server.R
rm(list = ls())
library(shiny)
library(tidyverse)
library(shiny)
library(ggplot2)
library(singer)
library(ggvis)
library(dplyr)
# Set Up DataFrames
data(package = "singer")
data(singer_locations)
sdf <- singer_locations %>% filter(year != 0) # filter out songs with missing years for simplicity
sdf %>% skim() %>% kable() # Check to see missing and incomplete values
sdf <- sdf %>% filter(complete.cases(.)) # filter out songs with missing observations for simplicity
sdf %>% skim() %>% kable() # Check to see if missing and incomplete values have been ignored
sdf <- sdf %>% select(
track_id, title, song_id, release, artist_id, artist_name, year, duration,
artist_hotttnesss, artist_familiarity, name, city, longitude, latitude
)
# add new columns with rounded data (for nicer graphs later)
sdf$latitude_rounded <- round(sdf$latitude, 0)
sdf$longitude_rounded <- round(sdf$longitude, 0)
sdf$duration_rounded <- round(sdf$duration, 0)
# Add song_popularity & very_popular_song columns
pops <- sdf$artist_hotttnesss + sdf$artist_familiarity
sdf$artist_popularity <- round(pops, 0)
sdf$very_popular_song <- round(sdf$artist_popularity)
sdf$very_popular_song[sdf$very_popular_song < 1] <- "No"
sdf$very_popular_song[sdf$very_popular_song >= 1] <- "Yes"
# Select() relevant variables so they can be passed into server below (without having to use df[,"VAR"])
songs_list <- sdf %>% select(
track_id, title, song_id, release, artist_id, artist_name, year, duration_rounded, duration,
artist_hotttnesss, artist_familiarity, name, city, latitude_rounded, longitude_rounded, longitude,
latitude, artist_popularity, very_popular_song
)
#axis_variables <- reactive({
axis_variables <- c(
"Length of Song (Seconds)" = "duration_rounded",
"Rating" = "artist_hotttnesss",
"Rating" = "artist_familiarity",
"Year" = "year",
"Popularity Rating" = "artist_popularity"
)
################################### SHINY SERVER #########################################
function(input, output) {
songs <- reactive({ # Create Reactive Filtering Component
duration_s <- input$duration_s
artist_hotttnesss_s <- input$artist_hotttnesss_s
artist_familiarity_s <- input$artist_familiarity_s
latitude_s <- input$latitude_s
longitude_s <- input$longitude_s
year_s <- input$year_s
artist_popularity_s <- input$artist_popularity_s
# Apply filters
songs_df <- songs_list %>%
dplyr::filter(
duration_rounded >= duration_s,
artist_hotttnesss >= artist_hotttnesss_s,
artist_familiarity >= artist_familiarity_s,
latitude_rounded >= latitude_s,
longitude_rounded >= longitude_s,
year >= year_s,
artist_popularity >= artist_popularity_s
) %>%
arrange(duration_rounded)
# filter by city option
if (input$city_in != "All") {
city_in_temp <- paste0("%", input$city_in, "%")
songs_df <- songs_df %>% dplyr::filter(songs_df$city %like% city_in_temp)
}
# filter by artist_name option
if (input$artist_name_in != "" && !is.null(input$artist_name_in)) {
artist_name_temp <- paste0("%", input$artist_name_in, "%")
songs_df <- songs_df %>% dplyr::filter(songs_df$artist_name %like% artist_name_temp)
}
songs_df <- as.data.frame(songs_df)
songs_df # return df
})
# search fuction
song_search <- function(s) {
if (is.null(s)) return(NULL)
if (is.null(s$track_id)) return(NULL)
# Isolate the given ID
songs_df <- isolate(songs())
temp_song <- songs_df[songs_df$track_id == s$track_id, ]
paste0("<b>", temp_song$artist_name, "</b><br>",
temp_song$year, "<br>",
"popularity ", format(temp_song$artist_popularity, big.mark = ",", scientific = FALSE)
)
}
# A reactive expression with the ggvis plot
vis <- reactive({
# setting variablex & variabley (input names are type str)
variablex <- prop("x", as.symbol(input$variablex))
variabley <- prop("y", as.symbol(input$variabley))
# Lables for axes
xvar_name <- names(axis_variables)[axis_variables == input$variablex]
yvar_name <- names(axis_variables)[axis_variables == input$variabley]
songs %>%
ggvis(x = variablex, y = variabley) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
stroke = ~artist_popularity, key := ~artist_name) %>%
add_tooltip(song_search, "hover") %>%
add_axis("x", title = xvar_name) %>%
add_axis("y", title = yvar_name) %>%
add_legend("stroke", title = "Very Popular", values = c("Yes", "No")) %>%
scale_nominal("stroke", domain = c("Yes", "No"),
range = c("orange", "#aaa")) %>%
set_options(width = 500, height = 500)
})
vis %>% bind_shiny("plot1")
output$songs_selected <- renderText({ nrow(songs()) })
}
Ui.R
rm(list = ls())
library(tidyverse)
library(shiny)
library(ggplot2)
library(singer)
library(ggvis)
library(dplyr)
#axis_variables <- reactive({
axis_variables <- c(
"Length of Song (Seconds)" = "duration_rounded",
"Hotness Rating" = "artist_hotttnesss",
"Familiarity Rating" = "artist_familiarity",
"Year" = "year",
"Popularity Rating" = "artist_popularity"
)
# Define UI for application that draws a histogram
shinyUI(fluidPage(
shinythemes::themeSelector(),
titlePanel("Artist & Song Data"),
fluidRow(
column(3,
wellPanel(
h4("Filter By"),
# Slider Options for Data Exploration
sliderInput("duration_s", "Minimum duration of song (seconds)", 10, 500, 100, step = 10),
sliderInput("year_s", "Year released", 1900, 2018, value = c(1980, 2018)),
sliderInput("artist_hotttnesss_s", "Ranking / 10 for popularity", 0, 2, 0, step = 0.1),
sliderInput("artist_familiarity_s", "Ranking / 10 for familiarity", 0, 2, 0, step = 0.1),
sliderInput("artist_popularity", "Ranking / 10 for familiarity", 0, 2, 0, step = 0.1),
# Filter by custom input condition
textInput("city_in", "Name of the city"),
textInput("artist_name_in", "Artist's name contains (e.g Pink f)")
),
wellPanel(
selectInput("variablex", "X-axis", axis_variables, selected = "year"),
selectInput("variabley", "Y-axis", axis_variables, selected = "duration_rounded")
)
),
column(9,
ggvisOutput("plot1"),
wellPanel(
span("Degrees of Freedom",
textOutput("songs_selected")
)
)
)
)
It looks like you are filtering using data created by input$XXX. Try to put req(input$XXX, req(input$YYY, ...) at the beginning of your reactive element(s).
Also read this tweet about starting with rm(list = ls()).