よく使うR小技集(随時更新)

データラングリングや可視化、分析をするためにRを操作していると、以前書いたコードを忘れて、調べるたびに同じ頁に行き着くことがあります。一定回数以上「あれ、どうだったけな?」と思って調べた小技について、随時掲載していきます。

目次

データラングリング

漢数字をアラビア数字に変換する

pacman::p_load(zipangu) dat$x <- dat$x %>% kansuji2arabic()
Code language: PHP (php)

全角を半角にする

pacman::p_load(stringi) dat$x <- dat$x %>% stri_trans_nfkc()
Code language: PHP (php)

数字を指定した桁数でパディングする(9 → 09)

dat %>% mutate(x_pad = str_pad(x, 2, pad=0))

数字列のNAを0に置換する

dat <- dat %>% mutate_if(is.numeric, ~ replace_na(.x, 0))
Code language: CSS (css)
dat <- dat %>% mutate(across(where(is.numeric), ~ replace_na(.x, 0)))
Code language: CSS (css)

mutate(across())の場合は、across()の中に関数も入れることに注意。

mutate(across(where(is.numeric)), ~ replace_na(.x, 0))とすると、

Error: Problem with `mutate()` input `..2`. x Input `..2` must be a vector, not a `formula` object. ℹ`..2` is `~replace_na(.x, 0)`.
Code language: JavaScript (javascript)

というエラーになる。

NA以外の行を選択

dat %>% filter(!(is.na(x)))
Code language: CSS (css)

dplyr::if_else で 0 を NA に置換

dat %>% mutate(x = if_else(x == 0, NA_real_, x))

dplyr::if_else はデータ型 を揃える必要があることに注意。NAとすると、

`false` must be a logical vector, not a double vector.
Code language: JavaScript (javascript)

といったエラーが返ってくる。double型の NA_real_ を使用する。

NAのある列をふくめたデータで文字結合(str_c())する

NAのある列を含めてstr_c()したい場合は、該当列(例ではY列)をstr_replace_na()で囲む。NAは”NA”のように生成されるため、その後、sep で指定した “:” とあわせて生成された”:NA”を文字置換する。

dat <- dat %>% mutate( Z = str_c(X,str_replace_na(Y),sep = ":")) %>% mutate(across(Z, ~ gsub(":NA","",.x)))
Code language: JavaScript (javascript)

データ型の一括変換

factor_list <- c("x","y","z") dat <- dat %>% mutate_at(vars(all_of(factor_list)),as.factor)
Code language: JavaScript (javascript)

across()を使うと下記の通り

factor_list <- c("x","y","z") dat <- dat %>% mutate(across(all_of(factor_list),as.factor))
Code language: JavaScript (javascript)

もしくは明示的に ~ と .x で関数を定義する

dat <- dat %>% mutate(across(all_of(factor_list), ~ as.factor(.x)))
Code language: CSS (css)

列名の一括変更

name_vector <- c("apple(変更前)"="1(変更後)", "banana"="2", "orange"="3") dat %>% mutate(across(label, ~ str_replace_all(.x, name_vector)))
Code language: JavaScript (javascript)

要素名の変更

pacman::p_load(forcats) fct_list <- c("全くそう思う(変更後)" = "1(変更前)","少しそう思う" = "2", "あまりそう思わない" = "3", "全くそう思わない" = "4") dat <- dat %>% mutate(x = fct_recode(x, !!!fct_list))
Code language: PHP (php)

下記の方法でも要素名を変更することができるが、順番を変更する訳ではないので注意。上記の方法で明示的に数字と対応させたほうがミスは少ない。

levels(dat$x) <- c("全くそう思う","少しそう思う","あまりそう思わない","そう思わない")
Code language: PHP (php)

要素名をまとめて再グループする

dat <- dat %>% mutate( x2 = fct_recode(x, "fruits" = "apple", "fruits" = "banana", "fruits" = "orange", "vehicle" = "car", "vehicle" = "bike"))
Code language: JavaScript (javascript)

要素名の順序の変更

fct_levels <- c("a","b","c") dat$x <- dat$x %>% factor(levels = fct_levels)
Code language: PHP (php)

mutate() でも across を使って以下のように書くことができる

dat <- dat %>% mutate(across(x, ~ factor(.x, levels = fct_levels)))
Code language: HTML, XML (xml)

{forcats} の fct_relevel() を使うと以下の通り。ただし、こちらは、存在しない値を指定すると警告が出る。

pacman::p_load(forcats) fct_levels <- c("a","b","c") dat <- dat %>% mutate(across(x, ~ fct_relevel(.x, levels = fct_levels)))
Code language: PHP (php)

