データ穴リストのブログ

すべては喰いっぱぐれないために

gghighlightがステキすぎることをポエむ。

こんにちは。先日、Tokyo.R#72に参加しました。

報告内容に「穴lytics」なるタイトルの方がいらして、
ヤバい、ライバル出現か!?などとひとり戦慄を覚えた訳ですが、
中身を拝見したら「(人としての、能力的な)欠損」の意味ではなく、
「データの特徴量をTDA(位相的データ分析)で見てみよう」という、
大変高度で私には全くもって手の届かない雲上の層にあらせられる方の報告で、
何をライバル出現などとおこがましいことを考えているんだ
この能力欠損野郎はと、改めて襟を正す思いでした。

普段Tシャツばっか着てるから襟無いんだけどな!
ダメ中年ざまぁ!!

gghighlightの話、あまり無い?

ところで本題なんですが、Tokyo.Rでも散々

  • gghighlightはすご過ぎる
  • gghighlightは神
  • gghighlightと結婚したい

という話が出たり出なかったりだと認識しているんですが、
肝心のgghighlightに関する記述はユタニさんの公式系資料とブログのみで、
なかなか他を見つけられないでいます。

こういうものって製作者に配慮して書かないものなのか?
とかよく分かっていないので、
とにかく愛しのgghighlightについてポエみたい、それが本記事です。

基本のキは本家へどうぞ

もちろんながら、
基本的な使い方についてはユタニさんのブログ等を見ていただくとして、

notchained.hatenablog.com

「こんなこと言ってたからこんな風にしてみたよ!」
ってなことを紹介していきたいと思います。

まぁとりあえず

見本を作ってみる

require(tidyverse)
require(lubridate)
require(gghighlight)

# データを作る(スマートじゃないね…)
dat <- data.frame(hiduke = today() %m-% days(0:364),
                  x1 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE))),
                  x2 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE))),
                  x3 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE))),
                  x4 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE))),
                  x5 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE))),
                  x6 = cumsum(c(sample(1:1000,1), sample(-100:100,364, replace = TRUE)))
                  ) %>% gather(product, val, -hiduke)

p <- 
ggplot(dat, aes(hiduke, val, colour = product))+
  geom_line()

# 基本
p + gghighlight(max(val) > 1500)

特に素晴らしいのはラベル

はい、ラベルです。これがgghighlightをハイライトしたいところです。
なにがいいって、ラベルの自由度の高さだと思っています。

このラベル、複数の変数を重ねられるんですよね。
ggrepelからそうなのかもしれないけど、
正直ggrepelってテキストズラすだけで使いづらいなーと思ってたので、
こんな感じだと万々歳です*1

ということを利用すると、こんな事が出来るわけです。

# 見出しを選択(複数選択&文字列可)
p + gghighlight(max(val) > 1500, label_key = paste0(month(hiduke), "/", day(hiduke),
                                                    "現在\n", 
                                                    product,":", val, "pt"))

f:id:cun-wang:20180904125657p:plain

…分かりますか…?
「グラフの見て欲しい部分を丸で囲ったりして数値を上から書く」とか言う
チマチマした作業が入らなくなるの!!
何というお手軽!何という幸せ!

Excelでも何でも分析結果を人に伝える際には大体皆さん経験あると思いますが、
観測データの定期報告に今まではイチイチ作ったグラフに対して
「ココがこうだ。んだもんで良い/悪い」とかを言葉に変換する作業が必要で、
早い話がくそ面倒なわけです。

僕は、出来ないなりに以下のようなステップで少しずつ進化させて来たのだけれど、

  1. Excelグラフ作成。丸とか四角とかで囲う。んで吹き出しとかつけて説明…
  2. Rでグラフ作成。画像ファイル化してPPT等に貼付けてその後丸以下略
  3. Rmarkdownでダッシュボード自動作成。で、図をPPTに貼り付けて以下略
  4. Rmarkdownでグラフ&スライド一括作成。結果をコメントとして記載

「次はanotateとか使って気になるデータとか強調しようかなー
 でもハイライトしたいトコ選ぶとかだるいなー」とか思ってたので、
このタイミングで出会えたことはまさに僥倖!!!だったわけです。

はい、ほぼコレで言いたいことは大体終わった。 あとは色々試したのを載せ…ようかと思ったけど無駄に長くなるのでそちらはQiitaで。

あ、ちなみにここで「書かなくてよくなった」のは、あくまでも
「結果が(とりあえず観測できた事実として)どうだったか」までであって、
そのあとの洞察(解釈)は別物です。
そんなん流石に自動化できないしそれがあったら僕は用済みだ。

でもこのコメントさえあれば、あとはまぁグラフ見ながら考えられるしなんならその場で解釈してもごまかせる大丈夫!!!*2

あとよくわからないもの

  • use_group_by():コレはggplotの段階でグループ指定してあげなきゃなやつで使う?それともgrouped_dfとかに使う?
  • facetしようとするとしばしばものすごい時間かかってエラーになるかなんなら落ちたりする。やり方がまずいのか、ちょっとケースを整理しなきゃ。

