d <- read.csv("https://stats.dip.jp/01_ds/data/UN_jp.csv")
head(d)
## 国名 地域 分類 出生数 GDP 平均寿命 都市人口率 乳児死亡率
## 1 Afghanistan Asia other 5.97 499.0 49.49 23 12.45
## 2 Albania Europe other 1.52 3677.2 80.40 53 1.66
## 3 Algeria Africa africa 2.14 4473.0 75.00 67 2.15
## 4 Angola Africa africa 5.14 4321.9 53.17 59 9.62
## 5 Argentina Latin Amer other 2.17 9162.1 79.89 93 1.23
## 6 Armenia Asia other 1.74 3030.7 77.33 64 2.43
library(DT)
## Warning: パッケージ 'DT' はバージョン 4.3.2 の R の下で造られました
datatable(d, caption = "国連社会指標データ")
r <- prcomp(d[, 4:ncol(d)], scale = T)
summary(r)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5
## Standard deviation 1.9015 0.8551 0.63807 0.42872 0.24968
## Proportion of Variance 0.7231 0.1462 0.08143 0.03676 0.01247
## Cumulative Proportion 0.7231 0.8693 0.95077 0.98753 1.00000
evec <- r$rotation
datatable(round(evec, 2))
rownames(r$x) <- d$国名
datatable(round(r$x, 2))
library(factoextra)
## Warning: パッケージ 'factoextra' はバージョン 4.3.1 の R の下で造られました
## 要求されたパッケージ ggplot2 をロード中です
## Warning: パッケージ 'ggplot2' はバージョン 4.3.1 の R の下で造られました
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
fviz_screeplot(r, addlabels = T)
fviz_contrib(r, choice = "var", axes = 1, top = 5)
fviz_contrib(r, choice = "var", axes = 2, top = 5)
library("corrplot")
## Warning: パッケージ 'corrplot' はバージョン 4.3.1 の R の下で造られました
## corrplot 0.92 loaded
var <- get_pca_var(r)
corrplot(var$cor, is.corr = T, addCoef.col = "gray")
fviz_pca_var(r,
col.var = "contrib", # 色分け
repel = T) # repel: テキストラベルの重なり防止
fviz_pca_biplot(r, col.ind = "contrib", repel = T)
d0 <- read.csv('https://www.mhlw.go.jp/content/pcr_tested_daily.csv')
library(quantmod)
## Warning: パッケージ 'quantmod' はバージョン 4.3.2 の R の下で造られました
## 要求されたパッケージ xts をロード中です
## Warning: パッケージ 'xts' はバージョン 4.3.2 の R の下で造られました
## 要求されたパッケージ zoo をロード中です
## Warning: パッケージ 'zoo' はバージョン 4.3.2 の R の下で造られました
##
## 次のパッケージを付け加えます: 'zoo'
## 以下のオブジェクトは 'package:base' からマスクされています:
##
## as.Date, as.Date.numeric
## 要求されたパッケージ TTR をロード中です
## Warning: パッケージ 'TTR' はバージョン 4.3.2 の R の下で造られました
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
x <- as.POSIXct(d0[,1], format = '%Y/%m/%d')
y <- d0[,2]
yhat <- rollmean(y,31,na.pad = T)
matplot(x , y ,type = 'l', col = 3,
main = 'PCR検査実施人数(1日)', xlab = '日付', ylab = '人数')
matlines(x = x, y = yhat, col = 1)
grid()
legend('topleft', col = c(3, 1), lty = 1, legend = c('原系列', '31日移動平均'))
px <- seq(as.POSIXct('1949-01-01'),
as.POSIXct('1960-12-01'), by = 'month')
n <- length(px)
d0 <- data.frame(px = paste(px), t=1:n ,y = AirPassengers)
library(DT)
datatable
## function (data, options = list(), class = "display", callback = JS("return table;"),
## rownames, colnames, container, caption = NULL, filter = c("none",
## "bottom", "top"), escape = TRUE, style = "auto", width = NULL,
## height = NULL, elementId = NULL, fillContainer = getOption("DT.fillContainer",
## NULL), autoHideNavigation = getOption("DT.autoHideNavigation",
## NULL), selection = c("multiple", "single", "none"), extensions = list(),
## plugins = NULL, editable = FALSE)
## {
## oop = base::options(stringsAsFactors = FALSE)
## on.exit(base::options(oop), add = TRUE)
## options = modifyList(getOption("DT.options", list()), if (is.function(options))
## options()
## else options)
## if (is.character(btnOpts <- options[["buttons"]]))
## options[["buttons"]] = as.list(btnOpts)
## params = list()
## attr(params, "TOJSON_ARGS") = getOption("DT.TOJSON_ARGS")
## if (crosstalk::is.SharedData(data)) {
## params$crosstalkOptions = list(key = data$key(), group = data$groupName())
## data = data$data(withSelection = FALSE, withFilter = TRUE,
## withKey = FALSE)
## }
## rn = if (missing(rownames) || isTRUE(rownames))
## base::rownames(data)
## else {
## if (is.character(rownames))
## rownames
## }
## hideDataTable = FALSE
## if (is.null(data) || identical(ncol(data), 0L)) {
## data = matrix(ncol = 0, nrow = NROW(data))
## hideDataTable = TRUE
## }
## else if (length(dim(data)) != 2) {
## str(data)
## stop("'data' must be 2-dimensional (e.g. data frame or matrix)")
## }
## if (is.data.frame(data)) {
## data = as.data.frame(data)
## numc = unname(which(vapply(data, is.numeric, logical(1))))
## }
## else {
## if (!is.matrix(data))
## stop("'data' must be either a matrix or a data frame, and cannot be ",
## classes(data), " (you may need to coerce it to matrix or data frame)")
## numc = if (is.numeric(data))
## seq_len(ncol(data))
## data = as.data.frame(data)
## }
## if (!is.null(rn)) {
## data = cbind(` ` = rn, data)
## numc = numc + 1
## }
## options[["columnDefs"]] = colDefsTgtHandle(options[["columnDefs"]],
## base::colnames(data))
## data = boxListColumnAtomicScalars(data)
## if (length(numc)) {
## undefined_numc = setdiff(numc - 1, classNameDefinedColumns(options,
## ncol(data)))
## if (length(undefined_numc))
## options = appendColumnDefs(options, list(className = "dt-right",
## targets = undefined_numc))
## }
## if (is.null(options[["order"]]))
## options$order = list()
## if (is.null(options[["autoWidth"]]))
## options$autoWidth = FALSE
## if (is.null(options[["orderClasses"]]))
## options$orderClasses = FALSE
## cn = base::colnames(data)
## if (missing(colnames)) {
## colnames = cn
## }
## else if (!is.null(names(colnames))) {
## i = convertIdx(colnames, cn)
## cn[i] = names(colnames)
## colnames = cn
## }
## if (ncol(data) - length(colnames) == 1)
## colnames = c(" ", colnames)
## if (length(colnames) && colnames[1] == " ")
## options = appendColumnDefs(options, list(orderable = FALSE,
## targets = 0))
## style = normalizeStyle(style)
## if (grepl("^bootstrap", style))
## class = DT2BSClass(class)
## if (style != "default")
## params$style = style
## if (isTRUE(fillContainer))
## class = paste(class, "fill-container")
## if (is.character(filter))
## filter = list(position = match.arg(filter))
## filter = modifyList(list(position = "none", clear = TRUE,
## plain = FALSE, vertical = FALSE, opacity = 1), filter)
## filterHTML = as.character(filterRow(data, !is.null(rn) &&
## colnames[1] == " ", filter))
## if (filter$position == "top")
## options$orderCellsTop = TRUE
## params$filter = filter$position
## params$vertical = filter$vertical
## if (filter$position != "none")
## params$filterHTML = filterHTML
## if (missing(container)) {
## container = tags$table(tableHeader(colnames, escape),
## class = class)
## }
## else {
## params$class = class
## }
## attr(options, "escapeIdx") = escapeToConfig(escape, colnames)
## if (is.list(extensions)) {
## extensions = names(extensions)
## }
## else if (!is.character(extensions)) {
## stop("'extensions' must be either a character vector or a named list")
## }
## params$extensions = if (length(extensions))
## as.list(extensions)
## if ("Responsive" %in% extensions && is.null(options$responsive)) {
## options$responsive = TRUE
## }
## params$caption = captionString(caption)
## if (isTRUE(editable))
## editable = "cell"
## if (is.character(editable))
## editable = list(target = editable, disable = list(columns = NULL))
## if (is.list(editable))
## params$editable = makeEditableField(editable, data, rn)
## if (!identical(class(callback), class(JS(""))))
## stop("The 'callback' argument only accept a value returned from JS()")
## if (length(options$pageLength) && length(options$lengthMenu) ==
## 0) {
## if (!isFALSE(options$lengthChange))
## options$lengthMenu = sort(unique(c(options$pageLength,
## 10, 25, 50, 100)))
## if (identical(options$lengthMenu, c(10, 25, 50, 100)))
## options$lengthMenu = NULL
## }
## if (!is.null(options[["search"]]) && !is.list(options[["search"]]))
## stop("The value of `search` in `options` must be NULL or a list")
## if (!is.null(fillContainer))
## params$fillContainer = fillContainer
## if (!is.null(autoHideNavigation)) {
## if (isTRUE(autoHideNavigation) && length(options$pageLength) ==
## 0L)
## warning("`autoHideNavigation` will be ignored if the `pageLength` option is not provided.",
## immediate. = TRUE)
## params$autoHideNavigation = autoHideNavigation
## }
## params = structure(modifyList(params, list(data = data, container = as.character(container),
## options = options, callback = if (!missing(callback)) JS("function(table) {",
## callback, "}"))), colnames = cn, rownames = length(rn) >
## 0)
## if (inShiny() || length(params$crosstalkOptions)) {
## if (is.character(selection)) {
## selection = list(mode = match.arg(selection))
## }
## selection = modifyList(list(mode = "multiple", selected = NULL,
## target = "row", selectable = NULL), selection, keep.null = TRUE)
## if (grepl("^row", selection$target) && is.character(selection$selected) &&
## length(rn)) {
## selection$selected = match(selection$selected, rn)
## }
## params$selection = validateSelection(selection)
## if ("Select" %in% extensions && selection$mode != "none")
## warning("The Select extension can't work properly with DT's own ",
## "selection implemention and is only recommended in the client mode. ",
## "If you really want to use the Select extension please set ",
## "`selection = 'none'`", immediate. = TRUE)
## }
## deps = DTDependencies(style)
## deps = c(deps, unlist(lapply(extensions, extDependency, style,
## options), recursive = FALSE))
## if (params$filter != "none")
## deps = c(deps, filterDependencies())
## if (isTRUE(options$searchHighlight))
## deps = c(deps, list(pluginDependency("searchHighlight")))
## if (length(plugins))
## deps = c(deps, lapply(plugins, pluginDependency))
## deps = c(deps, crosstalk::crosstalkLibs())
## if (isTRUE(fillContainer)) {
## width = NULL
## height = NULL
## }
## htmlwidgets::createWidget("datatables", if (hideDataTable)
## NULL
## else params, package = "DT", width = width, height = height,
## elementId = elementId, sizingPolicy = htmlwidgets::sizingPolicy(knitr.figure = FALSE,
## defaultWidth = "100%", defaultHeight = "auto"), dependencies = deps,
## preRenderHook = function(instance) {
## data = instance[["x"]][["data"]]
## if (object.size(data) > 1500000 && getOption("DT.warn.size",
## TRUE))
## warning("It seems your data is too big for client-side DataTables. You may ",
## "consider server-side processing: https://rstudio.github.io/DT/server.html")
## data = escapeData(data, escape, colnames)
## data = unname(data)
## instance$x$data = data
## instance
## })
## }
## <bytecode: 0x00000218f6ae3440>
## <environment: namespace:DT>
library('forecast')
## Warning: パッケージ 'forecast' はバージョン 4.3.2 の R の下で造られました
fit1 <- loess(y ~ t,
data = d0,
span = 12 * 10 / n)
trend <- fit1$fitted
matplot(px, d0$y, type = 'l', pch = 1, col = 2,
main = '航空旅客数',
xlab = '月',
ylab = 'GW')
abline(h = 0, col = 'gray')
matlines(px, trend, pch = 2, col = 4, lwd = 2)
legend('topleft', lty = 1, col = c(2, 4),
legend = c('原系列', 'トレンド'))
detrended <- d0$y - trend
matplot(px, detrended, type = 'l', pch = 1, col = 2,
main = '残余成分（原系列－トレンド）',
xlab = '月',
ylab = 'GW')
abline(h = 0, col = 'gray')
fit2 <- loess(y ~ t,
data = data.frame(px, t = 1:n, y = detrended),
span = 12 * 4 / n)
seasonal <- fit2$fitted
matplot(px, detrended, type = 'l', pch = 1, col = 2, ylim = c(-15, 15),
main = '残余成分（トレンド除去後の成分）・周期成分',
xlab = '月',
ylab = 'GW')
matlines(px, seasonal, pch = 2, col = 4, lwd = 2)
abline(h = 0, col = 'gray')
remainder <- detrended - seasonal
matplot(px, remainder, type = 'l', pch = 1, col = 2, ylim = c(-15, 15),
main = '残余成分（トレンド，周期成分除去後の成分）',
xlab = '月',
ylab = 'GW')
abline(h = 0, col = 'gray')
s <- mstl(x = msts(d0$y, seasonal.period = c(12, 12*10)),
s.window = 'periodic')
## Warning in mstl(x = msts(d0$y, seasonal.period = c(12, 12 * 10)), s.window =
## "periodic"): Dropping seasonal components with fewer than two full periods.
autoplot(s, main = '周期成分：時間変動なし')
s <- mstl(x = msts(d0$y, seasonal.period = c(12, 12*10)))
## Warning in mstl(x = msts(d0$y, seasonal.period = c(12, 12 * 10))): Dropping
## seasonal components with fewer than two full periods.
autoplot(s, main = '周期成分：時間変動あり')
