Saving Multiple HTML files in R - r

I am following this R tutorial here (towards the end of the page) : https://glin.github.io/reactable/articles/examples.html. I would like to make an interactive map that allows you to filter points on the map - i.e. when you click on the table rows, points on the map appear and disappear.
I decided to generate my own data for this problem. I am following the last part where they make a map/table:
library(leaflet)
library(htmltools)
library(crosstalk)
library(reactable)
library(htmlwidgets)
myFun <- function(n = 5000) {
a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}
id = 1:1000
long = 2.2945 + rnorm( 1000, 0.1085246 , 0.1)
lat = 48.8584 + rnorm( 1000, 0.009036273 , 0.1)
my_data_1 = data.frame(id, lat, long, var1 = myFun(1000), var2 = myFun(1000), var3 = myFun(1000) )
Then, I manipulated the data according
brew_sp <- SharedData$new(my_data_1, group = "breweries")
brew_data <- as_tibble(my_data_1) %>%
select(var1, var2, var3) %>%
SharedData$new(group = "breweries")
I then tried to make the map (I added a small change to the map):
map <- leaflet(brew_sp) %>%
addTiles() %>%
addMarkers(clusterOption=markerClusterOptions())
And then the table:
tbl <- reactable(
brew_data ,
selection = "multiple",
filterable = TRUE,
searchable = TRUE,
onClick = "select",
rowStyle = list(cursor = "pointer"),
minRows = 10
)
Then, I put them together and saved the result - this worked fine:
final_file = htmltools::browsable(
htmltools::tagList(map, tbl)
)
htmltools::save_html(tagList(map, tbl), file = "sample.html")
However, here is the problem:
I noticed that when I click on only one of the rows, I notice that everything else still appears on the map. Shouldn't all the other points disappear when only one item is selected?
Could someone show me how to make this map/table look the same way it appears in the tutorial?
Thank you!

Related

Dataframe issue when double clicking on VisNetwork node to run a function

I have a network diagram with a fairly large amount of nodes (~600), each node having some data, including an ID and its name.
I want to be able to run a very simple function when double-clicking on a specific node.
For that purpose, I have followed the instructions from this thread.
Using the code provided:
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)
The codes works well but when I replace the simple nodes and edges dataframe provided as example by my data (much larger network) then the code doesn't work anymore (nothing gets printed in the console when I double-click on any nodes).
Would anyone know why the code is not running with my data ?
Here is the adjustments that should be done to the code below:
load("NodesEdges.RData")
# nodes <- data.frame(id = 1:3, label = 1:3)
# edges <- data.frame(from = c(1,2), to = c(1,3))
Best wishes,
C.
I have tried:
adding more columns to the example nodes/edges (group, value, color, etc.) and the codes still runs well.
restricting my larger nodes/edges dataframes respectively to the "id", "label" and "from", "to" columns (same as example data) but the codes still fails.
I wonder whether the problem comes from the size of the dataframe.

r plotly update button with line plot does not work with add_markers

I have a problem with the joined plot of an updatable line and static markers in R plotly. The line plot is updated via a drop down menu button, which works well on its own. The additional dots in the add_markers function are also correct when the plot is first initialized.
But after the first update, the markers are cut off (to the left side of the plot where the line starts) and remaining markers are modified (y values are different to initial ones).
For the example here the button function is simplified, but the result shows the same strange behavior.
`
sample_df <- tibble::tibble(quarter_date = rep(c("2022-06-30","2022-09-30","2022-12-31"),3),
forecast_value = runif(9,min = 10,max = 16),
forecast_date = c(rep("2022-07-23",3),rep("2022-08-26",3),rep("2022-09-15",3)))
marks = tibble::tibble(dates = c("2022-05-21","2022-06-15","2022-07-02","2022-07-26","2022-08-27"),
values = c(11,13,12,15,14))
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id,df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>%
dplyr::filter(forecast_date == date_id) %>%
dplyr::pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
plotly::plot_ly(x = ~quarter_date) %>%
plotly::add_trace(data = sample_df %>%
dplyr::filter(forecast_date == max(forecast_date)),
#x = ~period_date,
y = ~forecast_value,
type = 'scatter',
mode = 'markers+lines',
name = 'forecasts') %>%
plotly::layout(
title = "Drop down menue",
yaxis = list(title = "y"),
updatemenus = list(
list(
y =1,
x = 0.9,
buttons = create_buttons(sample_df, unique(sample_df$forecast_date))
)
)) %>%
plotly::add_markers(data = marks,
x = ~dates,
y = ~values)
`
I have tried to set a wide xrange, used a second y2 axis and different approaches in the button calculation but nothing works as intended.
Does anyone have a clue why the add_markers is not working correctly after updating the line plot? Any ideas are highly appreciated!
Adding markers aren't the issue. The issue comes from the restyle. When you restyle the plot without designating that you only meant to change one trace, you changed all traces.
The solution is actually quite simple, you just need one more argument in your args call-- the trace number in a list: list(0) in this case. I've commented out your original args call, so you can see the change.
To make this repeatable, I added set.seed(46) before the creation of sample_df.
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id, df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>% filter(forecast_date == date_id) %>%
pull(forecast_value)), list(0)),
# args = list('y', list(df %>%
# filter(forecast_date == date_id) %>%
# pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
Now when you run your plot, you will see that your marker data remains visible.

