Hide and display multiple edges from process_map() using selectInput() - r

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.

Related

how to display selectedinput to plot title for shiny

output$selected <- renderText({
paste(input$name)
})
output$hcontainer8 <- renderHighchart({
var <- textOutput("selected")
hc2 <- df_clean %>% filter(df_clean$ManagerName == input$name)
hchart(hc2, "lollipop", hcaes(name = Employee_Name, low = Absences ),name = "Absences") %>%
hc_xAxis(type = "category") %>%
hc_yAxis(labels = list(format = "{value}")) %>%
hc_title(text="Employee Absences under {var}",align="center") %>%
hc_subtitle(text = "with mean value from each department group by Performance Score", align = "center")
})
so this is my code for the server.r and I want to show the manager name in the plot title
based on the selected input
(text="Employee Absences under {var}",align="center")
this is a closer look at the code, so I want to display it in {var} is there a way to do it?
input$name is a string that you can use to both filter and within the hc_title() call.
Try:
hc_title(text = paste0("Employee Absences under ", input$name), align="center") %>%

Why does `filter` crash with an input length error in my shiny app?

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.

Can I double click on a node in a visNetwork diagram to run a function?

I have a network diagram with a few nodes, each node having some data, including an ID and its name.
I'm building the visNetwork object like this:
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges
) %>%
visPhysics(stabilization = TRUE, enabled = TRUE) %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>% # The colour of the edge linking nodes
visLayout(improvedLayout = TRUE) %>%
visEdges(arrows = edges$arrows) %>%
visInteraction(multiselect = F)
return(v)
}
What I'm after is being able to pipe in visEvents and call a function in my code, ideally passing the ID as a parameter. Something like:
testFunction <- function(node_id){
print(paste("The selected node ID is:", node_id))
}
The examples I've seen online are mostly using the javascript alert() in their examples, but I'm looking to break out of javascript and call an R function in my code.
Any help with this would be much appreciated! Thank you in advance.
You can use Shiny.onInputChange in javascript to set anything as a Shiny input variable. This does the trick.
EDIT: Use doubleClick in visEvents to trigger the code on double click. See https://rdrr.io/cran/visNetwork/man/visEvents.html
library(shiny)
library(visNetwork)
ui <- fluidPage(
visNetworkOutput('network')
)
server <- function(input, output, session) {
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges
) %>%
visPhysics(stabilization = TRUE, enabled = TRUE) %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>% # The colour of the edge linking nodes
visLayout(improvedLayout = TRUE) %>%
visEdges(arrows = edges$arrows) %>%
visInteraction(multiselect = F) %>%
visEvents(doubleClick = "function(nodes) {
Shiny.onInputChange('current_node_id', nodes.nodes);
;}")
return(v)
}
testFunction <- function(node_id){
print(paste("The selected node ID is:", node_id))
}
nodes <- data.frame(id = 1:3, label = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
output$network <- renderVisNetwork(
getDiagramPlot(nodes, edges)
)
observeEvent(input$current_node_id,{
testFunction(input$current_node_id)
})
}
shinyApp(ui, server)

Shiny, Event reactive, running several functions

