library("tidyverse"); theme_set(theme_bw())
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ ggplot2 3.4.0 ✔ purrr 0.3.4
## ✔ tibble 3.1.8 ✔ dplyr 1.0.10
## ✔ tidyr 1.2.1 ✔ stringr 1.4.1
## ✔ readr 2.1.2 ✔ forcats 0.5.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
library("Sleuth3")
# Tables
library("knitr") # for kable
library("kableExtra")
## Warning: package 'kableExtra' was built under R version 4.2.3
##
## Attaching package: 'kableExtra'
##
## The following object is masked from 'package:dplyr':
##
## group_rows
library("formattable")
## Warning: package 'formattable' was built under R version 4.2.3
library("DT")
## Warning: package 'DT' was built under R version 4.2.3
# Figures
library("maps")
## Warning: package 'maps' was built under R version 4.2.3
##
## Attaching package: 'maps'
##
## The following object is masked from 'package:purrr':
##
## map
library("sf")
## Warning: package 'sf' was built under R version 4.2.3
## Linking to GEOS 3.9.3, GDAL 3.5.2, PROJ 8.2.1; sf_use_s2() is TRUE
library("tigris")
## Warning: package 'tigris' was built under R version 4.2.3
## To enable caching of data, set `options(tigris_use_cache = TRUE)`
## in your R script or .Rprofile.
library("leaflet")
## Warning: package 'leaflet' was built under R version 4.2.3
library("scales")
##
## Attaching package: 'scales'
##
## The following objects are masked from 'package:formattable':
##
## comma, percent, scientific
##
## The following object is masked from 'package:purrr':
##
## discard
##
## The following object is masked from 'package:readr':
##
## col_factor
library("plotly")
##
## Attaching package: 'plotly'
##
## The following object is masked from 'package:formattable':
##
## style
##
## The following object is masked from 'package:ggplot2':
##
## last_plot
##
## The following object is masked from 'package:stats':
##
## filter
##
## The following object is masked from 'package:graphics':
##
## layout
library("gifski")
## Warning: package 'gifski' was built under R version 4.2.3
Rmarkdown documents that produce HTML files can include a variety of features that provide an interactive document for the user. Primarily this interactivity is implemented as will concern stand-alone tables, figures, and animations (movies). Typically this interactivity is available via an R package interface to a javascript library.
We’ll take a look at the construction of tables using the knitr, formattable, and DT packages. Technically, the first two packages provide non-interactive tables while the third provides interactivity. But we’ll start with the first two as they provide some nice functionality to make nice looking HTML tables.
We will take a look at the diamonds
data set.
dim(diamonds)
## [1] 53940 10
These data are too large for interactive scatterplots and thus we will take a random sample of these data.
The kable()
function in the knitr
package
provides an easy display of tables in an HTML document.
By default, the kable function will show the entire table. So, let’s just show the first few lines.
d <- diamonds %>%
group_by(cut) %>% # ensure we have all cuts for grouping
sample_n(3)
Also, by default, the table looks pretty bad, so let’s add some styling.
knitr::kable(d) %>%
kable_styling()
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.70 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
d %>%
knitr::kable(
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
scroll_box(height = "200px")
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.70 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
groups <- table(d$cut)
d %>%
knitr::kable(
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
pack_rows(
index = setNames(groups, names(groups))
)
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
Fair | |||||||||
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
Good | |||||||||
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
Very Good | |||||||||
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.70 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
Premium | |||||||||
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
Ideal | |||||||||
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
d %>%
# Conditional highlighting
mutate(
carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
) %>%
knitr::kable(
escape = FALSE,
caption = "Diamonds data",
align = c("rlllrrrrrr")
) %>%
kable_styling(bootstrap_options = c('striped', 'hover', 'condensed'))
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.7 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
Another function is formattable()
in the
formattable
package. The default table is reasonable.
d %>%
formattable::formattable()
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.70 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
d %>%
# Conditional highlighting
mutate(
carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
) %>%
formattable::formattable(
list(
# Width depends on proportion from 0 to max value
x = color_bar("#C8102E"),
y = color_bar("#C8102E"),
z = color_bar("#C8102E"),
# Color depends on proportion from min to max value
depth = color_tile("#CAC7A7","#524727")
)
)
carat | cut | color | clarity | depth | table | price | x | y | z |
---|---|---|---|---|---|---|---|---|---|
0.97 | Fair | F | I1 | 68.5 | 54 | 1787 | 6.26 | 6.05 | 4.22 |
1.32 | Fair | H | I1 | 65.8 | 55 | 4140 | 6.87 | 6.83 | 4.51 |
1.51 | Fair | H | SI2 | 65.4 | 60 | 6291 | 7.06 | 6.96 | 4.60 |
0.92 | Good | F | SI2 | 64.2 | 58 | 3340 | 6.11 | 6.14 | 3.93 |
0.43 | Good | E | SI2 | 63.4 | 57 | 669 | 4.77 | 4.82 | 3.04 |
0.31 | Good | F | VS2 | 58.2 | 58 | 637 | 4.46 | 4.51 | 2.61 |
1.55 | Very Good | H | SI1 | 63.2 | 57 | 7066 | 7.35 | 7.31 | 4.64 |
0.7 | Very Good | E | VS2 | 62.5 | 57 | 2593 | 5.64 | 5.68 | 3.54 |
1.05 | Very Good | I | VS2 | 63.2 | 56 | 4895 | 6.47 | 6.51 | 4.10 |
1.06 | Premium | I | SI2 | 61.5 | 57 | 2968 | 6.57 | 6.49 | 4.02 |
0.51 | Premium | E | VS1 | 62.0 | 61 | 1758 | 5.14 | 5.11 | 3.18 |
2.02 | Premium | I | SI1 | 61.4 | 58 | 14240 | 8.14 | 8.07 | 4.98 |
0.54 | Ideal | I | VS1 | 61.6 | 54 | 1216 | 5.26 | 5.30 | 3.25 |
1.05 | Ideal | H | SI2 | 61.9 | 56 | 4504 | 6.49 | 6.56 | 4.04 |
0.43 | Ideal | E | VVS2 | 61.8 | 57 | 1308 | 4.79 | 4.85 | 2.98 |
As we will see, with the pagination, datatable()
provides the capability to succinctly display much larger tables. So we
will use more data
set.seed(20230416)
d <- diamonds %>%
sample_n(1000)
A basic interactive table using DT::datatable()
.
DT::datatable(d)
Many options can be added
DT::datatable(d, rownames = FALSE, filter = "top")
DT::datatable(d, rownames = FALSE,
editable = TRUE,
extensions = "Buttons",
options = list(
dom = "Bfrtip",
buttons = c("copy","csv","excel","pdf","print")
))
In this section, I am combining graphics, i.e. plots, as well as maps and animations (movies).
There are a variety of approaches to including interactivity in
graphics in rmarkdown documents. We’ll focus on using the plotly library and
specifically the ggplotly()
function which provides
interactivity for ggplot2 created graphics.
The ggplotly()
function from the plotly package provides
interactivity for (all?) ggplot2 constructed graphics. The interactivity
provide allows the user to
g <- ggplot(case0501, aes(x = Diet, y = Lifetime)) +
geom_boxplot() +
coord_flip()
ggplotly(g)
g <- ggplot(diamonds, aes(x = price)) +
geom_histogram(bins = 100)
ggplotly(g)
Here is a static plot of the diamonds data set.
d <- diamonds %>% sample_n(1000)
g <- ggplot(d,
aes(
x = carat,
y = price,
shape = cut,
color = color)) +
geom_point() +
scale_y_log10() +
scale_x_log10(breaks = scales::breaks_pretty())
g
## Warning: Using shapes for an ordinal variable is not advised
ggplotly(g)
## Warning: Using shapes for an ordinal variable is not advised
Another package from constructing interactive graphics is dygraphs.
Maps can be drawn with ggplot2, but these are not interactive.
ggplot(map_data("county","iowa"),
aes(x = long, y = lat, fill = subregion)) +
geom_polygon(color = "black") +
guides(fill = "none")
An open source R package and JavaScript library for mobile-friendly interactive maps is LeafLet.
World map:
leaflet::leaflet() %>%
addTiles()
In order to set the view, you will need the latitude (y) and longitude (x) in decimal format. I typically use Google maps, but there are other options, e.g. LatLong.net.
Here is Ames:
leaflet::leaflet() %>%
addTiles() %>%
setView(lng = -93.65, lat = 42.0285, zoom = 12)
Example taken from here.
leaflet::leaflet() %>%
addTiles() %>%
setView(-93.65, 42.0285, zoom = 17) %>%
addPopups(
-93.65, 42.0285,
'Here is the <b>Department of Statistics</b>, ISU'
)
Modified from here
counties <- tigris::counties(state = "IA", class = "sf")
## Retrieving data for the year 2021
leaflet() %>%
addTiles() %>%
addPolygons(data = counties, color = "grey")
## Warning: sf layer has inconsistent datum (+proj=longlat +datum=NAD83 +no_defs).
## Need '+proj=longlat +datum=WGS84'
gibbs_bivariate_normal = function(theta0, n_points, rho) {
theta = matrix(theta0, nrow=n_points, ncol=2, byrow=TRUE)
v = sqrt(1-rho^2)
for (i in 2:n_points) {
theta[i,1] = rnorm(1, rho*theta[i-1,2], v)
theta[i,2] = rnorm(1, rho*theta[i ,1], v)
}
return(theta)
}
theta = gibbs_bivariate_normal(c(-3,3), n<-20, rho=rho<-0.9)
bivariate_normal_animation = function(x, rho, ask=interactive()) {
# Create contour plot
n.out = 101
xx <- seq(-3, 3, length=n.out)
grid <- expand.grid(x=xx, y=xx)
Sigma = diag(rep(.1,2))+rho
like <- matrix(apply(grid, 1, function(x) mvtnorm::dmvnorm(x,sigma=Sigma)),n.out,n.out)
for (i in 2:nrow(x)) {
jj = (2:i)[-(i-1)] # vector from 2:(i-1) and NULL if i=2
for (j in 1:6) {
plot.new()
# All previous plotting
contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3),
xlab=expression(theta[1]), ylab=expression(theta[2]))
segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
segments(x[jj ,1], x[jj-1,2], x[jj,1], x[jj ,2], col="gray")
points(x[(1:(i-1)),1], x[(1:(i-1)),2], col="red", pch=19)
# New plotting
if (j>1 & j<4) abline(h=x[i-1,2], lty=2)
if (j>2) arrows(x[i-1,1], x[i-1,2], x[i,1], x[i-1,2], length=0.1)
if (j>3 & j<6) abline(v=x[i,1], lty=2)
if (j>4) arrows(x[i,1], x[i-1,2], x[i,1], x[i,2], length=0.1)
if (j>5) points(x[i,1], x[i,2], col="red", pch=19)
if (ask) readline("hit <enter>:")
}
}
jj=2:nrow(x)
contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3),
xlab=expression(theta[1]), ylab=expression(theta[2]))
segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
segments(x[jj ,1], x[jj-1,2], x[jj,1], x[jj ,2], col="gray")
points(x[,1], x[,2], col="red", pch=19)
}
bivariate_normal_animation(theta, rho = 0.9)
You can always embed additional interactivity. To get this to work,
you need to add the option data-external="1"
to the iframe
options.
For example, here is a google map.
Here is an embedded video of mine from YouTube discussing the Gibbs sampler demonstrated above.