How to shorten code for "visRemoveNodes" using loop in rstudio

I have constructed multiple protein - protein networks for diseases in shiny app and I ploted them using visnetwork. I found the articulation points for each network and I want to remove them.
My code for a disease looks like this:
output$plot54 <- renderVisNetwork({
alsex <- as.matrix(alsex)
sel1 <- alsex[,1]
sel2 <- alsex[,2]
n10 <- unique(c(sel1,sel2))
n10 <- as.data.frame(n10)
colnames(n10) <- "id"
ed10 <- as.data.frame(alsex)
colnames(ed10) <- c("from", "to", "width")
n10
g <- graph_from_data_frame(ed10)
articulation.points(g)
nodes4 <- data.frame(n10, color = ifelse(n10$id=="CLEC4E"|n10$id=="ACE2"|n10$id=="MYO7A"|n10$id=="HSPB4"
|n10$id=="EXOSC3"|n10$id=="RBM45"|n10$id=="SPAST"|n10$id=="ALMS1"|n10$id=="PIGQ"
|n10$id=="CDC27"|n10$id=="GFM1"|n10$id=="UTRN"|n10$id=="RAB7B"|n10$id=="GSN"|n10$id=="VAPA"|n10$id=="GLE1"
|n10$id=="FA2H"|n10$id=="HSPA4"|n10$id=="SNCA"|n10$id=="RAB5A"|n10$id=="SETX","red","blue"))
visNetwork(nodes4, ed10, main = "Articulation Points") %>%
visNodes (color = list(highlight = "pink"))%>%
visIgraphLayout()%>%
visOptions(highlightNearest = list(enabled = T, hover = T),
nodesIdSelection = T)%>%
visInteraction(keyboard = TRUE)
})
observe({
input$delete54
visNetworkProxy("plot54") %>%
visRemoveNodes(id="CLEC4E")%>%visRemoveEdges(id = "CLEC4E")%>%
visRemoveNodes(id="ACE2")%>%visRemoveEdges(id = "ACE2")%>%
visRemoveNodes(id="MYO7A")%>%visRemoveEdges(id = "MYO7A")%>%
visRemoveNodes(id="HSPB4")%>%visRemoveEdges(id = "HSPB4")%>%
visRemoveNodes(id="EXOSC3")%>%visRemoveEdges(id = "EXOSC3")%>%
visRemoveNodes(id="RBM45")%>%visRemoveEdges(id = "RBM45")%>%
visRemoveNodes(id="SPAST")%>%visRemoveEdges(id = "SPAST")%>%
visRemoveNodes(id="ALMS1")%>%visRemoveEdges(id = "ALMS1")%>%
visRemoveNodes(id="PIGQ")%>%visRemoveEdges(id = "PIGQ")%>%
visRemoveNodes(id="CDC27")%>%visRemoveEdges(id = "CDC27")%>%
visRemoveNodes(id="GFM1")%>%visRemoveEdges(id = "GFM1")%>%
visRemoveNodes(id="UTRN")%>%visRemoveEdges(id = "UTRN")%>%
visRemoveNodes(id="RAB7B")%>%visRemoveEdges(id = "RAB7B")%>%
visRemoveNodes(id="GSN")%>%visRemoveEdges(id = "GSN")%>%
visRemoveNodes(id="VAPA")%>%visRemoveEdges(id = "VAPA")%>%
visRemoveNodes(id="GLE1")%>%visRemoveEdges(id = "GLE1")%>%
visRemoveNodes(id="FA2H")%>%visRemoveEdges(id = "FA2H")%>%
visRemoveNodes(id="HSPA4")%>%visRemoveEdges(id = "HSPA4")%>%
visRemoveNodes(id="SNCA")%>%visRemoveEdges(id = "SNCA")%>%
visRemoveNodes(id="RAB5A")%>%visRemoveEdges(id = "RAB5A")%>%
visRemoveNodes(id="SETX")%>%visRemoveEdges(id = "SETX")
})
Using
g <- graph_from_data_frame(ed10)
articulation.points(g)
I found the articulation points, and I marked them with red color using ifelse as you can see in nodes4 vector.
My questions:
How to shorten my code in ifelse using loop, so I don't have to write the articullation points one by one manually.
How to shorten my code in visRemoveNodes and visRemoveEdges using loop, so I don't have to write them one by one manually as well.
Crossed posted at:
https://community.rstudio.com/t/how-to-shorten-code-for-visremovenodes-using-loop/72506
The answer for the second question is:
observe({
l <- c("CLEC4E","ACE2", "MYO7A", "HSPB4", "EXOSC3", "RBM45","SPAST","ALMS1",
"PIGQ","CDC27","GFM1","UTRN",
"RAB7B", "GSN", "VAPA", "GLE1","FA2H","HSPA4",
"SNCA","RAB5A","SETX") #we put all genes that we want to delete in a vector
for (i in l){
input$delete54
visNetworkProxy("plot54")%>%
visRemoveNodes(id= i)%>%visRemoveEdges(id = i)
}
})