I am new in shiny, at the moment I am trying to set up a code where I can calculate activity clusters (through DBSCAN package) based on input variables: "eps" (minimum distances between points to be part of a cluster), "minpts" (minimum number of points to certain categories as Health), "maxpts" (minimum number of points for general categories as pubs, restaurants etc).
I did a test only through leaflet (without shiny) and the code runs smoothly, but once I bring-in shiny, I'm not able to make it work
the idea is that the user can modify these 3 variables on the side panel, and click an action button in order to trigger the calculation.
#----------LIBRARIES----------#
library(plyr)
library(geosphere)
library(dbscan)
library(osmdata)
library(sf)
library(tidyr)
library(sp)
library(rgdal)
library(leaflet)
library(shiny)
#-------LOAD FILES-------#
OSM_merged <- read.csv(file = "C:\\Users\\jsainz\\Documents\\R\\Shiny_test\\OSM_merged.csv")
OSM_points <- OSM_merged
OSM_points$color <- OSM_points$category
OSM_points$color <- str_replace_all(OSM_points$color, "Culture", "#3073A")
OSM_points$color <- str_replace_all(OSM_points$color, "Educational", "# 887CAF")
OSM_points$color <- str_replace_all(OSM_points$color,"Financial", "#540002")
OSM_points$color <- str_replace_all(OSM_points$color,"Health", "#D6E899")
OSM_points$color <- str_replace_all(OSM_points$color,"Leisure", "#D2D68D")
OSM_points$color <- str_replace_all(OSM_points$color,"Office", "#D3696C")
OSM_points$color <- str_replace_all(OSM_points$color,"Shop", "#AA9739")
OSM_points$color <- str_replace_all(OSM_points$color,"Sport", "#378B2E")
OSM_points$color <- str_replace_all(OSM_points$color,"Sustain", "#554600")
OSM_points$color <- str_replace_all(OSM_points$color,"Toursim", "#5FAE57")
xy <- OSM_points[,c(2,3)]
OSM_points <- SpatialPointsDataFrame(coords = xy, data = OSM_points,proj4string = CRS("+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"))
#-------FUNCTIONS-------#
assign_clusters <- function(poi_df, minPts = NA) {
if(is.na(minPts)) {
if(poi_df[1, "category"] %in% c("Culture", "Leisure", "Education", "Health", "Financial")) {
minPts <- "minpts"
} else minPts <- "maxpts"
}
eps <- "epsilon"
poi_df[c("lng", "lat")] %>%
distm(fun = distHaversine) %>%
as.dist() %>%
dbscan(eps = eps, minPts = minPts) %>%
.[["cluster"]] %>%
cbind(poi_df, cluster = .)
}
get_hull<- function(df) {
cbind(df$lng, df$lat) %>%
as.matrix() %>%
st_multipoint() %>%
st_convex_hull() %>%
st_sfc(crs = 4326) %>%
{st_sf(category = df$category[1], cluster = df$cluster[1], geom = .)}
}
hulls <- function(df) {
df %>%
split(.$cluster) %>%
map(get_hull)
}
#----------SHINY CODE----------#
ui <- fluidPage(
titlePanel("Jorge_Test"),
sidebarPanel(
numericInput(inputId = "epsilon", label = "distance in meters to calculate activity clusters", 200),
numericInput(inputId = "minpts", label = "minimum points to calculate clusters", 5),
numericInput(inputId = "maxpts", label = "maximum points to calculate clusters", 10),
actionButton("run", "Run Calculation"),
actionButton("view", "generate plan"),
width = 2),
mainPanel(
leafletOutput("mymap", width = 1550, height = 850)
)
)
server <- function(input, output, session) {
output$mymap <- renderLeaflet({
leaflet("mymap")%>%
setView(lng = 0.0982, lat = 51.7674, zoom = 15)%>%
addProviderTiles(providers$CartoDB.Positron, options = providerTileOptions(noWrap = TRUE))%>%
addCircleMarkers(data = OSM_points,
radius = .7,
popup = ~category,
color = ~color)})
oberveEvent(input$run, {
updateNumericInput(session, "epsilon")
updateNumericInput(session, "minpts")
updateNumericInput(session, "maxpts")
})
Clean_data <- OSM_merged %>%
split(OSM_merged$category) %>%
map_df(assign_clusters)
hulls_cat <- Clean_data %>%
group_by(category) %>%
summarise()
map_cluster_hulls <- Clean_data %>%
filter(cluster != 0) %>%
select(lng, lat, category, cluster) %>%
split(.$category) %>%
map(hulls)
mdata <- melt(map_cluster_hulls, id = c("category", "cluster", "geom"))
mch <- data.frame(mdata$category, mdata$cluster, mdata$geom)
observeEvent(input$view, {
leafletProxy("mymap", session) %>%
addPolygons(data = mch$geom,
fill = NA,
fillOpacity = .01,
weight = 2,
color = "red",
opacity = .8)
}
)
}
shinyApp(ui, server)
any idea of how to solve it?
here is a link to the OSM_merged.csv file:
https://www.dropbox.com/s/5ok9frcvx8oj16y/OSM_merged.csv?dl=0

R Shiny, how to use highcharts drilldown in shinyapp depending on selectinput widget result?

I am trying to create a drill down chart using highcharts package, the chart must be dependent on the selectinput results.
The current error is
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
the expected or desired output is to get dynamic plot depending on the selected value.
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
b <- c(3,2,5,1,3,5,1,5)
c <- c(4,6,7,7,4,2,1,6)
xxxx <- data.frame(x, y, z, a, b, c, stringsAsFactors = FALSE)
header <- dashboardHeader()
body <- dashboardBody(
selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
zzz<-reactive({
#browser
select(xxxx,one_of(c("x", "y", "z", input$selectid)))})
output$Working <- renderHighchart({
summarized <- zzz() %>%
group_by(x) %>%
summarize(Quantity = sum(!!sym(input$selectid)))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
# This time, click handler is needed.
drilldownHandler <-
JS(
"function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
observeEvent(
#browser
input$ClickedInput, {
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
resemblences <- c("x", "y", "z")
dataSubSet <- reactive({
#browser()
zzz()
})
for (i in 1:length(levels)) {
dataSubSet() <- zzz()[zzz()[[resemblences[i]]] == levels[i],]
}
normalized <- data.frame(category = dataSubSet()[[resemblences[length(levels) + 1]]], amount = input$selectid)
summarized <- normalized %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
nextLevelCodes = lapply(tibbled$name, function(fac) {
paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes
}
session$sendCustomMessage("drilldown", list(
series = list(
type = "column",
name = paste(levels, sep = "_"),
data = list_parse(tibbled)
),
point = input$ClickedInput
))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)

Resources