R Shiny のプロットにツールチップを表示する (2)

Shiny は R のパッケージの一つで、 このパッケージを使うと R を用いて対話的に操作する Web アプリケーションを作成することができます。Web 上のユーザーインタフェース部分を司る ui.R と、内部動作を司る server.R の二つの R 言語スクリプトで、サーバーサイドのコンテンツを作成できることが大きな特徴です。

RjpWiKi より引用

UI のレイアウトを変えるとツールチップの表示がズレる！

ブログ記事 [1] で、プロットされたデータ点にマウスのポインタを近づけると、データ点に関係する情報をツールチップで表示する、という機能が実装できて喜んだのも束の間、問題を出ました。

 ツールチップを表示した例（参考サイト [1]） 

レイアウトを変えてプロットの上にウィジェットを配置すると、ツールチップが表示される位置がとんでもなくズレてしまうのです（下図）。

 レイアウトを変えてツールチップを表示した例 

改良版

マウスのポインタの座標を取得する仕組みを理解できておらず、どのようにすれば解決できるのかが皆目判らなかったので、とにかく他の方々がどのようにツールチップを表示させているのかをインターネットで探し続けると、参考サイト [2] にヒントがありました。

ui.R を下記に示しました。プロットを表示するブロックに、CSS のスタイル position: relative; を加えることでズレを解消できました。

リスト：ui.R 

fluidPage(
    fluidRow(
        titlePanel("Iris explorer"),
        selectInput(
            inputId = "varX",
            label = "Select the X variable",
            choices = get.choices()),
        selectInput(
            inputId = "varY",
            label = "Select the Y variable",
            choices = get.choices(), selected = 2)
    ),
    hr(),
    fluidRow(
        style = "position: relative;",
        plotOutput(
            outputId = "plot",
            dblclick = "plot_dblclick",
            brush = brushOpts(
                id = "plot_brush",
                resetOnNew = TRUE
            ),
            hover = hoverOpts("plot_hover", delay = 100, delayType = "debounce")
        ),
        uiOutput("hover_info")
    )
)

server.R を下記に示しました（参考サイト [1] と同じ）。

リスト：server.R 

function(input, output) {
    ranges <- reactiveValues(x = NULL, y = NULL)
    var.x <- reactive(iris[, as.numeric(input$varX)])
    var.y <- reactive(iris[, as.numeric(input$varY)])
    label.x <- reactive(names(iris[as.numeric(input$varX)]))
    label.y <- reactive(names(iris[as.numeric(input$varY)]))
    
    output$plot <- renderPlot({
        ggplot(iris, aes(x = var.x(), y = var.y(), colour = Species)) +
            xlab(label.x()) + ylab(label.y()) + 
            coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = FALSE) +
            geom_point(size = 4) + gtheme
    })
    
    observeEvent(input$plot_dblclick, {
        brush <- input$plot_brush
        if (!is.null(brush)) {
            ranges$x <- c(brush$xmin, brush$xmax)
            ranges$y <- c(brush$ymin, brush$ymax)
        } else {
            ranges$x <- NULL
            ranges$y <- NULL
        }
    })
    
    output$hover_info <- renderUI({
        hover <- input$plot_hover
        point <- nearPoints(iris, hover, xvar = label.x(), yvar = label.y(), threshold = 5, maxpoints = 1, addDist = TRUE)
        if (nrow(point) == 0) return(NULL)
        
        wellPanel(
            style = get.style(hover),
            p(HTML(paste0("<b> Species: </b>", point$Species, "<br/>",
                          "<b> ", label.x(), ": </b>", point[, label.x()], "<br/>",
                          "<b> ", label.y(), ": </b>", point[, label.y()], "<br/>")))
        )
    })
}

global.R を下記に示しました（参考サイト [1] と同じ）。

リスト：global.R 

library(shiny)
library(ggplot2)

gtheme <- theme(
    axis.title = element_text(size = 16),
    axis.text = element_text(size = 16),
    axis.line = element_line(),
    legend.title =  element_text(size = 14),
    legend.text = element_text(size = 14),
    panel.grid.major = element_line(colour="grey",size = rel(0.5)), 
    panel.grid.minor = element_blank(), 
    panel.background = element_rect(fill = "whitesmoke")
)

get.choices <- function() {
    part.iris <- list()
    for (item in names(iris)) {
        if (item != "Species") {
            part.iris[[item]] <- grep(item, names(iris))
        }
    }
    return(part.iris)
}

get.left_px <-  function(hover) {
    left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
    left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
    return(left_px)
}

get.top_px <-  function(hover) {
    top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom)
    top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
    return(top_px)
}

get.style <- function(hover) {
    style <- paste0("position: absolute; z-index: 100; ",
                    "left:", get.left_px(hover) + 2, "px; ",
                    "top:", get.top_px(hover) + 2, "px; ",
                    "background-color: rgba(245, 245, 245, 0.75); ",
                    "font-family: monospace;")
    return(style)
}

下記に実行例を示しました。

 ツールチップを表示した例（改良版） 

無事解決できましたが、正直、なんとなくコツをつかめたというレベルです。

参考サイト

1. bitWalk's: R Shiny のプロットにツールチップを表示する [2019-10-10]
2. Shiny でマウスの位置に応じてプロットにツールチップを表示する | Atusy's blog [2019-08-06]

 

 

にほんブログ村