(R) Edit Gradient Color of Cells Behind Multiple Columns of Data In Data Table

I asked a similar question a few days ago and have made some progress by talking with some people, but I need a little more help to get this to the point I wanted. So here's where I am:
I want to have a data table of a certain size with columns of data (different scales) and be able to apply a color range (kind of like a heat map) to the values in the cells of the data table depending on how large or small the values in the columns are.
Here is some code that was provided to me:
library(DT)
testrun <- round(runif(100), 6)
data <- data.frame(testrun = testrun)
brks <- quantile(data$testrun, probs = seq(.05, .95, .01), na.rm = TRUE)
clrs_df <- colorRamp(c("white","blue"))(c(0,brks)) %>%
as_tibble(.name_repair ="minimal") %>%
setNames(nm=c("r","g","b")) %>%
mutate_all(~as.character(round(.,digits=0))) %>%
mutate(mycolor=paste0("rgb(",paste(r,g,b,sep = ","),")"))
clrs <- pull(clrs_df,mycolor)
DT::datatable(data,rownames=TRUE,options = list(lengthChange = FALSE, dom='t')) %>%
formatStyle(colnames(data), backgroundColor = styleInterval(brks, clrs))
The above example works for one column of data, but I intend to have multiple columns of data for which I want these color gradients to apply to each column individually.
I've tried substituting mtcars for testrun in the assignment portion of the code and in the brks assignment line, but it just leaves me with a table with no colors applied.
Can someone help point me in the right direction? Any help would be appreciated!
Thank you!
I think you want:
library(DT)
data <- data.frame(
C1 = rnorm(100),
C2 = rgamma(100, 10, 10)
)
dtable <- datatable(data, rownames=TRUE, options = list(lengthChange = FALSE, dom='t'))
colRamp <- colorRamp(c("white","blue"))
for(column in names(data)){
x <- na.omit(data[[column]])
brks <- quantile(x, probs = seq(.05, .95, .01))
RGB <- colRamp(c(0, (brks-min(x))/(max(x)-min(x))))
clrs <- apply(RGB, 1, function(rgb){
sprintf("rgb(%s)", toString(round(rgb,0)))
})
dtable <- dtable %>%
formatStyle(column, backgroundColor = styleInterval(brks, clrs))
}
dtable

R- visNetwork - graph doesn't show edges

I have a code that looks like this:
setwd("C:/Users/Evangelista/Desktop/v1")
require(visNetwork)
require(dplyr)
require(shiny)
require(magrittr)
graf.info = read.csv("nodes.csv")
id <- rownames(graf.info)
graf.info <- (cbind(id=id, graf.info))
graf.powiazania = read.csv("edges.csv")
visNetworkNodes <- data.frame(graf.info) %>%
mutate(id=graf.info$id,
label = nazwa_agenta,
title = nazwa_agenta)
visNetworkLinks <- data.frame(from = graf.powiazania$From,
to = graf.powiazania$To,
width = 50,
arrows = list(to = list(enabled = TRUE, scaleFactor = 4)))
net <- visNetwork(nodes = visNetworkNodes,
edges = visNetworkLinks,
height = "600px",
width = "800px")
net
And my problem is that the graph doesn't display any edges. My data is taken from csv file and it looks like this:
I don't know what is wrong with it. My data looks correct to me, data frame with nodes also has the column id. Data frame with edges has "From" and "To" columns. I run out of ideas what went wrong.
I found a solution :
visNetworkNodes <- data.frame(graf.info) %>%
mutate(id=graf.info$nazwa_agenta, <------here i changed 'id' to 'nazwa_agenta'
label = nazwa_agenta,
title = nazwa_agenta)

Resources