Qlik SenseとShinyでコード進行を丁寧に描くと決めていたよ（Level 2）

概要

データクレンジングの壁に打ちひしがれつつ、できることをやります。
Rでコード進行を丁寧丁寧丁寧に可視化してみる（Level 1）の続きです。

課題対応

成分から曲の逆引きがしたい

そのまんまです。これも、Shiny + Qlik Senseを使えば解決するので、Level 2でやりたいところです。

なんていうことを書いていました。とりあえずこれに対応しました。
もうちょっときれいにしてからかなーと思って、GitHubにはPushしていませんが、アソシエーションルールのShinyを少し上等にしました。ソースは最後にあります。

雰囲気

前回、取得したデータを実はcsvとして保存していたので、これをそのままQlik Senseに読み込ませます。

左側のtitleとかbeforeとかを選択すると、当然ですが絞り込まれます。
これ、非常に残念なのが、なぜかmermaid.js(DiagrammeR)の矢印が出ないんですよね。。。Operaでやってもダメでした。なぜだろうー。Rのバージョンが3.1.3だからなのだろうか。
めげずに検索します。中央の島のF#7sus4、お前はだれだー。


モノクロトウキョーでした。モノクロトウキョー以外にはいませんでした。
一曲だけで島を作ってしまうとは。。。もうちょっと、supportの考え方を見直した方がよいのか。曲数の概念を入れるとか。

気を取り直して、当然、円グラフでもデータを選択することができます。円グラフでDを選ぶと、…

これがサクサクできるのが優秀です。
ちなみに、Dをサカナクション以外でも見てみると、…（confidenceを高くしました）

サカナクションにはD→Aという流れは無いですが、D→Aが結構ありますね。そりゃそうかー。

ざんねんなはなし

さて、もう一つ、Qlik Senseを使えばすぐに解決できるはずの課題があって、

年代やその他条件別の分析

特に小田和正の場合、オフコースの時代と今ではだいぶ色々違うと思うので、たとえばレコードの発売時期とか、アルバムかシングルかとか、そういうデータを付加して見ると面白いような気がします。

これ、それぞれの曲に対して発売時期を付加するだけの簡単なお仕事をすれば、同じように抽出条件に指定できる…つもりでした。しかし、そのデータを取ってくるのがちょっと面倒でした。Wikipediaとか探るのが早いかなーと思いつつ、これはLevel 3以降に回すことにしました。

今回の課題対応、Shinyと組み合わせる（HelloShinyを使う）というのがほぼ全てです。
しかし、地味に「Shinyに対してPostして、新しくURLを訪れた扱いになっても、入力を消させない」というあたりに悲しい努力を要しました。
これが相当地味かつ悲しい努力で、print(paste(input$support, input$confidence))とかいう処理が哀れな感じです。Shinyでアプリを作ろうとすると、たまにreactivityをうまくコントロールできなくて、こうせざるを得ない場合があります。これは、もう少しShinyの勉強をするしかないのかー。

ソース

ui.R

library(shiny)
library(DiagrammeR)
shinyUI(fluidPage(
  singleton(tags$head(HTML(
    '
    <script type="text/javascript">
    $(document).ready(function() {
      // creates a handler for our special message type
      Shiny.addCustomMessageHandler("api_url", function(message) {
        // set up the the submit URL of the form
        var shiny_test = document.getElementById("shiny_test")
        shiny_test.innerHTML = "http://127.0.0.1:7458/" + message.url;
      });
    })
    </script>
    '
  ))),
  uiOutput("hideScript"),
  div(id="keydiv",style="display:none;",
    HTML("<span id='shiny_test'></span>")
  ),
  div(id="tablediv",
    numericInput("support", "support", 0.90),
    numericInput("confidence", "confidence", 0.50),
    DiagrammeROutput("mermaidtest")
    #,dataTableOutput("tabletest")
  )
))

server.R

library(shiny)
library(stringr)
library(arules)
library(DiagrammeR)

df.test <- data.frame(a=1,b=2)