以上ですよ!

*1:多分元々geom_text()でも出来てたから、それと同じと考えればフツーだけど、同じように出来るってことが素晴らしいわけで。

*2:前職の業界用語なのかなんなのか、この辺は「1次コメント」などと呼んでいた。報告書にとりあえず数字の読めるスタッフさんにひたすら書いてもらって、あとで解釈をいれていく、みたいな…。労働集約的だし、自分の身にもならなくてしんどかった。。。

shinyにExcelの代わりをさせよう〜VLOOKUP編〜

こんにちは!

Excel関数大好き、R大好き中年ダメ人間だよ!

ボクとExcelとの出会いは、今の人生の半分より昔、
「生徒会室で校舎の略地図を罫線でかく」ために触れたのが初めてだよ!

そんなボクも、SUM、IF、INDEX、MID、SUMPRODUCT、OFFSETと、数々の関数と夜を共に過ごしてきたけど*1
やっぱりこれまでの人生で一番のExcelでの大仕事は、
Excelのセルサイズを細かな方眼紙状にして当時の職場の事務所引越しのレイアウト案をExcelで作ったことかな!

ちなみに自宅の引越しでも毎回間取り図書いてた!
Excelで!

しかし別れはやってくる

そんなExcel教の私も、Rの便利さに慣れ、なるべく業務のほとんどをRでこなしたくなってきた近年。
出会いがあれば、また別れも訪れるものですね。。。

ということで、なるべくRに触れてたいんだけど、
Excelで50万件のデータ捌けません〜」とか、
「計算中って出て1%進むのに1分くらいかかります〜」とか言われて、
その度にRでJOINさせてあげるなんて雑務をする羽目になったりするので、
「そんなもんRでやれば一瞬だよ☆」
「R、Excel関数とほとんど同じだよ☆慣れたらむしろ分かりやすいよ☆」