順序を反転するのであれば、 {forcats} のfct_rev() が有用。

pacman::p_load(forcats) dat <- dat %>% mutate(across(x, ~ fct_rev(.x)))
Code language: CSS (css)

dplyr::rename で 文字ベクトルを使って一括変更

列名を一括で変更したい場合は rename(!!! named_vector) が便利。もしくは dput() を活用する(後述)。

named_vector <- c("id" = "x", "fruits" = "y") dat <- dat %>% rename(!!! named_vector)
Code language: JavaScript (javascript)

ベクトルで列名を取得

例えば列名を一括で変更したい場合は、

dat %>% names() %>% dput()

とすると、

c("ID", "果物", "個数")
Code language: JavaScript (javascript)

といったような文字ベクトルが取得できるため、コピーして書き換える。

# c("ID", "果物", "個数") コピペした後に書き換えて setNames()を利用して一括で列名を変更 dat <- dat %>% setNames(c("ID", "fruits", "n"))
Code language: PHP (php)

ベクトル内の特定の値(X)の個数を取得

sum(dat$x == X)
Code language: PHP (php)

文字列を別に指定して関数に使用する

cat <- "x" dat %>% filter(!is.na(.data[[cat]]))
Code language: CSS (css)

is.na(cat)とするとエラーになる。このときは .data[[ 列名 ]] を使用する。

ggplot のaes()でも同様の手法を使うことができる(aes_string()を使う方法もある)。

dplyr::filter で列指定を文字列ではなく列番号で指定する

df %>% dplyr::filter(.[1] == 1)
Code language: PHP (php)