shinyServer(function(input, output, session) {
  output$hideScript <- renderText({
    query <- parseQueryString(session$clientData$url_search)
    if("key" %in% names(query)){
      "<script>$('#keydiv').css('display','none');</script>"
    } else {
      "<script>$('#tablediv').css('display','none');$('#keydiv').css('display','block');</script>"
    }
  })

  #output$tabletest <- renderDataTable(getRule())

  output$mermaidtest <- renderDiagrammeR(mermaid(getDiagramExpr()))

  getRule <- function(support, confidence){
    tryCatch({
      setTimeLimit(5,5)
      df <- data.frame(before=df.test[[2]], after=df.test[[3]])
      colnames(df)<-c("before","after")
      #print(df)
      d <- apriori(as(df,"transactions"), parameter=list(support=support, confidence=confidence))
      setTimeLimit(Inf,Inf)
    },error=function(e){
      setTimeLimit(Inf,Inf)
      stop(e)
    })
    e <- as(d,"data.frame")
    e$LHS <- str_replace_all(e$rules,"=>.+","")
    e$RHS <- str_replace_all(e$rules,".+=>","")
    e
  }

  getDiagramExpr <- function(){
    if(redirectFlg == T){
      redirectFlg <<- F
    } else {
      t_support <<- input$support
      t_confidence <<- input$confidence
    }
    tryCatch({
      updateNumericInput(session, "support", value = t_support)
      updateNumericInput(session, "confidence", value = t_confidence)
    }, error=function(e){
      t_support <<- input$support
      t_confidence <<- input$confidence
    })
    print(paste(input$support, input$confidence))
    e <- getRule(t_support, t_confidence)
    nodes <- e[!is.na(str_match(e$LHS, "before")),]
    nodes$LHS <- nodes$LHS %>% str_replace_all("\\{before=","") %>% str_replace_all("\\}","")
    nodes$RHS <- nodes$RHS %>% str_replace_all("\\{after=","") %>% str_replace_all("\\}","")
    nodes$mermaid <- paste0(nodes$LHS, "-->|", (floor(nodes$confidence*1000)/10), "%|", nodes$RHS)
    nodes$mermaid <- str_replace_all(nodes$mermaid, "♭", "b")
    str <- paste("graph TD",Reduce(function(...){paste(...,sep="\n")},nodes$mermaid),sep="\n")
    str
  }

  api_url <- session$registerDataObj( 
    name   = 'api', # an arbitrary but unique name for the data object
    data   = list(), # you can bind some data here, which is the data argument for the
    # filter function below.
    filter = function(data, req) {
      # print(ls(req))  # you can inspect what variables are encapsulated in this req
      # environment
      if (req$REQUEST_METHOD == "GET") {
        # handle GET requests
        query <- parseQueryString(req$QUERY_STRING)

      } 

      if (req$REQUEST_METHOD == "POST") {
        # handle POST requests here
        reqInput <- req$rook.input

        # data must be one line and must be the form of http://www.yoheim.net/blog.php?q=20120611
        strs <- paste0("?key=T")
        datastr <- reqInput$read_lines(1)
        str_split(datastr, "\\&")
        data <- parseQueryString(datastr)
        for(i in 1:length(data)){
          data[[i]] <- str_split(iconv(data[[i]],"utf-8","cp932"),",")
        }
        df.test <<- data
        buf <- paste0(
          '<HEAD><META HTTP-EQUIV="Refresh" CONTENT="0; URL=http://127.0.0.1:7458/',strs,
          '" /></HEAD>')
        redirectFlg <<- T
        shiny:::httpResponse(
          status=200, content_type='text/html', content=buf
        )
      }          
    }
  )

  # because the API entry is UNIQUE, we need to send it to the client
  # we can create a custom pipeline to convey this message
  session$sendCustomMessage("api_url", list(url=api_url))
})

まとめ

さくさくとQlik Sense + Shinyで遊べますが、微妙な課題も色々と残りました。
矢印が出ないとか、Reactiveで変な書き方しないといけないとか、曲数の概念を反映した方がいいかもしれないとか、発売年月日や累積販売枚数その他の情報を簡単に拾う方法を検討するとか。
これはLevel 3以降で対応することにしませう。

おわり

たのしめ！