なーんて布教をしてみようと試みるものの、
「言語とかマヂ無理っす」とか
「えー面倒だからmrkさんがやってくださいよぉ〜」
とか言われて、
その度に涙を枕で濡らしていたものです。゚(゚´ω`゚)゚。

そこで奥さん、shinyですよ!

そんなことイチイチやってられるか!ってんで、
前々から進めたかったshinyアプリ作成のネタとして、「RでVLOOKUPをする」アプリを作ってみました。

まぁVLOOKUPといってもやるのはJOINです。
参照列数とかそういうのは無い。

まぁそこは

こまけぇこたぁ
    いいんだよ!!

の精神で、SEO対策的にもココはひとつ、「RでVLOOKUPをやります」と宣言します。いいね?

で、とりあえずやってみました

真面目にshinyの仕組みをまとめるのは今度にするとして(仕組みって言っても雰囲気ね?)、
まずはShiny内でやりたい処理を考えてみる。

# はじめに----

# やりたいことはコレ
left_join(iris, iris %>% gather(key, val, -Species), by = c("Species" = "Species")) %>% View()

# テスト用データ用意
write.csv(iris, file = "/home/rstudio/iris.csv", row.names = FALSE)

iris %>% gather(key, val, -Species) %>% write.csv(., file = "/home/rstudio/iris_ga.csv", row.names = FALSE)

非常にシンプル。

とりあえずアプリ化にあたり、以下の要素を盛り込んでみた

  • ファイルのアップロード(2種類)
  • アップロードした各テーブルの表示
  • 結合のキー変数の選択
  • ポチッとな(結合)
  • マージ後テーブルの表示
  • マージ後データのダウンロード

シンプルだけど、割とやることいっぱい。

で、結合にはdplyrを使ったんだけど、
dplyrの***_JOIN()は結合キーを文字列で指定する必要があって、これで苦戦しました。

結果教えていただいて出来たのがコチラ

require(shiny)
require(tidyverse)
require(readxl)
require(openxlsx)

# UI部分----
ui <-   
  fluidPage(
    titlePanel("RでVLOOKUPツール(csv編)"),
    sidebarLayout(
      sidebarPanel(
        h4("1.ファイルを選択↓"),
        # ファイル1選択
        fileInput("inputfile_1", "File1を選ぶ",
                  accept = c(
                    "text/csv",
                    "text/comma-separated-values,text/plain",
                    ".csv")
        ),
        tags$hr(),
        # ファイル2選択
        fileInput("inputfile_2", "File2を選ぶ",
                  accept = c(
                    "text/csv",
                    "text/comma-separated-values,text/plain",
                    ".csv")
        ),
        tags$hr(),
        # 変数選択
        h4("2.キーにする変数を選択"),
        htmlOutput("file1_col"),
        htmlOutput("file2_col"),
        tags$hr(),
        # マージ
        h4("3.マージ&DL"),
        radioButtons("join_type", label = "マージ方法を選択",
                     choices = list("left_join",
                                    "right_join",
                                    "inner_join",
                                    "full_join",
                                    "anti_join")),
        actionButton("submit", "マージ"),
        downloadButton('downloadData', 'ダウンロード')
      ),
      # メインパネルはテーブル出力のみ
      mainPanel(
        tabsetPanel(type = "tabs",
                    tabPanel("Table1", tableOutput('table1')),
                    tabPanel("Table2", tableOutput('table2')),
                    tabPanel("Merged_Table", tableOutput('merged_table'))
        )
      )
    )
  )

# server----

server <- function(input, output, session) {

  # ファイル1の読み込み
  observeEvent(input$inputfile_1, {
    
    table_file = reactive(read.csv(input$inputfile_1$datapath))
    output$table1 = renderTable(table_file())
    
    output$file1_col = renderUI({
      selectInput("x", "ファイル1", colnames(table_file()))
    })
  })
  
  # ファイル2の読み込み
  observeEvent(input$inputfile_2, {

    table_file = reactive(read.csv(input$inputfile_2$datapath))
    output$table2 = renderTable(table_file())

    output$file2_col = renderUI({
      selectInput("y", "ファイル2", colnames(table_file()))
    })
  })
  
  # テーブルのマージ
  observeEvent(input$submit, {
    # ファイル指定
    table_file_1 = reactive(read.csv(input$inputfile_1$datapath))
    table_file_2 = reactive(read.csv(input$inputfile_2$datapath))
    
    # by用変数名指定
    by_1 = input$x
    by_2 = input$y
    
    # マージ方法指定
    choise = input$join_type
    
    output$merged_table = renderTable({
      eval(
        parse(
          text = paste0(
            choise, "(table_file_1(), table_file_2(), by = setNames(by_1, by_2))"
          )
        )
      )
    })
  })

  output$downloadData <- downloadHandler(
    filename = "merged_data.csv",
    content = function(file) {
      # ファイル指定
      table_file_1 = reactive(read.csv(input$inputfile_1$datapath))
      table_file_2 = reactive(read.csv(input$inputfile_2$datapath))
      
      # by用変数名指定
      by_1 = input$x
      by_2 = input$y
      
      # マージ方法指定
      choise = input$join_type
      
      write.csv(x = eval(
                    parse(text = paste0(
                       choise, "(table_file_1(), table_file_2(), by = setNames(by_1, by_2))")
                       )        ),
                file, na = "", row.names = FALSE)
    }
  )
  }

  # Run the application ----
shinyApp(ui = ui, server = server)

出来たのでここまででQiitaにまとめました。
くどくど与太話を読みたくない場合はそちらへGO!

CSVだけでExcelは語れぬ

とりあえず作ったのはread.csv()を基本としたツールですが、それだけじゃ満足できないワガママボディがいっぱいいそうです。

ちなみにCSV、コンマ・セパレーテッド・バリューという言葉だけでなく、
クリエーティング・シェアド・バリュー(共通価値の創造)なる訳もあります。
ほざけ。

ということで、Excelファイルも対応させるよね。
Excelファイルはreadxlパッケージを使います。

ちなみにご存知Excel御大にはCSVとは違ってシートという概念がございます。
当然選べるようにしたい。

あと、せっかくdplyrでマージ後させるんならleft_join()だけではなく、各種JOINも選びたくなるよね!
…ってんで、そこも選べるようにしました。

文字列を繋げてRの処理として評価してやる、というもの。

こういうのがNSEっていうの?逆?
オジサンわかんない!

あ、あとあと忘れちゃいけない、日本語を使うんなら、文字コードも対応しないと。
とりあえず想定ユーザはWindowsの人だから、SJISのみです。

で、作ったのがコチラ

require(shiny)
require(tidyverse)
require(readxl)
require(openxlsx)

# UI部分----
ui <-   
  fluidPage(
    titlePanel("RでVLOOKUPツール"),
    sidebarLayout(
      sidebarPanel(
        helpText(paste0("説明:1~5の手順で2つのファイルをマージしてください。","\r\n","csvとExcelの両方対応してます。")),
        h4("1.ファイルを選択↓"),
        # ファイル1選択
        radioButtons("file_type_1", label = "ファイル1の形式を選択",
                     choices = list("csv",
                                    "Excel")),
        fileInput("inputfile_1", "File1を選ぶ",
                  accept = c(
                    "text/csv",
                    "text/comma-separated-values,text/plain",
                    ".csv",
                    ".xlsx")
        ),
        htmlOutput("file1_sheet"),
        tags$hr(),
        # ファイル2選択
        radioButtons("file_type_2", label = "ファイル2の形式を選択",
                     choices = list("csv",
                                    "Excel")),
        fileInput("inputfile_2", "File2を選ぶ",
                  accept = c(
                    "text/csv",
                    "text/comma-separated-values,text/plain",
                    ".csv",
                    ".xlsx")
        ),
        htmlOutput("file2_sheet"),
        tags$hr(),
        # ファイルゲット
        h4("2.両ファイルを取得↓"),
        actionButton("getfiles", "ファイル取得"),
        tags$hr(),
        # 変数選択
        h4("3.キーにする変数を選択"),
        htmlOutput("file1_col"),
        htmlOutput("file2_col"),
        tags$hr(),
        # マージ
        h4("4.マージ"),
        radioButtons("join_type", label = "マージ方法を選択",
                     choices = list("left_join",
                                    "right_join",
                                    "inner_join",
                                    "full_join",
                                    "anti_join")),
        actionButton("submit", "マージ"),
        tags$hr(),
        h4("5.DL↓"),
        downloadButton('downloadData', 'ダウンロード(SJIS)')
      ),
      # メインパネルはテーブル出力のみ
      mainPanel(
        tabsetPanel(type = "tabs",
                    tabPanel("Table1", tableOutput('table1')),
                    tabPanel("Table2", tableOutput('table2')),
                    tabPanel("Merged_Table", tableOutput('merged_table'))
        )
      )
    )
  )


# ファイルアップロード上限を100MBに変更 ----
options(shiny.maxRequestSize=100*1024^2) 

# server部分----

server <- function(input, output, session) {
  # ファイル1のシート情報選択
  observeEvent(input$inputfile_1, {
    
    if(input$file_type_1 == "Excel"){
      sheet1 = reactive(excel_sheets(path = input$inputfile_1$datapath)
      )
      
      output$file1_sheet = renderUI({ 
        selectInput("sheet_x", "シート名選択(ファイル1)", sheet1())
      }) 
    }})
  
  # ファイル2のシート情報選択
  observeEvent(input$inputfile_2, {
    
    if(input$file_type_2 == "Excel"){
      sheet2 = reactive(excel_sheets(path = input$inputfile_2$datapath)
      )
      
      output$file2_sheet = renderUI({ 
        selectInput("sheet_y", "シート名選択(ファイル2)", sheet2())
      }) 
    }})
  
  # ファイル1&2の読み込み
  observeEvent(input$getfiles, {
    # ファイル1
    if(input$file_type_1 == "Excel"){ # EXCELの場合
      table_file1 = reactive(read_excel(path = input$inputfile_1$datapath, 
                                        sheet = input$file1_sheet,
                                        na = "NULL"))
      output$table1 = renderTable(table_file1())
      output$file1_col = renderUI({ 
        selectInput("x", "ファイル1", colnames(table_file1()))
      })
    } else { # CSVの場合
      table_file1 = reactive(read.csv(input$inputfile_1$datapath, fileEncoding = "Shift-JIS"))
      output$table1 = renderTable(table_file1())
      
      output$file1_col = renderUI({ 
        selectInput("x", "ファイル1", colnames(table_file1()))
      })
    }
    
    # ファイル2
    if(input$file_type_2 == "Excel"){ # EXCELの場合
      table_file2 = reactive(read_excel(path = input$inputfile_2$datapath, 
                                        sheet = input$file2_sheet,
                                        na = "NULL"))
      output$table2 = renderTable(table_file2())
      output$file2_col = renderUI({ 
        selectInput("y", "ファイル2", colnames(table_file2()))
      })
    } else { # CSVの場合
      table_file2 = reactive(read.csv(input$inputfile_2$datapath, fileEncoding = "Shift-JIS"))
      output$table2 = renderTable(table_file2())
      
      output$file2_col = renderUI({ 
        selectInput("y", "ファイル2", colnames(table_file2()))
      })
    }
  }
  )
  
  
  # テーブルのマージ
  observeEvent(input$submit, {
    
    if(input$file_type_1 == "Excel"){
    # ファイル1指定
      table_file_1 = reactive(read_excel(path = input$inputfile_1$datapath, 
                                         sheet = input$file1_sheet,
                                         na = "NULL"))
    } else {
      table_file_1 = reactive(read.csv(input$inputfile_1$datapath))
    }
    
    if(input$file_type_2 == "Excel"){
    # ファイル2指定
      table_file_2 = reactive(read_excel(path = input$inputfile_2$datapath, 
                                         sheet = input$file2_sheet,
                                         na = "NULL"))
    } else {
      table_file_2 = reactive(read.csv(input$inputfile_2$datapath))
    }
    
    # by用変数名指定
    by_1 = input$x
    by_2 = input$y
    
    # マージ方法指定
    choise = input$join_type
    
    output$merged_table = renderTable({
      eval(
        parse(
          text = paste0(
            choise, "(table_file_1(), table_file_2(), by = setNames(by_1, by_2))"
          )
        )
      )
    })
  })
  
  output$downloadData <- downloadHandler(
    filename = "merged_data.csv",
    content = function(file) {
      if(input$file_type_1 == "Excel"){
        # ファイル1指定
        table_file_1 = reactive(read_excel(path = input$inputfile_1$datapath, 
                                           sheet = input$file1_sheet,
                                           na = "NULL"))
      } else {
        table_file_1 = reactive(read.csv(input$inputfile_1$datapath))
      }
      
      if(input$file_type_2 == "Excel"){
        # ファイル2指定
        table_file_2 = reactive(read_excel(path = input$inputfile_2$datapath, 
                                           sheet = input$file2_sheet,
                                           na = "NULL"))
      } else {
        table_file_2 = reactive(read.csv(input$inputfile_2$datapath))
      }
      
      # by用変数名指定
      by_1 = input$x
      by_2 = input$y
      
      # マージ方法指定
      choise = input$join_type
      
      write.csv(x = eval(
        parse(text = paste0(
          choise, "(table_file_1(), table_file_2(), by = setNames(by_1, by_2))")
        )        ),
        file, na = "", row.names = FALSE, fileEncoding = "Shift-JIS")
    }
  )
}

# Run the application ----
shinyApp(ui = ui, server = server)

最初のものから追加したのは以下

  • アップロードファイル形式をcsvExcelか選択(判断は内部でしてやらない)
  • Excelの場合はアップロードするシート名を選択
  • JOIN方式を選択
  • 文字コード対応(in-out)
  • ヘルプテキスト(改行上手くいってない)

出力自体はcsvのみ。面倒だから。

あ、も一つ忘れてた

  • アップロードファイルのサイズ上限をデフォルトの5MBから100MBに変更

そもそも(超)軽量なテーブルなんざVLOOKでいいので、
これが出来なきゃなんの意味もないガラクタになるところだった。。

ExcelVLOOKUPより超高速でJOIN!

ということで、何でもかんでもExcelでやらない、
ちょっとしたことでとても業務がラクになることを体験してもらうべく、
shinyでカンタンなデータマージツールを作りました。

shiny、RUNしてみて初めて抜け漏れが多々見つかってコレもかよ。。。と自分にげんなりしましたが、
非常にシンプルで初めてのアプリ作成でしたが比較的短時間でここまで出来ました!(byの変数指定は困ったけど)

でもいろんな方々の資料やr-wakalangコミュニティのお蔭です!Rおじさんに乾杯!!

次はやったことのない貴方も!

Enjoy, shiny!!!

*1:残業で。

バブルチャートではなく四角でグラフ化~geom_rect()ってなんだ

バブルチャートもしくはバブルプロットは、 天下のExcel様でも作れますし、 「イケてるグラフ2008*1」にもノミネートされるほど便利なグラフで有名ですが、 残念なのはX軸、Y軸にZ軸を含めた3次元までしか表せないってところです。

ggplotであれば*2、 colour、shapeや、geom_path()なんかも含めると5次元まではいけます*3

ただ、size指定じゃ物足りない! もっと次元欲しい!

ってことで、これはついに自作geomの作成必要か…? と思ったら、フツーにありました。 geom_rect github.com

色んな説明にね、「矩形(くけい)」って書いてあったの。

読 め な い ★

コレ長方形ってことだったのね〜
お父さん35歳になって初めて知ったよ〜

長方形って書いて!!!(書いてあった)

とりあえずまずは公式の例をコピーして書いてみたけど、
なんかしっくりこない。
コレでやりたいこと出来るのか全くピンと来ない。
大体、geom_rectで検索して出てくる画像、コレだよ?
「geom_rect」の検索結果 - Yahoo!検索(画像)

anotateの進化版?みたいな。いや実際そういうことがしたかったんだけど、geom_barみたいなものと同じように思ってた。

まぁ何はともあれやってみる。

require(tidyverse)
require(lubridate)
require(plotly)


df <- data.frame(
  x = sample(10, 10, replace = TRUE),
  x_range = sample(5, 10, replace = TRUE),
  y = sample(10, 10, replace = TRUE),
  y_range = sample(5, 10, replace = TRUE),
  pd = letters[1:10]
)

# geom_rectってなんだ?
g <- ggplot(df, aes(xmin = x, xmax = x + x_range,
                    ymin = y, ymax = y + y_range,
                    color = pd, fill = pd, alpha = .3)) +
  geom_rect()+
  xlim(0,15) + ylim(0,15)+
  geom_text(aes(x=x + x_range/2, y=y + y_range/2, label = pd, alpha = 1))

欲しかったのは、各描画要素が要素ごとに異なる範囲を示す二次元グラフで、
グラフ要素同士は重なってて良い(ってか重なって欲しかった)ものなので、コレピッタリ。

出来上がったのが、はい、こんな感じです

alphaのlegendは消しとくべきか

引数は当然ながらいつものx、yだけではないんだけど、
「始点と長さ」ということではなく、あくまで2つの座標を示すものらしいです。

んだもんで、座標が同じだとただの点。

# xmax・ymaxはあくまで座標を表すらしい。
# 線分の長さではないから長さデータがあるなら各minに足さないといけないので注意
# 以下だとただのgeom_textと同じになっちゃう
g0 <- ggplot(df, aes(xmin = x, xmax = x + 0,
                    ymin = y, ymax = y + 0,
                    color = pd, fill = pd, alpha = .3)) +
  geom_rect()+
  xlim(0,15) + ylim(0,15)+
  geom_text(aes(x=x + x_range/2, y=y + y_range/2, label = pd, alpha = 1))

# あと大好きplotlyで変換すると値がよくわからん
ggplotly(g, width = 800, height = 600)

f:id:cun-wang:20180815141709p:plain
点。

コレで例えば、以下のような期間データを二次元に示したわけのわからん動きをするグラフをイイカンジにしたいのです*4

# 時系列っぽい複数次元データでやってみる
df1 <- data.frame(
  hiduke = ymd("2015-01-01") %m+% months(c(0:36)),
  product1 = cumsum(rnorm(37)),
  product2 = cumsum(rnorm(37)),
  product3 = cumsum(rnorm(37)),
  product4 = cumsum(rnorm(37))
  ) %>% gather(product, val1, -hiduke) %>% na.omit() %>% 
  mutate(val2 = cumsum(round(val1 * rnorm(1), digits = 0)))

f:id:cun-wang:20180815141720p:plain

例えば、「その要素の最小値-最大値」の範囲を示す
みたいなことが出来ますね。

ggplot(df1, aes(val2, val1, colour = product)) + geom_path()

df2 <- df1 %>% group_by(product) %>% summarise_if(is.numeric, funs(min, max))

ggplot(df2, aes(xmin = val1_min, xmax = val1_min + val1_max,
                ymin = val2_min, ymax = val2_min + val2_max, 
                fill = product, colour = product))+
  geom_rect(alpha = .1)+
  geom_text(aes(x=val1_min + val1_max/2, y=val2_min + val2_max/2, label = product))

はいどーん

お分かりいただけるだろうか…?
コレって、データ整理にものすごく役立つんですよね。

1つ1つの次元を1つずつグラフにしていってもちっとも分からないしアタマが追いつかないんですが、
まとめてみるとアラ不思議!

ということで、geom_rect、
この夏、オススメのグラフですよ………!?

※ちなみに当初やりたかったのはひし形でxy軸と関係のない別の二次元を付けたかったんですが、
 それは流石に分かりづらいですかね…(今のgeom_rectでも書けるけど)。

*1:そんなものは知らぬ

*2:geom_pointでsizeを指定しますが詳しくは他の方のブログなどをおググりください

*3:他にもcontourとか足すのもアリだけど

*4:ランダムなので値によってはわけわからんです。。ミミズがニョロニョロするような値の方が見やすいです。。

dplyrで平均年齢を計算する。

はい、もうなんでもいいから小出しで記事更新を試みます。 まず書く。

ということで、世のデータサイエンティストさんとは縁遠い、「平均年齢の求め方」を書きます。 dplyrで。

しかも割とこう、スマートではない感じです。

↓こういう数表があったとき、意外と結構な人が そのまま人数合計しちゃったりするわけですが(いや意味わからんけども)、 じゃぁそれをdplyrでやるとどうなるかをちょっとやってみました (単に仕事で計算したからネタにしただけです)。

年齢 人数
20代 150
30代 15
40代 1500
50代 1
require(tidyverse)

# 平均年齢を計算する(加重平均)

df <- data.frame(kind = letters[1:5],
                 age = c(11,12,13,14,15,16,17,18,19,20, NA),
                 uniq_count = sample(x = c(1:1000), size = 55))

df %>% group_by(kind) %>% mutate(sum_ageuniq = age * uniq_count) %>% 
  summarise_at(.vars = 4, funs(ave_age = sum(sum_ageuniq, na.rm = TRUE) / sum(uniq_count, na.rm = TRUE),
                               total_user = sum(uniq_count, na.rm = TRUE)))

mutate部分をsummariseの中でやりゃ一発かしらね。

まぁ、とりあえず。

多重コレスポンデンス分析やってみた。

本日二投目。

※本記事は下記のサイトを参考に書いてみただけで、なんらオリジナルな話はありません。 まあそもそもオリジナルなものなんて書いてないか。

sugioka.wiki.fc2.com

別事業部からの依頼で普段はやらないジャンルのゲームについて、 「ユーザの分類をしてみたい」ってな依頼が来たので興味本位でやってみよう、 というのが動機でした。

素材はアンケートデータなんですが、
よくあるこのMCAとかこの辺の手法って、
何でもかんでも分析者のお気持ち次第っていうか、
それにしたってぶっこむ変数によって世界観が360°変わる厄介者な認識です(笑っていいんだよ?)。

で、MCAをするにはみんな大好きSPSSのオプションとかをご購入してもれなくIBMさんに重課金するのか、我らの心の友(勝手に認定)、HADでも可能ですね。

ただし、我らがHADをもってしても、一回一回まわしていくのは面倒。 ということで、そう、Rの出番ですね!

データを適当に区切っておく

上のサイトでもいくつか紹介されていましたが、 FactoMineRというのが手軽そう&便利そうなのでそちらでやってみました。

まずはどんな変数をぶっこむか、先にリストを作っときます。

install.packages("FactoMineR")
require(FactoMineR)

# data teaの読み込み
data(tea)

# これらの行を選び、newteaに代入

tea_list <- list(c("Tea", "How", "how", "sugar", "where", "always"),
                 c("Tea", "How", "how", "sugar", "where"),
                 c("Tea", "How", "where", "always"),
                 c("where", "always"))

コレポンをぐるぐる、可視化まで。

で、あとはこいつをコレポンしてggplotのグラフオブジェクトを量産すれば…!

って思ったら上手くいかなかったのでとりあえずそちらを↓

for(i in 1:length(tea_list)){
  #描画準備
  newtea <- tea[, tea_list[[i]]]
  cats <- apply(newtea, 2, function(x) nlevels(as.factor(x)))
  mca1 <- MCA(newtea, graph = FALSE)
  mca1_vars_df <- data.frame(mca1$var$coord, Variable = rep(names(cats), cats))
  mca1_obs_df <- data.frame(mca1$ind$coord)
  
  #plot
  assign(paste0("tea_gg", i), ggplot(data = mca1_obs_df, aes(x = Dim.1, y = Dim.2)) +
    geom_hline(yintercept = 0, colour = "gray70") +
    geom_vline(xintercept = 0, colour = "gray70") +
    geom_point(colour = "gray70", alpha = 0.7) +
    stat_density2d(colour = "gray80", aes(fill = ..level.., alpha = 0.5), geom = "polygon") +
    geom_text(data = mca1_vars_df, 
              aes(x = Dim.1, y = Dim.2, 
                  label = rownames(mca1_vars_df), colour = Variable))+
    scale_fill_gradient(low = "grey80", high = "darkblue"))
}

# 見てみると…
tea_gg1 #エラー: Aesthetics must be either length 1 or the same as the data (17): x, y, label, colour
tea_gg2 #エラー: Aesthetics must be either length 1 or the same as the data (15): x, y, label, colour
tea_gg3 #エラー: Aesthetics must be either length 1 or the same as the data (12): x, y, label, colour
tea_gg4 #最後だけ正常出力

で、悩んで悩んでr-wakalangで聞いてみたところ、 教えていただいた解決策がコチラ↓

do_plot <- function(i) {
  #描画準備
  newtea <- tea[, tea_list[[i]]]
  cats <- apply(newtea, 2, function(x) nlevels(as.factor(x)))
  mca1 <- MCA(newtea, graph = FALSE)
  mca1_vars_df <- data.frame(mca1$var$coord, Variable = rep(names(cats), cats))
  mca1_obs_df <- data.frame(mca1$ind$coord)
  
  #plot
  ggplot(data = mca1_obs_df, aes(x = Dim.1, y = Dim.2)) +
    geom_hline(yintercept = 0, colour = "gray70") +
    geom_vline(xintercept = 0, colour = "gray70") +
    geom_point(colour = "gray70", alpha = 0.7) +
    stat_density2d(colour = "gray80", aes(fill = ..level.., alpha = 0.5), geom = "polygon") +
    geom_text(data = mca1_vars_df, 
              aes(x = Dim.1, y = Dim.2, 
                  label = rownames(mca1_vars_df), colour = Variable))+
    scale_fill_gradient(low = "grey80", high = "darkblue")
}

idx <- seq_along(tea_list)
names(idx) <- paste0("tea_gg", idx)

l <- purrr::map(idx, do_plot)
l$tea_gg1 #できたー!

f:id:cun-wang:20180715131647p:plain

どうやらグローバル環境とかそのあたりのお話なようで、 教えていただいた解決策は「処理を関数化する」ということでした。

それにしてもリスト処理、こんなん出来るんだなーと目からウロコでした。。。

ってことに触発された記事を書こうとしたんだけどさっきいったん断念。

ちなみに

どんなジャンルのゲームかっていうと、こういうのです↓

socialappsupport.com

え…アメリカで…?そうなの?ってかヘーシャ入ってn…

そろそろリストに手を出したい(たぶん2年くらい言ってる)

どうも、おじさん@低浮上です。

最近はRばかり触っていられる状況でもなくなってきて、 ちゃんと政治せえや、という政治力により慣れない政治を意識高めワードを用いながらごまかそうと画策中です。

さて、そんななか、ますますRでの分析ライフをサクサクしていきたいわけで、 今までなかなか手が出てなかったリスト型についても勉強していきたい所存です(しているとは言ってない)。

というのも、相変わらずslackでは教えて厨上級者として時たま聖人たちに質問を投げかけているのですが、 僕の好きなggplotオブジェクトを量産する際に華麗にpurrrを使われた式を拝見して、 こんなawesomeを少しでも書ければ…僕の仕事も捗るはず…!

ということで、以下を見ながらいろいろやってみようと思った次第です。

speakerdeck.com

…で、これをもとに考えてわからんなぁと思ったコードを以下に載せようと思ってたんだけど、 読んでみたらこれはdplyrの操作についてじゃね?

書いてみて「あーこれ記事ネタにしよー」と思ったのが数週間前だったんだけど、 そのころの僕はいったい何を考えていたのか全く分からない。 ちょっともうわかんないからそのまま載せよう(こんなのばっかり)

# テストデータ
a1 <- c("A","B","C")
a2 <- c("りんご","みかん","いちご", NA)
a3 <- c(0,1,10,100)
a4_1 <- c("好き", NA)
a4_2 <- c("食べたことがある", NA)
a4_3 <- c("買ったことがある", NA)

test_dat <- data.frame(a1 = sample(a1, 10, replace = TRUE),
                       a2 = sample(a2, 10, replace = TRUE),
                       a3 = sample(a3, 10, replace = TRUE),
                       a4_1 = sample(a4_1, 10, replace = TRUE),
                       a4_2 = sample(a4_2, 10, replace = TRUE),
                       a4_3 = sample(a4_3, 10, replace = TRUE)
                       )

# ↓これダメだった

# a4_1~3のテキストのある部分を1にしたい。ついでにNAを0にしたい(けど他のa1・a2は変換したくない)
# out <- test_dat %>% mutate_if(is.factor, as.numeric) %>% mutate_if(is.na, 0)


# 素直にatを使うべき…?
require(tidyverse)
out <- test_dat %>% mutate_at(4:6, as.numeric)

colnames(out)[4:6] <- as.character(map(test_dat[4:6], levels))

out[is.na(out) & is.numeric(out)]<-0

とりあえず次の記事で教えていただいたシャキッとした書き方は載せるとして、 ここで何がしたかったかってえとたぶんアンケートデータをMCAするときの前処理みたいなことをしたかったはず。

まぁ、とりあえずいいか。*1

*1:そんなんだから前回のflexdashboardもRPubsまで持ってったけどちゃんと表示されてないってのに。。。

flexdashboardで出来ることを試してみる

どうも、なかなかブログ投稿しないでツイッターでどうでもいいことばっかり呟いてるマンです。

あんまり時間経ち過ぎてはてなのアカウントもパスもハテナ っていう。*1

思えば学部生時代、院生時代も書いてたシャカイガクお勉強ブログをテキトーに更新して放置して……ってことを繰り返してた。 彼らは今もまだネットの海を彷徨ってる。。。*2

続けるって大事。

今回はflexdashboardおさらい

だらだら書く癖はどうにかしないとなので、 さっぱりいきます。

今回は、flexdashboardです。

これまでもとりあえずテキトーに使えるトコだけ使っとけーとやってきたんですが、 まぁなんというか、コンテンツが貧弱なのでここらで今一度整理しておこう、 という腹づもりで調べてたので、折角なのでこんなゴミブログにすらすがらないといけないような人が僕以外にいるのかよく分かりませんが、 そんな人のために残しておく。です。

とはいえ大体のことはもう余所に書いてあります

とりあえず公式は充実してます。 説明ないトコもあるにはあるけど。 他にもこれは出来る/出来ないみたいなことは大体ニッポンのRおじさんも色々紹介してくださっていて、 中でもやはりぞうさんことkazutan先生の資料には本当にいつもお世話になっております。

じゃぁ何をするのか

もちろん自分の手習いを記載するのがこのブログの第一目的ですが、 それだけじゃぁブログにする意味もない。

ブログにするからには、どなたか読者を想定するのが筋。

で、元から劣化版なんだからRおじさんたちの素晴らしい記事を劣化コピーすることはない。 ポジショニングとしちゃニッチを攻めるってのが後発フォロワーの定石ってことで、その辺を進めます。

そう、ほかの人が敢えて書かないくらいの基礎中の基礎。それを敢えて書く、ということをやります。

やってみた

んー、はてなMarkdown記法で書いてたら、Rmdファイルのchunkがシンタックスハイライトとかぶって残念な感じになってしまった。。 ホントはちゃんとgitなりRPubsなりで現物見本示せよって話なんですけど、とりあえずまぁRmdファイルのリンク貼っときます。

storyboadtest.Rmd - Google ドライブ

…本編で一気にダレるorz

まぁその、チラシの裏的にいろいろ試してみたからとりあえずknitしてみるとあーこんな感じかってのがわかるかと思います。

おわり。

追記:RPubsあげてみた。けどあがんない。

あげてみたよ!でもちゃんと表示できないんだ。。。

RPubs - flexdashboardのテスト

ローカルでやってるのはできるのに、なぜだろう。。。 まだまだわかんないよとーさん。。。

*1:ログインできなくて何度も失敗して一時垢凍結を喰らうほどに…

*2:微かな記憶を頼りにググってみたら案の定あったのでそっ閉じ。。。ログイン情報なんて覚えてないし。