ただし、後述の理由で、.[[列番号]] と [[ で閉じるほうが混乱が少なくて良いと思われる。

df %>% dplyr::filter(.[[1]] == 1)
Code language: PHP (php)

dplyr::filter で 文字の部分一致 を使う( + 列番号で指定)

dat %>% filter(str_detect(.[[1]], "文字"))
Code language: JavaScript (javascript)

もしくは

dat %>% filter(grep("文字", .[[1]]))
Code language: JavaScript (javascript)

.[列番号] ではだめで .[[列番号]] とすると動作する。そのため、最初から [[ で使うほうがエラーが少ない。

数字と文字が結合した列を分離する

例「0100札幌市保健所」といったデータの場合

dat <- dat %>% mutate(code = str_extract(code_area,"^(\\d)+")) %>% mutate(area = str_extract(code_area, "(\\D)+$"))
Code language: JavaScript (javascript)
  • \\d :数字
  • \\D:数字以外
  • + 文字の連続
  • ^:文頭
  • $:文末

という正規表現。(参考:基本的な正規表現一覧

2つの Date型 の日付データから年齢を計算

pacman::p_load(lubridate) dat <- dat %>% mutate_at(vars(d_birth, d_x), as.Date) dat <- dat %>% mutate( age = as.duration(d_x - d_birth)) dat <- dat %>% mutate( age = as.double(str_extract(age, "(?<=~).+(?=\s)")))
Code language: PHP (php)

(?<=~).+(?=\s) は「~とスペースの間の文字」という正規表現

  • ?<=~ : 直前に ~ がある
  • .+ :すべての文字の連続
  • ?=\s :直後に スペース(\s) がある

日付データから特定の期間のデータを抜き出す

日付の列(date)から2020年1月1日から2020年12月31日までのデータを抜き出したい場合

dat %>% filter(date >= as.Date("2020-01-01") & date <= as.Date("2020-12-31"))
Code language: JavaScript (javascript)

{lubridate} as.duration() で計算した値を日数単位に計算する

pacman::p_load(lubridate) dat <- dat %>% mutate(day = as.duration(x_2 - x_1 + ddays(1))/dseconds(86400))
Code language: PHP (php)

list 型のデータを data.frame に展開する

dat_list <- dat_list %>% reduce(rbind)
Code language: HTML, XML (xml)

重複行の削除

dat %>% distinct(x, y, .keep_all = TRUE)
Code language: PHP (php)

重複行の確認

重複の数も知りたい場合は table()を使用する。

dat %>% pull(col_name) %>% table() %>% data.frame() %>% filter(Freq >= 2) %>% arrange(desc(Freq))

特定の列の NA を置き換える

dat <- dat %>% replace_na(list(x = 0, y = 0, z = 0))
Code language: HTML, XML (xml)

行列 の 上三角 を 下三角 にコピー

M <- dat for(i in 1:nrow(M)) {for(j in 1:i) {M[j,i]=M[i,j]}}
Code language: HTML, XML (xml)

例えば、{polycor} の hetcor() で順序相関係数(ポリコリック相関係数やポリシリアル相関係数)を求めたときは、算出された値が下三角のみのため、{corrplot} などで相関行列を作成したい場合は下記のように対応する。

pacman::p_load(polycor) ans <- dat %>% hetcor() M <- ans$tests for(i in 1:nrow(M)) {for(j in 1:i) {M[j,i]=M[i,j] }}
Code language: HTML, XML (xml)

mutate() で複数列を選択して合計したい場合

rowSumsやreduceを活用する。

dat %>% mutate(sum = rowSums(across(c(●, ●))))

もしくは

dat %>% mutate(sum = reduce(across(c(●, ●)), `+`))
Code language: JavaScript (javascript)

サブディレクトリ内のデータも取得する

複数のサブディレクトリ内のデータのパスも取得したい場合は、 list.files() の中に recursive=TRUE を入力する。

read_xlsx_list <- list.files( "../materials/folder", # 検索するフォルダパスを指定 "*.xlsx", # .xlsx ファイルを抽出 recursive=TRUE) %>% # サブフォルダ内も検索できるようになる str_c("../materials/folder/",.) # パスを結合しておけば後でread_excel()しやすい
Code language: PHP (php)

可視化

{ggplot2} theme_set() の活用

ファイルの最初で定義すれば以後のggplotで反映されます

theme_set( theme_classic() + theme( strip.background = element_blank(), text = element_text(size = 10), axis.text.x = element_text(angle = 0, vjust = 1, hjust = 1), axis.ticks.length.x = unit(0.1, "cm"), legend.position = 'none') )
Code language: JavaScript (javascript)

{ggplot2} の aes() に 文字列でカラム名を渡す

dat %>% ggplot(aes_string(x=x, y=y))

aes() ではなく aes_string() を使用する。もしくは下記の方法でも良い。

dat %>% ggplot(aes(x=.data[["x"]], y=.data[["y"]]))
Code language: JavaScript (javascript)

.data[[“x”]] を覚えておくと、関数作成の際にうまく引数を渡せないときに役に立つことがある。(is.na(), arrange(), pull() など)

{ggplot2} の x 軸のラベルを少しだけ傾ける

dat %>% ggplot(aes(x)) + geom_count() + theme(axis.text.x = element_text(angle=30, hjust=1))

{ggplot2} 凡例の位置調整:bottomに置いて右寄せ

g <- ggplot() + ... g + theme(legend.position = "bottom", legend.justification = c("right"))
Code language: HTML, XML (xml)

{ggforce}geom_sina で geom_jitter()の幅を密度分布で制御する

violin plot() も見やすいですが、geom_sina()を使うと、ドットのまま violin plot() のように図示できるため、視覚的に分かりやすい図を描くことができます。

pacman::p_load(ggforce) dat %>% ggplot(aes(X,Y)) + geom_sina(aes(coular = Z))
Code language: PHP (php)

100%積み上げ棒グラフのラベル位置調整

ddat %>% group_by(x,y) %>% summarize(count=n()) %>% arrange(x,desc(y)) %>% ddply(x,transform,label_y=cumsum(count)) %>% ggplot(aes(x = x, y = count, fill = y)) + geom_col()+ geom_text ( aes ( y = label_y , label = count ), colour = "black", vjust = "inward") + scale_fill_brewer(palette = "Blues", name="Y", breaks=c("a", "b", "c"), labels=c("A", "B", "C") ) + scale_x_continuous(breaks=c(1,2,3)) + xlab("X")+ ylab("Count")+ theme_minimal()
Code language: JavaScript (javascript)

「Colorbrewer」で配色の決定

「Color Palette Cinema」で配色の決定

個人的に好きな色は

Moonrise Kingdom に出てくる #BD4670 です。

配色バリアフリー(safe color)

palette("Okabe-Ito")
Code language: JavaScript (javascript)

分析

tidydata から Steel-Dwass の多重比較

ノンパラメトリックの多重比較法であるスティール・ドゥワス(Steel-Dwass)には、群馬大学 青木先生 の記事 が参考になりますが、tidydata からそのまま Steel-Dwass を行えるように関数を自作してみました。

pacman::p_load(tidyverse) source("http://aoki2.si.gunma-u.ac.jp/R/src/Steel-Dwass.R", encoding="euc-jp") steel_dwass <- function(df, data, group){ data_vector <- df %>% pull(data) group_vector <- df %>% pull(group) result <- Steel.Dwass(data_vector, group_vector) result_tibble <- result %>% as_tibble() result_tibble <- cbind(steel_dwass = rownames(result),result_tibble) result_tibble <- result_tibble %>% mutate(star = if_else( p < 0.001, "**", if_else(p < 0.05, "*", "NS"))) %>% mutate(note = if_else(p < 0.001, "p<0.001", if_else(p < 0.05, "p<0.05", "NS"))) %>% mutate(across(p, ~ round(.x, digits = 3))) result_tibble }
Code language: PHP (php)

data列、group列の順に指定してください。

dat %>% steel_dwass("data", "group")
Code language: JavaScript (javascript)

{rstan} 実行速度の高速化

rstan_options(auto_write = TRUE) options(mc.cores = parallel::detectCores())
Code language: PHP (php)

{gtsummary} で連続値、カテゴリ値を一括で指定

pacman::p_load(gtsummary) table_list <- c("x_1", "x_2", "y_1", "y_2", "z") table_label_list <- c("X1", "X2", "Y1", "Y2", "Z") cnt_list <- c("x_1", "x_2") ctg_list <- c("y_1", "y_2") dct_list <- c("z") table_one <- dat %>% select(all_of(table_list)) %>% setNames(all_of(table_label_list)) %>% tbl_summary( type = list(cnt_list ~ "continuous", ctg_list ~ "categorical", dct_list ~ "dichotomous"))
Code language: PHP (php)

{gtsummary} 複数行で連続値 の summary を記載する

pacman::p_load(gtsummary) table_one <- dat %>% select("x","y","z") %>% tbl_summary( type = all_continuous() ~ "continuous2", statistic = all_continuous() ~ c( "{N_nonmiss}", "{mean} ({sd})", "{median} ({p25}, {p75})", "{min}, {max}"), digits = list(where(is.numeric) ~ c(0,1,1,1,1,1,1,1)), missing = "no")
Code language: PHP (php)

type を “continuous2” とすることに注意。有効数字は出現順に c() にまとめる。この場合は N を整数、その他を有効数字小数点1桁とした。

{gtsummary} 行列名や注釈を日本語表記にする

theme_gtsummary_language("ja")
Code language: JavaScript (javascript)

もとに戻したい場合は、下記のコードを実行する。

reset_gtsummary_theme()

{gtsummary} {snakecase} snake_case にしている変数名を camelCase に変更して表示する

pacman::p_load(gtsummary, snakecase) table_one <- dat %>% select("x","y","z") %>% set_variable_labels( .labels = to_title_case(names(.))) %>% tbl_summary()
Code language: PHP (php)

{gtsummary} で作成した列の順序を頻度順に並び替える

pacman::p_load(gtsummary) table_one <- dat %>% select("x","y","z") %>% tbl_summary( sort = all_categorical() ~ "frequency")
Code language: PHP (php)

特定の列(AとB列)のみの場合は、

tbl_summary(sort = c("A","B") ~ "frequency")
Code language: JavaScript (javascript)

とする。

{gtsummary} で作成した table を縦横変換する

pacman::p_load(gtsummary) table_one <- dat %>% select("x","y","z") %>% tbl_summary() %>% bold_labels() %>% add_n() %>% as_tibble() %>% t() %>% as.data.frame()
Code language: PHP (php)

{modelsummary} で star をつけたい場合

help に記載されている、estimate = “{estimate} ({std.error})stars” ではなく、”{estimate} ({std.error}){stars}” とすると表示されます

{corrplot} 相関行列をカスタマイズ

pacman::p_load(corrplot) col_list <- c("x","y","z") labelname_list <- c("X","Y","Z") dat_cor <- dat %>% select(all_of(col_list)) %>% setNames(all_of(labelname_list)) %>% na.omit() p <- dat_cor %>% cor.mtest(method = "spearman") corrplot(cor(dat_cor, method = "spearman"), method="number", tl.col="black", tl.cex=1, tl.srt=45, diag=FALSE) corrplot(cor(dat_cor, method = "spearman"), p.mat = p$p, sig.level=0, insig = "p-value", method="ellipse", type="lower", tl.pos = "n", cl.pos="n", add=TRUE, diag=FALSE)
Code language: PHP (php)

{polycor} カテゴリカル変数とカテゴリカル変数で相関行列(ポリコリック相関行列)

pacman::p_load(polycor) ans <- dat %>% hetcor() ans$correlation M <- ans$tests for(i in 1:nrow(M)) {for(j in 1:i) {M[j,i]=M[i,j] }} p$p <- M
Code language: PHP (php)

のように行い、上記 {corrplot} を一部書き換える。

corrplot(ans$correlation, method="number", tl.col="black", tl.cex=1, tl.srt=45, diag=FALSE) corrplot(ans$correlation, p.mat = p$p, sig.level=0, insig = "p-value", method="ellipse", type="lower", tl.pos = "n", cl.pos="n", add=TRUE, diag=FALSE)
Code language: PHP (php)

{ggstatsplot} で作成した図に {ggsignif} で有意差のバーを付ける

pacman::p_load(ggsignif, ggstatsplot, wesanderson) ggstatsplot::ggbetweenstats( data = dat, x = x, y = y, pairwise.comparisons = FALSE, k = 0, xlab = "x", ylab = "y", ggstatsplot.layer = TRUE, package = "wesanderson", palette = "GrandBudapest1" ) + geom_signif(comparisons = list(c("a", "b")), map_signif_level = c("<strong>* p<0.001"=0.001, "</strong> p<0.01"=0.01, "* p<0.05"=0.05))
Code language: PHP (php)

コミュニケーション・その他

library() のかわりに pacman::p_loadを使う

if (!require("pacman")) install.packages("pacman") pacman::p_load(tidyverse, magrittr, package_n)
Code language: PHP (php)

{tomwenseleers/export} {eoffice} 図表を ppt 形式で出力

pacman::p_load(officer,rvg,openxlsx,ggplot2,flextable,xtable,rgl,stargazer,tikzDevice,xml2,broom,devtools) pacman::p_load_gh("tomwenseleers/export") graph2ppt(append=TRUE, upscale=TRUE)
Code language: PHP (php)

エラーが出る場合は、一度リンク先のインストール方法を試してから graph2ppt() を実行してみてください。

install.packages("officer") install.packages("rvg") install.packages("openxlsx") install.packages("ggplot2") install.packages("flextable") install.packages("xtable") install.packages("rgl") install.packages("stargazer") install.packages("tikzDevice") install.packages("xml2") install.packages("broom") install.packages("devtools") devtools::install_github("tomwenseleers/export")
Code language: PHP (php)

{export}でうまく行かない場合は、{eoffice} を使います。

pacman::p_load(eoffice) topptx(file="filename.pptx", left = 0, top = 0, width = 8, height = 6, append = TRUE)
Code language: PHP (php)

ggsave() の画像データサイズを小さくする

ggsave("figure1.tiff", width = ..., height = ..., dpi=300, compression = "lzw")
Code language: JavaScript (javascript)

プロジェクトファイルを立ち上げた後に必要なフォルダを作成する

Console の隣の Terminal から下記を入力

mkdir {data,thesis,analysis,function,materials}
Code language: JavaScript (javascript)

Rmarkdown のデフォルトパスをプロジェクトファイルからの相対パスに変更する

knitr::opts_knit$set(root.dir = rprojroot::find_rstudio_root_file())
Code language: PHP (php)

Rmarkdown でよく行う初期設定

上記のデフォルトパスとあわせて私自身がよく行う初期設定例です。出力する図表は デフォルトで 300 dpi に設定しています。

--- title: "…" output: html_document: theme: cerulean toc: yes toc_depth: 3 toc_float: yes df_print: "kable" ---
Code language: JavaScript (javascript)
{r setup, include=FALSE} knitr::opts_knit$set(root.dir = rprojroot::find_rstudio_root_file()) knitr::opts_chunk$set(echo = FALSE) knitr::opts_chunk$set(eval = TRUE) knitr::opts_chunk$set(tidy = FALSE) knitr::opts_chunk$set(warning = FALSE) knitr::opts_chunk$set(error = FALSE) knitr::opts_chunk$set(message = FALSE) knitr::opts_chunk$set(dpi = 300)
Code language: PHP (php)
{r} if (!require("pacman")) install.packages("pacman") pacman::p_load(tidyverse,readxl,readr,magrittr,...)
Code language: PHP (php)

Rmarkdownで文中と文末の引用文献をハイパーリンクで関連付ける

デフォルトだと、本文中の参考文献は、1 といった上付き数字になり、文末のリスト番号と対応しているがハイパーリンクがない状態である。yaml ヘッダ に “link-citations: true” というオプションを指定して knit すればハイパーリンクで関連付けすることができる。

link-citations: true
Code language: JavaScript (javascript)

入力途中の日本語も見えるようにする

「よく使うR小技集(随時更新)」への1件のフィードバック

  1. ピンバック: Rstudio エディタの日本語入力を ポップアウト後も 表示する方法 - shoei05

コメントする

メールアドレスが公開されることはありません。