Related
I have the shiny app below in which I create a process map. What I want to do is subset this process map based on the transitions selectInput().
All the transitions can be seen from the obect edges which I extract from the process_map() object at the beginning but then how can I pass the selected from the selectInput() again to the process_map() object?what I acually need is to hide/display the edges between the nodes if deselect/select one transition pair.
This is how I make it work but I cannot make it work for multiple selection ,using multiple=T inside the selectInput().
library(shiny)
library(bupaR)
library(svgPanZoom)
library(DiagrammeRsvg)
library(DiagrammeR)
library(processmapR)
edges <- patients %>% process_map(performance(mean, "days"))
edges <- attr(edges, "edges")
colnames(edges)[1]<-"predecessor"
colnames(edges)[2]<-"successor"
graph <- process_map(patients
, type_nodes = frequency("absolute",color_scale = "Greys")
,type_edges = frequency("absolute",color_edges = "Greys"),
rankdir = "LR", render = FALSE)
ui <-shinyUI(fluidPage(
selectInput("tran","transitions"
,choices = c("All",paste(edges$predecessor,"-",edges$successor)),
#multiple=T
,selected = "All"),
svgPanZoomOutput("pmap",height = 500,width = 1600)
))
server <- function(input, output) {
output$pmap <- renderSvgPanZoom({
req(input$tran)
if (input$tran != "All"){
pre <- strsplit(input$tran, " - ")[[1]][[1]]
suc <- strsplit(input$tran, " - ")[[1]][[2]]
#creating copy of graph for processing
ndf = get_node_df(graph)
edf = get_edge_df(graph)
newg = create_graph(nodes_df = ndf, edges_df = edf)
newg$global_attrs <- graph$global_attrs
#Finding edges to remove based on pre/suc nodes, selecting edge, removing
#using startWith due termination chars being added
from_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,pre)) %>% get_selection()
to_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,suc)) %>% get_selection()
newg <- newg %>% clear_selection() %>%
select_edges(from = from_nodes, to = to_nodes) %>% delete_edges_ws
# newg %>% render_graph # debugging
} else {
newg <- graph
}
newg %>% generate_dot() %>% grViz(width = 1000, height = 2000) %>%
export_svg %>% svgPanZoom(height=800, controlIconsEnabled = TRUE)
})
}
shinyApp(ui=ui,server=server)
The (naive) solution simply revolves around iterating over selected values and filtering the graph accordingly.
library(shiny)
library(bupaR)
library(svgPanZoom)
library(DiagrammeRsvg)
library(DiagrammeR)
library(processmapR)
edges <- patients %>% process_map(performance(mean, "days"))
edges <- attr(edges, "edges")
colnames(edges)[1]<-"predecessor"
colnames(edges)[2]<-"successor"
graph <- process_map(patients
, type_nodes = frequency("absolute",color_scale = "Greys")
,type_edges = frequency("absolute",color_edges = "Greys"),
rankdir = "LR", render = FALSE)
ui <-shinyUI(fluidPage(
checkboxGroupInput("tran","Filter Transitions"
,choices = paste(edges$predecessor,"-",edges$successor)),
svgPanZoomOutput("pmap",height = 500,width = 1600)
))
server <- function(input, output) {
output$pmap <- renderSvgPanZoom({
if (all(!is.null(input$tran))){
#creating copy of graph for processing
ndf = get_node_df(graph)
edf = get_edge_df(graph)
newg = create_graph(nodes_df = ndf, edges_df = edf)
newg$global_attrs <- graph$global_attrs
for (t in input$tran){
pre <- strsplit(t, " - ")[[1]][[1]]
suc <- strsplit(t, " - ")[[1]][[2]]
#Finding edges to remove based on pre/suc nodes, selecting edge, removing
#using startWith due termination chars being added
from_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,pre)) %>% get_selection()
to_nodes = newg %>% clear_selection() %>%
select_nodes(conditions = startsWith(tooltip,suc)) %>% get_selection()
newg <- newg %>% clear_selection() %>%
select_edges(from = from_nodes, to = to_nodes) %>% delete_edges_ws
# newg %>% render_graph # debugging
}
} else {
newg <- graph
}
newg %>% generate_dot() %>% grViz(width = 1000, height = 2000) %>%
export_svg %>% svgPanZoom(height=800, controlIconsEnabled = TRUE)
})
}
shinyApp(ui=ui,server=server)
Potential performance improvement would be to pre-calculate the edges selection, then the loop iteration would "just" take care of removing these.
I am having trouble with the drop-down menu options and their outputs. Although I can see the list of options the output remains the same and doesn't change even though the user can pick a different person. Any suggestions are welcome! My code is below (I removed some sensitive information):
server.r
senators <- read.csv("senators.csv")
output$senator <- renderUI({
selectInput("variablex",
#inputID = "senator",
label = "Choose a U.S Senator from the list",
selected = senators$name,
choices = senators$name)
})
senTweets <- read.csv("person.year.count.csv")
person <- reactive({
req(variablex)
df <- senTweets %>%
group_by(input$variablex, year) %>%
top_n(input$a, n) %>%
ungroup() %>%
arrange(word, -n)
return(df)
})
observe({
df = input$df
})
output$plot <- renderPlot({
person () %>% mutate(word = reorder(word, n))
ggplot(aes(word, n, fill = factor(year))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ year, scales = "free") + scale_fill_viridis_d() +
coord_flip() + labs(y="Word frequency", x="Term", title = paste("Top words used in 2020"))
})
}
ur.r
ui <- dashboardPage(
dashboardHeader(title = ""),
dashboardSidebar(sidebarMenu(
menuItem("Main", tabName = "Main", icon = icon("r-project")),
menuItem("ReadMe", tabName = "ReadMe", icon = icon("readme"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "Main",
sidebarPanel(
helpText("text"),
uiOutput('senator'),
sliderInput(
"a",
label = "Select value to view top common words",
min = 1,
max = 10,
value = 5
),
),
mainPanel(
plotOutput("plot")
)
),
tabItem(tabName = "ReadMe",
includeMarkdown("README.md"))
),
)
)
UPDATE: I made the following changes as gss suggested but I still can't get the output to change, any tips? Also not sure if the observe made a difference but I added that line as well.
Let's try some debugging. I don't have data which you have, so I don't see other possibilities. After reading your code there are two parts which I'm not sure if there are correct. Here is the first part:
person <- reactive({
#req(variablex)
df <- senTweets %>%
group_by(input$variablex, year) %>%
top_n(input$a, n) %>%
ungroup() %>%
arrange(word, -n)
})
First of all, input$variablex is a name (senator's name), right? (Or should be at least). So I assume that senTweets data contains columns with the names which are present in senators$name. Otherwist it won't be possible to group by. input$variablex, as all inputs from shiny, is of type character, so the first thing is that you should probably use some knowledge about programming with dplyr (Programming with dplyr) and use .data[[input$variablex]]:
person <- reactive({
#req(variablex)
df <- senTweets %>%
group_by(.data[[input$variablex]], year) %>%
top_n(input$a, n) %>%
ungroup() %>%
arrange(word, -n)
})
This should not be a problem with input$a because it is just a number and even if top_n() function expects number, probably there are a implicit type conversion.
You can change the code according my adive or first you can check if you really get what you want when user chooses senator's name. To do this, add browser() function here:
person <- reactive({
#req(variablex)
df <- senTweets %>%
group_by(input$variablex, year) %>%
top_n(input$a, n) %>%
ungroup() %>%
arrange(word, -n)
browser()
})
(you may need to add req(input$variablex) at the beginning, otherwise it can be that you do not choose any senator and after opening the app, you will immediately will be moved to the console in RStudio)
When you open the app, choose senator, then go back to RStudio and you should be in debugging mode. Type df in the console and check if this table looks as you think it should.
The second part of your code which seems suspicious is this one:
output$plot <- renderPlot({
person () %>% mutate(word = reorder(word, n))
ggplot(data = person(), aes(word, n, fill = factor(year))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ year, scales = "free") + scale_fill_viridis_d() +
coord_flip() + labs(y="Word frequency", x="Term", title = paste("Top words used in 2020"))
})
Especially this: person () %>% mutate(word = reorder(word, n)) (it changes person() data, but do not save those changes!) doesn't seem to do anything useful. More sense would be to have:
output$plot <- renderPlot({
person () %>% mutate(word = reorder(word, n)) %>%
ggplot(aes(word, n, fill = factor(year))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ year, scales = "free") + scale_fill_viridis_d() +
coord_flip() + labs(y="Word frequency", x="Term", title = paste("Top words used in 2020"))
})
i am pretty new to programmring but i have to make a shiny app for a university course.
As you can see i webscraped a data table thats presents different bike geometries and i wanted to create a shiny app, where i can compare the geometries with each other. I am quite happy with my progress, but now i got the problem that it always shows me the error: "Error in : Problem with filter() input ..1.
x Input ..1 must be of size 19 or 1, not size 0.
i Input ..1 is !=.... 161: "
I want that its possible in the app to choose one bike and it automatically compares the bike and shows me the 10 most similar bikes.
#table
Canyon <- read_html("https://enduro-mtb.com/canyon-strive-cfr-9-0-ltd-test-2020/")
Rose <- read_html("https://enduro-mtb.com/rose-root-miller-2020-test/")
Ghost <- read_html("https://enduro-mtb.com/ghost-riot-enduro-2021-erster-test/")
Cube <- read_html("https://enduro-mtb.com/cube-stereo-170-sl-29-test-2020/")
Comparison <- tibble(
Geometry = Canyon %>%
html_nodes(".geometry strong") %>%
html_text()%>%
str_trim(),
CanyonStrive = Canyon %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
GhostRiot = Ghost %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
CubeStereo = Cube %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
RoseRootMiller = Rose %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
)
ComparisonTable <- Comparison %>%
mutate_all(~gsub("mm|°|-.*|/.*|\\.", "", .)) %>%
mutate_all(~gsub(",", ".", .)) %>%
mutate_all(type.convert, as.is=TRUE) %>%
gather("Bikes", "value", 2:ncol(Comparison)) %>%
spread(Geometry,value)
Art <- c("Enduro", "Enduro", "AllMountain", "Enduro")
ComparisonTableHallo <- ComparisonTable
ComparisonTableHallo$Art <- Art
# server
server <- function(input, output, session) {
selectedData1 <- reactive({
ComparisonTableHallo %>%
filter(ComparisonTableHallo$Bikes != gsub("[[:space:]]*$","",gsub("- .*",'',input$Bikes)))
})
selectedData2 <- reactive({
selectedData1() %>%
select(1:12) %>%
filter(selectedData1()$Art %in% input$Art)
})
selectedData3 <- reactive({
ComparisonTableHallo %>%
select(1:12) %>%
filter(ComparisonTableHallo$Bikes == gsub("[[:space:]]*$","",gsub("- .*",'',input$Bikes)))
})
selectedData4 <- reactive({
rbind(selectedData3(),selectedData2())
})
selectedData5 <- reactive({
selectedData4() %>%
select(3:11)
})
selectedData6 <- reactive({
as.numeric(knnx.index(selectedData5(), selectedData5()[1, , drop=FALSE], k=2))
})
selectedData7 <- reactive({
selectedData4()[selectedData6(),]
})
selectedData8 <- reactive({
selectedData7() %>%
select(3:11)
})
# Combine the selected variables into a new data frame
output$plot1 <- renderPlotly({
validate(
need(dim(selectedData2())[1]>=2, "Sorry, no ten similar bikes were found.
Please change the input filters."
)
)
plot_ly(
type = 'scatterpolar',
mode = "closest",
fill = 'toself'
) %>%
add_trace(
r = as.matrix(selectedData8()[1,]),
theta = c("Kettenstrebe", "Lenkwinkel","Oberrohr","Radstand","Reach","Sattelrohr","Sitzwinkel","Stack","Steuerrohr",
"Tretlagerabsenkung"),
showlegend = TRUE,
mode = "markers",
name = selectedData7()[1,1]
) %>%
add_trace(
r = as.matrix(selectedData8()[2,]),
theta = c("Kettenstrebe","Lenkwinkel","Oberrohr","Radstand","Reach","Sattelrohr","Sitzwinkel","Stack","Steuerrohr",
"Tretlagerabsenkung"),
showlegend = TRUE,
mode = "markers",
visible="legendonly",
name = selectedData7()[2,1]
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,100)
)
),
showlegend=TRUE
)
})
}
#shiny app
ui <- fluidPage(navbarPage("Bike Comparison",
tabPanel("Graphic",fluidPage(theme = shinytheme("flatly")),
tags$head(
tags$style(HTML(".shiny-output-error-validation{color: red;}"))),
pageWithSidebar(
headerPanel('Apply filters'),
sidebarPanel(width = 4,
selectInput('Bike', 'Choose a Bike:',paste(ComparisonTableHallo$Bikes)),
checkboxGroupInput(inputId = "Art",
label = 'Art:', choices = c("Enduro" = "Enduro", "AllMountain" = "AllMountain"
),
selected = c("Enduro" = "Enduro","AllMountain" = "AllMountain"),inline=TRUE),
submitButton("Update filters")
),
mainPanel(
column(8, plotlyOutput("plot1", width = 800, height=700),
p("To visualize the graph of the player, click the icon at side of names
in the graphic legend. It is worth noting that graphics will be overlapped.",
style = "font-size:25px")
)
)
)))
)
shinyApp(ui = ui, server = server)
On your UI, your input is named Bike, on your server, you are referring to input$Bikes. Either Bike needs to change to Bikes, or the opposite.
Edit: (elaboration) Your error is telling you that you have a problem with one your arguments to the function filter. Specifically, you're passing an object of length 0 to the function. You are trying to pass the Bike. An empty select input would pass "", so that isn't the problem. "" has length 1. However an input you never assigned would pass NULL. That has length 0.
Problem:
I was trying to build a shiny app that plot frequency of n-grams based on a user specified column from a user uploaded csv. In addition, a function was added to plot the senetiment over time, based on a date column specified by the user as well.
The app was working okay locally, with Warning, but failed work after published. Please see the following for a reproducible example.
Preparation: libraries and example data
# Load R packages
library(shiny)
library(tidyverse)
library(shinythemes)
library(lubridate)
library(tidytext)
library(textdata)
# Creating a example csv file for upload
Sample_csv <-
data.frame(text = janeaustenr::emma,
id = 1:length(janeaustenr::emma),
date = sample(seq(as.Date('1900/01/01'), as.Date('1920/01/01'), by="day"),
replace = T,
length(janeaustenr::emma)))
write.csv(Sample_csv, "Sample_csv.csv", row.names = F)
UI
ui <- fluidPage(theme = shinytheme("united"),
titlePanel("Text glancer"),
sidebarLayout(
sidebarPanel(
# Input: Select a file ----
fileInput("csv_file", "Feed csv here",
multiple = FALSE,
accept = c(".csv")),
#Conditional panel
conditionalPanel(
# use a server side condition
condition = "output$fileUploaded",
# Input: Select ----
uiOutput("text_select"),
# Input: Select ----
uiOutput("date_select"),
# Input: Simple integer interval ----
sliderInput("top_frequency", "Top n ngrams to be plotted:",
min = 5, max = 20, value = 10),
# Input: Select ----
selectInput("ngrams", "Ngrams of your choice:",
c("Single word" = 1,
"Bigram" = 2,
"Trigram" = 3)
)
),
# Submit bottom
submitButton("Update View", icon("refresh"))
),
# sidebarPanel
mainPanel(
tabsetPanel(
tabPanel(h2("Most frequenlty used n-grams"),
plotOutput("frequency_plot", height = 900, width = 1200)),
tabPanel(h2("Sentiment of the months"),
plotOutput("sentiment_plot", height = 900, width = 1200))
)
)
)
)
server
server <- function(input, output, session) {
# create reactive version of the dataset (a data.frame object)
LOAD_DATA <- reactive({
infile <- input$csv_file
if (is.null(infile))
{return(NULL)}
{read_csv(infile$datapath)}
})
# inform conditionalPanel wheter dropdowns sohould be hidden
output$fileUploaded <- reactive({
return(!is.null(LOAD_DATA()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
## update 'column' selectors
output$text_select <- renderUI({
if(is.null(LOAD_DATA()))
{return(NULL)}
else
selectInput("text_col", "Select the text column:", colnames(LOAD_DATA()))
})
output$date_select <- renderUI({
if(is.null(LOAD_DATA()))
{return(NULL)}
else
selectInput("date_col", "Select the date column (ymd):", colnames(LOAD_DATA()))
})
# Create reactive parameters
TOP_FREQUENCY <- reactive({
input$top_frequency
})
N_GRAMS <- reactive({
as.numeric(as.character(input$ngrams))
})
# Output frequency of ngrams
output$frequency_plot <- renderPlot( {
if(is.null(LOAD_DATA()))
{return(NULL)}
else{
WORK_DATA <- LOAD_DATA()[,c(input$text_col,
input$date_col)]
names(WORK_DATA) <- c("TEXTS", "DATES")
CSV_DOC_N_Grams <-
WORK_DATA %>%
# LOAD_DATA() %>%
# select(TEXTS = TEXT_COL(), DATES = DATE_COL()) %>%
mutate(TEXTS = gsub("http.*", " ", TEXTS)) %>%
# mutate(text = gsub("\\#.* |\\#.* .|\\#.* ,", " ", text)) %>%
unnest_tokens(words, TEXTS, token = "ngrams", n = N_GRAMS()) %>%
select(words) %>%
filter(str_detect(words, "[a-zA-Z]")) %>%
separate(words, c("word1","word2","word3"),sep = " ", remove = F) %>%
filter(! word1 %in% stop_words$word &
! word2 %in% stop_words$word&
! word3 %in% stop_words$word)
#Counting ngrams
CSV_DOC_N_Gramss_Count <-
CSV_DOC_N_Grams %>%
count(words, sort=T) %>%
select(N_Gram_Text = words,
N_Gram_Count = n)
#Plotting ngram frequency
CSV_DOC_N_Gramss_Count_freq <-
CSV_DOC_N_Gramss_Count %>%
mutate(N_Gram_Text = fct_reorder(N_Gram_Text, N_Gram_Count)) %>%
top_n(TOP_FREQUENCY(), N_Gram_Count) %>%
ggplot(aes(x = N_Gram_Text,
y = N_Gram_Count,
fill = N_Gram_Count)) +
geom_col()+
coord_flip() +
scale_fill_gradient2()+
labs(title = paste0("Top ", TOP_FREQUENCY(), " ngrams used in csv doc"),
x = "ngrams",
y = "frequency") +
theme_bw()+
theme(legend.position = "none",
axis.text.x = element_text(face='bold',size=12),
axis.text.y = element_text(face='bold',size=12),
axis.title.x = element_text(face='bold',size=18),
axis.title.y = element_blank())
print(CSV_DOC_N_Gramss_Count_freq)
}
})
output$sentiment_plot <- renderPlot( {
if(is.null(LOAD_DATA())){return(NULL)}
else{
WORK_DATA <- LOAD_DATA()[,c(input$text_col,
input$date_col)]
names(WORK_DATA) <- c("TEXTS", "DATES")
tk_afinn <-
WORK_DATA %>%
mutate(TEXTS = gsub("http.*", " ", TEXTS)) %>%
unnest_tokens(word, TEXTS) %>%
filter(! word %in% stop_words$word) %>%
filter(str_detect(word, "[a-zA-Z]")) %>%
filter(! DATES %in% NA) %>%
inner_join(get_sentiments("afinn")) %>%
mutate(YEAR_Month = ymd(paste(year(DATES),
month(DATES),
"1", sep="-"))) %>%
group_by(index = YEAR_Month) %>%
summarise(sentiment = sum(value))
tk_afinn_plot <-
tk_afinn %>%
ggplot(aes(x = index, y = sentiment)) +
geom_line()+
labs(x = "date (year-month)",
y = "sentiment of the month") +
theme_bw()+
theme(legend.position = "none",
axis.text.x = element_text(face='bold',size=12),
axis.text.y = element_text(face='bold',size=12),
axis.title.x = element_text(face='bold',size=18),
axis.title.y = element_blank())
print(tk_afinn_plot)
}
})
}
Fuse
shinyApp(ui = ui, server = server)
Warnings:
After loading the csv file, the local app reports :
"Problem with mutate() input TEXTS.
object 'TEXTS' not found
Input TEXTS is gsub("http.*", " ", TEXTS)."
After specify the text column and date column, both tab showed plots. However, after publishing it to shinyapp.io, it reports error and would not run.
Can anybody help with this issue? I have consulted the other thread includin this>https://stackoverflow.com/questions/47248534/dynamically-list-choices-for-selectinput-from-a-user-selected-column, but still no luck.
Any insight would be greatly appreciated!
I have the following code on my Server. R
data_agg_plot1<- reactive({
brush1 <- linked_brush(keys = data_agg()$id, "navy" )
data_agg <- data_agg()
plot1<-data_agg%>%
ggvis(x = ~dates_all) %>%
group_by(factor(dates_all.1)) %>%
layer_points(y = ~ value, fill =~dates_all.1, shape =~dates_all.1) %>%
layer_paths(y = ~ value, stroke = ~dates_all.1 , strokeOpacity := 0.5) %>%
scale_ordinal("fill", range = c("green", "red", "blue"))%>%
scale_ordinal("shape", range = c("triangle-up","triangle-down","circle")) %>%
scale_ordinal("stroke",range=c("green","red","blue")) %>%
brush1$input() %>%
hide_legend(c('stroke','fill'))%>%
add_legend(c('shape','fill'),
title = "Symbol", orient = "left",
values = c("New hires", "Attrition" , "Net Growth"),
properties = legend_props(
title = list(fontSize = 16))) %>%
add_axis("x",properties= axis_props(labels = list(angle=60,align = "left")),
tick_padding =0,
title = "") %>%
add_axis("y", title = "Total Count") %>%
set_options(width = "auto",height = 400) %>%
scale_numeric('y',clamp = TRUE)
return(list(plot1,brush1))
})
so this is a reactive function that returns me a list of 2 functions, a plot and my brush object.
the purpose of doing so is so that I can make my keys reactive - this is so that I can make an additional plot based on my user's selection. think of it as the second plot depends on what the first user highlights in the first plot.
this is my following code:
plot1_data<-reactive({
data_agg_plot1()[[1]]
})
plot1_data%>%bind_shiny("plot1")
selected_plot1 <- reactive({
data_agg_plot1()[[2]]
})
output$test <- renderPrint({
temp <- selected_plot1()$selected()
print(temp)
})
however, when I print out the selection, it is all false,
please refer to the image below:
can anybody explain to me how to overcome this?
I highly suspect I have to re-write my linkedbrush function,
I have tried both solutions from:
linked_brush in ggvis cannot work in Shiny when data change
but it does not work.