以下代码将在数据表中创建“火花线”图。我想重新设计代码，以便在鼠标悬停时在小的弹出屏幕（如工具提示）中显示“火花线”图。
我已经通过了'showModal'函数，但是无法实现。谢谢。
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)
答案 0 :(得分：0)
以下代码大致完成了它的工作。欢迎任何建议（特别是自动关闭）。
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)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s 50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
max_val,color1,max_val,color1,color2,color2,max_val,max_val))
}
# 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)
答案 1 :(得分：0)
这是做同一件事的另一种方式。
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)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s 50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
max_val,color1,max_val,color1,color2,color2,max_val,max_val))
}
#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)