Clash Royale CLAN TAG#URR8PPP

How to create a popup for 'sparkline' object in a datatable?

The following code will create a 'Sparkline' plot in the datatable. I want to reform the code so that it show the 'Sparkline' plot in a small popup screen (like a tool tips) on mouse hover.

I have gone through the 'showModal' function but could not implement. Thanks.

require(sparkline)
require(DT)
require(shiny)
require(dplyr)


ui <- fluidPage(
sparklineOutput("ooooooooo"),
DT::dataTableOutput("tbl")
)

server <- function(input, output)

df <- data.frame(
season = rep(1992:1993, each=5),
result = c(1,0,1,-1,0,0,1,1,0,-1),
goals = c(2,0,1,0,3,0,2,3,1,0)
)
x = df %>%
group_by(season) %>%
summarize(
result = paste(result, collapse = ","),
goals = paste(goals, collapse = ",")
)
columnDefs = list(list(
targets = c(1,2),
render = JS("function(data, type, full)
return '<span class=spark>' + data + '</span>'")
))
fnDrawCallback = JS("function (oSettings, json)
$('.spark:not(:has(canvas))').sparkline('html',
type: 'bar',
highlightColor: 'orange'
);"
)
d1 <- datatable(x,options = list(
columnDefs = columnDefs,
fnDrawCallback = fnDrawCallback
))
output$tbl <- renderSparkline(d1)


shinyApp(ui = ui, server = server)


2 Answers
2

The following code is doing it's job, roughly. Any suggestions are welcome (specially for auto close).

require(sparkline)
require(DT)
require(shiny)
require(dplyr)
require(shinyBS)


ui <- fluidPage(
sparklineOutput("ooooooooo"),
DT::dataTableOutput("tbl"),
uiOutput("plot")
)

server <- function(session, input, output)
# Data Creation
df <- data.frame(
season = rep(1992:1993, each=5),
result = c(100,-20,10,-17,23,-34,111,61,30,-31),
goals = c(-22,30,-15,50,-32,20,-42,13,-11,50)
)
x = df %>%
group_by(season) %>%
summarize(
result = paste(result, collapse = ","),
goals = paste(goals, collapse = ",")
)

# Creating sparkline object into datatable cell
columnDefs = list(list(
targets = c(1,2),
render = JS("function(data, type, full)
return '<span class=spark>' + data + '</span>'")
))
fnDrawCallback = JS("function (oSettings, json)
$('.spark:not(:has(canvas))').sparkline('html',
type: 'bar',
highlightColor: 'orange'
);"
)

# This will return the cell value as output object
callback = JS("/* code for cell content on click */
table.on('mouseenter', 'td', function()
var td = $(this);
var info_out = table.cell( this ).data();
Shiny.onInputChange('hoverIndexJS', info_out);
);"

)
d1 <- datatable(x,options = list(
columnDefs = columnDefs,
fnDrawCallback = fnDrawCallback
), callback = callback)

output$tbl <- renderSparkline(d1)

# function to create butterfly plot
color_from_middle <- function (data, color1,color2)
max_val=max(abs(data))
JS(sprintf("isNaN(parseFloat(value))


# Creating a shiny Popover
observeEvent(input$hoverIndexJS,
toggleModal(session, "bsModel", "open")
)


output$plot <- renderUI(
if(!is.null(input$hoverIndexJS))
df <- data.frame(x = sapply(strsplit(input$hoverIndexJS, ","), as.numeric))
bsModal("bsModel", "sparkline Object: ", "DoNotKnowWhyItIsNeeded", size = "small",
renderDT(datatable(df,rownames = F, colnames=NULL, options = list(dom = "t"))
%>% formatStyle('x',background = color_from_middle(range(df$x), 'red','green'))
)
)


)



shinyApp(ui = ui, server = server)


This is another way to do the same thing.

require(sparkline)
require(DT)
require(shiny)
require(dplyr)
require(shinyBS)


ui <- fluidPage(
sparklineOutput("ooooooooo"),
DT::dataTableOutput("tbl"),
uiOutput("popover")
)

server <- function(session, input, output)
# Data Creation
df <- data.frame(
season = rep(1992:1993, each=5),
result = c(100,-20,10,-17,23,-34,111,61,30,-31),
goals = c(-22,30,-15,50,-32,20,-42,13,-11,50)
)
x = df %>%
group_by(season) %>%
summarize(
result = paste(result, collapse = ","),
goals = paste(goals, collapse = ",")
)

# Creating sparkline object into datatable cell
columnDefs = list(list(
targets = c(2,3),
render = JS("function(data, type, full)
return '<span class=spark>' + data + '</span>'")
))
fnDrawCallback = JS("function (oSettings, json)
$('.spark:not(:has(canvas))').sparkline('html',
type: 'bar',
highlightColor: 'orange'
);"
)

# This will return the cell value as output object
callback = JS("/* code for cell content on click */
table.on('mouseenter', 'td', function()
var td = $(this);
var info_out = table.cell( this ).data();
Shiny.onInputChange('hoverIndexJS', info_out);
);"

)
d1 <- datatable(x,options = list(
columnDefs = columnDefs,
fnDrawCallback = fnDrawCallback
), callback = callback)

output$tbl <- renderSparkline(d1)

# function to create butterfly popover
color_from_middle <- function (data, color1,color2)
max_val=max(abs(data))
JS(sprintf("isNaN(parseFloat(value))


#our modal dialog box
myModal <- function(failed=FALSE)
modalDialog(
renderDT(
if(!is.null(input$hoverIndexJS))
df <- data.frame(x = sapply(strsplit(input$hoverIndexJS, ","), as.numeric))
return(
datatable(df,rownames = F, colnames=NULL, options = list(dom = "t"))
%>% formatStyle('x',background = color_from_middle(range(df$x), 'red','green'))
)

),
easyClose = TRUE
)

#event to trigger the modal box to appear
observeEvent(input$hoverIndexJS,
if(!is.null(input$hoverIndexJS))
showModal(myModal())

)




shinyApp(ui = ui, server = server)


By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.