Histogram

---

---

複数のヒストグラムをプロット

---

データ

#<font size="1"> This is my text number1</font> 
set.seed(123)
dat <- data.frame(x = rnorm(500, 90, 10),
                  y = rnorm(500, 60, 10),
                  z = rnorm(500, 30, 10))

dat

x	y	z
84.39524	53.98107	20.042013
87.69823	50.06301	19.600450
105.58708	70.26785	29.820198
90.70508	67.51061	28.678249
91.29288	44.90833	4.506572
107.15065	59.04853	40.405735

hist

• 引数としてリストまたはデータフレームを与える。

# function
mhist <- function(x, cols, brk=NULL, xlb="", mt=""){
  # x軸,y軸範囲を指定する関数
  wrange <- function(v){
    # min or max value
    mn <- range(v)[1]
    mx <- range(v)[2]
  
    # round function
    wr <- function(x){
      if (x < 0 ) {
        n = 10^floor(log10(abs(x)))
        res <- ceiling(abs(x)/n) * n * -1
      } else if (x > 0 ) {
        n = 10^floor(log10(x))
        res <- ceiling(x/n) * n
      } else if (x == 0) {
        res <- 0
      }
      return(res)
    }
  
    # return
    wmx <- wr(mx)
    if (!mn <= 0) { wmn <- 0 } else { wmn <- wr(mn) }
    return(c(wmn, wmx))
  }
  
  # x軸範囲, y軸範囲, # breaks
  if(is.null(brk)){
    xlm <- range(unlist(x))
      hv <- lapply(x, function(v) hist(v, plot = FALSE))
      cnts <- sapply(hv, function(x)x$counts)
    ylm <- wrange(range(unlist(cnts)))
      dst <- min(sapply(hv, function(x)x$breaks[2]-x$breaks[1]))
      brks <- sapply(hv, function(x)x$breaks)
    brk <- seq(min(unlist(brks)), max(unlist(brks)), dst)
  } else {
    xlm <- range(unlist(x))
      hv <- lapply(x, function(v) hist(v, breaks = brk, plot = FALSE))
      cnts <- sapply(hv, function(x)x$counts)
    ylm <- wrange(range(unlist(cnts)))
    
  }

  # hist
  for(i in seq_along(x)) {
    if(i==1){
      hist(x[[i]], ylim = ylm, xlim = xlm, col = cols[i], breaks = brk, main = mt, xlab=xlb)
    } else if(i>1){
      hist(x[[i]], ylim = ylm, xlim = xlm, col = cols[i], breaks = brk, add=TRUE)
    }
  }
  legend('topright', legend = names(x), fill=cols, border = F, box.lwd = F)
  return(hv)
}

# plot
par(mfcol=c(1,2))
cols <- adjustcolor(c("#999999", "#E69F00", "#56B4E9"), alpha.f = 0.5)
res <- mhist(x = dat, cols = cols)
res <- mhist(x = dat, cols = cols, brk = 30)

geom_histogram

• 引数としてデータフレームを与える。

# function
ggmhist <- function(x, cols=seq_along(x), binwd=20){
  ggdat <- tidyr::gather(x, "k", "v")
  ggplot2::ggplot(ggdat, ggplot2::aes(x = v, fill = k), colour = k) + 
    ggplot2::geom_histogram(binwidth = binwd, position = "identity") +
    ggplot2::scale_fill_manual(values = cols)
}


# plot
cols <- adjustcolor(RColorBrewer::brewer.pal(3, "Set1"), 0.5)
ggmhist(dat, cols, binwd = 5)

環境.

sessionInfo()

## R version 4.0.3 (2020-10-10)
## Platform: x86_64-apple-darwin17.0 (64-bit)
## Running under: macOS Mojave 10.14.6
## 
## Matrix products: default
## BLAS:   /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRblas.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib
## 
## locale:
## [1] ja_JP.UTF-8/ja_JP.UTF-8/ja_JP.UTF-8/C/ja_JP.UTF-8/ja_JP.UTF-8
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## loaded via a namespace (and not attached):
##  [1] tidyselect_1.2.0   xfun_0.36          bslib_0.4.2        purrr_1.0.1       
##  [5] colorspace_2.1-0   vctrs_0.5.2        generics_0.1.3     htmltools_0.5.4   
##  [9] viridisLite_0.4.1  yaml_2.3.7         utf8_1.2.2         rlang_1.0.6       
## [13] jquerylib_0.1.4    pillar_1.8.1       glue_1.6.2         withr_2.5.0       
## [17] DBI_1.1.3          RColorBrewer_1.1-3 lifecycle_1.0.3    plyr_1.8.8        
## [21] stringr_1.5.0      munsell_0.5.0      gtable_0.3.1       rvest_1.0.3       
## [25] kableExtra_1.3.4   evaluate_0.20      labeling_0.4.2     knitr_1.41        
## [29] fastmap_1.1.0      rsko_0.1.0         fansi_1.0.4        highr_0.10        
## [33] Rcpp_1.0.10        scales_1.2.1       cachem_1.0.6       webshot_0.5.4     
## [37] jsonlite_1.8.4     farver_2.1.1       systemfonts_1.0.4  ggplot2_3.4.0     
## [41] digest_0.6.31      stringi_1.7.12     dplyr_1.0.10       grid_4.0.3        
## [45] cli_3.6.0          tools_4.0.3        magrittr_2.0.3     sass_0.4.4        
## [49] tibble_3.1.8       tidyr_1.2.1        pkgconfig_2.0.3    ellipsis_0.3.2    
## [53] xml2_1.3.3         assertthat_0.2.1   rmarkdown_2.20     svglite_2.0.0     
## [57] httr_1.4.4         rstudioapi_0.14    R6_2.5.1           compiler_4.0.3