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

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

RjpWiKi より引用

ggplot2 でツールチップを表示する

参考サイト [1] に、ggplot2 で描画したプロットのデータポイントにマウスのポインタを持っていくと、データポイントの内容をツールチップで表示するスクリプトが紹介されていました。これはインタラクティブにデータ解析をするのに是非活用できるようにしたい機能です。そこで、前回のブログ記事 [2] で紹介した簡単な Shiny アプリ iris-explorer にこのツールチップ機能を加えてみました。

ui.R を下記に示しました。

リスト：ui.R 

fluidPage(
    titlePanel("Iris explorer"),
    sidebarLayout(
        sidebarPanel(
            selectInput(
                inputId = "varX",
                label = "Select the X variable",
                choices = get.choices()),
            selectInput(
                inputId = "varY",
                label = "Select the Y variable",
                choices = get.choices(), selected = 2)
        ),
        mainPanel(
            plotOutput(
                "plot",
                dblclick = "plot_dblclick",
                brush = brushOpts(
                    id = "plot_brush",
                    resetOnNew = TRUE
                ),
                hover = hoverOpts("plot_hover", delay = 100, delayType = "debounce")
            ),
            uiOutput("hover_info")
        )
    )
)

server.R を下記に示しました。

リスト：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 を下記に示しました。

リスト：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)
}

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

 ツールチップを表示した例 

まだ十分に使いこなせるレベルにありませんが、shiny の web アプリでデータ解析をするときに、ズームと併せて必須の機能だと思っていますので、備忘録としてまとめました。

参考サイト

1. Custom interactive CSS/HTML tooltips with ggplot, shiny and R (ggvis like). ($16220) · Snippets · GitLab
2. bitWalk's: R Shiny でプロットのズーム [2019-10-09]

 

 

にほんブログ村