Does any one know how to put Javascript with namespace in R Shiny?
I create a Shiny module to add draggable text to Sankey plot, right click at the text will give an option to remove it from the plot. Everything works well except the add text button. I guess it’s due to the namespace issue. Can anyone find a solution for this?
I tried different ways without being able to resolve it
mod_graph_sankey_ui <- function(id) {
ns <- NS(id)
tabItem(
id,
shinydashboardPlus::box(
width = 12,
title = "File Upload (Node ID variable must be successive integers start from 0)",
collapsible = TRUE,
dropdownMenu = reset_dropdown(ns("reset_file")),
fluidRow(
column(6, fileInput(ns("sankey"), "Choose an input file",
accept = file_accept))
),
fluidRow(
column(2, selectInput(ns("sankey_node"), "Node", NULL)),
column(2, selectInput(ns("sankey_node_id"), "Node ID", NULL)),
column(2, selectInput(ns("sankey_source"), "Source", NULL)),
column(2, selectInput(ns("sankey_target"), "Target", NULL)),
column(2, selectInput(ns("sankey_value"), "Value", NULL))
)
),
shinydashboardPlus::box(width = 12,
title = "Plot Parameter",
collapsible = TRUE,
fluidRow(
column(3, numericInput(ns('height'), "Plot Height", 400, min=400, max=8000, step=100)),
column(3, numericInput(ns('width'), "Plot Width", 900, min=400, max=2000, step=100)),
column(3, numericInput(ns('node_weight'), "Node Weight", 10, min=1, max=20, step=1)),
column(3, numericInput(ns('pad'), "Node Pad", 15, min=5, max=30, step=1)),
column(3, numericInput(ns('transparency'), "Transparency", 0.6, min=0.1, max=1, step=0.1)),
column(9, textInput(ns('title'), "Title", NULL))
)
),
shinydashboardPlus::box(width = 12,
collapsible = TRUE,
title = 'Customize the Colors for Sources',
fluidRow(
column(12, uiOutput(ns("color_input")))
)
),
tags$head(
tags$script(HTML('
Shiny.addCustomMessageHandler("#{ns("addDraggableText")}", function(message) {
console.log("Updating text:", newText.id);
Plotly.update(newText.id, { textfont: { size: newSize } });
var text = message.text;
var x = message.x;
var y = message.y;
var id = message.id;
var newText = document.createElement("div");
newText.style.position = "absolute";
newText.style.left = x + "px";
newText.style.top = y + "px";
newText.style.cursor = "move";
newText.innerText = text;
newText.id = id;
newText.addEventListener("mousedown", function(e) {
var posX = e.clientX;
var posY = e.clientY;
document.onmousemove = function(e) {
var dx = e.clientX - posX;
var dy = e.clientY - posY;
posX = e.clientX;
posY = e.clientY;
newText.style.left = (newText.offsetLeft + dx) + "px";
newText.style.top = (newText.offsetTop + dy) + "px";
}
document.onmouseup = function() {
document.onmousemove = document.onmouseup = null;
}
});
// Add context menu
newText.addEventListener("contextmenu", function(e) {
e.preventDefault();
var menu = document.createElement("div");
menu.id = "contextMenu";
menu.style.position = "absolute";
menu.style.left = e.clientX + "px";
menu.style.top = e.clientY + "px";
var fontSizeOption = document.createElement("div");
fontSizeOption.innerText = "Change Font Size";
fontSizeOption.addEventListener("click", function() {
var newSize = prompt("Enter new font size:");
if (newSize !== null) {
Plotly.update(newText.id, {textfont: {size: newSize}});
}
menu.remove();
});
var removeOption = document.createElement("div");
removeOption.innerText = "Remove Text";
removeOption.addEventListener("click", function() {
newText.remove();
menu.remove();
});
menu.appendChild(fontSizeOption);
menu.appendChild(removeOption);
document.body.appendChild(menu);
});
document.getElementById("#{ns("sankey_plot")}").appendChild(newText);
});
'))
),
titlePanel("Draggable Text on Graph"),
sidebarLayout(
sidebarPanel(
textInput(ns("text"), "Enter Text"),
actionButton(ns("addText"), "Add Text to Graph"),
textOutput(ns("removeInstruction")),
),
shinydashboardPlus::box(width = 12,
title = "Sankey Plot",
plotlyOutput(ns("sankey_plot"))
)
)
)
}
mod_graph_sankey_server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues(
df_sankey = NULL,
)
#Function to create Tepee plot
sankey <- function(indata)
{
#var1 <- input$sankey_node
#print(var1)
#input_data <- indata
input_data <- indata %>%
mutate(node := !!sym(input$sankey_node)) %>%
mutate(node_id := !!sym(input$sankey_node_id)) %>%
mutate(source := !!sym(input$sankey_source)) %>%
mutate(target := !!sym(input$sankey_target)) %>%
mutate(value := !!sym(input$sankey_value))
input_data <- select(input_data, node, node_id, source, target, value)
#######################################################################################
##################################### Create plot #####################################
#######################################################################################
# input_data$source contains integers which represent node, need to get node names to be displayed in
# color selection section, so user knows which node he/she is choosing color for
node_name <- input_data %>%
select(node_id, node) %>%
subset(node!='' & !is.na(node)) %>%
arrange(node_id)
# This data frame contains all node which may not be source
source_name <- rename(node_name, source=node_id)
# After merge, this data frame contains only the node which can be source
source_name <- merge(source_name, select(input_data, source), by='source')
source_name_dedup <- source_name %>%
distinct(source, .keep_all = TRUE) %>%
arrange(source)
# Node can relate to different Node ID, this happens when a therapy (represented by node) can be displayed at
# the 1st LOT, 2nd LOT, etc. In this case, links flow from them will use the same color.
funs <- unique(source_name$node)
default_color <- colors()
cols <- reactive({
lapply(seq_len(length(funs)), function(i) {
column(3, colourInput(ns(paste("col", i, sep="_")), funs[i], default_color[i]) )
})
})
output$color_input <- renderUI({cols()})
# Put all the input in a vector
colors2 <- reactive({
lapply(seq_len(length(funs)), function(i) {
input[[paste("col", i, sep="_")]]
})
})
updated_color <- unlist(colors2())
req(updated_color)
default_color <- updated_color
if (length(default_color) != length(funs)) {default_color<-colors()}
updated_color2 <- paste(sapply(updated_color, function(x)
{paste0("rgba(", paste(c(col2rgb(x), input$transparency), collapse = "," ), ")") }
), collapse = ", ")
updated_color3 <- vector(length = length(funs))
test <- strsplit(updated_color2, split=', ')
for (i in 1:length(funs)) {
updated_color3[i] <- test[[1]][i]
}
color_data <- data.frame(node=unique(source_name$node),
link_color=updated_color3)
# Due to the fact that node can relate to different Node ID, in the above data frame, we use
# node=unique(source_name$node) instead of source=unique(source_name$source)
# Now, need to merge back to get source (which are integers)
color_data <- merge(color_data, source_name_dedup, by='node')
input_data <- merge(input_data, select(color_data, -c('node')), by='source', all.x=T)
# Create plot
p <- plot_ly(
type = "sankey",
domain = c(
x = c(0,1),
y = c(0,1)
),
orientation = "h",
valueformat = ".0f",
valuesuffix = " ",
node = list(
label = node_name$node,
color = 'black',
pad = input$pad,
thickness = input$node_weight,
line = list(
color = "black",
width = 0.5
)
),
link = list(
source = input_data$source,
target = input_data$target,
value = input_data$value,
color = input_data$link_color
)
) %>%
layout(
title = input$title,
height = input$height,
width = input$width,
font = list(
size = 12
),
xaxis = list(showgrid = F, zeroline = F, showticklabels = F),
yaxis = list(showgrid = F, zeroline = F, showticklabels = F)
)
# ggplotly(p, height=input$height)
p
}
#End of the plot function
observe({
req(input$sankey)
rv$df_sankey <- upload_file(input$sankey)
})
# Reset fileInputs
observeEvent(input$reset_file, {
rv$df_sankey <- NULL
reset("sankey")
})
main1 <- reactive({
req(rv$df_sankey)
process_file(rv$df_sankey)
})
observeEvent(input$sankey, {
var_name <- names(rv$df_sankey)
default_node <- grep("^la", var_name, TRUE, value = TRUE)
default_node_id <- grep("^lid", var_name, TRUE, value = TRUE)
default_source <- grep("^s", var_name, TRUE, value = TRUE)
default_target <- grep("^t", var_name, TRUE, value = TRUE)
default_value <- grep("^v", var_name, TRUE, value = TRUE)
updateSelectInput(session, "sankey_node", choices = var_name, selected=default_node)
updateSelectInput(session, "sankey_node_id", choices = var_name, selected=default_node_id)
updateSelectInput(session, "sankey_source", choices = var_name, selected=default_source)
updateSelectInput(session, "sankey_target", choices = var_name, selected=default_target)
updateSelectInput(session, "sankey_value", choices = var_name, selected=default_value)
})
output$removeInstruction <- renderText({
"Right-click on the text to access the context menu for additional options."
})
##############################################################################################################
###Generate Plot Parameter Input Box (X-axis range, step by value) depend on which efficacy data you upload###
##############################################################################################################
observe({
output$sankey_plot <- renderPlotly({
sankey_data <- main1()
req(sankey_data)
sankey(indata=sankey_data)
})
})
observeEvent(input$addText, {
text <- input$text
x <- 0
y <- 0
id <- paste0("text_", format(Sys.time(), "%H%M%S"))
print(text)
print(x)
print(y)
print(id)
if (nchar(text) > 0) {
session$sendCustomMessage("addDraggableText", list(text = text, x = x, y = y, id = id))
}
})
})
}
A simplified version without using namespace works well:
library(shiny)
library(plotly)
ui <- fluidPage(
tags$head(
tags$script(HTML('
Shiny.addCustomMessageHandler("addDraggableText", function(message) {
var text = message.text;
var x = message.x;
var y = message.y;
var id = message.id;
var newText = document.createElement("div");
newText.style.position = "absolute";
newText.style.left = x + "px";
newText.style.top = y + "px";
newText.style.cursor = "move";
newText.innerText = text;
newText.id = id;
newText.addEventListener("mousedown", function(e) {
var posX = e.clientX;
var posY = e.clientY;
document.onmousemove = function(e) {
var dx = e.clientX - posX;
var dy = e.clientY - posY;
posX = e.clientX;
posY = e.clientY;
newText.style.left = (newText.offsetLeft + dx) + "px";
newText.style.top = (newText.offsetTop + dy) + "px";
}
document.onmouseup = function() {
document.onmousemove = document.onmouseup = null;
}
});
// Add context menu
newText.addEventListener("contextmenu", function(e) {
e.preventDefault();
var menu = document.createElement("div");
menu.id = "contextMenu";
menu.style.position = "absolute";
menu.style.left = e.clientX + "px";
menu.style.top = e.clientY + "px";
var fontSizeOption = document.createElement("div");
fontSizeOption.innerText = "Change Font Size";
fontSizeOption.addEventListener("click", function() {
var newSize = prompt("Enter new font size:");
if (newSize !== null) {
Plotly.update(newText.id, {textfont: {size: newSize}});
}
menu.remove();
});
var removeOption = document.createElement("div");
removeOption.innerText = "Remove Text";
removeOption.addEventListener("click", function() {
newText.remove();
menu.remove();
});
menu.appendChild(fontSizeOption);
menu.appendChild(removeOption);
document.body.appendChild(menu);
});
document.getElementById("plot").appendChild(newText);
});
'))
),
titlePanel("Draggable Text on Sankey Diagram"),
sidebarLayout(
sidebarPanel(
textInput("text", "Enter Text"),
actionButton("addText", "Add Text to Sankey"),
textOutput("removeInstruction")
),
mainPanel(
plotlyOutput("plot")
)
)
)
server <- function(input, output, session) {
output$removeInstruction <- renderText({
"Right-click on the text to access the context menu for additional options."
})
output$plot <- renderPlotly({
# Sample Sankey diagram
fig <- plot_ly(
type = "sankey",
domain = c(
x = c(0,1),
y = c(0,1)
),
orientation = "h",
node = list(
label = c("A", "B", "C", "D", "E")
),
link = list(
source = c(0, 1, 0, 2, 3),
target = c(2, 3, 4, 4, 4),
value = c(8, 4, 2, 8, 4)
)
)
fig
})
observeEvent(input$addText, {
text <- input$text
x <- 100 # X-coordinate for initial position
y <- 100 # Y-coordinate for initial position
id <- paste0("text_", format(Sys.time(), "%H%M%S"))
print(text)
print(x)
print(y)
print(id)
if (nchar(text) > 0) {
session$sendCustomMessage("addDraggableText", list(text = text, x = x, y = y, id = id))
}
})
}
shinyApp(ui, server)
enter image description here
