ch13.R
yoshio
Tuesday, August 05, 2014
13章 さまざまなグラフ
data(mtcars)
head(mtcars)## mpg cyl disp hp drat wt qsec vs am gear carb
## Mazda RX4 21.0 6 160 110 3.90 2.620 16.46 0 1 4 4
## Mazda RX4 Wag 21.0 6 160 110 3.90 2.875 17.02 0 1 4 4
## Datsun 710 22.8 4 108 93 3.85 2.320 18.61 1 1 4 1
## Hornet 4 Drive 21.4 6 258 110 3.08 3.215 19.44 1 0 3 1
## Hornet Sportabout 18.7 8 360 175 3.15 3.440 17.02 0 0 3 2
## Valiant 18.1 6 225 105 2.76 3.460 20.22 1 0 3 1summary(mtcars)## mpg cyl disp hp
## Min. :10.4 Min. :4.00 Min. : 71.1 Min. : 52.0
## 1st Qu.:15.4 1st Qu.:4.00 1st Qu.:120.8 1st Qu.: 96.5
## Median :19.2 Median :6.00 Median :196.3 Median :123.0
## Mean :20.1 Mean :6.19 Mean :230.7 Mean :146.7
## 3rd Qu.:22.8 3rd Qu.:8.00 3rd Qu.:326.0 3rd Qu.:180.0
## Max. :33.9 Max. :8.00 Max. :472.0 Max. :335.0
## drat wt qsec vs
## Min. :2.76 Min. :1.51 Min. :14.5 Min. :0.000
## 1st Qu.:3.08 1st Qu.:2.58 1st Qu.:16.9 1st Qu.:0.000
## Median :3.69 Median :3.33 Median :17.7 Median :0.000
## Mean :3.60 Mean :3.22 Mean :17.8 Mean :0.438
## 3rd Qu.:3.92 3rd Qu.:3.61 3rd Qu.:18.9 3rd Qu.:1.000
## Max. :4.93 Max. :5.42 Max. :22.9 Max. :1.000
## am gear carb
## Min. :0.000 Min. :3.00 Min. :1.00
## 1st Qu.:0.000 1st Qu.:3.00 1st Qu.:2.00
## Median :0.000 Median :4.00 Median :2.00
## Mean :0.406 Mean :3.69 Mean :2.81
## 3rd Qu.:1.000 3rd Qu.:4.00 3rd Qu.:4.00
## Max. :1.000 Max. :5.00 Max. :8.00str(mtcars)## 'data.frame': 32 obs. of 11 variables:
## $ mpg : num 21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ...
## $ cyl : num 6 6 4 6 8 6 8 4 4 6 ...
## $ disp: num 160 160 108 258 360 ...
## $ hp : num 110 110 93 110 175 105 245 62 95 123 ...
## $ drat: num 3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ...
## $ wt : num 2.62 2.88 2.32 3.21 3.44 ...
## $ qsec: num 16.5 17 18.6 19.4 17 ...
## $ vs : num 0 0 1 1 0 1 0 1 1 1 ...
## $ am : num 1 1 1 0 0 0 0 0 0 0 ...
## $ gear: num 4 4 4 3 3 3 3 4 4 4 ...
## $ carb: num 4 4 1 1 2 1 4 2 2 4 ...mcor <- cor(mtcars)
round(mcor, digits=2)## mpg cyl disp hp drat wt qsec vs am gear carb
## mpg 1.00 -0.85 -0.85 -0.78 0.68 -0.87 0.42 0.66 0.60 0.48 -0.55
## cyl -0.85 1.00 0.90 0.83 -0.70 0.78 -0.59 -0.81 -0.52 -0.49 0.53
## disp -0.85 0.90 1.00 0.79 -0.71 0.89 -0.43 -0.71 -0.59 -0.56 0.39
## hp -0.78 0.83 0.79 1.00 -0.45 0.66 -0.71 -0.72 -0.24 -0.13 0.75
## drat 0.68 -0.70 -0.71 -0.45 1.00 -0.71 0.09 0.44 0.71 0.70 -0.09
## wt -0.87 0.78 0.89 0.66 -0.71 1.00 -0.17 -0.55 -0.69 -0.58 0.43
## qsec 0.42 -0.59 -0.43 -0.71 0.09 -0.17 1.00 0.74 -0.23 -0.21 -0.66
## vs 0.66 -0.81 -0.71 -0.72 0.44 -0.55 0.74 1.00 0.17 0.21 -0.57
## am 0.60 -0.52 -0.59 -0.24 0.71 -0.69 -0.23 0.17 1.00 0.79 0.06
## gear 0.48 -0.49 -0.56 -0.13 0.70 -0.58 -0.21 0.21 0.79 1.00 0.27
## carb -0.55 0.53 0.39 0.75 -0.09 0.43 -0.66 -0.57 0.06 0.27 1.00レシピ 13.1 相関行列の図を作成する
library(corrplot)
corrplot(mcor)
corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45)
# Generate a lighter palette
col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45,
col=col(200), addCoef.col="black", addcolorlabel="no", order="AOE")## Warning: "addcolorlabel" is not a graphical parameter
## Warning: "addcolorlabel" is not a graphical parameter
## Warning: "addcolorlabel" is not a graphical parameter
レシピ 13.2 関数をプロットする
library(ggplot2)## Warning: package 'ggplot2' was built under R version 3.0.3# The data frame is only used for setting the range
p <- ggplot(data.frame(x=c(-3,3)), aes(x=x))
p + stat_function(fun = dnorm)
p + stat_function(fun = dt, args=list(df=2))
myfun <- function(xvar) {
1/(1 + exp(-xvar + 10))
}
ggplot(data.frame(x=c(0, 20)), aes(x=x)) + stat_function(fun=myfun)
レシピ 13.3 関数曲線の下の部分領域に網掛けをする
# Return dnorm(x) for 0 < x < 2, and NA for all other x
dnorm_limit <- function(x) {
y <- dnorm(x)
y[x < 0 | x > 2] <- NA
return(y)
}
# ggplot() with dummy data
p <- ggplot(data.frame(x=c(-3, 3)), aes(x=x))
p + stat_function(fun=dnorm_limit, geom="area", fill="blue", alpha=0.2) +
stat_function(fun=dnorm)
limitRange <- function(fun, min, max) {
function(x) {
y <- fun(x)
y[x < min | x > max] <- NA
return(y)
}
}# This returns a function
dlimit <- limitRange(dnorm, 0, 2)
dlimit## function(x) {
## y <- fun(x)
## y[x < min | x > max] <- NA
## return(y)
## }
## <environment: 0x03083294>p <- ggplot(data.frame(x=c(-3, 3)), aes(x=x))
p + stat_function(fun = dnorm) +
stat_function(fun = limitRange(dnorm, 0, 2),
geom="area", fill="blue", alpha=0.2)
レシピ 13.4 ネットワークグラフを作成する
# May need to install first, with install.packages("igraph")
library(igraph)## Warning: package 'igraph' was built under R version 3.0.3# Specify edges for a directed graph
gd <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6))
plot(gd)
# For an undirected graph
gu <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6), directed=FALSE)
# No labels
plot(gu, vertex.label=NA)
str(gd)## IGRAPH D--- 6 6 --
## + edges:
## [1] 1->2 2->3 2->4 1->4 5->5 3->6str(gu)## IGRAPH U--- 6 6 --
## + edges:
## [1] 1--2 2--3 2--4 1--4 5--5 3--6set.seed(229)
plot(gu)
library(gcookbook) # For the data set
data(madmen2)
head(madmen2)## Name1 Name2
## 1 Abe Drexler Peggy Olson
## 2 Allison Don Draper
## 3 Arthur Case Betty Draper
## 4 Bellhop in Baltimore Sal Romano
## 5 Bethany Van Nuys Don Draper
## 6 Betty Draper Don Draper# Create a graph object from the data set
g <- graph.data.frame(madmen2, directed=TRUE)
# Remove unnecessary margins
par(mar=c(0,0,0,0))
plot(g, layout=layout.fruchterman.reingold, vertex.size=8, edge.arrow.size=0.5,
vertex.label=NA)
g <- graph.data.frame(madmen, directed=FALSE)
par(mar=c(0,0,0,0)) # Remove unnecessary margins
plot(g, layout=layout.circle, vertex.size=8, vertex.label=NA)
レシピ 13.5 ネットワークグラフにテキストラベルを使う
library(igraph)
library(gcookbook) # For the data set
# Copy madmen and drop every other row
m <- madmen[1:nrow(madmen) %% 2 == 1, ]
g <- graph.data.frame(m, directed=FALSE)
# Print out the names of each vertex
V(g)$name## [1] "Betty Draper" "Don Draper" "Harry Crane"
## [4] "Joan Holloway" "Lane Pryce" "Peggy Olson"
## [7] "Pete Campbell" "Roger Sterling" "Sal Romano"
## [10] "Henry Francis" "Allison" "Candace"
## [13] "Faye Miller" "Megan Calvet" "Rachel Menken"
## [16] "Suzanne Farrell" "Hildy" "Franklin"
## [19] "Rebecca Pryce" "Abe Drexler" "Duck Phillips"
## [22] "Playtex bra model" "Ida Blankenship" "Mirabelle Ames"
## [25] "Vicky" "Kitty Romano"plot(g, layout=layout.fruchterman.reingold,
vertex.size = 4, # Smaller nodes
vertex.label = V(g)$name, # Set the labels
vertex.label.cex = 0.8, # Slightly smaller font
vertex.label.dist = 0.4, # Offset the labels
vertex.label.color = "black")
# This is equivalent to the preceding code
V(g)$size <- 4
V(g)$label <- V(g)$name
V(g)$label.cex <- 0.8
V(g)$label.dist <- 0.4
V(g)$label.color <- "black"
# Set a property of the entire graph
g$layout <- layout.fruchterman.reingold
plot(g)
# View the edges
E(g)## Edge sequence:
##
## [1] Henry Francis -- Betty Draper
## [2] Allison -- Don Draper
## [3] Don Draper -- Betty Draper
## [4] Candace -- Don Draper
## [5] Faye Miller -- Don Draper
## [6] Megan Calvet -- Don Draper
## [7] Rachel Menken -- Don Draper
## [8] Suzanne Farrell -- Don Draper
## [9] Hildy -- Harry Crane
## [10] Franklin -- Joan Holloway
## [11] Roger Sterling -- Joan Holloway
## [12] Rebecca Pryce -- Lane Pryce
## [13] Abe Drexler -- Peggy Olson
## [14] Duck Phillips -- Peggy Olson
## [15] Pete Campbell -- Peggy Olson
## [16] Playtex bra model -- Pete Campbell
## [17] Ida Blankenship -- Roger Sterling
## [18] Mirabelle Ames -- Roger Sterling
## [19] Vicky -- Roger Sterling
## [20] Kitty Romano -- Sal Romano# Set some of the labels to "M"
E(g)[c(2,11,19)]$label <- "M"
# Set color of all to grey, and then color a few red
E(g)$color <- "grey70"
E(g)[c(2,11,19)]$color <- "red"
plot(g)
レシピ 13.6 ヒートマップを作成する
data(presidents)
presidents## Qtr1 Qtr2 Qtr3 Qtr4
## 1945 NA 87 82 75
## 1946 63 50 43 32
## 1947 35 60 54 55
## 1948 36 39 NA NA
## 1949 69 57 57 51
## 1950 45 37 46 39
## 1951 36 24 32 23
## 1952 25 32 NA 32
## 1953 59 74 75 60
## 1954 71 61 71 57
## 1955 71 68 79 73
## 1956 76 71 67 75
## 1957 79 62 63 57
## 1958 60 49 48 52
## 1959 57 62 61 66
## 1960 71 62 61 57
## 1961 72 83 71 78
## 1962 79 71 62 74
## 1963 76 64 62 57
## 1964 80 73 69 69
## 1965 71 64 69 62
## 1966 63 46 56 44
## 1967 44 52 38 46
## 1968 36 49 35 44
## 1969 59 65 65 56
## 1970 66 53 61 52
## 1971 51 48 54 49
## 1972 49 61 NA NA
## 1973 68 44 40 27
## 1974 28 25 24 24str(presidents)## Time-Series [1:120] from 1945 to 1975: NA 87 82 75 63 50 43 32 35 60 ...pres_rating <- data.frame(
rating = as.numeric(presidents),
year = as.numeric(floor(time(presidents))),
quarter = as.numeric(cycle(presidents))
)
head(pres_rating)## rating year quarter
## 1 NA 1945 1
## 2 87 1945 2
## 3 82 1945 3
## 4 75 1945 4
## 5 63 1946 1
## 6 50 1946 2tail(pres_rating)## rating year quarter
## 115 40 1973 3
## 116 27 1973 4
## 117 28 1974 1
## 118 25 1974 2
## 119 24 1974 3
## 120 24 1974 4library(ggplot2)
# Base plot
p <- ggplot(pres_rating, aes(x=year, y=quarter, fill=rating))
# Using geom_tile()
p + geom_tile()
# Using geom_raster() - looks the same, but a little more efficient
p + geom_raster()
p + geom_tile() +
scale_x_continuous(breaks = seq(1940, 1976, by = 4)) +
scale_y_reverse() +
scale_fill_gradient2(midpoint=50, mid="grey70", limits=c(0,100))
レシピ 13.7 3次元の散布図を作成する
# You may need to install first, with install.packages("rgl")
library(rgl)## Warning: package 'rgl' was built under R version 3.0.3plot3d(mtcars$wt, mtcars$disp, mtcars$mpg, type="s", size=0.75, lit=FALSE)
rgl.snapshot('3dplot1.png', fmt='png')# Function to interleave the elements of two vectors
interleave <- function(v1, v2) as.vector(rbind(v1,v2))
# Plot the points
plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
xlab="Weight", ylab="Displacement", zlab="MPG",
size=.75, type="s", lit=FALSE)
# Add the segments
segments3d(interleave(mtcars$wt, mtcars$wt),
interleave(mtcars$disp, mtcars$disp),
interleave(mtcars$mpg, min(mtcars$mpg)),
alpha=0.4, col="blue")# Make plot without axis ticks or labels
plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
xlab = "", ylab = "", zlab = "",
axes = FALSE,
size=.75, type="s", lit=FALSE)
segments3d(interleave(mtcars$wt, mtcars$wt),
interleave(mtcars$disp, mtcars$disp),
interleave(mtcars$mpg, min(mtcars$mpg)),
alpha = 0.4, col = "blue")
# Draw the box.
rgl.bbox(color="grey50", # grey60 surface and black text
emission="grey50", # emission color is grey50
xlen=0, ylen=0, zlen=0) # Don't add tick marks
# Set default color of future objects to black
rgl.material(color="black")
# Add axes to specific sides. Possible values are "x--", "x-+", "x+-", and "x++".
axes3d(edges=c("x--", "y+-", "z--"),
ntick=6, # Attempt 6 tick marks on each side
cex=.75) # Smaller font
# Add axis labels. 'line' specifies how far to set the label from the axis.
mtext3d("Weight", edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG", edge="z--", line=3)# Given a model, predict zvar from xvar and yvar
# Defaults to range of x and y variables, and a 16x16 grid
predictgrid <- function(model, xvar, yvar, zvar, res = 16, type = NULL) {
# Find the range of the predictor variable. This works for lm and glm
# and some others, but may require customization for others.
xrange <- range(model$model[[xvar]])
yrange <- range(model$model[[yvar]])
newdata <- expand.grid(x = seq(xrange[1], xrange[2], length.out = res),
y = seq(yrange[1], yrange[2], length.out = res))
names(newdata) <- c(xvar, yvar)
newdata[[zvar]] <- predict(model, newdata = newdata, type = type)
newdata
}
# Convert long-style data frame with x, y, and z vars into a list
# with x and y as row/column values, and z as a matrix.
df2mat <- function(p, xvar = NULL, yvar = NULL, zvar = NULL) {
if (is.null(xvar)) xvar <- names(p)[1]
if (is.null(yvar)) yvar <- names(p)[2]
if (is.null(zvar)) zvar <- names(p)[3]
x <- unique(p[[xvar]])
y <- unique(p[[yvar]])
z <- matrix(p[[zvar]], nrow = length(y), ncol = length(x))
m <- list(x, y, z)
names(m) <- c(xvar, yvar, zvar)
m
}# Function to interleave the elements of two vectors
interleave <- function(v1, v2) as.vector(rbind(v1,v2))
library(rgl)
# Make a copy of the data set
m <- mtcars
# Generate a linear model
mod <- lm(mpg ~ wt + disp + wt:disp, data = m)
# Get predicted values of mpg from wt and disp
m$pred_mpg <- predict(mod)
# Get predicted mpg from a grid of wt and disp
mpgrid_df <- predictgrid(mod, "wt", "disp", "mpg")
mpgrid_list <- df2mat(mpgrid_df)
# Make the plot with the data points
plot3d(m$wt, m$disp, m$mpg, type="s", size=0.5, lit=FALSE)# Add the corresponding predicted points (smaller)
spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)
# Add line segments showing the error
segments3d(interleave(m$wt, m$wt),
interleave(m$disp, m$disp),
interleave(m$mpg, m$pred_mpg),
alpha=0.4, col="red")# Add the mesh of predicted values
surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
alpha=0.4, front="lines", back="lines")plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
xlab = "", ylab = "", zlab = "",
axes = FALSE,
size=.5, type="s", lit=FALSE)
# Add the corresponding predicted points (smaller)
spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)# Add line segments showing the error
segments3d(interleave(m$wt, m$wt),
interleave(m$disp, m$disp),
interleave(m$mpg, m$pred_mpg),
alpha=0.4, col="red")
# Add the mesh of predicted values
surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
alpha=0.4, front="lines", back="lines")# Draw the box
rgl.bbox(color="grey50", # grey60 surface and black text
emission="grey50", # emission color is grey50
xlen=0, ylen=0, zlen=0) # Don't add tick marks
# Set default color of future objects to black
rgl.material(color="black")
# Add axes to specific sides. Possible values are "x--", "x-+", "x+-", and "x++".
axes3d(edges=c("x--", "y+-", "z--"),
ntick=6, # Attempt 6 tick marks on each side
cex=.75) # Smaller font
# Add axis labels. 'line' specifies how far to set the label from the axis.
mtext3d("Weight", edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG", edge="z--", line=3)レシピ 13.7 3次元の散布図を作成する レシピ 13.8 3次元プロットに予測面を追加する レシピ 13.9 3次元プロットを保存する レシピ 13.10 3次元プロットのアニメーション レシピ 13.11 樹形図を作成する レシピ 13.12 ベクトルフィールドを作成する レシピ 13.13 QQプロットを作成する レシピ 13.14 経験累積分布関数のグラフを作成する レシピ 13.15 モザイクプロットを作成する レシピ 13.16 円グラフを作成する レシピ 13.17 地図を描く レシピ 13.18 コロプレス地図（塗り分け地図）を描く レシピ 13.19 地図の背景を消す レシピ 13.20 シェープファイルから地図を描く